Test #4429, #5406

testsuite/tests/th/TH_lookupName.hs

+-- test 'lookupTypeName' and 'lookupValueName'
+
+import Language.Haskell.TH
+
+import qualified TH_lookupName_Lib
+import qualified TH_lookupName_Lib as TheLib
+
+f :: String
+f = "TH_lookupName.f"
+
+data D = D
+
+main = mapM_ print [
+  -- looking up values
+  $(do { Just n <- lookupValueName "f" ; varE n }),
+  $(do { Nothing <- lookupTypeName "f";  [| "" |] }),
+  -- looking up types
+  $(do { Just n <- lookupTypeName "String"; sigE [| "" |] (conT n) }),
+  $(do { Nothing <- lookupValueName "String"; [| "" |] }),
+  -- namespacing
+  $(do { Just n <- lookupValueName "D"; DataConI{} <- reify n; [| "" |] }),
+  $(do { Just n <- lookupTypeName "D"; TyConI{} <- reify n; [| "" |] }),
+  -- qualified lookup
+  $(do { Just n <- lookupValueName "TH_lookupName_Lib.f"; varE n }),
+  $(do { Just n <- lookupValueName "TheLib.f"; varE n }),
+  -- shadowing
+  $(TheLib.lookup_f),
+  $( [| let f = "local f" in $(TheLib.lookup_f) |] ),
+  $( [| let f = "local f" in $(do { Just n <- lookupValueName "f"; varE n }) |] ),
+  $( [| let f = "local f" in $(varE 'f) |] ),
+  let f = "local f" in $(TheLib.lookup_f),
+  let f = "local f" in $(varE 'f)
+ ]

testsuite/tests/th/TH_lookupName.stdout

+"TH_lookupName.f"
+""
+""
+""
+""
+""
+"TH_lookupName_Lib.f"
+"TH_lookupName_Lib.f"
+"TH_lookupName.f"
+"TH_lookupName.f"
+"TH_lookupName.f"
+"local f"
+"local f"
+"local f"

testsuite/tests/th/TH_lookupName_Lib.hs

+module TH_lookupName_Lib where
+
+import Language.Haskell.TH
+
+f :: String
+f = "TH_lookupName_Lib.f"
+
+lookup_f :: Q Exp
+lookup_f = do { Just n <- lookupValueName "f"; varE n }

testsuite/tests/th/TH_reifyDecl1.hs

 -- test reification of data declarations
 
+{-# LANGUAGE TypeFamilies #-}
 module TH_reifyDecl1 where
 
 import Language.Haskell.TH
 import Text.PrettyPrint.HughesPJ
 
-infixl 3 `m`
+infixl 3 `m1`
 
 -- simple
 data T = A | B
@@ -26,8 +27,37 @@ type IntList = [Int]
 newtype Length = Length Int
 
 -- simple class
-class C a where
-  m :: a -> Int
+class C1 a where
+  m1 :: a -> Int
+
+-- class with instances
+class C2 a where
+  m2 :: a -> Int
+instance C2 Int where
+  m2 x = x
+
+-- associated types
+class C3 a where
+  type AT1 a
+  data AT2 a
+
+instance C3 Int where
+  type AT1 Int = Bool
+  data AT2 Int = AT2Int
+
+-- type family
+type family TF1 a
+
+-- type family, with instances
+type family TF2 a
+type instance TF2 Bool = Bool
+
+-- data family
+data family DF1 a
+
+-- data family, with instances
+data family DF2 a
+data instance DF2 Bool = DBool
 
 test :: ()
 test = $(let 
@@ -40,7 +70,16 @@ test = $(let
 	      ; display ''IntList
 	      ; display ''Length
 	      ; display 'Leaf
-	      ; display 'm
+	      ; display 'm1
+	      ; display ''C1
+	      ; display ''C2
+	      ; display ''C3
+	      ; display ''AT1
+	      ; display ''AT2
+	      ; display ''TF1
+	      ; display ''TF2
+	      ; display ''DF1
+	      ; display ''DF2
 	      ; [| () |] })
 
 

testsuite/tests/th/TH_reifyDecl1.stderr

 
-TH_reifyDecl1.hs:33:10:
+TH_reifyDecl1.hs:63:10:
     data TH_reifyDecl1.T = TH_reifyDecl1.A | TH_reifyDecl1.B
 
-TH_reifyDecl1.hs:33:10:
+TH_reifyDecl1.hs:63:10:
     data TH_reifyDecl1.R a_0 = TH_reifyDecl1.C a_0 | TH_reifyDecl1.D
 
-TH_reifyDecl1.hs:33:10:
+TH_reifyDecl1.hs:63:10:
     data TH_reifyDecl1.List a_0
     = TH_reifyDecl1.Nil
     | TH_reifyDecl1.Cons a_0 (TH_reifyDecl1.List a_0)
 
-TH_reifyDecl1.hs:33:10:
+TH_reifyDecl1.hs:63:10:
     data TH_reifyDecl1.Tree a_0
     = TH_reifyDecl1.Leaf
     | (TH_reifyDecl1.Tree a_0) TH_reifyDecl1.:+: (TH_reifyDecl1.Tree a_0)
 
-TH_reifyDecl1.hs:33:10:
+TH_reifyDecl1.hs:63:10:
     type TH_reifyDecl1.IntList = [GHC.Types.Int]
 
-TH_reifyDecl1.hs:33:10:
+TH_reifyDecl1.hs:63:10:
     newtype TH_reifyDecl1.Length = TH_reifyDecl1.Length GHC.Types.Int
 
-TH_reifyDecl1.hs:33:10:
+TH_reifyDecl1.hs:63:10:
     Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall a_0 . TH_reifyDecl1.Tree a_0
 
-TH_reifyDecl1.hs:33:10:
-    Class op from TH_reifyDecl1.C: TH_reifyDecl1.m :: forall a_0 . TH_reifyDecl1.C a_0 =>
-                                                               a_0 -> GHC.Types.Int
-                               infixl 3 TH_reifyDecl1.m
+TH_reifyDecl1.hs:63:10:
+    Class op from TH_reifyDecl1.C1: TH_reifyDecl1.m1 :: forall a_0 . TH_reifyDecl1.C1 a_0 =>
+                                                                 a_0 -> GHC.Types.Int
+                                infixl 3 TH_reifyDecl1.m1
+
+TH_reifyDecl1.hs:63:10:
+    class TH_reifyDecl1.C1 a_0
+    where TH_reifyDecl1.m1 :: forall a_0 . TH_reifyDecl1.C1 a_0 =>
+                                           a_0 -> GHC.Types.Int
+
+TH_reifyDecl1.hs:63:10:
+    class TH_reifyDecl1.C2 a_0
+    where TH_reifyDecl1.m2 :: forall a_0 . TH_reifyDecl1.C2 a_0 =>
+                                           a_0 -> GHC.Types.Int
+instance TH_reifyDecl1.C2 GHC.Types.Int
+
+TH_reifyDecl1.hs:63:10:
+    class TH_reifyDecl1.C3 a_0
+instance TH_reifyDecl1.C3 GHC.Types.Int
+
+TH_reifyDecl1.hs:63:10:
+    type family TH_reifyDecl1.AT1 a_0 :: * -> *
+type instance TH_reifyDecl1.AT1 GHC.Types.Int = GHC.Types.Bool
+
+TH_reifyDecl1.hs:63:10:
+    data family TH_reifyDecl1.AT2 a_0 :: * -> *
+data instance TH_reifyDecl1.AT2 GHC.Types.Int
+    = TH_reifyDecl1.AT2Int
+
+TH_reifyDecl1.hs:63:10: type family TH_reifyDecl1.TF1 a_0 :: * -> *
+
+TH_reifyDecl1.hs:63:10:
+    type family TH_reifyDecl1.TF2 a_0 :: * -> *
+type instance TH_reifyDecl1.TF2 GHC.Types.Bool = GHC.Types.Bool
+
+TH_reifyDecl1.hs:63:10: data family TH_reifyDecl1.DF1 a_0 :: * -> *
+
+TH_reifyDecl1.hs:63:10:
+    data family TH_reifyDecl1.DF2 a_0 :: * -> *
+data instance TH_reifyDecl1.DF2 GHC.Types.Bool
+    = TH_reifyDecl1.DBool

testsuite/tests/th/TH_reifyInstances.hs

+-- test reifyInstances
+
+{-# LANGUAGE TypeFamilies #-}
+module TH_reifyInstances where
+
+import System.IO
+import Language.Haskell.TH
+import Text.PrettyPrint.HughesPJ
+
+-- classes
+class C1 a where f1 :: a
+
+class C2 a where f2 :: a
+instance C2 Int where f2 = 0
+instance C2 Bool where f2 = True
+
+-- type families
+type family T1 a
+
+type family T2 a
+type instance T2 Int = Char
+type instance T2 Bool = Int
+
+-- data families
+data family D1 a
+
+data family D2 a
+data instance D2 Int = DInt | DInt2
+data instance D2 Bool = DBool
+
+test :: ()
+test = $(let
+          display :: Name -> Q ()
+          display n = do 
+               { intTy <- [t| Int |]
+               ; is1 <- reifyInstances n [intTy]
+               ; runIO $ hPutStrLn stderr (nameBase n)
+               ; runIO $ hPutStrLn stderr (pprint is1)
+               }
+        in do { display ''C1
+              ; display ''C2
+              ; display ''T1
+              ; display ''T2
+              ; display ''D1
+              ; display ''D2
+              ; [| () |]
+              })

testsuite/tests/th/TH_reifyInstances.stderr

+C1
+
+C2
+instance TH_reifyInstances.C2 GHC.Types.Int
+T1
+
+T2
+type instance TH_reifyInstances.T2 GHC.Types.Int = GHC.Types.Char
+D1
+
+D2
+data instance TH_reifyInstances.D2 GHC.Types.Int
+    = TH_reifyInstances.DInt | TH_reifyInstances.DInt2

testsuite/tests/th/all.T

@@ -71,6 +71,8 @@ test('TH_reifyType1', normal, compile, [''])
 test('TH_reifyType2', normal, compile, [''])
 test('TH_reifyMkName', normal, compile, ['-v0'])
 
+test('TH_reifyInstances', normal, compile, ['-v0'])
+
 test('TH_spliceDecl1', normal, compile, ['-v0'])
 test('TH_spliceDecl2', normal, compile, ['-v0'])
 test('TH_spliceDecl3',
@@ -198,3 +200,7 @@ test('T5358', normal, compile_fail, [''])
 test('T5379', normal, compile_and_run, [''])
 test('T5404', normal, compile, ['-v0'])
 test('T5410', normal, compile_and_run, ['-v0'])
+test('TH_lookupName', 
+     extra_clean(['TH_lookupName_Lib.hi', 'TH_lookupName_Lib.o']),
+     multimod_compile_and_run,
+     ['TH_lookupName.hs', ''])