1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
module Language.Haskell.TH.Quote(
QuasiQuoter(..),
dataToQa, dataToExpQ, dataToPatQ,
quoteFile
) where
import Data.Data
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
data QuasiQuoter = QuasiQuoter { quoteExp :: String -> Q Exp,
quotePat :: String -> Q Pat,
quoteType :: String -> Q Type,
quoteDec :: String -> Q [Dec] }
dataToQa :: forall a k q. Data a
=> (Name -> k)
-> (Lit -> Q q)
-> (k -> [Q q] -> Q q)
-> (forall b . Data b => b -> Maybe (Q q))
-> a
-> Q q
dataToQa mkCon mkLit appCon antiQ t =
case antiQ t of
Nothing ->
case constrRep constr of
AlgConstr _ ->
appCon (mkCon conName) conArgs
where
conName :: Name
conName =
case showConstr constr of
"(:)" -> Name (mkOccName ":") (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))
con@"[]" -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))
con@('(':_) -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Tuple"))
con -> mkNameG_d (tyConPackage tycon)
(tyConModule tycon)
con
where
tycon :: TyCon
tycon = (typeRepTyCon . typeOf) t
conArgs :: [Q q]
conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
IntConstr n ->
mkLit $ integerL n
FloatConstr n ->
mkLit $ rationalL n
CharConstr c ->
mkLit $ charL c
where
constr :: Constr
constr = toConstr t
Just y -> y
-- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the same
-- value. It takes a function to handle type-specific cases.
dataToExpQ :: Data a
=> (forall b . Data b => b -> Maybe (Q Exp))
-> a
-> Q Exp
dataToExpQ = dataToQa conE litE (foldl appE)
-- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same
-- value. It takes a function to handle type-specific cases.
dataToPatQ :: Data a
=> (forall b . Data b => b -> Maybe (Q Pat))
-> a
-> Q Pat
dataToPatQ = dataToQa id litP conP
-- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read
-- the data out of a file. For example, suppose 'asmq' is an
-- assembly-language quoter, so that you can write [asmq| ld r1, r2 |]
-- as an expression. Then if you define @asmq_f = quoteFile asmq@, then
-- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead
-- of the inline text
quoteFile :: QuasiQuoter -> QuasiQuoter
quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd })
= QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd }
where
get :: (String -> Q a) -> String -> Q a
get old_quoter file_name = do { file_cts <- runIO (readFile file_name)
; addDependentFile file_name
; old_quoter file_cts }
|
