summaryrefslogtreecommitdiff
path: root/libraries/template-haskell/Language/Haskell/TH
diff options
context:
space:
mode:
Diffstat (limited to 'libraries/template-haskell/Language/Haskell/TH')
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib.hs671
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs108
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs568
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/PprLib.hs227
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Quote.hs87
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Syntax.hs1457
6 files changed, 3118 insertions, 0 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
new file mode 100644
index 0000000000..3ac16d1dba
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -0,0 +1,671 @@
+-- |
+-- TH.Lib contains lots of useful helper functions for
+-- generating and manipulating Template Haskell terms
+
+module Language.Haskell.TH.Lib where
+ -- All of the exports from this module should
+ -- be "public" functions. The main module TH
+ -- re-exports them all.
+
+import Language.Haskell.TH.Syntax hiding (Role)
+import qualified Language.Haskell.TH.Syntax as TH
+import Control.Monad( liftM, liftM2 )
+import Data.Word( Word8 )
+
+----------------------------------------------------------
+-- * Type synonyms
+----------------------------------------------------------
+
+type InfoQ = Q Info
+type PatQ = Q Pat
+type FieldPatQ = Q FieldPat
+type ExpQ = Q Exp
+type TExpQ a = Q (TExp a)
+type DecQ = Q Dec
+type DecsQ = Q [Dec]
+type ConQ = Q Con
+type TypeQ = Q Type
+type TyLitQ = Q TyLit
+type CxtQ = Q Cxt
+type PredQ = Q Pred
+type MatchQ = Q Match
+type ClauseQ = Q Clause
+type BodyQ = Q Body
+type GuardQ = Q Guard
+type StmtQ = Q Stmt
+type RangeQ = Q Range
+type StrictTypeQ = Q StrictType
+type VarStrictTypeQ = Q VarStrictType
+type FieldExpQ = Q FieldExp
+type RuleBndrQ = Q RuleBndr
+type TySynEqnQ = Q TySynEqn
+type Role = TH.Role -- must be defined here for DsMeta to find it
+
+----------------------------------------------------------
+-- * Lowercase pattern syntax functions
+----------------------------------------------------------
+
+intPrimL :: Integer -> Lit
+intPrimL = IntPrimL
+wordPrimL :: Integer -> Lit
+wordPrimL = WordPrimL
+floatPrimL :: Rational -> Lit
+floatPrimL = FloatPrimL
+doublePrimL :: Rational -> Lit
+doublePrimL = DoublePrimL
+integerL :: Integer -> Lit
+integerL = IntegerL
+charL :: Char -> Lit
+charL = CharL
+stringL :: String -> Lit
+stringL = StringL
+stringPrimL :: [Word8] -> Lit
+stringPrimL = StringPrimL
+rationalL :: Rational -> Lit
+rationalL = RationalL
+
+litP :: Lit -> PatQ
+litP l = return (LitP l)
+varP :: Name -> PatQ
+varP v = return (VarP v)
+tupP :: [PatQ] -> PatQ
+tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}
+unboxedTupP :: [PatQ] -> PatQ
+unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}
+conP :: Name -> [PatQ] -> PatQ
+conP n ps = do ps' <- sequence ps
+ return (ConP n ps')
+infixP :: PatQ -> Name -> PatQ -> PatQ
+infixP p1 n p2 = do p1' <- p1
+ p2' <- p2
+ return (InfixP p1' n p2')
+uInfixP :: PatQ -> Name -> PatQ -> PatQ
+uInfixP p1 n p2 = do p1' <- p1
+ p2' <- p2
+ return (UInfixP p1' n p2')
+parensP :: PatQ -> PatQ
+parensP p = do p' <- p
+ return (ParensP p')
+
+tildeP :: PatQ -> PatQ
+tildeP p = do p' <- p
+ return (TildeP p')
+bangP :: PatQ -> PatQ
+bangP p = do p' <- p
+ return (BangP p')
+asP :: Name -> PatQ -> PatQ
+asP n p = do p' <- p
+ return (AsP n p')
+wildP :: PatQ
+wildP = return WildP
+recP :: Name -> [FieldPatQ] -> PatQ
+recP n fps = do fps' <- sequence fps
+ return (RecP n fps')
+listP :: [PatQ] -> PatQ
+listP ps = do ps' <- sequence ps
+ return (ListP ps')
+sigP :: PatQ -> TypeQ -> PatQ
+sigP p t = do p' <- p
+ t' <- t
+ return (SigP p' t')
+viewP :: ExpQ -> PatQ -> PatQ
+viewP e p = do e' <- e
+ p' <- p
+ return (ViewP e' p')
+
+fieldPat :: Name -> PatQ -> FieldPatQ
+fieldPat n p = do p' <- p
+ return (n, p')
+
+
+-------------------------------------------------------------------------------
+-- * Stmt
+
+bindS :: PatQ -> ExpQ -> StmtQ
+bindS p e = liftM2 BindS p e
+
+letS :: [DecQ] -> StmtQ
+letS ds = do { ds1 <- sequence ds; return (LetS ds1) }
+
+noBindS :: ExpQ -> StmtQ
+noBindS e = do { e1 <- e; return (NoBindS e1) }
+
+parS :: [[StmtQ]] -> StmtQ
+parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) }
+
+-------------------------------------------------------------------------------
+-- * Range
+
+fromR :: ExpQ -> RangeQ
+fromR x = do { a <- x; return (FromR a) }
+
+fromThenR :: ExpQ -> ExpQ -> RangeQ
+fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }
+
+fromToR :: ExpQ -> ExpQ -> RangeQ
+fromToR x y = do { a <- x; b <- y; return (FromToR a b) }
+
+fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
+fromThenToR x y z = do { a <- x; b <- y; c <- z;
+ return (FromThenToR a b c) }
+-------------------------------------------------------------------------------
+-- * Body
+
+normalB :: ExpQ -> BodyQ
+normalB e = do { e1 <- e; return (NormalB e1) }
+
+guardedB :: [Q (Guard,Exp)] -> BodyQ
+guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }
+
+-------------------------------------------------------------------------------
+-- * Guard
+
+normalG :: ExpQ -> GuardQ
+normalG e = do { e1 <- e; return (NormalG e1) }
+
+normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
+normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }
+
+patG :: [StmtQ] -> GuardQ
+patG ss = do { ss' <- sequence ss; return (PatG ss') }
+
+patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)
+patGE ss e = do { ss' <- sequence ss;
+ e' <- e;
+ return (PatG ss', e') }
+
+-------------------------------------------------------------------------------
+-- * Match and Clause
+
+-- | Use with 'caseE'
+match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
+match p rhs ds = do { p' <- p;
+ r' <- rhs;
+ ds' <- sequence ds;
+ return (Match p' r' ds') }
+
+-- | Use with 'funD'
+clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
+clause ps r ds = do { ps' <- sequence ps;
+ r' <- r;
+ ds' <- sequence ds;
+ return (Clause ps' r' ds') }
+
+
+---------------------------------------------------------------------------
+-- * Exp
+
+-- | Dynamically binding a variable (unhygenic)
+dyn :: String -> ExpQ
+dyn s = return (VarE (mkName s))
+
+global :: Name -> ExpQ
+{-# DEPRECATED global "Use varE instead" #-}
+-- Trac #8656; I have no idea why this function is duplicated
+global s = return (VarE s)
+
+varE :: Name -> ExpQ
+varE s = return (VarE s)
+
+conE :: Name -> ExpQ
+conE s = return (ConE s)
+
+litE :: Lit -> ExpQ
+litE c = return (LitE c)
+
+appE :: ExpQ -> ExpQ -> ExpQ
+appE x y = do { a <- x; b <- y; return (AppE a b)}
+
+parensE :: ExpQ -> ExpQ
+parensE x = do { x' <- x; return (ParensE x') }
+
+uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
+ return (UInfixE x' s' y') }
+
+infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
+infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
+ return (InfixE (Just a) s' (Just b))}
+infixE Nothing s (Just y) = do { s' <- s; b <- y;
+ return (InfixE Nothing s' (Just b))}
+infixE (Just x) s Nothing = do { a <- x; s' <- s;
+ return (InfixE (Just a) s' Nothing)}
+infixE Nothing s Nothing = do { s' <- s; return (InfixE Nothing s' Nothing) }
+
+infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+infixApp x y z = infixE (Just x) y (Just z)
+sectionL :: ExpQ -> ExpQ -> ExpQ
+sectionL x y = infixE (Just x) y Nothing
+sectionR :: ExpQ -> ExpQ -> ExpQ
+sectionR x y = infixE Nothing x (Just y)
+
+lamE :: [PatQ] -> ExpQ -> ExpQ
+lamE ps e = do ps' <- sequence ps
+ e' <- e
+ return (LamE ps' e')
+
+-- | Single-arg lambda
+lam1E :: PatQ -> ExpQ -> ExpQ
+lam1E p e = lamE [p] e
+
+lamCaseE :: [MatchQ] -> ExpQ
+lamCaseE ms = sequence ms >>= return . LamCaseE
+
+tupE :: [ExpQ] -> ExpQ
+tupE es = do { es1 <- sequence es; return (TupE es1)}
+
+unboxedTupE :: [ExpQ] -> ExpQ
+unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}
+
+condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)}
+
+multiIfE :: [Q (Guard, Exp)] -> ExpQ
+multiIfE alts = sequence alts >>= return . MultiIfE
+
+letE :: [DecQ] -> ExpQ -> ExpQ
+letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }
+
+caseE :: ExpQ -> [MatchQ] -> ExpQ
+caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }
+
+doE :: [StmtQ] -> ExpQ
+doE ss = do { ss1 <- sequence ss; return (DoE ss1) }
+
+compE :: [StmtQ] -> ExpQ
+compE ss = do { ss1 <- sequence ss; return (CompE ss1) }
+
+arithSeqE :: RangeQ -> ExpQ
+arithSeqE r = do { r' <- r; return (ArithSeqE r') }
+
+listE :: [ExpQ] -> ExpQ
+listE es = do { es1 <- sequence es; return (ListE es1) }
+
+sigE :: ExpQ -> TypeQ -> ExpQ
+sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }
+
+recConE :: Name -> [Q (Name,Exp)] -> ExpQ
+recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }
+
+recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
+recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }
+
+stringE :: String -> ExpQ
+stringE = litE . stringL
+
+fieldExp :: Name -> ExpQ -> Q (Name, Exp)
+fieldExp s e = do { e' <- e; return (s,e') }
+
+-- ** 'arithSeqE' Shortcuts
+fromE :: ExpQ -> ExpQ
+fromE x = do { a <- x; return (ArithSeqE (FromR a)) }
+
+fromThenE :: ExpQ -> ExpQ -> ExpQ
+fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }
+
+fromToE :: ExpQ -> ExpQ -> ExpQ
+fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }
+
+fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
+fromThenToE x y z = do { a <- x; b <- y; c <- z;
+ return (ArithSeqE (FromThenToR a b c)) }
+
+
+-------------------------------------------------------------------------------
+-- * Dec
+
+valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
+valD p b ds =
+ do { p' <- p
+ ; ds' <- sequence ds
+ ; b' <- b
+ ; return (ValD p' b' ds')
+ }
+
+funD :: Name -> [ClauseQ] -> DecQ
+funD nm cs =
+ do { cs1 <- sequence cs
+ ; return (FunD nm cs1)
+ }
+
+tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
+tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }
+
+dataD :: CxtQ -> Name -> [TyVarBndr] -> [ConQ] -> [Name] -> DecQ
+dataD ctxt tc tvs cons derivs =
+ do
+ ctxt1 <- ctxt
+ cons1 <- sequence cons
+ return (DataD ctxt1 tc tvs cons1 derivs)
+
+newtypeD :: CxtQ -> Name -> [TyVarBndr] -> ConQ -> [Name] -> DecQ
+newtypeD ctxt tc tvs con derivs =
+ do
+ ctxt1 <- ctxt
+ con1 <- con
+ return (NewtypeD ctxt1 tc tvs con1 derivs)
+
+classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
+classD ctxt cls tvs fds decs =
+ do
+ decs1 <- sequence decs
+ ctxt1 <- ctxt
+ return $ ClassD ctxt1 cls tvs fds decs1
+
+instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
+instanceD ctxt ty decs =
+ do
+ ctxt1 <- ctxt
+ decs1 <- sequence decs
+ ty1 <- ty
+ return $ InstanceD ctxt1 ty1 decs1
+
+sigD :: Name -> TypeQ -> DecQ
+sigD fun ty = liftM (SigD fun) $ ty
+
+forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
+forImpD cc s str n ty
+ = do ty' <- ty
+ return $ ForeignD (ImportF cc s str n ty')
+
+infixLD :: Int -> Name -> DecQ
+infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)
+
+infixRD :: Int -> Name -> DecQ
+infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)
+
+infixND :: Int -> Name -> DecQ
+infixND prec nm = return (InfixD (Fixity prec InfixN) nm)
+
+pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ
+pragInlD name inline rm phases
+ = return $ PragmaD $ InlineP name inline rm phases
+
+pragSpecD :: Name -> TypeQ -> Phases -> DecQ
+pragSpecD n ty phases
+ = do
+ ty1 <- ty
+ return $ PragmaD $ SpecialiseP n ty1 Nothing phases
+
+pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ
+pragSpecInlD n ty inline phases
+ = do
+ ty1 <- ty
+ return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases
+
+pragSpecInstD :: TypeQ -> DecQ
+pragSpecInstD ty
+ = do
+ ty1 <- ty
+ return $ PragmaD $ SpecialiseInstP ty1
+
+pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
+pragRuleD n bndrs lhs rhs phases
+ = do
+ bndrs1 <- sequence bndrs
+ lhs1 <- lhs
+ rhs1 <- rhs
+ return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases
+
+pragAnnD :: AnnTarget -> ExpQ -> DecQ
+pragAnnD target expr
+ = do
+ exp1 <- expr
+ return $ PragmaD $ AnnP target exp1
+
+familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ
+familyNoKindD flav tc tvs = return $ FamilyD flav tc tvs Nothing
+
+familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ
+familyKindD flav tc tvs k = return $ FamilyD flav tc tvs (Just k)
+
+dataInstD :: CxtQ -> Name -> [TypeQ] -> [ConQ] -> [Name] -> DecQ
+dataInstD ctxt tc tys cons derivs =
+ do
+ ctxt1 <- ctxt
+ tys1 <- sequence tys
+ cons1 <- sequence cons
+ return (DataInstD ctxt1 tc tys1 cons1 derivs)
+
+newtypeInstD :: CxtQ -> Name -> [TypeQ] -> ConQ -> [Name] -> DecQ
+newtypeInstD ctxt tc tys con derivs =
+ do
+ ctxt1 <- ctxt
+ tys1 <- sequence tys
+ con1 <- con
+ return (NewtypeInstD ctxt1 tc tys1 con1 derivs)
+
+tySynInstD :: Name -> TySynEqnQ -> DecQ
+tySynInstD tc eqn =
+ do
+ eqn1 <- eqn
+ return (TySynInstD tc eqn1)
+
+closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ
+closedTypeFamilyNoKindD tc tvs eqns =
+ do
+ eqns1 <- sequence eqns
+ return (ClosedTypeFamilyD tc tvs Nothing eqns1)
+
+closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ
+closedTypeFamilyKindD tc tvs kind eqns =
+ do
+ eqns1 <- sequence eqns
+ return (ClosedTypeFamilyD tc tvs (Just kind) eqns1)
+
+roleAnnotD :: Name -> [Role] -> DecQ
+roleAnnotD name roles = return $ RoleAnnotD name roles
+
+tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ
+tySynEqn lhs rhs =
+ do
+ lhs1 <- sequence lhs
+ rhs1 <- rhs
+ return (TySynEqn lhs1 rhs1)
+
+cxt :: [PredQ] -> CxtQ
+cxt = sequence
+
+normalC :: Name -> [StrictTypeQ] -> ConQ
+normalC con strtys = liftM (NormalC con) $ sequence strtys
+
+recC :: Name -> [VarStrictTypeQ] -> ConQ
+recC con varstrtys = liftM (RecC con) $ sequence varstrtys
+
+infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ
+infixC st1 con st2 = do st1' <- st1
+ st2' <- st2
+ return $ InfixC st1' con st2'
+
+forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
+forallC ns ctxt con = liftM2 (ForallC ns) ctxt con
+
+
+-------------------------------------------------------------------------------
+-- * Type
+
+forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
+forallT tvars ctxt ty = do
+ ctxt1 <- ctxt
+ ty1 <- ty
+ return $ ForallT tvars ctxt1 ty1
+
+varT :: Name -> TypeQ
+varT = return . VarT
+
+conT :: Name -> TypeQ
+conT = return . ConT
+
+appT :: TypeQ -> TypeQ -> TypeQ
+appT t1 t2 = do
+ t1' <- t1
+ t2' <- t2
+ return $ AppT t1' t2'
+
+arrowT :: TypeQ
+arrowT = return ArrowT
+
+listT :: TypeQ
+listT = return ListT
+
+litT :: TyLitQ -> TypeQ
+litT l = fmap LitT l
+
+tupleT :: Int -> TypeQ
+tupleT i = return (TupleT i)
+
+unboxedTupleT :: Int -> TypeQ
+unboxedTupleT i = return (UnboxedTupleT i)
+
+sigT :: TypeQ -> Kind -> TypeQ
+sigT t k
+ = do
+ t' <- t
+ return $ SigT t' k
+
+equalityT :: TypeQ
+equalityT = return EqualityT
+
+{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}
+classP :: Name -> [Q Type] -> Q Pred
+classP cla tys
+ = do
+ tysl <- sequence tys
+ return (foldl AppT (ConT cla) tysl)
+
+{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}
+equalP :: TypeQ -> TypeQ -> PredQ
+equalP tleft tright
+ = do
+ tleft1 <- tleft
+ tright1 <- tright
+ eqT <- equalityT
+ return (foldl AppT eqT [tleft1, tright1])
+
+promotedT :: Name -> TypeQ
+promotedT = return . PromotedT
+
+promotedTupleT :: Int -> TypeQ
+promotedTupleT i = return (PromotedTupleT i)
+
+promotedNilT :: TypeQ
+promotedNilT = return PromotedNilT
+
+promotedConsT :: TypeQ
+promotedConsT = return PromotedConsT
+
+isStrict, notStrict, unpacked :: Q Strict
+isStrict = return $ IsStrict
+notStrict = return $ NotStrict
+unpacked = return Unpacked
+
+strictType :: Q Strict -> TypeQ -> StrictTypeQ
+strictType = liftM2 (,)
+
+varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
+varStrictType v st = do (s, t) <- st
+ return (v, s, t)
+
+-- * Type Literals
+
+numTyLit :: Integer -> TyLitQ
+numTyLit n = if n >= 0 then return (NumTyLit n)
+ else fail ("Negative type-level number: " ++ show n)
+
+strTyLit :: String -> TyLitQ
+strTyLit s = return (StrTyLit s)
+
+
+
+-------------------------------------------------------------------------------
+-- * Kind
+
+plainTV :: Name -> TyVarBndr
+plainTV = PlainTV
+
+kindedTV :: Name -> Kind -> TyVarBndr
+kindedTV = KindedTV
+
+varK :: Name -> Kind
+varK = VarT
+
+conK :: Name -> Kind
+conK = ConT
+
+tupleK :: Int -> Kind
+tupleK = TupleT
+
+arrowK :: Kind
+arrowK = ArrowT
+
+listK :: Kind
+listK = ListT
+
+appK :: Kind -> Kind -> Kind
+appK = AppT
+
+starK :: Kind
+starK = StarT
+
+constraintK :: Kind
+constraintK = ConstraintT
+
+-------------------------------------------------------------------------------
+-- * Role
+
+nominalR, representationalR, phantomR, inferR :: Role
+nominalR = NominalR
+representationalR = RepresentationalR
+phantomR = PhantomR
+inferR = InferR
+
+-------------------------------------------------------------------------------
+-- * Callconv
+
+cCall, stdCall :: Callconv
+cCall = CCall
+stdCall = StdCall
+
+-------------------------------------------------------------------------------
+-- * Safety
+
+unsafe, safe, interruptible :: Safety
+unsafe = Unsafe
+safe = Safe
+interruptible = Interruptible
+
+-------------------------------------------------------------------------------
+-- * FunDep
+
+funDep :: [Name] -> [Name] -> FunDep
+funDep = FunDep
+
+-------------------------------------------------------------------------------
+-- * FamFlavour
+
+typeFam, dataFam :: FamFlavour
+typeFam = TypeFam
+dataFam = DataFam
+
+-------------------------------------------------------------------------------
+-- * RuleBndr
+ruleVar :: Name -> RuleBndrQ
+ruleVar = return . RuleVar
+
+typedRuleVar :: Name -> TypeQ -> RuleBndrQ
+typedRuleVar n ty = ty >>= return . TypedRuleVar n
+
+--------------------------------------------------------------
+-- * Useful helper function
+
+appsE :: [ExpQ] -> ExpQ
+appsE [] = error "appsE []"
+appsE [x] = x
+appsE (x:y:zs) = appsE ( (appE x y) : zs )
+
+-- | Return the Module at the place of splicing. Can be used as an
+-- input for 'reifyModule'.
+thisModule :: Q Module
+thisModule = do
+ loc <- location
+ return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs
new file mode 100644
index 0000000000..ac241515b8
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- This is a non-exposed internal module
+--
+-- The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost
+-- verbatimely to avoid a dependency of 'template-haskell' on the containers package.
+--
+-- [1] see https://hackage.haskell.org/package/containers-0.5.5.1
+--
+-- The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al.
+
+module Language.Haskell.TH.Lib.Map
+ ( Map
+ , empty
+ , insert
+ , Language.Haskell.TH.Lib.Map.lookup
+ ) where
+
+data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
+ | Tip
+
+type Size = Int
+
+empty :: Map k a
+empty = Tip
+{-# INLINE empty #-}
+
+singleton :: k -> a -> Map k a
+singleton k x = Bin 1 k x Tip Tip
+{-# INLINE singleton #-}
+
+size :: Map k a -> Int
+size Tip = 0
+size (Bin sz _ _ _ _) = sz
+{-# INLINE size #-}
+
+lookup :: Ord k => k -> Map k a -> Maybe a
+lookup = go
+ where
+ go _ Tip = Nothing
+ go !k (Bin _ kx x l r) = case compare k kx of
+ LT -> go k l
+ GT -> go k r
+ EQ -> Just x
+{-# INLINABLE lookup #-}
+
+
+insert :: Ord k => k -> a -> Map k a -> Map k a
+insert = go
+ where
+ go :: Ord k => k -> a -> Map k a -> Map k a
+ go !kx x Tip = singleton kx x
+ go !kx x (Bin sz ky y l r) =
+ case compare kx ky of
+ LT -> balanceL ky y (go kx x l) r
+ GT -> balanceR ky y l (go kx x r)
+ EQ -> Bin sz kx x l r
+{-# INLINABLE insert #-}
+
+balanceL :: k -> a -> Map k a -> Map k a -> Map k a
+balanceL k x l r = case r of
+ Tip -> case l of
+ Tip -> Bin 1 k x Tip Tip
+ (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip
+ (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)
+ (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)
+ (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))
+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)
+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)
+
+ (Bin rs _ _ _ _) -> case l of
+ Tip -> Bin (1+rs) k x Tip r
+
+ (Bin ls lk lx ll lr)
+ | ls > delta*rs -> case (ll, lr) of
+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)
+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)
+ | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)
+ (_, _) -> error "Failure in Data.Map.balanceL"
+ | otherwise -> Bin (1+ls+rs) k x l r
+{-# NOINLINE balanceL #-}
+
+balanceR :: k -> a -> Map k a -> Map k a -> Map k a
+balanceR k x l r = case l of
+ Tip -> case r of
+ Tip -> Bin 1 k x Tip Tip
+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r
+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr
+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)
+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))
+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr
+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
+
+ (Bin ls _ _ _ _) -> case r of
+ Tip -> Bin (1+ls) k x l Tip
+
+ (Bin rs rk rx rl rr)
+ | rs > delta*ls -> case (rl, rr) of
+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)
+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr
+ | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
+ (_, _) -> error "Failure in Data.Map.balanceR"
+ | otherwise -> Bin (1+ls+rs) k x l r
+{-# NOINLINE balanceR #-}
+
+delta,ratio :: Int
+delta = 3
+ratio = 2
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
new file mode 100644
index 0000000000..e2370666e4
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -0,0 +1,568 @@
+-- | contains a prettyprinter for the
+-- Template Haskell datatypes
+
+module Language.Haskell.TH.Ppr where
+ -- All of the exports from this module should
+ -- be "public" functions. The main module TH
+ -- re-exports them all.
+
+import Text.PrettyPrint (render)
+import Language.Haskell.TH.PprLib
+import Language.Haskell.TH.Syntax
+import Data.Word ( Word8 )
+import Data.Char ( toLower, chr, ord, isSymbol )
+import GHC.Show ( showMultiLineString )
+import Data.Ratio ( numerator, denominator )
+
+nestDepth :: Int
+nestDepth = 4
+
+type Precedence = Int
+appPrec, unopPrec, opPrec, noPrec :: Precedence
+appPrec = 3 -- Argument of a function application
+opPrec = 2 -- Argument of an infix operator
+unopPrec = 1 -- Argument of an unresolved infix operator
+noPrec = 0 -- Others
+
+parensIf :: Bool -> Doc -> Doc
+parensIf True d = parens d
+parensIf False d = d
+
+------------------------------
+
+pprint :: Ppr a => a -> String
+pprint x = render $ to_HPJ_Doc $ ppr x
+
+class Ppr a where
+ ppr :: a -> Doc
+ ppr_list :: [a] -> Doc
+ ppr_list = vcat . map ppr
+
+instance Ppr a => Ppr [a] where
+ ppr x = ppr_list x
+
+------------------------------
+instance Ppr Name where
+ ppr v = pprName v
+
+------------------------------
+instance Ppr Info where
+ ppr (TyConI d) = ppr d
+ ppr (ClassI d is) = ppr d $$ vcat (map ppr is)
+ ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)
+ ppr (PrimTyConI name arity is_unlifted)
+ = text "Primitive"
+ <+> (if is_unlifted then text "unlifted" else empty)
+ <+> text "type constructor" <+> quotes (ppr name)
+ <+> parens (text "arity" <+> int arity)
+ ppr (ClassOpI v ty cls fix)
+ = text "Class op from" <+> ppr cls <> colon <+>
+ vcat [ppr_sig v ty, pprFixity v fix]
+ ppr (DataConI v ty tc fix)
+ = text "Constructor from" <+> ppr tc <> colon <+>
+ vcat [ppr_sig v ty, pprFixity v fix]
+ ppr (TyVarI v ty)
+ = text "Type variable" <+> ppr v <+> equals <+> ppr ty
+ ppr (VarI v ty mb_d fix)
+ = vcat [ppr_sig v ty, pprFixity v fix,
+ case mb_d of { Nothing -> empty; Just d -> ppr d }]
+
+ppr_sig :: Name -> Type -> Doc
+ppr_sig v ty = ppr v <+> text "::" <+> ppr ty
+
+pprFixity :: Name -> Fixity -> Doc
+pprFixity _ f | f == defaultFixity = empty
+pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
+ where ppr_fix InfixR = text "infixr"
+ ppr_fix InfixL = text "infixl"
+ ppr_fix InfixN = text "infix"
+
+
+------------------------------
+instance Ppr Module where
+ ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m)
+
+instance Ppr ModuleInfo where
+ ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps)
+
+------------------------------
+instance Ppr Exp where
+ ppr = pprExp noPrec
+
+pprPrefixOcc :: Name -> Doc
+-- Print operators with parens around them
+pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)
+
+isSymOcc :: Name -> Bool
+isSymOcc n
+ = case nameBase n of
+ [] -> True -- Empty name; weird
+ (c:_) -> isSymbolASCII c || (ord c > 0x7f && isSymbol c)
+ -- c.f. OccName.startsVarSym in GHC itself
+
+isSymbolASCII :: Char -> Bool
+isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
+
+pprInfixExp :: Exp -> Doc
+pprInfixExp (VarE v) = pprName' Infix v
+pprInfixExp (ConE v) = pprName' Infix v
+pprInfixExp _ = text "<<Non-variable/constructor in infix context>>"
+
+pprExp :: Precedence -> Exp -> Doc
+pprExp _ (VarE v) = pprName' Applied v
+pprExp _ (ConE c) = pprName' Applied c
+pprExp i (LitE l) = pprLit i l
+pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
+ <+> pprExp appPrec e2
+pprExp _ (ParensE e) = parens (pprExp noPrec e)
+pprExp i (UInfixE e1 op e2)
+ = parensIf (i > unopPrec) $ pprExp unopPrec e1
+ <+> pprInfixExp op
+ <+> pprExp unopPrec e2
+pprExp i (InfixE (Just e1) op (Just e2))
+ = parensIf (i >= opPrec) $ pprExp opPrec e1
+ <+> pprInfixExp op
+ <+> pprExp opPrec e2
+pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
+ <+> pprInfixExp op
+ <+> pprMaybeExp noPrec me2
+pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
+ <+> text "->" <+> ppr e
+pprExp i (LamCaseE ms) = parensIf (i > noPrec)
+ $ text "\\case" $$ nest nestDepth (ppr ms)
+pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es
+pprExp _ (UnboxedTupE es) = hashParens $ sep $ punctuate comma $ map ppr es
+-- Nesting in Cond is to avoid potential problems in do statments
+pprExp i (CondE guard true false)
+ = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,
+ nest 1 $ text "then" <+> ppr true,
+ nest 1 $ text "else" <+> ppr false]
+pprExp i (MultiIfE alts)
+ = parensIf (i > noPrec) $ vcat $
+ case alts of
+ [] -> [text "if {}"]
+ (alt : alts') -> text "if" <+> pprGuarded arrow alt
+ : map (nest 3 . pprGuarded arrow) alts'
+pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_
+ $$ text " in" <+> ppr e
+ where
+ pprDecs [] = empty
+ pprDecs [d] = ppr d
+ pprDecs ds = braces $ sep $ punctuate semi $ map ppr ds
+
+pprExp i (CaseE e ms)
+ = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
+ $$ nest nestDepth (ppr ms)
+pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
+ where
+ pprStms [] = empty
+ pprStms [s] = ppr s
+ pprStms ss = braces $ sep $ punctuate semi $ map ppr ss
+
+pprExp _ (CompE []) = text "<<Empty CompExp>>"
+-- This will probably break with fixity declarations - would need a ';'
+pprExp _ (CompE ss) = text "[" <> ppr s
+ <+> text "|"
+ <+> (sep $ punctuate comma $ map ppr ss')
+ <> text "]"
+ where s = last ss
+ ss' = init ss
+pprExp _ (ArithSeqE d) = ppr d
+pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es
+pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t
+pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
+pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
+
+pprFields :: [(Name,Exp)] -> Doc
+pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
+
+pprMaybeExp :: Precedence -> Maybe Exp -> Doc
+pprMaybeExp _ Nothing = empty
+pprMaybeExp i (Just e) = pprExp i e
+
+------------------------------
+instance Ppr Stmt where
+ ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
+ ppr (LetS ds) = text "let" <+> ppr ds
+ ppr (NoBindS e) = ppr e
+ ppr (ParS sss) = sep $ punctuate (text "|")
+ $ map (sep . punctuate comma . map ppr) sss
+
+------------------------------
+instance Ppr Match where
+ ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
+ $$ where_clause ds
+
+------------------------------
+pprGuarded :: Doc -> (Guard, Exp) -> Doc
+pprGuarded eqDoc (guard, expr) = case guard of
+ NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr
+ PatG stmts -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$
+ nest nestDepth (eqDoc <+> ppr expr)
+
+------------------------------
+pprBody :: Bool -> Body -> Doc
+pprBody eq body = case body of
+ GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs
+ NormalB e -> eqDoc <+> ppr e
+ where eqDoc | eq = equals
+ | otherwise = arrow
+
+------------------------------
+pprLit :: Precedence -> Lit -> Doc
+pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0)
+ (integer x <> char '#')
+pprLit _ (WordPrimL x) = integer x <> text "##"
+pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0)
+ (float (fromRational x) <> char '#')
+pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
+ (double (fromRational x) <> text "##")
+pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)
+pprLit _ (CharL c) = text (show c)
+pprLit _ (StringL s) = pprString s
+pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'
+pprLit i (RationalL rat) = parensIf (i > noPrec) $
+ integer (numerator rat) <+> char '/'
+ <+> integer (denominator rat)
+
+bytesToString :: [Word8] -> String
+bytesToString = map (chr . fromIntegral)
+
+pprString :: String -> Doc
+-- Print newlines as newlines with Haskell string escape notation,
+-- not as '\n'. For other non-printables use regular escape notation.
+pprString s = vcat (map text (showMultiLineString s))
+
+------------------------------
+instance Ppr Pat where
+ ppr = pprPat noPrec
+
+pprPat :: Precedence -> Pat -> Doc
+pprPat i (LitP l) = pprLit i l
+pprPat _ (VarP v) = pprName' Applied v
+pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps
+pprPat _ (UnboxedTupP ps) = hashParens $ sep $ punctuate comma $ map ppr ps
+pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s
+ <+> sep (map (pprPat appPrec) ps)
+pprPat _ (ParensP p) = parens $ pprPat noPrec p
+pprPat i (UInfixP p1 n p2)
+ = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>
+ pprName' Infix n <+>
+ pprPat unopPrec p2)
+pprPat i (InfixP p1 n p2)
+ = parensIf (i >= opPrec) (pprPat opPrec p1 <+>
+ pprName' Infix n <+>
+ pprPat opPrec p2)
+pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p
+pprPat i (BangP p) = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p
+pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"
+ <> pprPat appPrec p
+pprPat _ WildP = text "_"
+pprPat _ (RecP nm fs)
+ = parens $ ppr nm
+ <+> braces (sep $ punctuate comma $
+ map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
+pprPat _ (ListP ps) = brackets $ sep $ punctuate comma $ map ppr ps
+pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> text "::" <+> ppr t
+pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p
+
+------------------------------
+instance Ppr Dec where
+ ppr = ppr_dec True
+
+ppr_dec :: Bool -- declaration on the toplevel?
+ -> Dec
+ -> Doc
+ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs
+ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
+ $$ where_clause ds
+ppr_dec _ (TySynD t xs rhs)
+ = ppr_tySyn empty t (hsep (map ppr xs)) rhs
+ppr_dec _ (DataD ctxt t xs cs decs)
+ = ppr_data empty ctxt t (hsep (map ppr xs)) cs decs
+ppr_dec _ (NewtypeD ctxt t xs c decs)
+ = ppr_newtype empty ctxt t (sep (map ppr xs)) c decs
+ppr_dec _ (ClassD ctxt c xs fds ds)
+ = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
+ $$ where_clause ds
+ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
+ $$ where_clause ds
+ppr_dec _ (SigD f t) = pprPrefixOcc f <+> text "::" <+> ppr t
+ppr_dec _ (ForeignD f) = ppr f
+ppr_dec _ (InfixD fx n) = pprFixity n fx
+ppr_dec _ (PragmaD p) = ppr p
+ppr_dec isTop (FamilyD flav tc tvs k)
+ = ppr flav <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
+ where
+ maybeFamily | isTop = text "family"
+ | otherwise = empty
+
+ maybeKind | (Just k') <- k = text "::" <+> ppr k'
+ | otherwise = empty
+ppr_dec isTop (DataInstD ctxt tc tys cs decs)
+ = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) cs decs
+ where
+ maybeInst | isTop = text "instance"
+ | otherwise = empty
+ppr_dec isTop (NewtypeInstD ctxt tc tys c decs)
+ = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) c decs
+ where
+ maybeInst | isTop = text "instance"
+ | otherwise = empty
+ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
+ = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
+ where
+ maybeInst | isTop = text "instance"
+ | otherwise = empty
+ppr_dec _ (ClosedTypeFamilyD tc tvs mkind eqns)
+ = hang (hsep [ text "type family", ppr tc, hsep (map ppr tvs), maybeKind
+ , text "where" ])
+ nestDepth (vcat (map ppr_eqn eqns))
+ where
+ maybeKind | (Just k') <- mkind = text "::" <+> ppr k'
+ | otherwise = empty
+ ppr_eqn (TySynEqn lhs rhs)
+ = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
+
+ppr_dec _ (RoleAnnotD name roles)
+ = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
+
+ppr_data :: Doc -> Cxt -> Name -> Doc -> [Con] -> [Name] -> Doc
+ppr_data maybeInst ctxt t argsDoc cs decs
+ = sep [text "data" <+> maybeInst
+ <+> pprCxt ctxt
+ <+> ppr t <+> argsDoc,
+ nest nestDepth (sep (pref $ map ppr cs)),
+ if null decs
+ then empty
+ else nest nestDepth
+ $ text "deriving"
+ <+> parens (hsep $ punctuate comma $ map ppr decs)]
+ where
+ pref :: [Doc] -> [Doc]
+ pref [] = [] -- No constructors; can't happen in H98
+ pref (d:ds) = (char '=' <+> d):map (char '|' <+>) ds
+
+ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Con -> [Name] -> Doc
+ppr_newtype maybeInst ctxt t argsDoc c decs
+ = sep [text "newtype" <+> maybeInst
+ <+> pprCxt ctxt
+ <+> ppr t <+> argsDoc,
+ nest 2 (char '=' <+> ppr c),
+ if null decs
+ then empty
+ else nest nestDepth
+ $ text "deriving"
+ <+> parens (hsep $ punctuate comma $ map ppr decs)]
+
+ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
+ppr_tySyn maybeInst t argsDoc rhs
+ = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
+
+------------------------------
+instance Ppr FunDep where
+ ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
+ ppr_list [] = empty
+ ppr_list xs = char '|' <+> sep (punctuate (text ", ") (map ppr xs))
+
+------------------------------
+instance Ppr FamFlavour where
+ ppr DataFam = text "data"
+ ppr TypeFam = text "type"
+
+------------------------------
+instance Ppr Foreign where
+ ppr (ImportF callconv safety impent as typ)
+ = text "foreign import"
+ <+> showtextl callconv
+ <+> showtextl safety
+ <+> text (show impent)
+ <+> ppr as
+ <+> text "::" <+> ppr typ
+ ppr (ExportF callconv expent as typ)
+ = text "foreign export"
+ <+> showtextl callconv
+ <+> text (show expent)
+ <+> ppr as
+ <+> text "::" <+> ppr typ
+
+------------------------------
+instance Ppr Pragma where
+ ppr (InlineP n inline rm phases)
+ = text "{-#"
+ <+> ppr inline
+ <+> ppr rm
+ <+> ppr phases
+ <+> ppr n
+ <+> text "#-}"
+ ppr (SpecialiseP n ty inline phases)
+ = text "{-# SPECIALISE"
+ <+> maybe empty ppr inline
+ <+> ppr phases
+ <+> sep [ ppr n <+> text "::"
+ , nest 2 $ ppr ty ]
+ <+> text "#-}"
+ ppr (SpecialiseInstP inst)
+ = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
+ ppr (RuleP n bndrs lhs rhs phases)
+ = sep [ text "{-# RULES" <+> pprString n <+> ppr phases
+ , nest 4 $ ppr_forall <+> ppr lhs
+ , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
+ where ppr_forall | null bndrs = empty
+ | otherwise = text "forall"
+ <+> fsep (map ppr bndrs)
+ <+> char '.'
+ ppr (AnnP tgt expr)
+ = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
+ where target1 ModuleAnnotation = text "module"
+ target1 (TypeAnnotation t) = text "type" <+> ppr t
+ target1 (ValueAnnotation v) = ppr v
+
+------------------------------
+instance Ppr Inline where
+ ppr NoInline = text "NOINLINE"
+ ppr Inline = text "INLINE"
+ ppr Inlinable = text "INLINABLE"
+
+------------------------------
+instance Ppr RuleMatch where
+ ppr ConLike = text "CONLIKE"
+ ppr FunLike = empty
+
+------------------------------
+instance Ppr Phases where
+ ppr AllPhases = empty
+ ppr (FromPhase i) = brackets $ int i
+ ppr (BeforePhase i) = brackets $ char '~' <> int i
+
+------------------------------
+instance Ppr RuleBndr where
+ ppr (RuleVar n) = ppr n
+ ppr (TypedRuleVar n ty) = parens $ ppr n <+> text "::" <+> ppr ty
+
+------------------------------
+instance Ppr Clause where
+ ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
+ $$ where_clause ds
+
+------------------------------
+instance Ppr Con where
+ ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)
+ ppr (RecC c vsts)
+ = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))
+ ppr (InfixC st1 c st2) = pprStrictType st1
+ <+> pprName' Infix c
+ <+> pprStrictType st2
+ ppr (ForallC ns ctxt con) = text "forall" <+> hsep (map ppr ns)
+ <+> char '.' <+> sep [pprCxt ctxt, ppr con]
+
+------------------------------
+pprVarStrictType :: (Name, Strict, Type) -> Doc
+-- Slight infelicity: with print non-atomic type with parens
+pprVarStrictType (v, str, t) = ppr v <+> text "::" <+> pprStrictType (str, t)
+
+------------------------------
+pprStrictType :: (Strict, Type) -> Doc
+-- Prints with parens if not already atomic
+pprStrictType (IsStrict, t) = char '!' <> pprParendType t
+pprStrictType (NotStrict, t) = pprParendType t
+pprStrictType (Unpacked, t) = text "{-# UNPACK #-} !" <> pprParendType t
+
+------------------------------
+pprParendType :: Type -> Doc
+pprParendType (VarT v) = ppr v
+pprParendType (ConT c) = ppr c
+pprParendType (TupleT 0) = text "()"
+pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
+pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
+pprParendType ArrowT = parens (text "->")
+pprParendType ListT = text "[]"
+pprParendType (LitT l) = pprTyLit l
+pprParendType (PromotedT c) = text "'" <> ppr c
+pprParendType (PromotedTupleT 0) = text "'()"
+pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma))
+pprParendType PromotedNilT = text "'[]"
+pprParendType PromotedConsT = text "(':)"
+pprParendType StarT = char '*'
+pprParendType ConstraintT = text "Constraint"
+pprParendType other = parens (ppr other)
+
+instance Ppr Type where
+ ppr (ForallT tvars ctxt ty)
+ = text "forall" <+> hsep (map ppr tvars) <+> text "."
+ <+> sep [pprCxt ctxt, ppr ty]
+ ppr (SigT ty k) = ppr ty <+> text "::" <+> ppr k
+ ppr ty = pprTyApp (split ty)
+
+pprTyApp :: (Type, [Type]) -> Doc
+pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
+pprTyApp (EqualityT, [arg1, arg2]) =
+ sep [pprFunArgType arg1 <+> text "~", ppr arg2]
+pprTyApp (ListT, [arg]) = brackets (ppr arg)
+pprTyApp (TupleT n, args)
+ | length args == n = parens (sep (punctuate comma (map ppr args)))
+pprTyApp (PromotedTupleT n, args)
+ | length args == n = quoteParens (sep (punctuate comma (map ppr args)))
+pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)
+
+pprFunArgType :: Type -> Doc -- Should really use a precedence argument
+-- Everything except forall and (->) binds more tightly than (->)
+pprFunArgType ty@(ForallT {}) = parens (ppr ty)
+pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
+pprFunArgType ty@(SigT _ _) = parens (ppr ty)
+pprFunArgType ty = ppr ty
+
+split :: Type -> (Type, [Type]) -- Split into function and args
+split t = go t []
+ where go (AppT t1 t2) args = go t1 (t2:args)
+ go ty args = (ty, args)
+
+pprTyLit :: TyLit -> Doc
+pprTyLit (NumTyLit n) = integer n
+pprTyLit (StrTyLit s) = text (show s)
+
+instance Ppr TyLit where
+ ppr = pprTyLit
+
+------------------------------
+instance Ppr TyVarBndr where
+ ppr (PlainTV nm) = ppr nm
+ ppr (KindedTV nm k) = parens (ppr nm <+> text "::" <+> ppr k)
+
+instance Ppr Role where
+ ppr NominalR = text "nominal"
+ ppr RepresentationalR = text "representational"
+ ppr PhantomR = text "phantom"
+ ppr InferR = text "_"
+
+------------------------------
+pprCxt :: Cxt -> Doc
+pprCxt [] = empty
+pprCxt [t] = ppr t <+> text "=>"
+pprCxt ts = parens (sep $ punctuate comma $ map ppr ts) <+> text "=>"
+
+------------------------------
+instance Ppr Range where
+ ppr = brackets . pprRange
+ where pprRange :: Range -> Doc
+ pprRange (FromR e) = ppr e <> text ".."
+ pprRange (FromThenR e1 e2) = ppr e1 <> text ","
+ <> ppr e2 <> text ".."
+ pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2
+ pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","
+ <> ppr e2 <> text ".."
+ <> ppr e3
+
+------------------------------
+where_clause :: [Dec] -> Doc
+where_clause [] = empty
+where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)
+
+showtextl :: Show a => a -> Doc
+showtextl = text . map toLower . show
+
+hashParens :: Doc -> Doc
+hashParens d = text "(# " <> d <> text " #)"
+
+quoteParens :: Doc -> Doc
+quoteParens d = text "'(" <> d <> text ")"
diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
new file mode 100644
index 0000000000..c4b0b77430
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs
@@ -0,0 +1,227 @@
+{-# LANGUAGE FlexibleInstances, MagicHash #-}
+
+-- | Monadic front-end to Text.PrettyPrint
+
+module Language.Haskell.TH.PprLib (
+
+ -- * The document type
+ Doc, -- Abstract, instance of Show
+ PprM,
+
+ -- * Primitive Documents
+ empty,
+ semi, comma, colon, space, equals, arrow,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+ -- * Converting values into documents
+ text, char, ptext,
+ int, integer, float, double, rational,
+
+ -- * Wrapping documents in delimiters
+ parens, brackets, braces, quotes, doubleQuotes,
+
+ -- * Combining documents
+ (<>), (<+>), hcat, hsep,
+ ($$), ($+$), vcat,
+ sep, cat,
+ fsep, fcat,
+ nest,
+ hang, punctuate,
+
+ -- * Predicates on documents
+ isEmpty,
+
+ to_HPJ_Doc, pprName, pprName'
+ ) where
+
+
+import Language.Haskell.TH.Syntax
+ (Name(..), showName', NameFlavour(..), NameIs(..))
+import qualified Text.PrettyPrint as HPJ
+import Control.Applicative (Applicative(..))
+import Control.Monad (liftM, liftM2, ap)
+import Language.Haskell.TH.Lib.Map ( Map )
+import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty )
+import GHC.Base (Int(..))
+
+infixl 6 <>
+infixl 6 <+>
+infixl 5 $$, $+$
+
+-- ---------------------------------------------------------------------------
+-- The interface
+
+-- The primitive Doc values
+
+instance Show Doc where
+ show d = HPJ.render (to_HPJ_Doc d)
+
+isEmpty :: Doc -> PprM Bool; -- ^ Returns 'True' if the document is empty
+
+empty :: Doc; -- ^ An empty document
+semi :: Doc; -- ^ A ';' character
+comma :: Doc; -- ^ A ',' character
+colon :: Doc; -- ^ A ':' character
+space :: Doc; -- ^ A space character
+equals :: Doc; -- ^ A '=' character
+arrow :: Doc; -- ^ A "->" string
+lparen :: Doc; -- ^ A '(' character
+rparen :: Doc; -- ^ A ')' character
+lbrack :: Doc; -- ^ A '[' character
+rbrack :: Doc; -- ^ A ']' character
+lbrace :: Doc; -- ^ A '{' character
+rbrace :: Doc; -- ^ A '}' character
+
+text :: String -> Doc
+ptext :: String -> Doc
+char :: Char -> Doc
+int :: Int -> Doc
+integer :: Integer -> Doc
+float :: Float -> Doc
+double :: Double -> Doc
+rational :: Rational -> Doc
+
+
+parens :: Doc -> Doc; -- ^ Wrap document in @(...)@
+brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@
+braces :: Doc -> Doc; -- ^ Wrap document in @{...}@
+quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@
+doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@
+
+-- Combining @Doc@ values
+
+(<>) :: Doc -> Doc -> Doc; -- ^Beside
+hcat :: [Doc] -> Doc; -- ^List version of '<>'
+(<+>) :: Doc -> Doc -> Doc; -- ^Beside, separated by space
+hsep :: [Doc] -> Doc; -- ^List version of '<+>'
+
+($$) :: Doc -> Doc -> Doc; -- ^Above; if there is no
+ -- overlap it \"dovetails\" the two
+($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing.
+vcat :: [Doc] -> Doc; -- ^List version of '$$'
+
+cat :: [Doc] -> Doc; -- ^ Either hcat or vcat
+sep :: [Doc] -> Doc; -- ^ Either hsep or vcat
+fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of cat
+fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of sep
+
+nest :: Int -> Doc -> Doc; -- ^ Nested
+
+
+-- GHC-specific ones.
+
+hang :: Doc -> Int -> Doc -> Doc; -- ^ @hang d1 n d2 = sep [d1, nest n d2]@
+punctuate :: Doc -> [Doc] -> [Doc]; -- ^ @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
+
+
+-- ---------------------------------------------------------------------------
+-- The "implementation"
+
+type State = (Map Name Name, Int)
+data PprM a = PprM { runPprM :: State -> (a, State) }
+
+pprName :: Name -> Doc
+pprName = pprName' Alone
+
+pprName' :: NameIs -> Name -> Doc
+pprName' ni n@(Name o (NameU _))
+ = PprM $ \s@(fm, i@(I# i'))
+ -> let (n', s') = case Map.lookup n fm of
+ Just d -> (d, s)
+ Nothing -> let n'' = Name o (NameU i')
+ in (n'', (Map.insert n n'' fm, i + 1))
+ in (HPJ.text $ showName' ni n', s')
+pprName' ni n = text $ showName' ni n
+
+{-
+instance Show Name where
+ show (Name occ (NameU u)) = occString occ ++ "_" ++ show (I# u)
+ show (Name occ NameS) = occString occ
+ show (Name occ (NameG ns m)) = modString m ++ "." ++ occString occ
+
+data Name = Name OccName NameFlavour
+
+data NameFlavour
+ | NameU Int# -- A unique local name
+-}
+
+to_HPJ_Doc :: Doc -> HPJ.Doc
+to_HPJ_Doc d = fst $ runPprM d (Map.empty, 0)
+
+instance Functor PprM where
+ fmap = liftM
+
+instance Applicative PprM where
+ pure = return
+ (<*>) = ap
+
+instance Monad PprM where
+ return x = PprM $ \s -> (x, s)
+ m >>= k = PprM $ \s -> let (x, s') = runPprM m s
+ in runPprM (k x) s'
+
+type Doc = PprM HPJ.Doc
+
+-- The primitive Doc values
+
+isEmpty = liftM HPJ.isEmpty
+
+empty = return HPJ.empty
+semi = return HPJ.semi
+comma = return HPJ.comma
+colon = return HPJ.colon
+space = return HPJ.space
+equals = return HPJ.equals
+arrow = return $ HPJ.text "->"
+lparen = return HPJ.lparen
+rparen = return HPJ.rparen
+lbrack = return HPJ.lbrack
+rbrack = return HPJ.rbrack
+lbrace = return HPJ.lbrace
+rbrace = return HPJ.rbrace
+
+text = return . HPJ.text
+ptext = return . HPJ.ptext
+char = return . HPJ.char
+int = return . HPJ.int
+integer = return . HPJ.integer
+float = return . HPJ.float
+double = return . HPJ.double
+rational = return . HPJ.rational
+
+
+parens = liftM HPJ.parens
+brackets = liftM HPJ.brackets
+braces = liftM HPJ.braces
+quotes = liftM HPJ.quotes
+doubleQuotes = liftM HPJ.doubleQuotes
+
+-- Combining @Doc@ values
+
+(<>) = liftM2 (HPJ.<>)
+hcat = liftM HPJ.hcat . sequence
+(<+>) = liftM2 (HPJ.<+>)
+hsep = liftM HPJ.hsep . sequence
+
+($$) = liftM2 (HPJ.$$)
+($+$) = liftM2 (HPJ.$+$)
+vcat = liftM HPJ.vcat . sequence
+
+cat = liftM HPJ.cat . sequence
+sep = liftM HPJ.sep . sequence
+fcat = liftM HPJ.fcat . sequence
+fsep = liftM HPJ.fsep . sequence
+
+nest n = liftM (HPJ.nest n)
+
+hang d1 n d2 = do d1' <- d1
+ d2' <- d2
+ return (HPJ.hang d1' n d2')
+
+-- punctuate uses the same definition as Text.PrettyPrint
+punctuate _ [] = []
+punctuate p (d:ds) = go d ds
+ where
+ go d' [] = [d']
+ go d' (e:es) = (d' <> p) : go e es
+
diff --git a/libraries/template-haskell/Language/Haskell/TH/Quote.hs b/libraries/template-haskell/Language/Haskell/TH/Quote.hs
new file mode 100644
index 0000000000..b9c0d25d2b
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/Quote.hs
@@ -0,0 +1,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 }
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
new file mode 100644
index 0000000000..3172cbbced
--- /dev/null
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -0,0 +1,1457 @@
+{-# LANGUAGE DeriveDataTypeable, MagicHash, PolymorphicComponents, RoleAnnotations, UnboxedTuples #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Language.Haskell.Syntax
+-- Copyright : (c) The University of Glasgow 2003
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Abstract syntax definitions for Template Haskell.
+--
+-----------------------------------------------------------------------------
+
+module Language.Haskell.TH.Syntax where
+
+import GHC.Exts
+import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex)
+import qualified Data.Data as Data
+import Control.Applicative( Applicative(..) )
+import Data.IORef
+import System.IO.Unsafe ( unsafePerformIO )
+import Control.Monad (liftM)
+import System.IO ( hPutStrLn, stderr )
+import Data.Char ( isAlpha, isAlphaNum, isUpper )
+import Data.Word ( Word8 )
+
+-----------------------------------------------------
+--
+-- The Quasi class
+--
+-----------------------------------------------------
+
+class (Monad m, Applicative m) => Quasi m where
+ qNewName :: String -> m Name
+ -- ^ Fresh names
+
+ -- Error reporting and recovery
+ qReport :: Bool -> String -> m () -- ^ Report an error (True) or warning (False)
+ -- ...but carry on; use 'fail' to stop
+ qRecover :: m a -- ^ the error handler
+ -> m a -- ^ action which may fail
+ -> m a -- ^ Recover from the monadic 'fail'
+
+ -- Inspect the type-checker's environment
+ qLookupName :: Bool -> String -> m (Maybe Name)
+ -- True <=> type namespace, False <=> value namespace
+ qReify :: Name -> m Info
+ qReifyInstances :: Name -> [Type] -> m [Dec]
+ -- Is (n tys) an instance?
+ -- Returns list of matching instance Decs
+ -- (with empty sub-Decs)
+ -- Works for classes and type functions
+ qReifyRoles :: Name -> m [Role]
+ qReifyAnnotations :: Data a => AnnLookup -> m [a]
+ qReifyModule :: Module -> m ModuleInfo
+
+ qLocation :: m Loc
+
+ qRunIO :: IO a -> m a
+ -- ^ Input/output (dangerous)
+
+ qAddDependentFile :: FilePath -> m ()
+
+ qAddTopDecls :: [Dec] -> m ()
+
+ qAddModFinalizer :: Q () -> m ()
+
+ qGetQ :: Typeable a => m (Maybe a)
+
+ qPutQ :: Typeable a => a -> m ()
+
+-----------------------------------------------------
+-- The IO instance of Quasi
+--
+-- This instance is used only when running a Q
+-- computation in the IO monad, usually just to
+-- print the result. There is no interesting
+-- type environment, so reification isn't going to
+-- work.
+--
+-----------------------------------------------------
+
+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)
+
+ qLookupName _ _ = badIO "lookupName"
+ qReify _ = badIO "reify"
+ qReifyInstances _ _ = badIO "reifyInstances"
+ qReifyRoles _ = badIO "reifyRoles"
+ qReifyAnnotations _ = badIO "reifyAnnotations"
+ qReifyModule _ = badIO "reifyModule"
+ qLocation = badIO "currentLocation"
+ qRecover _ _ = badIO "recover" -- Maybe we could fix this?
+ qAddDependentFile _ = badIO "addDependentFile"
+ qAddTopDecls _ = badIO "addTopDecls"
+ qAddModFinalizer _ = badIO "addModFinalizer"
+ qGetQ = badIO "getQ"
+ qPutQ _ = badIO "putQ"
+
+ qRunIO m = m
+
+badIO :: String -> IO a
+badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad")
+ ; fail "Template Haskell failure" }
+
+-- Global variable to generate unique symbols
+counter :: IORef Int
+{-# NOINLINE counter #-}
+counter = unsafePerformIO (newIORef 0)
+
+
+-----------------------------------------------------
+--
+-- The Q monad
+--
+-----------------------------------------------------
+
+newtype Q a = Q { unQ :: forall m. Quasi m => m a }
+
+-- \"Runs\" the 'Q' monad. Normal users of Template Haskell
+-- should not need this function, as the splice brackets @$( ... )@
+-- are the usual way of running a 'Q' computation.
+--
+-- This function is primarily used in GHC internals, and for debugging
+-- splices by running them in 'IO'.
+--
+-- Note that many functions in 'Q', such as 'reify' and other compiler
+-- queries, are not supported when running 'Q' in 'IO'; these operations
+-- simply fail at runtime. Indeed, the only operations guaranteed to succeed
+-- are 'newName', 'runIO', 'reportError' and 'reportWarning'.
+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)
+
+instance Applicative Q where
+ pure x = Q (pure x)
+ Q f <*> Q x = Q (f <*> x)
+
+-----------------------------------------------------
+--
+-- The TExp type
+--
+-----------------------------------------------------
+
+type role TExp nominal -- See Note [Role of TExp]
+newtype TExp a = TExp { unType :: Exp }
+
+unTypeQ :: Q (TExp a) -> Q Exp
+unTypeQ m = do { TExp e <- m
+ ; return e }
+
+unsafeTExpCoerce :: Q Exp -> Q (TExp a)
+unsafeTExpCoerce m = do { e <- m
+ ; return (TExp e) }
+
+{- Note [Role of TExp]
+~~~~~~~~~~~~~~~~~~~~~~
+TExp's argument must have a nominal role, not phantom as would
+be inferred (Trac #8459). Consider
+
+ e :: TExp Age
+ e = MkAge 3
+
+ foo = $(coerce e) + 4::Int
+
+The splice will evaluate to (MkAge 3) and you can't add that to
+4::Int. So you can't coerce a (TExp Age) to a (TExp Int). -}
+
+----------------------------------------------------
+-- Packaged versions for the programmer, hiding the Quasi-ness
+
+{- |
+Generate a fresh name, which cannot be captured.
+
+For example, this:
+
+@f = $(do
+ nm1 <- newName \"x\"
+ let nm2 = 'mkName' \"x\"
+ return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1)))
+ )@
+
+will produce the splice
+
+>f = \x0 -> \x -> x0
+
+In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@,
+and is not captured by the binding @VarP nm2@.
+
+Although names generated by @newName@ cannot /be captured/, they can
+/capture/ other names. For example, this:
+
+>g = $(do
+> nm1 <- newName "x"
+> let nm2 = mkName "x"
+> return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2)))
+> )
+
+will produce the splice
+
+>g = \x -> \x0 -> x0
+
+since the occurrence @VarE nm2@ is captured by the innermost binding
+of @x@, namely @VarP nm1@.
+-}
+newName :: String -> Q Name
+newName s = Q (qNewName s)
+
+-- | Report an error (True) or warning (False),
+-- but carry on; use 'fail' to stop.
+report :: Bool -> String -> Q ()
+report b s = Q (qReport b s)
+{-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
+
+-- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
+reportError :: String -> Q ()
+reportError = report True
+
+-- | Report a warning to the user, and carry on.
+reportWarning :: String -> Q ()
+reportWarning = report False
+
+-- | Recover from errors raised by 'reportError' or 'fail'.
+recover :: Q a -- ^ handler to invoke on failure
+ -> Q a -- ^ computation to run
+ -> Q a
+recover (Q r) (Q m) = Q (qRecover r m)
+
+-- We don't export lookupName; the Bool isn't a great API
+-- Instead we export lookupTypeName, lookupValueName
+lookupName :: Bool -> String -> Q (Maybe Name)
+lookupName ns s = Q (qLookupName ns s)
+
+-- | Look up the given name in the (type namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
+lookupTypeName :: String -> Q (Maybe Name)
+lookupTypeName s = Q (qLookupName True s)
+
+-- | Look up the given name in the (value namespace of the) current splice's scope. See "Language.Haskell.TH.Syntax#namelookup" for more details.
+lookupValueName :: String -> Q (Maybe Name)
+lookupValueName s = Q (qLookupName False s)
+
+{-
+Note [Name lookup]
+~~~~~~~~~~~~~~~~~~
+-}
+{- $namelookup #namelookup#
+The functions 'lookupTypeName' and 'lookupValueName' provide
+a way to query the current splice's context for what names
+are in scope. The function 'lookupTypeName' queries the type
+namespace, whereas 'lookupValueName' queries the value namespace,
+but the functions are otherwise identical.
+
+A call @lookupValueName s@ will check if there is a value
+with name @s@ in scope at the current splice's location. If
+there is, the @Name@ of this value is returned;
+if not, then @Nothing@ is returned.
+
+The returned name cannot be \"captured\".
+For example:
+
+> f = "global"
+> g = $( do
+> Just nm <- lookupValueName "f"
+> [| let f = "local" in $( varE nm ) |]
+
+In this case, @g = \"global\"@; the call to @lookupValueName@
+returned the global @f@, and this name was /not/ captured by
+the local definition of @f@.
+
+The lookup is performed in the context of the /top-level/ splice
+being run. For example:
+
+> f = "global"
+> g = $( [| let f = "local" in
+> $(do
+> Just nm <- lookupValueName "f"
+> varE nm
+> ) |] )
+
+Again in this example, @g = \"global\"@, because the call to
+@lookupValueName@ queries the context of the outer-most @$(...)@.
+
+Operators should be queried without any surrounding parentheses, like so:
+
+> lookupValueName "+"
+
+Qualified names are also supported, like so:
+
+> lookupValueName "Prelude.+"
+> lookupValueName "Prelude.map"
+
+-}
+
+
+{- | 'reify' looks up information about the 'Name'.
+
+It is sometimes useful to construct the argument name using 'lookupTypeName' or 'lookupValueName'
+to ensure that we are reifying from the right namespace. For instance, in this context:
+
+> data D = D
+
+which @D@ does @reify (mkName \"D\")@ return information about? (Answer: @D@-the-type, but don't rely on it.)
+To ensure we get information about @D@-the-value, use 'lookupValueName':
+
+> do
+> Just nm <- lookupValueName "D"
+> reify nm
+
+and to get information about @D@-the-type, use 'lookupTypeName'.
+-}
+reify :: Name -> Q Info
+reify v = Q (qReify v)
+
+{- | @reifyInstances nm tys@ returns a list of visible instances of @nm tys@. That is,
+if @nm@ is the name of a type class, then all instances of this class at the types @tys@
+are returned. Alternatively, if @nm@ is the name of a data family or type family,
+all instances of this family at the types @tys@ are returned.
+-}
+reifyInstances :: Name -> [Type] -> Q [InstanceDec]
+reifyInstances cls tys = Q (qReifyInstances cls tys)
+
+{- | @reifyRoles nm@ returns the list of roles associated with the parameters of
+the tycon @nm@. Fails if @nm@ cannot be found or is not a tycon.
+The returned list should never contain 'InferR'.
+-}
+reifyRoles :: Name -> Q [Role]
+reifyRoles nm = Q (qReifyRoles nm)
+
+-- | @reifyAnnotations target@ returns the list of annotations
+-- associated with @target@. Only the annotations that are
+-- appropriately typed is returned. So if you have @Int@ and @String@
+-- annotations for the same target, you have to call this function twice.
+reifyAnnotations :: Data a => AnnLookup -> Q [a]
+reifyAnnotations an = Q (qReifyAnnotations an)
+
+-- | @reifyModule mod@ looks up information about module @mod@. To
+-- look up the current module, call this function with the return
+-- value of @thisModule@.
+reifyModule :: Module -> Q ModuleInfo
+reifyModule m = Q (qReifyModule m)
+
+-- | Is the list of instances returned by 'reifyInstances' nonempty?
+isInstance :: Name -> [Type] -> Q Bool
+isInstance nm tys = do { decs <- reifyInstances nm tys
+ ; return (not (null decs)) }
+
+-- | The location at which this computation is spliced.
+location :: Q Loc
+location = Q qLocation
+
+-- |The 'runIO' function lets you run an I\/O computation in the 'Q' monad.
+-- Take care: you are guaranteed the ordering of calls to 'runIO' within
+-- a single 'Q' computation, but not about the order in which splices are run.
+--
+-- Note: for various murky reasons, stdout and stderr handles are not
+-- necessarily flushed when the compiler finishes running, so you should
+-- flush them yourself.
+runIO :: IO a -> Q a
+runIO m = Q (qRunIO m)
+
+-- | Record external files that runIO is using (dependent upon).
+-- The compiler can then recognize that it should re-compile the file using this TH when the external file changes.
+-- Note that ghc -M will still not know about these dependencies - it does not execute TH.
+-- Expects an absolute file path.
+addDependentFile :: FilePath -> Q ()
+addDependentFile fp = Q (qAddDependentFile fp)
+
+-- | Add additional top-level declarations. The added declarations will be type
+-- checked along with the current declaration group.
+addTopDecls :: [Dec] -> Q ()
+addTopDecls ds = Q (qAddTopDecls ds)
+
+-- | Add a finalizer that will run in the Q monad after the current module has
+-- been type checked. This only makes sense when run within a top-level splice.
+addModFinalizer :: Q () -> Q ()
+addModFinalizer act = Q (qAddModFinalizer (unQ act))
+
+-- | Get state from the Q monad.
+getQ :: Typeable a => Q (Maybe a)
+getQ = Q qGetQ
+
+-- | Replace the state in the Q monad.
+putQ :: Typeable a => a -> Q ()
+putQ x = Q (qPutQ x)
+
+instance Quasi Q where
+ qNewName = newName
+ qReport = report
+ qRecover = recover
+ qReify = reify
+ qReifyInstances = reifyInstances
+ qReifyRoles = reifyRoles
+ qReifyAnnotations = reifyAnnotations
+ qReifyModule = reifyModule
+ qLookupName = lookupName
+ qLocation = location
+ qRunIO = runIO
+ qAddDependentFile = addDependentFile
+ qAddTopDecls = addTopDecls
+ qAddModFinalizer = addModFinalizer
+ qGetQ = getQ
+ qPutQ = putQ
+
+
+----------------------------------------------------
+-- The following operations are used solely in DsMeta when desugaring brackets
+-- They are not necessary for the user, who can use ordinary return and (>>=) etc
+
+returnQ :: a -> Q a
+returnQ = return
+
+bindQ :: Q a -> (a -> Q b) -> Q b
+bindQ = (>>=)
+
+sequenceQ :: [Q a] -> Q [a]
+sequenceQ = sequence
+
+
+-----------------------------------------------------
+--
+-- The Lift class
+--
+-----------------------------------------------------
+
+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
+-- Used in TcExpr to short-circuit the lifting for strings
+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]
+
+-- TH has a special form for literal strings,
+-- which we should take advantage of.
+-- NB: the lhs of the rule has no args, so that
+-- the rule will apply to a 'lift' all on its own
+-- which happens to be the way the type checker
+-- creates it.
+{-# RULES "TH:liftString" lift = \s -> return (LitE (StringL s)) #-}
+
+
+trueName, falseName :: Name
+trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True"
+falseName = mkNameG DataName "ghc-prim" "GHC.Types" "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"
+
+
+-----------------------------------------------------
+-- Names and uniques
+-----------------------------------------------------
+
+newtype ModName = ModName String -- Module name
+ deriving (Show,Eq,Ord,Typeable,Data)
+
+newtype PkgName = PkgName String -- package name
+ deriving (Show,Eq,Ord,Typeable,Data)
+
+-- | Obtained from 'reifyModule' and 'thisModule'.
+data Module = Module PkgName ModName -- package qualified module name
+ deriving (Show,Eq,Ord,Typeable,Data)
+
+newtype OccName = OccName String
+ deriving (Show,Eq,Ord,Typeable,Data)
+
+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
+
+
+-----------------------------------------------------
+-- OccName
+-----------------------------------------------------
+
+mkOccName :: String -> OccName
+mkOccName s = OccName s
+
+occString :: OccName -> String
+occString (OccName occ) = occ
+
+
+-----------------------------------------------------
+-- Names
+-----------------------------------------------------
+--
+-- For "global" names ('NameG') we need a totally unique name,
+-- so we must include the name-space of the thing
+--
+-- For unique-numbered things ('NameU'), we've got a unique reference
+-- anyway, so no need for name space
+--
+-- For dynamically bound thing ('NameS') we probably want them to
+-- in a context-dependent way, so again we don't want the name
+-- space. For example:
+--
+-- > let v = mkName "T" in [| data $v = $v |]
+--
+-- Here we use the same Name for both type constructor and data constructor
+--
+--
+-- NameL and NameG are bound *outside* the TH syntax tree
+-- either globally (NameG) or locally (NameL). Ex:
+--
+-- > f x = $(h [| (map, x) |])
+--
+-- The 'map' will be a NameG, and 'x' wil be a NameL
+--
+-- These Names should never appear in a binding position in a TH syntax tree
+
+{- $namecapture #namecapture#
+Much of 'Name' API is concerned with the problem of /name capture/, which
+can be seen in the following example.
+
+> f expr = [| let x = 0 in $expr |]
+> ...
+> g x = $( f [| x |] )
+> h y = $( f [| y |] )
+
+A naive desugaring of this would yield:
+
+> g x = let x = 0 in x
+> h y = let x = 0 in y
+
+All of a sudden, @g@ and @h@ have different meanings! In this case,
+we say that the @x@ in the RHS of @g@ has been /captured/
+by the binding of @x@ in @f@.
+
+What we actually want is for the @x@ in @f@ to be distinct from the
+@x@ in @g@, so we get the following desugaring:
+
+> g x = let x' = 0 in x
+> h y = let x' = 0 in y
+
+which avoids name capture as desired.
+
+In the general case, we say that a @Name@ can be captured if
+the thing it refers to can be changed by adding new declarations.
+-}
+
+{- |
+An abstract type representing names in the syntax tree.
+
+'Name's can be constructed in several ways, which come with different
+name-capture guarantees (see "Language.Haskell.TH.Syntax#namecapture" for
+an explanation of name capture):
+
+ * the built-in syntax @'f@ and @''T@ can be used to construct names,
+ The expression @'f@ gives a @Name@ which refers to the value @f@
+ currently in scope, and @''T@ gives a @Name@ which refers to the
+ type @T@ currently in scope. These names can never be captured.
+
+ * 'lookupValueName' and 'lookupTypeName' are similar to @'f@ and
+ @''T@ respectively, but the @Name@s are looked up at the point
+ where the current splice is being run. These names can never be
+ captured.
+
+ * 'newName' monadically generates a new name, which can never
+ be captured.
+
+ * 'mkName' generates a capturable name.
+
+Names constructed using @newName@ and @mkName@ may be used in bindings
+(such as @let x = ...@ or @\x -> ...@), but names constructed using
+@lookupValueName@, @lookupTypeName@, @'f@, @''T@ may not.
+-}
+data Name = Name OccName NameFlavour deriving (Typeable, Data)
+
+data NameFlavour
+ = NameS -- ^ An unqualified name; dynamically bound
+ | NameQ ModName -- ^ A qualified name; dynamically bound
+ | NameU Int# -- ^ A unique local name
+ | NameL Int# -- ^ Local name bound outside of the TH AST
+ | NameG NameSpace PkgName ModName -- ^ Global name bound outside of the TH AST:
+ -- An original name (occurrences only, not binders)
+ -- Need the namespace too to be sure which
+ -- thing we are naming
+ deriving ( Typeable )
+
+-- |
+-- Although the NameFlavour type is abstract, the Data instance is not. The reason for this
+-- is that currently we use Data to serialize values in annotations, and in order for that to
+-- work for Template Haskell names introduced via the 'x syntax we need gunfold on NameFlavour
+-- to work. Bleh!
+--
+-- The long term solution to this is to use the binary package for annotation serialization and
+-- then remove this instance. However, to do _that_ we need to wait on binary to become stable, since
+-- boot libraries cannot be upgraded separately from GHC itself.
+--
+-- This instance cannot be derived automatically due to bug #2701
+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 -- ^ Variables
+ | DataName -- ^ Data constructors
+ | TcClsName -- ^ Type constructors and classes; Haskell has them
+ -- in the same name space for now.
+ deriving( Eq, Ord, Data, Typeable )
+
+type Uniq = Int
+
+-- | The name without its module prefix
+nameBase :: Name -> String
+nameBase (Name occ _) = occString occ
+
+-- | Module prefix of a name, if it exists
+nameModule :: Name -> Maybe String
+nameModule (Name _ (NameQ m)) = Just (modString m)
+nameModule (Name _ (NameG _ _ m)) = Just (modString m)
+nameModule _ = Nothing
+
+{- |
+Generate a capturable name. Occurrences of such names will be
+resolved according to the Haskell scoping rules at the occurrence
+site.
+
+For example:
+
+> f = [| pi + $(varE (mkName "pi")) |]
+> ...
+> g = let pi = 3 in $f
+
+In this case, @g@ is desugared to
+
+> g = Prelude.pi + 3
+
+Note that @mkName@ may be used with qualified names:
+
+> mkName "Prelude.pi"
+
+See also 'Language.Haskell.TH.Lib.dyn' for a useful combinator. The above example could
+be rewritten using 'dyn' as
+
+> f = [| pi + $(dyn "pi") |]
+-}
+mkName :: String -> Name
+-- The string can have a '.', thus "Foo.baz",
+-- giving a dynamically-bound qualified name,
+-- in which case we want to generate a NameQ
+--
+-- Parse the string to see if it has a "." in it
+-- so we know whether to generate a qualified or unqualified name
+-- It's a bit tricky because we need to parse
+--
+-- > Foo.Baz.x as Qual Foo.Baz x
+--
+-- So we parse it from back to front
+mkName str
+ = split [] (reverse str)
+ where
+ split occ [] = Name (mkOccName occ) NameS
+ split occ ('.':rev) | not (null occ)
+ , is_rev_mod_name rev
+ = Name (mkOccName occ) (NameQ (mkModName (reverse rev)))
+ -- The 'not (null occ)' guard ensures that
+ -- mkName "&." = Name "&." NameS
+ -- The 'is_rev_mod' guards ensure that
+ -- mkName ".&" = Name ".&" NameS
+ -- mkName "^.." = Name "^.." NameS -- Trac #8633
+ -- mkName "Data.Bits..&" = Name ".&" (NameQ "Data.Bits")
+ -- This rather bizarre case actually happened; (.&.) is in Data.Bits
+ split occ (c:rev) = split (c:occ) rev
+
+ -- Recognises a reversed module name xA.yB.C,
+ -- with at least one component,
+ -- and each component looks like a module name
+ -- (i.e. non-empty, starts with capital, all alpha)
+ is_rev_mod_name rev_mod_str
+ | (compt, rest) <- break (== '.') rev_mod_str
+ , not (null compt), isUpper (last compt), all is_mod_char compt
+ = case rest of
+ [] -> True
+ (_dot : rest') -> is_rev_mod_name rest'
+ | otherwise
+ = False
+
+ is_mod_char c = isAlphaNum c || c == '_' || c == '\''
+
+-- | Only used internally
+mkNameU :: String -> Uniq -> Name
+mkNameU s (I# u) = Name (mkOccName s) (NameU u)
+
+-- | Only used internally
+mkNameL :: String -> Uniq -> Name
+mkNameL s (I# u) = Name (mkOccName s) (NameL u)
+
+-- | Used for 'x etc, but not available to the programmer
+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 < NameQ < NameU < NameL < NameG
+ 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) | isTrue# (u1 <# u2) = LT
+ | isTrue# (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) | isTrue# (u1 <# u2) = LT
+ | isTrue# (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
+ -- For now, we make the NameQ and NameG print the same, even though
+ -- NameQ is a qualified name (so what it means depends on what the
+ -- current scope is), and NameG is an original name (so its meaning
+ -- should be independent of what's in scope.
+ -- We may well want to distinguish them in the end.
+ -- Ditto NameU and NameL
+ 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
+
+ -- True if we are function style, e.g. f, [], (,)
+ -- False if we are operator style, e.g. +, :+
+ classify "" = False -- shouldn't happen; . operator is handled below
+ classify (x:xs) | isAlpha x || (x `elem` "_[]()") =
+ case dropWhile (/='.') xs of
+ (_:xs') -> classify xs'
+ [] -> True
+ | otherwise = False
+
+instance Show Name where
+ show = showName
+
+-- Tuple data and type constructors
+-- | Tuple data constructor
+tupleDataName :: Int -> Name
+-- | Tuple type constructor
+tupleTypeName :: Int -> Name
+
+tupleDataName 0 = mk_tup_name 0 DataName
+tupleDataName 1 = error "tupleDataName 1"
+tupleDataName n = mk_tup_name (n-1) DataName
+
+tupleTypeName 0 = mk_tup_name 0 TcClsName
+tupleTypeName 1 = error "tupleTypeName 1"
+tupleTypeName n = mk_tup_name (n-1) 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"
+
+-- Unboxed tuple data and type constructors
+-- | Unboxed tuple data constructor
+unboxedTupleDataName :: Int -> Name
+-- | Unboxed tuple type constructor
+unboxedTupleTypeName :: Int -> Name
+
+unboxedTupleDataName 0 = error "unboxedTupleDataName 0"
+unboxedTupleDataName 1 = error "unboxedTupleDataName 1"
+unboxedTupleDataName n = mk_unboxed_tup_name (n-1) DataName
+
+unboxedTupleTypeName 0 = error "unboxedTupleTypeName 0"
+unboxedTupleTypeName 1 = error "unboxedTupleTypeName 1"
+unboxedTupleTypeName n = mk_unboxed_tup_name (n-1) TcClsName
+
+mk_unboxed_tup_name :: Int -> NameSpace -> Name
+mk_unboxed_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"
+
+
+
+-----------------------------------------------------
+-- Locations
+-----------------------------------------------------
+
+data Loc
+ = Loc { loc_filename :: String
+ , loc_package :: String
+ , loc_module :: String
+ , loc_start :: CharPos
+ , loc_end :: CharPos }
+
+type CharPos = (Int, Int) -- ^ Line and character position
+
+
+-----------------------------------------------------
+--
+-- The Info returned by reification
+--
+-----------------------------------------------------
+
+-- | Obtained from 'reify' in the 'Q' Monad.
+data Info
+ =
+ -- | A class, with a list of its visible instances
+ ClassI
+ Dec
+ [InstanceDec]
+
+ -- | A class method
+ | ClassOpI
+ Name
+ Type
+ ParentName
+ Fixity
+
+ -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned using 'PrimTyConI' or 'FamilyI' as appropriate
+ | TyConI
+ Dec
+
+ -- | A type or data family, with a list of its visible instances. A closed
+ -- type family is returned with 0 instances.
+ | FamilyI
+ Dec
+ [InstanceDec]
+
+ -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'. Examples: @(->)@, @Int#@.
+ | PrimTyConI
+ Name
+ Arity
+ Unlifted
+
+ -- | A data constructor
+ | DataConI
+ Name
+ Type
+ ParentName
+ Fixity
+
+ {- |
+ A \"value\" variable (as opposed to a type variable, see 'TyVarI').
+
+ The @Maybe Dec@ field contains @Just@ the declaration which
+ defined the variable -- including the RHS of the declaration --
+ or else @Nothing@, in the case where the RHS is unavailable to
+ the compiler. At present, this value is _always_ @Nothing@:
+ returning the RHS has not yet been implemented because of
+ lack of interest.
+ -}
+ | VarI
+ Name
+ Type
+ (Maybe Dec)
+ Fixity
+
+ {- |
+ A type variable.
+
+ The @Type@ field contains the type which underlies the variable.
+ At present, this is always @'VarT' theName@, but future changes
+ may permit refinement of this.
+ -}
+ | TyVarI -- Scoped type variable
+ Name
+ Type -- What it is bound to
+ deriving( Show, Data, Typeable )
+
+-- | Obtained from 'reifyModule' in the 'Q' Monad.
+data ModuleInfo =
+ -- | Contains the import list of the module.
+ ModuleInfo [Module]
+ deriving( Show, Data, Typeable )
+
+{- |
+In 'ClassOpI' and 'DataConI', name of the parent class or type
+-}
+type ParentName = Name
+
+-- | In 'PrimTyConI', arity of the type constructor
+type Arity = Int
+
+-- | In 'PrimTyConI', is the type constructor unlifted?
+type Unlifted = Bool
+
+-- | 'InstanceDec' desribes a single instance of a class or type function.
+-- It is just a 'Dec', but guaranteed to be one of the following:
+--
+-- * 'InstanceD' (with empty @['Dec']@)
+--
+-- * 'DataInstD' or 'NewtypeInstD' (with empty derived @['Name']@)
+--
+-- * 'TySynInstD'
+type InstanceDec = Dec
+
+data Fixity = Fixity Int FixityDirection
+ deriving( Eq, Show, Data, Typeable )
+data FixityDirection = InfixL | InfixR | InfixN
+ deriving( Eq, Show, Data, Typeable )
+
+-- | Highest allowed operator precedence for 'Fixity' constructor (answer: 9)
+maxPrecedence :: Int
+maxPrecedence = (9::Int)
+
+-- | Default fixity: @infixl 9@
+defaultFixity :: Fixity
+defaultFixity = Fixity maxPrecedence InfixL
+
+
+{-
+Note [Unresolved infix]
+~~~~~~~~~~~~~~~~~~~~~~~
+-}
+{- $infix #infix#
+When implementing antiquotation for quasiquoters, one often wants
+to parse strings into expressions:
+
+> parse :: String -> Maybe Exp
+
+But how should we parse @a + b * c@? If we don't know the fixities of
+@+@ and @*@, we don't know whether to parse it as @a + (b * c)@ or @(a
++ b) * c@.
+
+In cases like this, use 'UInfixE' or 'UInfixP', which stand for
+\"unresolved infix expression\" and \"unresolved infix pattern\". When
+the compiler is given a splice containing a tree of @UInfixE@
+applications such as
+
+> UInfixE
+> (UInfixE e1 op1 e2)
+> op2
+> (UInfixE e3 op3 e4)
+
+it will look up and the fixities of the relevant operators and
+reassociate the tree as necessary.
+
+ * trees will not be reassociated across 'ParensE' or 'ParensP',
+ which are of use for parsing expressions like
+
+ > (a + b * c) + d * e
+
+ * 'InfixE' and 'InfixP' expressions are never reassociated.
+
+ * The 'UInfixE' constructor doesn't support sections. Sections
+ such as @(a *)@ have no ambiguity, so 'InfixE' suffices. For longer
+ sections such as @(a + b * c -)@, use an 'InfixE' constructor for the
+ outer-most section, and use 'UInfixE' constructors for all
+ other operators:
+
+ > InfixE
+ > Just (UInfixE ...a + b * c...)
+ > op
+ > Nothing
+
+ Sections such as @(a + b +)@ and @((a + b) +)@ should be rendered
+ into 'Exp's differently:
+
+ > (+ a + b) ---> InfixE Nothing + (Just $ UInfixE a + b)
+ > -- will result in a fixity error if (+) is left-infix
+ > (+ (a + b)) ---> InfixE Nothing + (Just $ ParensE $ UInfixE a + b)
+ > -- no fixity errors
+
+ * Quoted expressions such as
+
+ > [| a * b + c |] :: Q Exp
+ > [p| a : b : c |] :: Q Pat
+
+ will never contain 'UInfixE', 'UInfixP', 'ParensE', or 'ParensP'
+ constructors.
+
+-}
+
+-----------------------------------------------------
+--
+-- The main syntax data types
+--
+-----------------------------------------------------
+
+data Lit = CharL Char
+ | StringL String
+ | IntegerL Integer -- ^ Used for overloaded and non-overloaded
+ -- literals. We don't have a good way to
+ -- represent non-overloaded literals at
+ -- the moment. Maybe that doesn't matter?
+ | RationalL Rational -- Ditto
+ | IntPrimL Integer
+ | WordPrimL Integer
+ | FloatPrimL Rational
+ | DoublePrimL Rational
+ | StringPrimL [Word8] -- ^ A primitive C-style string, type Addr#
+ deriving( Show, Eq, Data, Typeable )
+
+ -- We could add Int, Float, Double etc, as we do in HsLit,
+ -- but that could complicate the
+ -- suppposedly-simple TH.Syntax literal type
+
+-- | Pattern in Haskell given in @{}@
+data Pat
+ = LitP Lit -- ^ @{ 5 or 'c' }@
+ | VarP Name -- ^ @{ x }@
+ | TupP [Pat] -- ^ @{ (p1,p2) }@
+ | UnboxedTupP [Pat] -- ^ @{ (# p1,p2 #) }@
+ | ConP Name [Pat] -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@
+ | InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@
+ | UInfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@
+ --
+ -- See "Language.Haskell.TH.Syntax#infix"
+ | ParensP Pat -- ^ @{(p)}@
+ --
+ -- See "Language.Haskell.TH.Syntax#infix"
+ | TildeP Pat -- ^ @{ ~p }@
+ | BangP Pat -- ^ @{ !p }@
+ | AsP Name Pat -- ^ @{ x \@ p }@
+ | WildP -- ^ @{ _ }@
+ | RecP Name [FieldPat] -- ^ @f (Pt { pointx = x }) = g x@
+ | ListP [ Pat ] -- ^ @{ [1,2,3] }@
+ | SigP Pat Type -- ^ @{ p :: t }@
+ | ViewP Exp Pat -- ^ @{ e -> p }@
+ deriving( Show, Eq, Data, Typeable )
+
+type FieldPat = (Name,Pat)
+
+data Match = Match Pat Body [Dec] -- ^ @case e of { pat -> body where decs }@
+ deriving( Show, Eq, Data, Typeable )
+data Clause = Clause [Pat] Body [Dec]
+ -- ^ @f { p1 p2 = body where decs }@
+ deriving( Show, Eq, Data, Typeable )
+
+data Exp
+ = VarE Name -- ^ @{ x }@
+ | ConE Name -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2 @
+ | LitE Lit -- ^ @{ 5 or 'c'}@
+ | AppE Exp Exp -- ^ @{ f x }@
+
+ | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@
+
+ -- It's a bit gruesome to use an Exp as the
+ -- operator, but how else can we distinguish
+ -- constructors from non-constructors?
+ -- Maybe there should be a var-or-con type?
+ -- Or maybe we should leave it to the String itself?
+
+ | UInfixE Exp Exp Exp -- ^ @{x + y}@
+ --
+ -- See "Language.Haskell.TH.Syntax#infix"
+ | ParensE Exp -- ^ @{ (e) }@
+ --
+ -- See "Language.Haskell.TH.Syntax#infix"
+ | LamE [Pat] Exp -- ^ @{ \ p1 p2 -> e }@
+ | LamCaseE [Match] -- ^ @{ \case m1; m2 }@
+ | TupE [Exp] -- ^ @{ (e1,e2) } @
+ | UnboxedTupE [Exp] -- ^ @{ (# e1,e2 #) } @
+ | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@
+ | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@
+ | LetE [Dec] Exp -- ^ @{ let x=e1; y=e2 in e3 }@
+ | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@
+ | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@
+ | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@
+ --
+ -- The result expression of the comprehension is
+ -- the /last/ of the @'Stmt'@s, and should be a 'NoBindS'.
+ --
+ -- E.g. translation:
+ --
+ -- > [ f x | x <- xs ]
+ --
+ -- > CompE [BindS (VarP x) (VarE xs), NoBindS (AppE (VarE f) (VarE x))]
+
+ | ArithSeqE Range -- ^ @{ [ 1 ,2 .. 10 ] }@
+ | ListE [ Exp ] -- ^ @{ [1,2,3] }@
+ | SigE Exp Type -- ^ @{ e :: t }@
+ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@
+ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@
+ deriving( Show, Eq, Data, Typeable )
+
+type FieldExp = (Name,Exp)
+
+-- Omitted: implicit parameters
+
+data Body
+ = GuardedB [(Guard,Exp)] -- ^ @f p { | e1 = e2
+ -- | e3 = e4 }
+ -- where ds@
+ | NormalB Exp -- ^ @f p { = e } where ds@
+ deriving( Show, Eq, Data, Typeable )
+
+data Guard
+ = NormalG Exp -- ^ @f x { | odd x } = x@
+ | PatG [Stmt] -- ^ @f x { | Just y <- x, Just z <- y } = z@
+ 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] -- ^ @{ f p1 p2 = b where decs }@
+ | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@
+ | DataD Cxt Name [TyVarBndr]
+ [Con] [Name] -- ^ @{ data Cxt x => T x = A x | B (T x)
+ -- deriving (Z,W)}@
+ | NewtypeD Cxt Name [TyVarBndr]
+ Con [Name] -- ^ @{ newtype Cxt x => T x = A (B x)
+ -- deriving (Z,W)}@
+ | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@
+ | ClassD Cxt Name [TyVarBndr]
+ [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@
+ | InstanceD Cxt Type [Dec] -- ^ @{ instance Show w => Show [w]
+ -- where ds }@
+ | SigD Name Type -- ^ @{ length :: [a] -> Int }@
+ | ForeignD Foreign -- ^ @{ foreign import ... }
+ --{ foreign export ... }@
+
+ | InfixD Fixity Name -- ^ @{ infix 3 foo }@
+
+ -- | pragmas
+ | PragmaD Pragma -- ^ @{ {\-# INLINE [1] foo #-\} }@
+
+ -- | type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
+ | FamilyD FamFlavour Name
+ [TyVarBndr] (Maybe Kind) -- ^ @{ type family T a b c :: * }@
+
+ | DataInstD Cxt Name [Type]
+ [Con] [Name] -- ^ @{ data instance Cxt x => T [x] = A x
+ -- | B (T x)
+ -- deriving (Z,W)}@
+ | NewtypeInstD Cxt Name [Type]
+ Con [Name] -- ^ @{ newtype instance Cxt x => T [x] = A (B x)
+ -- deriving (Z,W)}@
+ | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@
+
+ | ClosedTypeFamilyD Name
+ [TyVarBndr] (Maybe Kind)
+ [TySynEqn] -- ^ @{ type family F a b :: * where ... }@
+
+ | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@
+ deriving( Show, Eq, Data, Typeable )
+
+-- | One equation of a type family instance or closed type family. The
+-- arguments are the left-hand-side type patterns and the right-hand-side
+-- result.
+data TySynEqn = TySynEqn [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 | Interruptible
+ deriving( Show, Eq, Data, Typeable )
+
+data Pragma = InlineP Name Inline RuleMatch Phases
+ | SpecialiseP Name Type (Maybe Inline) Phases
+ | SpecialiseInstP Type
+ | RuleP String [RuleBndr] Exp Exp Phases
+ | AnnP AnnTarget Exp
+ deriving( Show, Eq, Data, Typeable )
+
+data Inline = NoInline
+ | Inline
+ | Inlinable
+ deriving (Show, Eq, Data, Typeable)
+
+data RuleMatch = ConLike
+ | FunLike
+ deriving (Show, Eq, Data, Typeable)
+
+data Phases = AllPhases
+ | FromPhase Int
+ | BeforePhase Int
+ deriving (Show, Eq, Data, Typeable)
+
+data RuleBndr = RuleVar Name
+ | TypedRuleVar Name Type
+ deriving (Show, Eq, Data, Typeable)
+
+data AnnTarget = ModuleAnnotation
+ | TypeAnnotation Name
+ | ValueAnnotation Name
+ deriving (Show, Eq, Data, Typeable)
+
+type Cxt = [Pred] -- ^ @(Eq a, Ord b)@
+
+-- | Since the advent of @ConstraintKinds@, constraints are really just types.
+-- Equality constraints use the 'EqualityT' constructor. Constraints may also
+-- be tuples of other constraints.
+type Pred = Type
+
+data Strict = IsStrict | NotStrict | Unpacked
+ deriving( Show, Eq, Data, Typeable )
+
+data Con = NormalC Name [StrictType] -- ^ @C Int a@
+ | RecC Name [VarStrictType] -- ^ @C { v :: Int, w :: a }@
+ | InfixC StrictType Name StrictType -- ^ @Int :+ a@
+ | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@
+ deriving( Show, Eq, Data, Typeable )
+
+type StrictType = (Strict, Type)
+type VarStrictType = (Name, Strict, Type)
+
+data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<type\>@
+ | AppT Type Type -- ^ @T a b@
+ | SigT Type Kind -- ^ @t :: k@
+ | VarT Name -- ^ @a@
+ | ConT Name -- ^ @T@
+ | PromotedT Name -- ^ @'T@
+
+ -- See Note [Representing concrete syntax in types]
+ | TupleT Int -- ^ @(,), (,,), etc.@
+ | UnboxedTupleT Int -- ^ @(#,#), (#,,#), etc.@
+ | ArrowT -- ^ @->@
+ | EqualityT -- ^ @~@
+ | ListT -- ^ @[]@
+ | PromotedTupleT Int -- ^ @'(), '(,), '(,,), etc.@
+ | PromotedNilT -- ^ @'[]@
+ | PromotedConsT -- ^ @(':)@
+ | StarT -- ^ @*@
+ | ConstraintT -- ^ @Constraint@
+ | LitT TyLit -- ^ @0,1,2, etc.@
+ deriving( Show, Eq, Data, Typeable )
+
+data TyVarBndr = PlainTV Name -- ^ @a@
+ | KindedTV Name Kind -- ^ @(a :: k)@
+ deriving( Show, Eq, Data, Typeable )
+
+data TyLit = NumTyLit Integer -- ^ @2@
+ | StrTyLit String -- ^ @"Hello"@
+ deriving ( Show, Eq, Data, Typeable )
+
+-- | Role annotations
+data Role = NominalR -- ^ @nominal@
+ | RepresentationalR -- ^ @representational@
+ | PhantomR -- ^ @phantom@
+ | InferR -- ^ @_@
+ deriving( Show, Eq, Data, Typeable )
+
+-- | Annotation target for reifyAnnotations
+data AnnLookup = AnnLookupModule Module
+ | AnnLookupName Name
+ deriving( Show, Eq, Data, Typeable )
+
+-- | To avoid duplication between kinds and types, they
+-- are defined to be the same. Naturally, you would never
+-- have a type be 'StarT' and you would never have a kind
+-- be 'SigT', but many of the other constructors are shared.
+-- Note that the kind @Bool@ is denoted with 'ConT', not
+-- 'PromotedT'. Similarly, tuple kinds are made with 'TupleT',
+-- not 'PromotedTupleT'.
+
+type Kind = Type
+
+{- Note [Representing concrete syntax in types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Haskell has a rich concrete syntax for types, including
+ t1 -> t2, (t1,t2), [t], and so on
+In TH we represent all of this using AppT, with a distinguished
+type constructor at the head. So,
+ Type TH representation
+ -----------------------------------------------
+ t1 -> t2 ArrowT `AppT` t2 `AppT` t2
+ [t] ListT `AppT` t
+ (t1,t2) TupleT 2 `AppT` t1 `AppT` t2
+ '(t1,t2) PromotedTupleT 2 `AppT` t1 `AppT` t2
+
+But if the original HsSyn used prefix application, we won't use
+these special TH constructors. For example
+ [] t ConT "[]" `AppT` t
+ (->) t ConT "->" `AppT` t
+In this way we can faithfully represent in TH whether the original
+HsType used concrete syntax or not.
+
+The one case that doesn't fit this pattern is that of promoted lists
+ '[ Maybe, IO ] PromotedListT 2 `AppT` t1 `AppT` t2
+but it's very smelly because there really is no type constructor
+corresponding to PromotedListT. So we encode HsExplicitListTy with
+PromotedConsT and PromotedNilT (which *do* have underlying type
+constructors):
+ '[ Maybe, IO ] PromotedConsT `AppT` Maybe `AppT`
+ (PromotedConsT `AppT` IO `AppT` PromotedNilT)
+-}
+
+-----------------------------------------------------
+-- Internal helper functions
+-----------------------------------------------------
+
+cmpEq :: Ordering -> Bool
+cmpEq EQ = True
+cmpEq _ = False
+
+thenCmp :: Ordering -> Ordering -> Ordering
+thenCmp EQ o2 = o2
+thenCmp o1 _ = o1
View Lorry Controller Status