diff options
Diffstat (limited to 'testsuite/tests/quasiquotation')
55 files changed, 729 insertions, 0 deletions
diff --git a/testsuite/tests/quasiquotation/Makefile b/testsuite/tests/quasiquotation/Makefile new file mode 100644 index 0000000000..8e2e7e7c78 --- /dev/null +++ b/testsuite/tests/quasiquotation/Makefile @@ -0,0 +1,11 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: T4150 + +T4150: + $(RM) T4150A.hi T4150A.o T4150.hi T4150.o + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -c T4150A.hs + -'$(TEST_HC)' $(TEST_HC_OPTS) -v0 -c T4150.hs + diff --git a/testsuite/tests/quasiquotation/T3953.hs b/testsuite/tests/quasiquotation/T3953.hs new file mode 100644 index 0000000000..2b17419201 --- /dev/null +++ b/testsuite/tests/quasiquotation/T3953.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE QuasiQuotes #-} + +module T3953 where + +foo = [notDefinedHere| |] + diff --git a/testsuite/tests/quasiquotation/T3953.stderr b/testsuite/tests/quasiquotation/T3953.stderr new file mode 100644 index 0000000000..bd2b0fed56 --- /dev/null +++ b/testsuite/tests/quasiquotation/T3953.stderr @@ -0,0 +1,2 @@ + +T3953.hs:5:7: Not in scope: ‛notDefinedHere’ diff --git a/testsuite/tests/quasiquotation/T4150.hs b/testsuite/tests/quasiquotation/T4150.hs new file mode 100644 index 0000000000..3bf7cddc49 --- /dev/null +++ b/testsuite/tests/quasiquotation/T4150.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP, QuasiQuotes #-} + +module Main (main) where + +import T4150A + +myHtmlsTemplate = [multiLineStr| +#include "T4150template.txt" +|] + +somethingElse :: NoSuchType +somethingElse = undefined + +main :: IO () +main = print myHtmlsTemplate + diff --git a/testsuite/tests/quasiquotation/T4150.stderr b/testsuite/tests/quasiquotation/T4150.stderr new file mode 100644 index 0000000000..9e0f4c26ab --- /dev/null +++ b/testsuite/tests/quasiquotation/T4150.stderr @@ -0,0 +1,3 @@ + +T4150.hs:11:18: + Not in scope: type constructor or class `NoSuchType' diff --git a/testsuite/tests/quasiquotation/T4150A.hs b/testsuite/tests/quasiquotation/T4150A.hs new file mode 100644 index 0000000000..25ee003fee --- /dev/null +++ b/testsuite/tests/quasiquotation/T4150A.hs @@ -0,0 +1,13 @@ + +module T4150A where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +multiLineStr :: QuasiQuoter +multiLineStr = QuasiQuoter { + quoteExp = stringE, + quotePat = error "XXX", + quoteType = error "XXX", + quoteDec = error "XXX" + } diff --git a/testsuite/tests/quasiquotation/T4150template.txt b/testsuite/tests/quasiquotation/T4150template.txt new file mode 100644 index 0000000000..a92d664bc2 --- /dev/null +++ b/testsuite/tests/quasiquotation/T4150template.txt @@ -0,0 +1,3 @@ +line 1 +line 2 +line 3 diff --git a/testsuite/tests/quasiquotation/T4491/A.hs b/testsuite/tests/quasiquotation/T4491/A.hs new file mode 100644 index 0000000000..8c562d7221 --- /dev/null +++ b/testsuite/tests/quasiquotation/T4491/A.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveDataTypeable #-}
+
+module A where
+
+import Data.Data
+import Data.Typeable
+
+data Foo = Foo Int
+ deriving (Show, Data, Typeable)
diff --git a/testsuite/tests/quasiquotation/T4491/Makefile b/testsuite/tests/quasiquotation/T4491/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/quasiquotation/T4491/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/quasiquotation/T4491/T4491.hs b/testsuite/tests/quasiquotation/T4491/T4491.hs new file mode 100644 index 0000000000..3e5dd7f476 --- /dev/null +++ b/testsuite/tests/quasiquotation/T4491/T4491.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Language.Haskell.TH.Quote + +import qualified A as B + +test1 :: [Int] +test1 = $(dataToExpQ (const Nothing) [1 :: Int, 2, 3]) + +test2 :: () +test2 = $(dataToExpQ (const Nothing) ()) + +test3 :: (Int, Int, Int) +test3 = $(dataToExpQ (const Nothing) (1 :: Int, 2 :: Int, 3 :: Int)) + +test4 :: Rational +test4 = $(dataToExpQ (const Nothing) (5.5 :: Rational)) + +test5 :: B.Foo +test5 = $(dataToExpQ (const Nothing) (B.Foo 1)) + +main :: IO () +main = do + print test1 + print test2 + print test3 + print test4 + print test5 diff --git a/testsuite/tests/quasiquotation/T4491/T4491.stdout b/testsuite/tests/quasiquotation/T4491/T4491.stdout new file mode 100644 index 0000000000..931a6b74b6 --- /dev/null +++ b/testsuite/tests/quasiquotation/T4491/T4491.stdout @@ -0,0 +1,5 @@ +[1,2,3] +() +(1,2,3) +11 % 2 +Foo 1 diff --git a/testsuite/tests/quasiquotation/T4491/test.T b/testsuite/tests/quasiquotation/T4491/test.T new file mode 100644 index 0000000000..a9ead0fa61 --- /dev/null +++ b/testsuite/tests/quasiquotation/T4491/test.T @@ -0,0 +1,11 @@ +test('T4491', + [ + req_interp, + # We'd need to jump through some hoops to run this test the + # other ways, due to the TH use, so for now we only run it + # the TH way + only_ways([config.ghc_th_way]), + only_compiler_types(['ghc']), + extra_clean(['A.hi', 'A.o']) + ], + compile_and_run, ['']) diff --git a/testsuite/tests/quasiquotation/T5204.hs b/testsuite/tests/quasiquotation/T5204.hs new file mode 100644 index 0000000000..00c976bc59 --- /dev/null +++ b/testsuite/tests/quasiquotation/T5204.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, QuasiQuotes, MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable, NamedFieldPuns, ScopedTypeVariables #-} +module Pnm where +import qualified Data.Char as Char +-- import Language.Pads.Padsc +import Control.Monad + +_ws = one_or_more Char.isSpace + where one_or_more = undefined + +ws, wsnl, whitechar :: RE + +ws = REd "[ \t\n\r]+" " " -- whitespace +wsnl = let REd wplus _ = ws in REd wplus "\n" -- whitespace output as \n +whitechar = REd "[ \t\n\r]" "\n" -- one white character + + +[pads| + + data PGMx a = PGM "P5" ws Header whitechar (Pixmap a) + + data Header = Header -- fields should be separated by whitespace + { width :: Int + ws , height :: Int + wsnl , constrain denominator :: Int + where <| 0 <= denominator && denominator < 65536 |> + } + + data Pixmap a (h::Header) = Rows [Row a h | wsnl] length <| height h |> + data Row a (h::Header) = Pixels [a h | ws] length <| width h |> + + newtype Greypix (h::Header) = + G constrain g::Int16 where <| 0 <= g && g <= denominator h |> + + data PGM = PGMx Int16 Greypix + +] + +pgm file = do (rep, md) <- parseFile file + return rep diff --git a/testsuite/tests/quasiquotation/T5204.stderr b/testsuite/tests/quasiquotation/T5204.stderr new file mode 100644 index 0000000000..8f19d65cb2 --- /dev/null +++ b/testsuite/tests/quasiquotation/T5204.stderr @@ -0,0 +1,2 @@ + +T5204.hs:17:7: unterminated quasiquotation at end of input diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs new file mode 100644 index 0000000000..7126cb166e --- /dev/null +++ b/testsuite/tests/quasiquotation/T7918.hs @@ -0,0 +1,78 @@ +-- | Check the source spans associated with the expansion of quasi-quotes +module Main (main) where + +import GHC +import DynFlags +import Outputable +import MonadUtils +import NameSet +import Var + +import Data.Data + +import System.Environment +import Control.Monad +import Control.Monad.Trans.State +import Data.List +import Data.Ord + +type Traverse a = State (SrcSpan, [(Name, SrcSpan)]) a + +traverse :: Data a => a -> Traverse a +traverse a = + skipNameSet (cast a) a $ do + updateLoc (cast a) + showVar (cast a) + showTyVar (cast a) + showPatVar (cast a) + gmapM traverse a + where + showVar :: Maybe (HsExpr Id) -> Traverse () + showVar (Just (HsVar v)) = + modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) + showVar _ = + return () + + showTyVar :: Maybe (HsType Name) -> Traverse () + showTyVar (Just (HsTyVar v)) = + modify $ \(loc, ids) -> (loc, (v, loc) : ids) + showTyVar _ = + return () + + showPatVar :: Maybe (Pat Id) -> Traverse () + showPatVar (Just (VarPat v)) = + modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) + showPatVar _ + = return () + + -- Updating the location in this way works because we see the SrcSpan + -- before the associated term due to the definition of GenLocated + updateLoc :: Maybe SrcSpan -> Traverse () + updateLoc (Just loc) = modify $ \(_, ids) -> (loc, ids) + updateLoc _ = return () + + skipNameSet :: Monad m => Maybe NameSet -> a -> m a -> m a + skipNameSet (Just _) a _ = return a + skipNameSet Nothing _ f = f + +test7918 :: Ghc () +test7918 = do + dynFlags <- getSessionDynFlags + void $ setSessionDynFlags (gopt_set dynFlags Opt_BuildDynamicToo) + + let target = Target { + targetId = TargetFile "T7918B.hs" Nothing + , targetAllowObjCode = True + , targetContents = Nothing + } + setTargets [target] + void $ load LoadAllTargets + + typecheckedB <- getModSummary (mkModuleName "T7918B") >>= parseModule >>= typecheckModule + let (_loc, ids) = execState (traverse (tm_typechecked_source typecheckedB)) (noSrcSpan, []) + liftIO . forM_ (sortBy (comparing snd) (reverse ids)) $ putStrLn . showSDoc dynFlags . ppr + +main :: IO () +main = do + [libdir] <- getArgs + runGhc (Just libdir) test7918 diff --git a/testsuite/tests/quasiquotation/T7918.stdout b/testsuite/tests/quasiquotation/T7918.stdout new file mode 100644 index 0000000000..43de631493 --- /dev/null +++ b/testsuite/tests/quasiquotation/T7918.stdout @@ -0,0 +1,27 @@ +(GHC.Types.True, T7918B.hs:6:11-14) +(GHC.Base.id, T7918B.hs:7:11-14) +(GHC.Types.True, T7918B.hs:7:11-14) +(GHC.Types.True, T7918B.hs:8:11-14) +(GHC.Classes.||, T7918B.hs:8:11-14) +(GHC.Types.False, T7918B.hs:8:11-14) +(GHC.Types.False, T7918B.hs:9:11-14) +(GHC.Err.undefined, T7918B.hs:11:7-15) +(GHC.Types.Bool, T7918B.hs:11:24-27) +(GHC.Err.undefined, T7918B.hs:12:7-15) +(Data.Maybe.Maybe, T7918B.hs:12:24-27) +(GHC.Types.Bool, T7918B.hs:12:24-27) +(GHC.Err.undefined, T7918B.hs:13:7-15) +(Data.Either.Either, T7918B.hs:13:24-27) +(GHC.Types.Bool, T7918B.hs:13:24-27) +(GHC.Types.Int, T7918B.hs:13:24-27) +(GHC.Err.undefined, T7918B.hs:14:7-15) +(GHC.Types.Int, T7918B.hs:14:24-27) +(x, T7918B.hs:16:9-12) +(GHC.Err.undefined, T7918B.hs:16:16-24) +(x, T7918B.hs:17:9-12) +(GHC.Err.undefined, T7918B.hs:17:16-24) +(x, T7918B.hs:18:9-12) +(y, T7918B.hs:18:9-12) +(GHC.Err.undefined, T7918B.hs:18:16-24) +(y, T7918B.hs:19:9-12) +(GHC.Err.undefined, T7918B.hs:19:16-24) diff --git a/testsuite/tests/quasiquotation/T7918A.hs b/testsuite/tests/quasiquotation/T7918A.hs new file mode 100644 index 0000000000..f20dfeef59 --- /dev/null +++ b/testsuite/tests/quasiquotation/T7918A.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +module T7918A where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +qq = QuasiQuoter { + quoteExp = \str -> case str of + "e1" -> [| True |] + "e2" -> [| id True |] + "e3" -> [| True || False |] + "e4" -> [| False |] + , quoteType = \str -> case str of + "t1" -> [t| Bool |] + "t2" -> [t| Maybe Bool |] + "t3" -> [t| Either Bool Int |] + "t4" -> [t| Int |] + , quotePat = let x = VarP (mkName "x") + y = VarP (mkName "y") + in \str -> case str of + "p1" -> return $ x + "p2" -> return $ ConP 'Just [x] + "p3" -> return $ TupP [x, y] + "p4" -> return $ y + , quoteDec = undefined + } diff --git a/testsuite/tests/quasiquotation/T7918B.hs b/testsuite/tests/quasiquotation/T7918B.hs new file mode 100644 index 0000000000..949801428a --- /dev/null +++ b/testsuite/tests/quasiquotation/T7918B.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} +module T7918B where + +import T7918A + +ex1 = [qq|e1|] +ex2 = [qq|e2|] +ex3 = [qq|e3|] +ex4 = [qq|e4|] + +tx1 = undefined :: [qq|t1|] +tx2 = undefined :: [qq|t2|] +tx3 = undefined :: [qq|t3|] +tx4 = undefined :: [qq|t4|] + +px1 [qq|p1|] = undefined +px2 [qq|p2|] = undefined +px3 [qq|p3|] = undefined +px4 [qq|p4|] = undefined diff --git a/testsuite/tests/quasiquotation/all.T b/testsuite/tests/quasiquotation/all.T new file mode 100644 index 0000000000..2173da6100 --- /dev/null +++ b/testsuite/tests/quasiquotation/all.T @@ -0,0 +1,19 @@ +test('T3953', [req_interp, only_compiler_types(['ghc'])], compile_fail, ['']) +test('T4150', + [only_compiler_types(['ghc']), + expect_broken(4150), + extra_clean(['T4150A.hi', 'T4150A.o', 'T4150.hi', 'T4150.o'])], + run_command, + ['$MAKE -s --no-print-directory T4150']) +test('T5204', [req_interp, only_compiler_types(['ghc'])], + compile_fail, ['']) +test('T7918', + [req_interp, + extra_run_opts('"' + config.libdir + '"'), + only_compiler_types(['ghc']), + only_ways(config.ghc_th_way), + unless(have_dynamic(),skip), + extra_clean(['T7918A.hi', 'T7918A.o', 'T7918A.dyn_hi', 'T7918A.dyn_o', + 'T7918B.hi', 'T7918B.o', 'T7918B.dyn_hi', 'T7918B.dyn_o'])], + compile_and_run, + ['-package ghc ' + config.ghc_th_way_flags]) diff --git a/testsuite/tests/quasiquotation/qq001/Makefile b/testsuite/tests/quasiquotation/qq001/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/quasiquotation/qq001/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/quasiquotation/qq001/qq001.hs b/testsuite/tests/quasiquotation/qq001/qq001.hs new file mode 100644 index 0000000000..652c8cf874 --- /dev/null +++ b/testsuite/tests/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/quasiquotation/qq001/qq001.stderr b/testsuite/tests/quasiquotation/qq001/qq001.stderr new file mode 100644 index 0000000000..aa748e60cd --- /dev/null +++ b/testsuite/tests/quasiquotation/qq001/qq001.stderr @@ -0,0 +1,4 @@ + +qq001.hs:7:16: + GHC stage restriction: parse + is used in a quasiquote, and must be imported, not defined locally diff --git a/testsuite/tests/quasiquotation/qq001/test.T b/testsuite/tests/quasiquotation/qq001/test.T new file mode 100644 index 0000000000..2db7546687 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq001/test.T @@ -0,0 +1,2 @@ +test('qq001', [req_interp, only_compiler_types(['ghc'])], + compile_fail, ['']) diff --git a/testsuite/tests/quasiquotation/qq002/Makefile b/testsuite/tests/quasiquotation/qq002/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/quasiquotation/qq002/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/quasiquotation/qq002/qq002.hs b/testsuite/tests/quasiquotation/qq002/qq002.hs new file mode 100644 index 0000000000..a9ac995e5a --- /dev/null +++ b/testsuite/tests/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/quasiquotation/qq002/qq002.stderr b/testsuite/tests/quasiquotation/qq002/qq002.stderr new file mode 100644 index 0000000000..b32b5ac6a0 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq002/qq002.stderr @@ -0,0 +1,4 @@ + +qq002.hs:8:10: + GHC stage restriction: parse + is used in a quasiquote, and must be imported, not defined locally diff --git a/testsuite/tests/quasiquotation/qq002/test.T b/testsuite/tests/quasiquotation/qq002/test.T new file mode 100644 index 0000000000..2c39664a85 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq002/test.T @@ -0,0 +1,2 @@ +test('qq002', [req_interp, only_compiler_types(['ghc'])], + compile_fail, ['']) diff --git a/testsuite/tests/quasiquotation/qq003/Makefile b/testsuite/tests/quasiquotation/qq003/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/quasiquotation/qq003/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/quasiquotation/qq003/qq003.hs b/testsuite/tests/quasiquotation/qq003/qq003.hs new file mode 100644 index 0000000000..7afbad964e --- /dev/null +++ b/testsuite/tests/quasiquotation/qq003/qq003.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} +module Main where + +main :: IO () +main = print $ \parse -> [parse||] diff --git a/testsuite/tests/quasiquotation/qq003/qq003.stderr b/testsuite/tests/quasiquotation/qq003/qq003.stderr new file mode 100644 index 0000000000..a1f490fb2c --- /dev/null +++ b/testsuite/tests/quasiquotation/qq003/qq003.stderr @@ -0,0 +1,4 @@ + +qq003.hs:5:26: + GHC stage restriction: parse + is used in a quasiquote, and must be imported, not defined locally diff --git a/testsuite/tests/quasiquotation/qq003/test.T b/testsuite/tests/quasiquotation/qq003/test.T new file mode 100644 index 0000000000..9c61d0a11a --- /dev/null +++ b/testsuite/tests/quasiquotation/qq003/test.T @@ -0,0 +1,2 @@ +test('qq003', [req_interp, only_compiler_types(['ghc'])], + compile_fail, ['']) diff --git a/testsuite/tests/quasiquotation/qq004/Makefile b/testsuite/tests/quasiquotation/qq004/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/quasiquotation/qq004/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/quasiquotation/qq004/qq004.hs b/testsuite/tests/quasiquotation/qq004/qq004.hs new file mode 100644 index 0000000000..c95b94ef02 --- /dev/null +++ b/testsuite/tests/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/quasiquotation/qq004/qq004.stderr b/testsuite/tests/quasiquotation/qq004/qq004.stderr new file mode 100644 index 0000000000..be61788926 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq004/qq004.stderr @@ -0,0 +1,4 @@ + +qq004.hs:8:21: + GHC stage restriction: parse + is used in a quasiquote, and must be imported, not defined locally diff --git a/testsuite/tests/quasiquotation/qq004/test.T b/testsuite/tests/quasiquotation/qq004/test.T new file mode 100644 index 0000000000..13ecda5dad --- /dev/null +++ b/testsuite/tests/quasiquotation/qq004/test.T @@ -0,0 +1,2 @@ +test('qq004', [req_interp, only_compiler_types(['ghc'])], + compile_fail, ['']) diff --git a/testsuite/tests/quasiquotation/qq005/Expr.hs b/testsuite/tests/quasiquotation/qq005/Expr.hs new file mode 100644 index 0000000000..d628e8d52f --- /dev/null +++ b/testsuite/tests/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 { quoteExp = parseExprExp, quotePat = 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/quasiquotation/qq005/Main.hs b/testsuite/tests/quasiquotation/qq005/Main.hs new file mode 100644 index 0000000000..d8c8a3433c --- /dev/null +++ b/testsuite/tests/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/quasiquotation/qq005/Makefile b/testsuite/tests/quasiquotation/qq005/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/quasiquotation/qq005/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/quasiquotation/qq005/qq005.stderr b/testsuite/tests/quasiquotation/qq005/qq005.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq005/qq005.stderr diff --git a/testsuite/tests/quasiquotation/qq005/qq005.stdout b/testsuite/tests/quasiquotation/qq005/qq005.stdout new file mode 100644 index 0000000000..b9473d1e3b --- /dev/null +++ b/testsuite/tests/quasiquotation/qq005/qq005.stdout @@ -0,0 +1,3 @@ +9 +2 +1 + 2 diff --git a/testsuite/tests/quasiquotation/qq005/test.T b/testsuite/tests/quasiquotation/qq005/test.T new file mode 100644 index 0000000000..efa7b9d955 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq005/test.T @@ -0,0 +1,11 @@ +test('qq005', + [when(fast(), skip), + reqlib('parsec'), + only_compiler_types(['ghc']), + # We'd need to jump through some hoops to run this test the + # profiling ways, due to the TH use, so for now we just + # omit the profiling ways + omit_ways(['profasm','profthreaded']), + extra_clean(['Expr.hi', 'Expr.o', 'Main.hi', 'Main.o'])], + multimod_compile_and_run, + ['Main', '']) diff --git a/testsuite/tests/quasiquotation/qq006/Expr.hs b/testsuite/tests/quasiquotation/qq006/Expr.hs new file mode 100644 index 0000000000..d628e8d52f --- /dev/null +++ b/testsuite/tests/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 { quoteExp = parseExprExp, quotePat = 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/quasiquotation/qq006/Main.hs b/testsuite/tests/quasiquotation/qq006/Main.hs new file mode 100644 index 0000000000..7e21acc235 --- /dev/null +++ b/testsuite/tests/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/quasiquotation/qq006/Makefile b/testsuite/tests/quasiquotation/qq006/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/quasiquotation/qq006/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/quasiquotation/qq006/qq006.stderr b/testsuite/tests/quasiquotation/qq006/qq006.stderr new file mode 100644 index 0000000000..3eb51824b0 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq006/qq006.stderr @@ -0,0 +1,4 @@ + +Main.hs:8:20: + Conflicting definitions for `x' + In a case alternative diff --git a/testsuite/tests/quasiquotation/qq006/test.T b/testsuite/tests/quasiquotation/qq006/test.T new file mode 100644 index 0000000000..be471de9ca --- /dev/null +++ b/testsuite/tests/quasiquotation/qq006/test.T @@ -0,0 +1,7 @@ +test('qq006', + [when(fast(), skip), + reqlib('parsec'), + extra_clean(['Expr.hi', 'Expr.o']), + only_compiler_types(['ghc'])], + multimod_compile_fail, + ['Main', '-v0']) diff --git a/testsuite/tests/quasiquotation/qq007/Makefile b/testsuite/tests/quasiquotation/qq007/Makefile new file mode 100644 index 0000000000..e31a732a26 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq007/Makefile @@ -0,0 +1,12 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: TH_QQ +TH_QQ: +ifeq "$(GhcDynamic)" "YES" + '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs -dynamic -osuf dyn_o -hisuf dyn_hi +else + '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs +endif + diff --git a/testsuite/tests/quasiquotation/qq007/QQ.hs b/testsuite/tests/quasiquotation/qq007/QQ.hs new file mode 100644 index 0000000000..3c13315a31 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq007/QQ.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-}
+module QQ where
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH
+
+pq = QuasiQuoter { quoteDec = \_ -> [d| f x = x |],
+ quoteType = \_ -> [t| Int -> Int |],
+ quoteExp = \_ -> [| $(varE (mkName "x")) + 1::Int |],
+ quotePat = \_ -> [p| Just x |] }
+
diff --git a/testsuite/tests/quasiquotation/qq007/Test.hs b/testsuite/tests/quasiquotation/qq007/Test.hs new file mode 100644 index 0000000000..42cef722d3 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq007/Test.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE QuasiQuotes #-}
+module Test where
+
+import QQ
+
+f :: [pq| foo |] -- Expands to Int -> Int
+[pq| blah |] -- Expands to f x = x
+
+h [pq| foo |] = f [pq| blah |] * 8
+ -- Expands to h (Just x) = f (x+1) * 8
+
+
+
diff --git a/testsuite/tests/quasiquotation/qq007/test.T b/testsuite/tests/quasiquotation/qq007/test.T new file mode 100644 index 0000000000..cf59e4f733 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq007/test.T @@ -0,0 +1,7 @@ +test('qq007', + [when(fast(), skip), + extra_clean(['QQ.hi', 'QQ.o', 'Test.hi', 'Test.o']), + pre_cmd('$MAKE -s --no-print-directory TH_QQ'), + only_compiler_types(['ghc'])], + multimod_compile, + ['Test', '-v0']) diff --git a/testsuite/tests/quasiquotation/qq008/Makefile b/testsuite/tests/quasiquotation/qq008/Makefile new file mode 100644 index 0000000000..e31a732a26 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq008/Makefile @@ -0,0 +1,12 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: TH_QQ +TH_QQ: +ifeq "$(GhcDynamic)" "YES" + '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs -dynamic -osuf dyn_o -hisuf dyn_hi +else + '$(TEST_HC)' $(TEST_HC_OPTS) -c QQ.hs +endif + diff --git a/testsuite/tests/quasiquotation/qq008/QQ.hs b/testsuite/tests/quasiquotation/qq008/QQ.hs new file mode 100644 index 0000000000..eee8dc9670 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq008/QQ.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module QQ where + +import Language.Haskell.TH.Quote +import Language.Haskell.TH + +pq = QuasiQuoter { quoteDec = \_ -> [d| f x = x |], + quoteType = \_ -> [t| Int -> Int |], + quoteExp = \_ -> [| $(varE (mkName "x")) + 1::Int |], + quotePat = \_ -> [p| Just x |] } + diff --git a/testsuite/tests/quasiquotation/qq008/Test.hs b/testsuite/tests/quasiquotation/qq008/Test.hs new file mode 100644 index 0000000000..c04f427f63 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq008/Test.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE QuasiQuotes #-} +module Test where + +import QQ + +f :: [pq| foo |] -- Expands to Int -> Int +[pq| blah |] -- Expands to f x = x + +h [pq| foo |] = f [$pq| blah |] * 8 +-- Expands to h (Just x) = f (x+1) * 8 + + + diff --git a/testsuite/tests/quasiquotation/qq008/qq008.stderr b/testsuite/tests/quasiquotation/qq008/qq008.stderr new file mode 100644 index 0000000000..b13e999463 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq008/qq008.stderr @@ -0,0 +1,4 @@ + +Test.hs:9:19: + Warning: Deprecated syntax: + quasiquotes no longer need a dollar sign: $pq diff --git a/testsuite/tests/quasiquotation/qq008/test.T b/testsuite/tests/quasiquotation/qq008/test.T new file mode 100644 index 0000000000..99fef71394 --- /dev/null +++ b/testsuite/tests/quasiquotation/qq008/test.T @@ -0,0 +1,7 @@ +test('qq008', + [when(fast(), skip), + extra_clean(['QQ.hi', 'QQ.o', 'Test.hi', 'Test.o']), + pre_cmd('$MAKE -s --no-print-directory TH_QQ'), + only_compiler_types(['ghc'])], + multimod_compile, + ['Test', '-v0']) |