Commit fcaa1f52 authored by reinerp's avatar reinerp Committed by Simon Peyton Jones

Test unresolved infix expressions and patterns

parent f42770dd
{-# LANGUAGE QuasiQuotes #-}
module Main where
import TH_unresolvedInfix_Lib
import Language.Haskell.TH
--------------------------------------------------------------------------------
-- Expressions --
--------------------------------------------------------------------------------
exprs = [
-------------- Completely-unresolved bindings
$( n +? (n *? n) ),
$( (n +? n) *? n ),
$( n +? (n +? n) ),
$( (n +? n) +? n ),
-- VarE version
$( uInfixE n plus2 (uInfixE n plus2 n) ),
$( uInfixE (uInfixE n plus2 n) plus2 n ),
$( uInfixE n plus3 (uInfixE n plus3 n) ),
$( uInfixE (uInfixE n plus3 n) plus3 n ),
--------------- Completely-resolved bindings
$( n +! (n *! n) ),
$( (n +! n) *! n ),
$( n +! (n +! n) ),
$( (n +! n) +! n ),
-------------- Mixed resolved/unresolved
$( (n +! n) *? (n +? n) ),
$( (n +? n) *? (n +! n) ),
$( (n +? n) *! (n +! n) ),
$( (n +? n) *! (n +? n) ),
-------------- Parens
$( ((parensE ((n +? n) *? n)) +? n) *? n ),
$( (parensE (n +? n)) *? (parensE (n +? n)) ),
$( parensE ((n +? n) *? (n +? n)) ),
-------------- Sections
$( infixE (Just $ n +? n) plus Nothing ) N,
-- see B.hs for the (non-compiling) other version of the above
$( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N,
-------------- Dropping constructors
$( n *? tupE [n +? n] )
]
--------------------------------------------------------------------------------
-- Patterns --
--------------------------------------------------------------------------------
patterns = [
-------------- Completely-unresolved patterns
case N :+ (N :* N) of
[p1|unused|] -> True,
case N :+ (N :* N) of
[p2|unused|] -> True,
case (N :+ N) :+ N of
[p3|unused|] -> True,
case (N :+ N) :+ N of
[p4|unused|] -> True,
-------------- Completely-resolved patterns
case N :+ (N :* N) of
[p5|unused|] -> True,
case (N :+ N) :* N of
[p6|unused|] -> True,
case N :+ (N :+ N) of
[p7|unused|] -> True,
case (N :+ N) :+ N of
[p8|unused|] -> True,
-------------- Mixed resolved/unresolved
case ((N :+ N) :* N) :+ N of
[p9|unused|] -> True,
case N :+ (N :* (N :+ N)) of
[p10|unused|] -> True,
case (N :+ N) :* (N :+ N) of
[p11|unused|] -> True,
case (N :+ N) :* (N :+ N) of
[p12|unused|] -> True,
-------------- Parens
case (N :+ (N :* N)) :+ (N :* N) of
[p13|unused|] -> True,
case (N :+ N) :* (N :+ N) of
[p14|unused|] -> True,
case (N :+ (N :* N)) :+ N of
[p15|unused|] -> True,
-------------- Dropping constructors
case (N :* (N :+ N)) of
[p16|unused|] -> True
]
main = do
mapM_ print exprs
mapM_ print patterns
-- check that there are no Parens or UInfixes in the output
runQ [|N :* N :+ N|] >>= print
runQ [|(N :* N) :+ N|] >>= print
runQ [p|N :* N :+ N|] >>= print
runQ [p|(N :* N) :+ N|] >>= print
-- pretty-printing of unresolved infix expressions
let ne = ConE $ mkName "N"
np = ConP (mkName "N") []
plusE = ConE (mkName ":+")
plusP = (mkName ":+")
putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne)))
putStrLn $ pprint (ParensE ne)
putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np)))
putStrLn $ pprint (ParensP np)
(N :+ (N :* N))
(N :+ (N :* N))
((N :+ N) :+ N)
((N :+ N) :+ N)
((N :+ N) :+ N)
((N :+ N) :+ N)
((N :+ N) :+ N)
((N :+ N) :+ N)
(N :+ (N :* N))
((N :+ N) :* N)
(N :+ (N :+ N))
((N :+ N) :+ N)
(((N :+ N) :* N) :+ N)
(N :+ (N :* (N :+ N)))
((N :+ N) :* (N :+ N))
((N :+ N) :* (N :+ N))
((N :+ (N :* N)) :+ (N :* N))
((N :+ N) :* (N :+ N))
((N :+ (N :* N)) :+ N)
((N :+ N) :+ N)
(N :+ (N :+ N))
(N :* (N :+ N))
True
True
True
True
True
True
True
True
True
True
True
True
True
True
True
True
InfixE (Just (InfixE (Just (ConE TH_unresolvedInfix_Lib.N)) (ConE TH_unresolvedInfix_Lib.:*) (Just (ConE TH_unresolvedInfix_Lib.N)))) (ConE TH_unresolvedInfix_Lib.:+) (Just (ConE TH_unresolvedInfix_Lib.N))
InfixE (Just (InfixE (Just (ConE TH_unresolvedInfix_Lib.N)) (ConE TH_unresolvedInfix_Lib.:*) (Just (ConE TH_unresolvedInfix_Lib.N)))) (ConE TH_unresolvedInfix_Lib.:+) (Just (ConE TH_unresolvedInfix_Lib.N))
InfixP (InfixP (ConP TH_unresolvedInfix_Lib.N []) TH_unresolvedInfix_Lib.:* (ConP TH_unresolvedInfix_Lib.N [])) TH_unresolvedInfix_Lib.:+ (ConP TH_unresolvedInfix_Lib.N [])
InfixP (InfixP (ConP TH_unresolvedInfix_Lib.N []) TH_unresolvedInfix_Lib.:* (ConP TH_unresolvedInfix_Lib.N [])) TH_unresolvedInfix_Lib.:+ (ConP TH_unresolvedInfix_Lib.N [])
N :+ (N :+ N :+ N)
(N)
N :+ (N :+ N :+ N)
(N)
module TH_unresolvedInfix2 where
import TH_unresolvedInfix_Lib
import Language.Haskell.TH
expr = $( infixE Nothing plus (Just $ n +? n) )
TH_unresolvedInfix2.hs:6:11:
The operator `:+' [infixl 6] of a section
must have lower precedence than that of the operand,
namely `:+' [infixl 6]
in the section: `:+ N :+ N'
In the result of the splice:
$(infixE Nothing plus (Just $ n +? n))
To see what the splice expanded to, use -ddump-splices
In the expression: $(infixE Nothing plus (Just $ n +? n))
In an equation for `expr':
expr = $(infixE Nothing plus (Just $ n +? n))
module TH_unresolvedInfix_Lib where
import Language.Haskell.TH
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Quote
infixl 6 :+
infixl 7 :*
data Tree = N
| Tree :+ Tree
| Tree :* Tree
-- custom instance, including redundant parentheses
instance Show Tree where
show N = "N"
show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")"
show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")"
-- VarE versions
infixl 6 +:
infixl 7 *:
(+:) = (:+)
(*:) = (:*)
n = conE (mkName "N")
plus = conE (mkName ":+")
times = conE (mkName ":*")
a +? b = uInfixE a plus b
a *? b = uInfixE a times b
a +! b = infixApp a plus b
a *! b = infixApp a times b
plus2 = varE (mkName "+:")
times2 = varE (mkName "*:")
plus3 = conE ('(:+))
--------------------------------------------------------------------------------
-- Patterns --
--------------------------------------------------------------------------------
-- The only way to test pattern splices is using QuasiQuotation
mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined
p = conP (mkName "N") []
plus' = mkName ":+"
times' = mkName ":*"
a ^+? b = uInfixP a plus' b
a ^*? b = uInfixP a times' b
a ^+! b = infixP a plus' b
a ^*! b = infixP a times' b
-------------- Completely-unresolved patterns
p1 = mkQQ ( p ^+? (p ^*? p) )
p2 = mkQQ ( (p ^+? p) ^*? p )
p3 = mkQQ ( p ^+? (p ^+? p) )
p4 = mkQQ ( (p ^+? p) ^+? p )
-------------- Completely-resolved patterns
p5 = mkQQ ( p ^+! (p ^*! p) )
p6 = mkQQ ( (p ^+! p) ^*! p )
p7 = mkQQ ( p ^+! (p ^+! p) )
p8 = mkQQ ( (p ^+! p) ^+! p )
-------------- Mixed resolved/unresolved
p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) )
p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) )
p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) )
p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) )
-------------- Parens
p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p )
p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) )
p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) )
-------------- Dropping constructors
p16 = mkQQ ( p ^*? (tupP [p ^+? p]) )
......@@ -184,3 +184,11 @@ test('T5037', normal, compile, ['-v0'])
test('TH_unboxedSingleton', normal, compile, ['-v0'])
test('T5290', normal, compile, ['-v0 -ddump-splices'])
test('TH_unresolvedInfix',
extra_clean(['TH_unresolvedInfix_Lib.hi', 'TH_unresolvedInfix_Lib.o']),
multimod_compile_and_run,
['TH_unresolvedInfix.hs', '-v0'])
test('TH_unresolvedInfix2',
extra_clean(['TH_unresolvedInfix_Lib.hi', 'TH_unresolvedInfix_Lib.o']),
multimod_compile_fail,
['TH_unresolvedInfix2.hs', '-v0'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment