[commit: testsuite] master: Test for T7918 (bba785f)
git at git.haskell.org
git at git.haskell.org
Tue Sep 3 15:31:35 CEST 2013
Repository : ssh://git@git.haskell.org/testsuite
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/bba785f4733da4d8d4dbf00dfaefab79a4ac7a25/testsuite
>---------------------------------------------------------------
commit bba785f4733da4d8d4dbf00dfaefab79a4ac7a25
Author: Edsko de Vries <edsko at well-typed.com>
Date: Mon Sep 2 08:50:42 2013 +0100
Test for T7918
>---------------------------------------------------------------
bba785f4733da4d8d4dbf00dfaefab79a4ac7a25
tests/quasiquotation/T7918.hs | 78 +++++++++++++++++++++++++++++++++++++
tests/quasiquotation/T7918.stdout | 27 +++++++++++++
tests/quasiquotation/T7918A.hs | 26 +++++++++++++
tests/quasiquotation/T7918B.hs | 19 +++++++++
tests/quasiquotation/all.T | 9 +++++
5 files changed, 159 insertions(+)
diff --git a/tests/quasiquotation/T7918.hs b/tests/quasiquotation/T7918.hs
new file mode 100644
index 0000000..7126cb1
--- /dev/null
+++ b/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/tests/quasiquotation/T7918.stdout b/tests/quasiquotation/T7918.stdout
new file mode 100644
index 0000000..43de631
--- /dev/null
+++ b/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/tests/quasiquotation/T7918A.hs b/tests/quasiquotation/T7918A.hs
new file mode 100644
index 0000000..f20dfee
--- /dev/null
+++ b/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/tests/quasiquotation/T7918B.hs b/tests/quasiquotation/T7918B.hs
new file mode 100644
index 0000000..9498014
--- /dev/null
+++ b/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/tests/quasiquotation/all.T b/tests/quasiquotation/all.T
index 6193001..63f6298 100644
--- a/tests/quasiquotation/all.T
+++ b/tests/quasiquotation/all.T
@@ -7,3 +7,12 @@ test('T4150',
['$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(['normal']),
+ 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'])
More information about the ghc-commits
mailing list