Test for T7918

5 files changed, 159 insertions, 0 deletions

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
index 6193001ec4..63f6298c35 100644
--- a/testsuite/tests/quasiquotation/all.T
+++ b/testsuite/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'])