Commit dee226cc authored by reinerp's avatar reinerp Committed by Simon Peyton Jones

Test #4429, #5406

parent b7aa8a83
-- 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)
]
"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"
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 }
-- 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
; [| () |] })
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
-- 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
; [| () |]
})
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
......@@ -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', ''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment