Tests for quasi-quotation

29 files changed, 320 insertions, 1 deletions

diff --git a/testsuite/tests/ghc-regress/quasiquotation/Makefile b/testsuite/tests/ghc-regress/quasiquotation/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq001/Makefile b/testsuite/tests/ghc-regress/quasiquotation/qq001/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq001/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq001/qq001.hs b/testsuite/tests/ghc-regress/quasiquotation/qq001/qq001.hs
new file mode 100644
index 0000000000..0ef94644b5
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq001/qq001.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main where
+
+parse = undefined
+
+main :: IO ()
+main = print $ [$parse||]
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq001/qq001.stderr b/testsuite/tests/ghc-regress/quasiquotation/qq001/qq001.stderr
new file mode 100644
index 0000000000..ec1a9965bb
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq001/qq001.stderr
@@ -0,0 +1,4 @@
+
+qq001.hs:7:15:
+    GHC stage restriction: parse
+      is used in a quasiquote, and must be imported, not defined locally
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq001/test.T b/testsuite/tests/ghc-regress/quasiquotation/qq001/test.T
new file mode 100644
index 0000000000..c1dd1daede
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq001/test.T
@@ -0,0 +1,2 @@
+test('qq001', only_compiler_types(['ghc']),
+     compile_fail, [''])
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq002/Makefile b/testsuite/tests/ghc-regress/quasiquotation/qq002/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq002/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq002/qq002.hs b/testsuite/tests/ghc-regress/quasiquotation/qq002/qq002.hs
new file mode 100644
index 0000000000..98200b8ff2
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq002/qq002.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main where
+
+parse = undefined
+
+main :: IO ()
+main = case () of
+         [$parse||] -> return ()
+         _ -> return ()
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq002/qq002.stderr b/testsuite/tests/ghc-regress/quasiquotation/qq002/qq002.stderr
new file mode 100644
index 0000000000..c7ea17c5e9
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq002/qq002.stderr
@@ -0,0 +1,4 @@
+
+qq002.hs:8:9:
+    GHC stage restriction: parse
+      is used in a quasiquote, and must be imported, not defined locally
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq002/test.T b/testsuite/tests/ghc-regress/quasiquotation/qq002/test.T
new file mode 100644
index 0000000000..134a837534
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq002/test.T
@@ -0,0 +1,2 @@
+test('qq002', only_compiler_types(['ghc']),
+     compile_fail, [''])
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq003/Makefile b/testsuite/tests/ghc-regress/quasiquotation/qq003/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq003/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq003/qq003.hs b/testsuite/tests/ghc-regress/quasiquotation/qq003/qq003.hs
new file mode 100644
index 0000000000..f85b245a67
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq003/qq003.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main where
+
+main :: IO ()
+main = print $ \parse -> [$parse||]
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq003/qq003.stderr b/testsuite/tests/ghc-regress/quasiquotation/qq003/qq003.stderr
new file mode 100644
index 0000000000..9ad970b620
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq003/qq003.stderr
@@ -0,0 +1,4 @@
+
+qq003.hs:5:25:
+    GHC stage restriction: parse
+      is used in a quasiquote, and must be imported, not defined locally
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq003/test.T b/testsuite/tests/ghc-regress/quasiquotation/qq003/test.T
new file mode 100644
index 0000000000..5bb9343c24
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq003/test.T
@@ -0,0 +1,2 @@
+test('qq003', only_compiler_types(['ghc']),
+     compile_fail, [''])
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq004/Makefile b/testsuite/tests/ghc-regress/quasiquotation/qq004/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq004/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq004/qq004.hs b/testsuite/tests/ghc-regress/quasiquotation/qq004/qq004.hs
new file mode 100644
index 0000000000..4571243c24
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq004/qq004.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main where
+
+main :: IO ()
+main = p undefined
+  where
+    p = \parse -> case () of
+                    [$parse||] -> return ()
+                    _ -> return ()
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq004/qq004.stderr b/testsuite/tests/ghc-regress/quasiquotation/qq004/qq004.stderr
new file mode 100644
index 0000000000..eb69effd9e
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq004/qq004.stderr
@@ -0,0 +1,4 @@
+
+qq004.hs:8:20:
+    GHC stage restriction: parse
+      is used in a quasiquote, and must be imported, not defined locally
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq004/test.T b/testsuite/tests/ghc-regress/quasiquotation/qq004/test.T
new file mode 100644
index 0000000000..c0c9cbe769
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq004/test.T
@@ -0,0 +1,2 @@
+test('qq004', only_compiler_types(['ghc']),
+     compile_fail, [''])
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq005/Expr.hs b/testsuite/tests/ghc-regress/quasiquotation/qq005/Expr.hs
new file mode 100644
index 0000000000..200423b3a6
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq005/Expr.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Expr where
+
+import Data.Generics
+import Language.Haskell.TH as TH
+import Language.Haskell.TH.Quote
+
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Char
+
+data Expr  =  IntExpr Integer
+           |  AntiIntExpr String
+           |  BinopExpr BinOp Expr Expr
+           |  AntiExpr String
+    deriving(Typeable, Data)
+
+data BinOp  =  AddOp
+            |  SubOp
+            |  MulOp
+            |  DivOp
+    deriving(Typeable, Data)
+
+eval :: Expr -> Integer
+eval (IntExpr n)        = n
+eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y)
+  where
+    opToFun AddOp = (+)
+    opToFun SubOp = (-)
+    opToFun MulOp = (*)
+    opToFun DivOp = (div)
+
+small   = lower <|> char '_'
+large   = upper
+idchar  = small <|> large <|> digit <|> char '\''
+
+lexeme p    = do{ x <- p; spaces; return x  }
+symbol name = lexeme (string name)
+parens p    = between (symbol "(") (symbol ")") p
+
+_expr :: CharParser st Expr
+_expr   = term   `chainl1` mulop
+
+term :: CharParser st Expr
+term    = factor `chainl1` addop
+
+factor :: CharParser st Expr
+factor  = parens _expr <|> integer <|> anti
+
+mulop   =   do{ symbol "*"; return $ BinopExpr MulOp }
+        <|> do{ symbol "/"; return $ BinopExpr DivOp }
+
+addop   =   do{ symbol "+"; return $ BinopExpr AddOp }
+        <|> do{ symbol "-"; return $ BinopExpr SubOp }
+
+integer :: CharParser st Expr
+integer  = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) }
+
+anti   = lexeme $
+         do  symbol "$"
+             c <- small
+             cs <- many idchar
+             return $ AntiIntExpr (c : cs)
+
+parseExpr :: Monad m => TH.Loc -> String -> m Expr
+parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s =
+    case runParser p () "" s of
+      Left err  -> fail $ show err
+      Right e   -> return e
+  where
+    p = do  pos <- getPosition
+            setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file
+            spaces
+            e <- _expr
+            eof
+            return e
+
+expr = QuasiQuoter parseExprExp parseExprPat
+
+parseExprExp :: String -> Q Exp
+parseExprExp s =  do  loc <- location
+                      expr <- parseExpr loc s
+                      dataToExpQ (const Nothing `extQ` antiExprExp) expr
+
+antiExprExp :: Expr -> Maybe (Q Exp)
+antiExprExp  (AntiIntExpr v)  = Just $ appE  (conE (mkName "IntExpr"))
+                                                (varE (mkName v))
+antiExprExp  (AntiExpr v)     = Just $ varE  (mkName v)
+antiExprExp  _                = Nothing
+
+parseExprPat :: String -> Q Pat
+parseExprPat s =  do  loc <- location
+                      expr <- parseExpr loc s
+                      dataToPatQ (const Nothing `extQ` antiExprPat) expr
+
+antiExprPat :: Expr -> Maybe (Q Pat)
+antiExprPat  (AntiIntExpr v)  = Just $ conP  (mkName "IntExpr")
+                                                [varP (mkName v)]
+antiExprPat  (AntiExpr v)     = Just $ varP  (mkName v)
+antiExprPat  _                = Nothing
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq005/Main.hs b/testsuite/tests/ghc-regress/quasiquotation/qq005/Main.hs
new file mode 100644
index 0000000000..d6a28d326e
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq005/Main.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main where
+
+import Expr
+
+main :: IO ()
+main = do  print $ eval [$expr|1 + 3 + 5|]
+           case [$expr|2|] of
+             [$expr|$n|] -> print n
+             _           -> return ()
+           case [$expr|1 + 2|] of
+             [$expr|$x + $y|] -> putStrLn $ show x ++ " + " ++ show y
+             _                -> return ()
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq005/Makefile b/testsuite/tests/ghc-regress/quasiquotation/qq005/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq005/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq005/qq005.stderr b/testsuite/tests/ghc-regress/quasiquotation/qq005/qq005.stderr
new file mode 100644
index 0000000000..e69de29bb2
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq005/qq005.stderr
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq005/qq005.stdout b/testsuite/tests/ghc-regress/quasiquotation/qq005/qq005.stdout
new file mode 100644
index 0000000000..b9473d1e3b
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq005/qq005.stdout
@@ -0,0 +1,3 @@
+9
+2
+1 + 2
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq005/test.T b/testsuite/tests/ghc-regress/quasiquotation/qq005/test.T
new file mode 100644
index 0000000000..fae6c865d2
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq005/test.T
@@ -0,0 +1,4 @@
+test('qq005', compose( skip_if_fast, only_compiler_types(['ghc']) ),
+	multimod_compile_and_run,
+	['Main', ''])
+clean_o_hi()
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq006/Expr.hs b/testsuite/tests/ghc-regress/quasiquotation/qq006/Expr.hs
new file mode 100644
index 0000000000..200423b3a6
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq006/Expr.hs
@@ -0,0 +1,99 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module Expr where
+
+import Data.Generics
+import Language.Haskell.TH as TH
+import Language.Haskell.TH.Quote
+
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Char
+
+data Expr  =  IntExpr Integer
+           |  AntiIntExpr String
+           |  BinopExpr BinOp Expr Expr
+           |  AntiExpr String
+    deriving(Typeable, Data)
+
+data BinOp  =  AddOp
+            |  SubOp
+            |  MulOp
+            |  DivOp
+    deriving(Typeable, Data)
+
+eval :: Expr -> Integer
+eval (IntExpr n)        = n
+eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y)
+  where
+    opToFun AddOp = (+)
+    opToFun SubOp = (-)
+    opToFun MulOp = (*)
+    opToFun DivOp = (div)
+
+small   = lower <|> char '_'
+large   = upper
+idchar  = small <|> large <|> digit <|> char '\''
+
+lexeme p    = do{ x <- p; spaces; return x  }
+symbol name = lexeme (string name)
+parens p    = between (symbol "(") (symbol ")") p
+
+_expr :: CharParser st Expr
+_expr   = term   `chainl1` mulop
+
+term :: CharParser st Expr
+term    = factor `chainl1` addop
+
+factor :: CharParser st Expr
+factor  = parens _expr <|> integer <|> anti
+
+mulop   =   do{ symbol "*"; return $ BinopExpr MulOp }
+        <|> do{ symbol "/"; return $ BinopExpr DivOp }
+
+addop   =   do{ symbol "+"; return $ BinopExpr AddOp }
+        <|> do{ symbol "-"; return $ BinopExpr SubOp }
+
+integer :: CharParser st Expr
+integer  = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) }
+
+anti   = lexeme $
+         do  symbol "$"
+             c <- small
+             cs <- many idchar
+             return $ AntiIntExpr (c : cs)
+
+parseExpr :: Monad m => TH.Loc -> String -> m Expr
+parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s =
+    case runParser p () "" s of
+      Left err  -> fail $ show err
+      Right e   -> return e
+  where
+    p = do  pos <- getPosition
+            setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file
+            spaces
+            e <- _expr
+            eof
+            return e
+
+expr = QuasiQuoter parseExprExp parseExprPat
+
+parseExprExp :: String -> Q Exp
+parseExprExp s =  do  loc <- location
+                      expr <- parseExpr loc s
+                      dataToExpQ (const Nothing `extQ` antiExprExp) expr
+
+antiExprExp :: Expr -> Maybe (Q Exp)
+antiExprExp  (AntiIntExpr v)  = Just $ appE  (conE (mkName "IntExpr"))
+                                                (varE (mkName v))
+antiExprExp  (AntiExpr v)     = Just $ varE  (mkName v)
+antiExprExp  _                = Nothing
+
+parseExprPat :: String -> Q Pat
+parseExprPat s =  do  loc <- location
+                      expr <- parseExpr loc s
+                      dataToPatQ (const Nothing `extQ` antiExprPat) expr
+
+antiExprPat :: Expr -> Maybe (Q Pat)
+antiExprPat  (AntiIntExpr v)  = Just $ conP  (mkName "IntExpr")
+                                                [varP (mkName v)]
+antiExprPat  (AntiExpr v)     = Just $ varP  (mkName v)
+antiExprPat  _                = Nothing
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq006/Main.hs b/testsuite/tests/ghc-regress/quasiquotation/qq006/Main.hs
new file mode 100644
index 0000000000..7e21acc235
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq006/Main.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main where
+
+import Expr
+
+main :: IO ()
+main = do  case [$expr|1 + 2|] of
+             [$expr|$x + $x|] -> print x
+             _                -> return ()
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq006/Makefile b/testsuite/tests/ghc-regress/quasiquotation/qq006/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq006/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq006/qq006.stderr b/testsuite/tests/ghc-regress/quasiquotation/qq006/qq006.stderr
new file mode 100644
index 0000000000..c8755dd892
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq006/qq006.stderr
@@ -0,0 +1,13 @@
+[1 of 2] Compiling Expr             ( ./Expr.hs, ./Expr.o )
+[2 of 2] Compiling Main             ( Main.hs, Main.o )
+
+Main.hs:8:20:
+    Conflicting definitions for `x'
+    In a case alternative
+Loading package base ... linking ... done.
+Loading package array-0.1 ... linking ... done.
+Loading package packedstring-0.1 ... linking ... done.
+Loading package containers-0.1 ... linking ... done.
+Loading package pretty-1.0 ... linking ... done.
+Loading package template-haskell ... linking ... done.
+Loading package parsec-2.1.0.0 ... linking ... done.
diff --git a/testsuite/tests/ghc-regress/quasiquotation/qq006/test.T b/testsuite/tests/ghc-regress/quasiquotation/qq006/test.T
new file mode 100644
index 0000000000..d3b7a533ba
--- /dev/null
+++ b/testsuite/tests/ghc-regress/quasiquotation/qq006/test.T
@@ -0,0 +1,4 @@
+test('qq006', compose( skip_if_fast, only_compiler_types(['ghc']) ),
+	multimod_compile_fail,
+	['Main', ''])
+clean_o_hi()
diff --git a/testsuite/tests/ghc-regress/th/TH_fail.stderr b/testsuite/tests/ghc-regress/th/TH_fail.stderr
index 13eb8bbe2b..96c07bd0cb 100644
--- a/testsuite/tests/ghc-regress/th/TH_fail.stderr
+++ b/testsuite/tests/ghc-regress/th/TH_fail.stderr
@@ -1,2 +1,2 @@
 
-TH_fail.hs:1:0: Code not written yet...
+TH_fail.hs:7:3: Code not written yet...