Test unresolved infix expressions and patterns
authorReiner Pope <reiner.pope@gmail.com>
Sat, 23 Jul 2011 06:21:58 +0000 (16:21 +1000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 25 Jul 2011 13:20:49 +0000 (14:20 +0100)
testsuite/tests/th/TH_unresolvedInfix.hs [new file with mode: 0644]
testsuite/tests/th/TH_unresolvedInfix.stdout [new file with mode: 0644]
testsuite/tests/th/TH_unresolvedInfix2.hs [new file with mode: 0644]
testsuite/tests/th/TH_unresolvedInfix2.stderr [new file with mode: 0644]
testsuite/tests/th/TH_unresolvedInfix_Lib.hs [new file with mode: 0644]
testsuite/tests/th/all.T

diff --git a/testsuite/tests/th/TH_unresolvedInfix.hs b/testsuite/tests/th/TH_unresolvedInfix.hs
new file mode 100644 (file)
index 0000000..03e97cf
--- /dev/null
@@ -0,0 +1,109 @@
+{-# 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)
diff --git a/testsuite/tests/th/TH_unresolvedInfix.stdout b/testsuite/tests/th/TH_unresolvedInfix.stdout
new file mode 100644 (file)
index 0000000..9ef0da4
--- /dev/null
@@ -0,0 +1,46 @@
+(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)
diff --git a/testsuite/tests/th/TH_unresolvedInfix2.hs b/testsuite/tests/th/TH_unresolvedInfix2.hs
new file mode 100644 (file)
index 0000000..5cd8332
--- /dev/null
@@ -0,0 +1,6 @@
+module TH_unresolvedInfix2 where
+
+import TH_unresolvedInfix_Lib
+import Language.Haskell.TH
+
+expr = $( infixE Nothing plus (Just $ n +? n) )
diff --git a/testsuite/tests/th/TH_unresolvedInfix2.stderr b/testsuite/tests/th/TH_unresolvedInfix2.stderr
new file mode 100644 (file)
index 0000000..44c4324
--- /dev/null
@@ -0,0 +1,12 @@
+
+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))
diff --git a/testsuite/tests/th/TH_unresolvedInfix_Lib.hs b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
new file mode 100644 (file)
index 0000000..aa734ab
--- /dev/null
@@ -0,0 +1,74 @@
+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]) )
index f490f39..347466b 100644 (file)
@@ -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'])