module Language.Haskell.TH.Syntax(
Quasi(..), Lift(..), liftString,
Q, runQ,
report, recover, reify,
location, runIO,
isClassInstance, classInstances,
Name(..), mkName, newName, nameBase, nameModule,
showName, showName', NameIs(..),
Dec(..), Exp(..), Con(..), Type(..), TyVarBndr(..), Kind(..),Cxt,
Pred(..), Match(..), Clause(..), Body(..), Guard(..), Stmt(..),
Range(..), Lit(..), Pat(..), FieldExp, FieldPat, ClassInstance(..),
Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
InlineSpec(..), StrictType, VarStrictType, FunDep(..), FamFlavour(..),
Info(..), Loc(..), CharPos,
Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
returnQ, bindQ, sequenceQ,
NameFlavour(..), NameSpace (..),
mkNameG_v, mkNameG_d, mkNameG_tc, Uniq, mkNameL, mkNameU,
tupleTypeName, tupleDataName,
OccName, mkOccName, occString,
ModName, mkModName, modString,
PkgName, mkPkgName, pkgString
) where
import GHC.Base ( Int(..), Int#, (<#), (==#) )
import Language.Haskell.TH.Syntax.Internals
import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex)
import qualified Data.Data as Data
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
import Control.Monad (liftM)
import System.IO ( hPutStrLn, stderr )
import Data.Char ( isAlpha )
class (Monad m, Functor m) => Quasi m where
qNewName :: String -> m Name
qReport :: Bool -> String -> m ()
qRecover :: m a
-> m a
-> m a
qReify :: Name -> m Info
qClassInstances :: Name -> [Type] -> m [Name]
qLocation :: m Loc
qRunIO :: IO a -> m a
instance Quasi IO where
qNewName s = do { n <- readIORef counter
; writeIORef counter (n+1)
; return (mkNameU s n) }
qReport True msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
qReify _ = badIO "reify"
qClassInstances _ _ = badIO "classInstances"
qLocation = badIO "currentLocation"
qRecover _ _ = badIO "recover"
qRunIO m = m
badIO :: String -> IO a
badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
; fail "Template Haskell failure" }
counter :: IORef Int
counter = unsafePerformIO (newIORef 0)
newtype Q a = Q { unQ :: forall m. Quasi m => m a }
runQ :: Quasi m => Q a -> m a
runQ (Q m) = m
instance Monad Q where
return x = Q (return x)
Q m >>= k = Q (m >>= \x -> unQ (k x))
Q m >> Q n = Q (m >> n)
fail s = report True s >> Q (fail "Q monad failure")
instance Functor Q where
fmap f (Q x) = Q (fmap f x)
newName :: String -> Q Name
newName s = Q (qNewName s)
report :: Bool -> String -> Q ()
report b s = Q (qReport b s)
recover :: Q a
-> Q a
-> Q a
recover (Q r) (Q m) = Q (qRecover r m)
reify :: Name -> Q Info
reify v = Q (qReify v)
classInstances :: Name -> [Type] -> Q [Name]
classInstances cls tys = Q (qClassInstances cls tys)
isClassInstance :: Name -> [Type] -> Q Bool
isClassInstance cls tys = do { dfuns <- classInstances cls tys
; return (not (null dfuns)) }
location :: Q Loc
location = Q qLocation
runIO :: IO a -> Q a
runIO m = Q (qRunIO m)
instance Quasi Q where
qNewName = newName
qReport = report
qRecover = recover
qReify = reify
qClassInstances = classInstances
qLocation = location
qRunIO = runIO
returnQ :: a -> Q a
returnQ = return
bindQ :: Q a -> (a -> Q b) -> Q b
bindQ = (>>=)
sequenceQ :: [Q a] -> Q [a]
sequenceQ = sequence
class Lift t where
lift :: t -> Q Exp
instance Lift Integer where
lift x = return (LitE (IntegerL x))
instance Lift Int where
lift x= return (LitE (IntegerL (fromIntegral x)))
instance Lift Char where
lift x = return (LitE (CharL x))
instance Lift Bool where
lift True = return (ConE trueName)
lift False = return (ConE falseName)
instance Lift a => Lift (Maybe a) where
lift Nothing = return (ConE nothingName)
lift (Just x) = liftM (ConE justName `AppE`) (lift x)
instance (Lift a, Lift b) => Lift (Either a b) where
lift (Left x) = liftM (ConE leftName `AppE`) (lift x)
lift (Right y) = liftM (ConE rightName `AppE`) (lift y)
instance Lift a => Lift [a] where
lift xs = do { xs' <- mapM lift xs; return (ListE xs') }
liftString :: String -> Q Exp
liftString s = return (LitE (StringL s))
instance (Lift a, Lift b) => Lift (a, b) where
lift (a, b)
= liftM TupE $ sequence [lift a, lift b]
instance (Lift a, Lift b, Lift c) => Lift (a, b, c) where
lift (a, b, c)
= liftM TupE $ sequence [lift a, lift b, lift c]
instance (Lift a, Lift b, Lift c, Lift d) => Lift (a, b, c, d) where
lift (a, b, c, d)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d]
instance (Lift a, Lift b, Lift c, Lift d, Lift e)
=> Lift (a, b, c, d, e) where
lift (a, b, c, d, e)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e]
instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f)
=> Lift (a, b, c, d, e, f) where
lift (a, b, c, d, e, f)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f]
instance (Lift a, Lift b, Lift c, Lift d, Lift e, Lift f, Lift g)
=> Lift (a, b, c, d, e, f, g) where
lift (a, b, c, d, e, f, g)
= liftM TupE $ sequence [lift a, lift b, lift c, lift d, lift e, lift f, lift g]
trueName, falseName :: Name
trueName = mkNameG DataName "ghc-prim" "GHC.Bool" "True"
falseName = mkNameG DataName "ghc-prim" "GHC.Bool" "False"
nothingName, justName :: Name
nothingName = mkNameG DataName "base" "Data.Maybe" "Nothing"
justName = mkNameG DataName "base" "Data.Maybe" "Just"
leftName, rightName :: Name
leftName = mkNameG DataName "base" "Data.Either" "Left"
rightName = mkNameG DataName "base" "Data.Either" "Right"
mkModName :: String -> ModName
mkModName s = ModName s
modString :: ModName -> String
modString (ModName m) = m
mkPkgName :: String -> PkgName
mkPkgName s = PkgName s
pkgString :: PkgName -> String
pkgString (PkgName m) = m
mkOccName :: String -> OccName
mkOccName s = OccName s
occString :: OccName -> String
occString (OccName occ) = occ
data Name = Name OccName NameFlavour deriving (Typeable, Data)
data NameFlavour
= NameS
| NameQ ModName
| NameU Int#
| NameL Int#
| NameG NameSpace PkgName ModName
deriving ( Typeable )
instance Data NameFlavour where
gfoldl _ z NameS = z NameS
gfoldl k z (NameQ mn) = z NameQ `k` mn
gfoldl k z (NameU i) = z (\(I# i') -> NameU i') `k` (I# i)
gfoldl k z (NameL i) = z (\(I# i') -> NameL i') `k` (I# i)
gfoldl k z (NameG ns p m) = z NameG `k` ns `k` p `k` m
gunfold k z c = case constrIndex c of
1 -> z NameS
2 -> k $ z NameQ
3 -> k $ z (\(I# i) -> NameU i)
4 -> k $ z (\(I# i) -> NameL i)
5 -> k $ k $ k $ z NameG
_ -> error "gunfold: NameFlavour"
toConstr NameS = con_NameS
toConstr (NameQ _) = con_NameQ
toConstr (NameU _) = con_NameU
toConstr (NameL _) = con_NameL
toConstr (NameG _ _ _) = con_NameG
dataTypeOf _ = ty_NameFlavour
con_NameS, con_NameQ, con_NameU, con_NameL, con_NameG :: Data.Constr
con_NameS = mkConstr ty_NameFlavour "NameS" [] Data.Prefix
con_NameQ = mkConstr ty_NameFlavour "NameQ" [] Data.Prefix
con_NameU = mkConstr ty_NameFlavour "NameU" [] Data.Prefix
con_NameL = mkConstr ty_NameFlavour "NameL" [] Data.Prefix
con_NameG = mkConstr ty_NameFlavour "NameG" [] Data.Prefix
ty_NameFlavour :: Data.DataType
ty_NameFlavour = mkDataType "Language.Haskell.TH.Syntax.NameFlavour"
[con_NameS, con_NameQ, con_NameU,
con_NameL, con_NameG]
data NameSpace = VarName
| DataName
| TcClsName
deriving( Eq, Ord, Data, Typeable )
type Uniq = Int
nameBase :: Name -> String
nameBase (Name occ _) = occString occ
nameModule :: Name -> Maybe String
nameModule (Name _ (NameQ m)) = Just (modString m)
nameModule (Name _ (NameG _ _ m)) = Just (modString m)
nameModule _ = Nothing
mkName :: String -> Name
mkName str
= split [] (reverse str)
where
split occ [] = Name (mkOccName occ) NameS
split occ ('.':rev) | not (null occ),
not (null rev), head rev /= '.'
= Name (mkOccName occ) (NameQ (mkModName (reverse rev)))
split occ (c:rev) = split (c:occ) rev
mkNameU :: String -> Uniq -> Name
mkNameU s (I# u) = Name (mkOccName s) (NameU u)
mkNameL :: String -> Uniq -> Name
mkNameL s (I# u) = Name (mkOccName s) (NameL u)
mkNameG :: NameSpace -> String -> String -> String -> Name
mkNameG ns pkg modu occ
= Name (mkOccName occ) (NameG ns (mkPkgName pkg) (mkModName modu))
mkNameG_v, mkNameG_tc, mkNameG_d :: String -> String -> String -> Name
mkNameG_v = mkNameG VarName
mkNameG_tc = mkNameG TcClsName
mkNameG_d = mkNameG DataName
instance Eq Name where
v1 == v2 = cmpEq (v1 `compare` v2)
instance Ord Name where
(Name o1 f1) `compare` (Name o2 f2) = (f1 `compare` f2) `thenCmp`
(o1 `compare` o2)
instance Eq NameFlavour where
f1 == f2 = cmpEq (f1 `compare` f2)
instance Ord NameFlavour where
NameS `compare` NameS = EQ
NameS `compare` _ = LT
(NameQ _) `compare` NameS = GT
(NameQ m1) `compare` (NameQ m2) = m1 `compare` m2
(NameQ _) `compare` _ = LT
(NameU _) `compare` NameS = GT
(NameU _) `compare` (NameQ _) = GT
(NameU u1) `compare` (NameU u2) | u1 <# u2 = LT
| u1 ==# u2 = EQ
| otherwise = GT
(NameU _) `compare` _ = LT
(NameL _) `compare` NameS = GT
(NameL _) `compare` (NameQ _) = GT
(NameL _) `compare` (NameU _) = GT
(NameL u1) `compare` (NameL u2) | u1 <# u2 = LT
| u1 ==# u2 = EQ
| otherwise = GT
(NameL _) `compare` _ = LT
(NameG ns1 p1 m1) `compare` (NameG ns2 p2 m2) = (ns1 `compare` ns2) `thenCmp`
(p1 `compare` p2) `thenCmp`
(m1 `compare` m2)
(NameG _ _ _) `compare` _ = GT
data NameIs = Alone | Applied | Infix
showName :: Name -> String
showName = showName' Alone
showName' :: NameIs -> Name -> String
showName' ni nm
= case ni of
Alone -> nms
Applied
| pnam -> nms
| otherwise -> "(" ++ nms ++ ")"
Infix
| pnam -> "`" ++ nms ++ "`"
| otherwise -> nms
where
nms = case nm of
Name occ NameS -> occString occ
Name occ (NameQ m) -> modString m ++ "." ++ occString occ
Name occ (NameG _ _ m) -> modString m ++ "." ++ occString occ
Name occ (NameU u) -> occString occ ++ "_" ++ show (I# u)
Name occ (NameL u) -> occString occ ++ "_" ++ show (I# u)
pnam = classify nms
classify "" = False
classify (x:xs) | isAlpha x || (x `elem` "_[]()") =
case dropWhile (/='.') xs of
(_:xs') -> classify xs'
[] -> True
| otherwise = False
instance Show Name where
show = showName
tupleDataName :: Int -> Name
tupleTypeName :: Int -> Name
tupleDataName 0 = mk_tup_name 0 DataName
tupleDataName 1 = error "tupleDataName 1"
tupleDataName n = mk_tup_name (n1) DataName
tupleTypeName 0 = mk_tup_name 0 TcClsName
tupleTypeName 1 = error "tupleTypeName 1"
tupleTypeName n = mk_tup_name (n1) TcClsName
mk_tup_name :: Int -> NameSpace -> Name
mk_tup_name n_commas space
= Name occ (NameG space (mkPkgName "ghc-prim") tup_mod)
where
occ = mkOccName ('(' : replicate n_commas ',' ++ ")")
tup_mod = mkModName "GHC.Tuple"
data Loc
= Loc { loc_filename :: String
, loc_package :: String
, loc_module :: String
, loc_start :: CharPos
, loc_end :: CharPos }
type CharPos = (Int, Int)
data Info
=
ClassI
Dec
[ClassInstance]
| ClassOpI
Name
Type
Name
Fixity
| TyConI Dec
| PrimTyConI
Name
Int
Bool
| DataConI
Name
Type
Name
Fixity
| VarI
Name
Type
(Maybe Dec)
Fixity
| TyVarI
Name
Type
deriving( Show, Data, Typeable )
data ClassInstance
= ClassInstance {
ci_dfun :: Name,
ci_tvs :: [TyVarBndr],
ci_cxt :: Cxt,
ci_cls :: Name,
ci_tys :: [Type]
} deriving( Show, Data, Typeable )
data Fixity = Fixity Int FixityDirection
deriving( Eq, Show, Data, Typeable )
data FixityDirection = InfixL | InfixR | InfixN
deriving( Eq, Show, Data, Typeable )
maxPrecedence :: Int
maxPrecedence = (9::Int)
defaultFixity :: Fixity
defaultFixity = Fixity maxPrecedence InfixL
data Lit = CharL Char
| StringL String
| IntegerL Integer
| RationalL Rational
| IntPrimL Integer
| WordPrimL Integer
| FloatPrimL Rational
| DoublePrimL Rational
| StringPrimL String
deriving( Show, Eq, Data, Typeable )
data Pat
= LitP Lit
| VarP Name
| TupP [Pat]
| ConP Name [Pat]
| InfixP Pat Name Pat
| TildeP Pat
| BangP Pat
| AsP Name Pat
| WildP
| RecP Name [FieldPat]
| ListP [ Pat ]
| SigP Pat Type
| ViewP Exp Pat
deriving( Show, Eq, Data, Typeable )
type FieldPat = (Name,Pat)
data Match = Match Pat Body [Dec]
deriving( Show, Eq, Data, Typeable )
data Clause = Clause [Pat] Body [Dec]
deriving( Show, Eq, Data, Typeable )
data Exp
= VarE Name
| ConE Name
| LitE Lit
| AppE Exp Exp
| InfixE (Maybe Exp) Exp (Maybe Exp)
| LamE [Pat] Exp
| TupE [Exp]
| CondE Exp Exp Exp
| LetE [Dec] Exp
| CaseE Exp [Match]
| DoE [Stmt]
| CompE [Stmt]
| ArithSeqE Range
| ListE [ Exp ]
| SigE Exp Type
| RecConE Name [FieldExp]
| RecUpdE Exp [FieldExp]
deriving( Show, Eq, Data, Typeable )
type FieldExp = (Name,Exp)
data Body
= GuardedB [(Guard,Exp)]
| NormalB Exp
deriving( Show, Eq, Data, Typeable )
data Guard
= NormalG Exp
| PatG [Stmt]
deriving( Show, Eq, Data, Typeable )
data Stmt
= BindS Pat Exp
| LetS [ Dec ]
| NoBindS Exp
| ParS [[Stmt]]
deriving( Show, Eq, Data, Typeable )
data Range = FromR Exp | FromThenR Exp Exp
| FromToR Exp Exp | FromThenToR Exp Exp Exp
deriving( Show, Eq, Data, Typeable )
data Dec
= FunD Name [Clause]
| ValD Pat Body [Dec]
| DataD Cxt Name [TyVarBndr]
[Con] [Name]
| NewtypeD Cxt Name [TyVarBndr]
Con [Name]
| TySynD Name [TyVarBndr] Type
| ClassD Cxt Name [TyVarBndr]
[FunDep] [Dec]
| InstanceD Cxt Type [Dec]
| SigD Name Type
| ForeignD Foreign
| PragmaD Pragma
| FamilyD FamFlavour Name
[TyVarBndr] (Maybe Kind)
| DataInstD Cxt Name [Type]
[Con] [Name]
| NewtypeInstD Cxt Name [Type]
Con [Name]
| TySynInstD Name [Type] Type
deriving( Show, Eq, Data, Typeable )
data FunDep = FunDep [Name] [Name]
deriving( Show, Eq, Data, Typeable )
data FamFlavour = TypeFam | DataFam
deriving( Show, Eq, Data, Typeable )
data Foreign = ImportF Callconv Safety String Name Type
| ExportF Callconv String Name Type
deriving( Show, Eq, Data, Typeable )
data Callconv = CCall | StdCall
deriving( Show, Eq, Data, Typeable )
data Safety = Unsafe | Safe | Threadsafe
deriving( Show, Eq, Data, Typeable )
data Pragma = InlineP Name InlineSpec
| SpecialiseP Name Type (Maybe InlineSpec)
deriving( Show, Eq, Data, Typeable )
data InlineSpec
= InlineSpec Bool
Bool
(Maybe (Bool, Int))
deriving( Show, Eq, Data, Typeable )
type Cxt = [Pred]
data Pred = ClassP Name [Type]
| EqualP Type Type
deriving( Show, Eq, Data, Typeable )
data Strict = IsStrict | NotStrict
deriving( Show, Eq, Data, Typeable )
data Con = NormalC Name [StrictType]
| RecC Name [VarStrictType]
| InfixC StrictType Name StrictType
| ForallC [TyVarBndr] Cxt Con
deriving( Show, Eq, Data, Typeable )
type StrictType = (Strict, Type)
type VarStrictType = (Name, Strict, Type)
data Type = ForallT [TyVarBndr] Cxt Type
| VarT Name
| ConT Name
| TupleT Int
| ArrowT
| ListT
| AppT Type Type
| SigT Type Kind
deriving( Show, Eq, Data, Typeable )
data TyVarBndr = PlainTV Name
| KindedTV Name Kind
deriving( Show, Eq, Data, Typeable )
data Kind = StarK
| ArrowK Kind Kind
deriving( Show, Eq, Data, Typeable )
cmpEq :: Ordering -> Bool
cmpEq EQ = True
cmpEq _ = False
thenCmp :: Ordering -> Ordering -> Ordering
thenCmp EQ o2 = o2
thenCmp o1 _ = o1