diff --git a/Language/Haskell/TH.hs b/Language/Haskell/TH.hs --- a/Language/Haskell/TH.hs +++ b/Language/Haskell/TH.hs @@ -73,7 +73,7 @@ SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..), Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..), Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..), - FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..), + FunDep(..), TySynEqn(..), TypeFamilyHead(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, PatSynDir(..), PatSynArgs(..), -- ** Expressions diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs --- a/Language/Haskell/TH/Lib.hs +++ b/Language/Haskell/TH/Lib.hs @@ -1,8 +1,13 @@ -- | --- TH.Lib contains lots of useful helper functions for +-- Language.Haskell.TH.Lib contains lots of useful helper functions for -- generating and manipulating Template Haskell terms -{-# LANGUAGE CPP #-} +-- Note: this module mostly re-exports functions from +-- Language.Haskell.TH.Lib.Internal, but if a change occurs to Template +-- Haskell which requires breaking the API offered in this module, we opt to +-- copy the old definition here, and make the changes in +-- Language.Haskell.TH.Lib.Internal. This way, we can retain backwards +-- compatibility while still allowing GHC to make changes as it needs. module Language.Haskell.TH.Lib ( -- All of the exports from this module should @@ -11,11 +16,12 @@ -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, - DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, - SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, - StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, - TySynEqnQ, PatSynDirQ, PatSynArgsQ, + InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyVarBndrQ, + TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, + StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, + BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, + FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, + FamilyResultSigQ, -- ** Constructors lifted to 'Q' -- *** Literals @@ -31,7 +37,7 @@ normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, -- *** Expressions - dyn, varE, unboundVarE, conE, litE, appE, appTypeE, uInfixE, parensE, + dyn, varE, unboundVarE, labelE, conE, litE, appE, appTypeE, uInfixE, parensE, staticE, infixE, infixApp, sectionL, sectionR, lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, @@ -82,9 +88,8 @@ roleAnnotD, -- **** Type Family / Data Family dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD, - familyNoKindD, familyKindD, closedTypeFamilyNoKindD, closedTypeFamilyKindD, newtypeInstD, tySynInstD, - typeFam, dataFam, tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, + tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig, -- **** Fixity infixLD, infixRD, infixND, @@ -111,355 +116,45 @@ ) where -import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) -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 DerivClauseQ = Q DerivClause -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 SourceStrictnessQ = Q SourceStrictness -type SourceUnpackednessQ = Q SourceUnpackedness -type BangQ = Q Bang -type BangTypeQ = Q BangType -type VarBangTypeQ = Q VarBangType -type StrictTypeQ = Q StrictType -type VarStrictTypeQ = Q VarStrictType -type FieldExpQ = Q FieldExp -type RuleBndrQ = Q RuleBndr -type TySynEqnQ = Q TySynEqn -type PatSynDirQ = Q PatSynDir -type PatSynArgsQ = Q PatSynArgs - --- must be defined here for DsMeta to find it -type Role = TH.Role -type InjectivityAnn = TH.InjectivityAnn - ----------------------------------------------------------- --- * 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 -charPrimL :: Char -> Lit -charPrimL = CharPrimL -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)} - -unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ -unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) } - -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)) - -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)} - -appTypeE :: ExpQ -> TypeQ -> ExpQ -appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) } - -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)} - -unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ -unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) } - -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') } - --- | @staticE x = [| static x |]@ -staticE :: ExpQ -> ExpQ -staticE = fmap StaticE +import Language.Haskell.TH.Lib.Internal hiding + ( tySynD + , dataD + , newtypeD + , classD + , dataInstD + , newtypeInstD + , dataFamilyD + , openTypeFamilyD + , closedTypeFamilyD + , forallC -unboundVarE :: Name -> ExpQ -unboundVarE s = return (UnboundVarE s) + , forallT + , sigT --- ** 'arithSeqE' Shortcuts -fromE :: ExpQ -> ExpQ -fromE x = do { a <- x; return (ArithSeqE (FromR a)) } + , plainTV + , kindedTV + , starK + , constraintK -fromThenE :: ExpQ -> ExpQ -> ExpQ -fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) } + , noSig + , kindSig + , tyVarSig -fromToE :: ExpQ -> ExpQ -> ExpQ -fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) } + , Role + , InjectivityAnn + ) +import Language.Haskell.TH.Syntax -fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ -fromThenToE x y z = do { a <- x; b <- y; c <- z; - return (ArithSeqE (FromThenToR a b c)) } +import Control.Monad (liftM2) +-- All definitions below represent the "old" API, since their definitions are +-- different in Language.Haskell.TH.Lib.Internal. Please think carefully before +-- deciding to change the APIs of the functions below, as they represent the +-- public API (as opposed to the Internal module, which has no API promises.) ------------------------------------------------------------------------------- -- * 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) } @@ -488,78 +183,6 @@ ctxt1 <- ctxt return $ ClassD ctxt1 cls tvs fds decs1 -instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ -instanceD = instanceWithOverlapD Nothing - -instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ -instanceWithOverlapD o ctxt ty decs = - do - ctxt1 <- ctxt - decs1 <- sequence decs - ty1 <- ty - return $ InstanceD o 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 - -pragLineD :: Int -> String -> DecQ -pragLineD line file = return $ PragmaD $ LineP line file - -pragCompleteD :: [Name] -> Maybe Name -> DecQ -pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty - dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] -> DecQ dataInstD ctxt tc tys ksig cons derivs = @@ -580,12 +203,6 @@ derivs1 <- sequence derivs return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1) -tySynInstD :: Name -> TySynEqnQ -> DecQ -tySynInstD tc eqn = - do - eqn1 <- eqn - return (TySynInstD tc eqn1) - dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ dataFamilyD tc tvs kind = return $ DataFamilyD tc tvs kind @@ -601,112 +218,9 @@ do eqns1 <- sequence eqns return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) --- These were deprecated in GHC 8.0 with a plan to remove them in 8.2. If you --- remove this check please also: --- 1. remove deprecated functions --- 2. remove CPP language extension from top of this module --- 3. remove the FamFlavour data type from Syntax module --- 4. make sure that all references to FamFlavour are gone from DsMeta, --- Convert, TcSplice (follows from 3) -#if __GLASGOW_HASKELL__ >= 804 -#error Remove deprecated familyNoKindD, familyKindD, closedTypeFamilyNoKindD and closedTypeFamilyKindD -#endif - -{-# DEPRECATED familyNoKindD, familyKindD - "This function will be removed in the next stable release. Use openTypeFamilyD/dataFamilyD instead." #-} -familyNoKindD :: FamFlavour -> Name -> [TyVarBndr] -> DecQ -familyNoKindD flav tc tvs = - case flav of - TypeFam -> return $ OpenTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) - DataFam -> return $ DataFamilyD tc tvs Nothing - -familyKindD :: FamFlavour -> Name -> [TyVarBndr] -> Kind -> DecQ -familyKindD flav tc tvs k = - case flav of - TypeFam -> - return $ OpenTypeFamilyD (TypeFamilyHead tc tvs (KindSig k) Nothing) - DataFam -> return $ DataFamilyD tc tvs (Just k) - -{-# DEPRECATED closedTypeFamilyNoKindD, closedTypeFamilyKindD - "This function will be removed in the next stable release. Use closedTypeFamilyD instead." #-} -closedTypeFamilyNoKindD :: Name -> [TyVarBndr] -> [TySynEqnQ] -> DecQ -closedTypeFamilyNoKindD tc tvs eqns = - do eqns1 <- sequence eqns - return (ClosedTypeFamilyD (TypeFamilyHead tc tvs NoSig Nothing) eqns1) - -closedTypeFamilyKindD :: Name -> [TyVarBndr] -> Kind -> [TySynEqnQ] -> DecQ -closedTypeFamilyKindD tc tvs kind eqns = - do eqns1 <- sequence eqns - return (ClosedTypeFamilyD (TypeFamilyHead tc tvs (KindSig kind) Nothing) - eqns1) - -roleAnnotD :: Name -> [Role] -> DecQ -roleAnnotD name roles = return $ RoleAnnotD name roles - -standaloneDerivD :: CxtQ -> TypeQ -> DecQ -standaloneDerivD = standaloneDerivWithStrategyD Nothing - -standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ -standaloneDerivWithStrategyD ds ctxtq tyq = - do - ctxt <- ctxtq - ty <- tyq - return $ StandaloneDerivD ds ctxt ty - -defaultSigD :: Name -> TypeQ -> DecQ -defaultSigD n tyq = - do - ty <- tyq - return $ DefaultSigD n ty - --- | Pattern synonym declaration -patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ -patSynD name args dir pat = do - args' <- args - dir' <- dir - pat' <- pat - return (PatSynD name args' dir' pat') - --- | Pattern synonym type signature -patSynSigD :: Name -> TypeQ -> DecQ -patSynSigD nm ty = - do ty' <- ty - return $ PatSynSigD nm ty' - -tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ -tySynEqn lhs rhs = - do - lhs1 <- sequence lhs - rhs1 <- rhs - return (TySynEqn lhs1 rhs1) - -cxt :: [PredQ] -> CxtQ -cxt = sequence - -derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ -derivClause ds p = do p' <- cxt p - return $ DerivClause ds p' - -normalC :: Name -> [BangTypeQ] -> ConQ -normalC con strtys = liftM (NormalC con) $ sequence strtys - -recC :: Name -> [VarBangTypeQ] -> ConQ -recC con varstrtys = liftM (RecC con) $ sequence varstrtys - -infixC :: Q (Bang, Type) -> Name -> Q (Bang, 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 -gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ -gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty - -recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ -recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty - ------------------------------------------------------------------------------- -- * Type @@ -716,145 +230,12 @@ ty1 <- ty return $ ForallT tvars ctxt1 ty1 -varT :: Name -> TypeQ -varT = return . VarT - -conT :: Name -> TypeQ -conT = return . ConT - -infixT :: TypeQ -> Name -> TypeQ -> TypeQ -infixT t1 n t2 = do t1' <- t1 - t2' <- t2 - return (InfixT t1' n t2') - -uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ -uInfixT t1 n t2 = do t1' <- t1 - t2' <- t2 - return (UInfixT t1' n t2') - -parensT :: TypeQ -> TypeQ -parensT t = do t' <- t - return (ParensT t') - -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) - -unboxedSumT :: SumArity -> TypeQ -unboxedSumT arity = return (UnboxedSumT arity) - sigT :: TypeQ -> Kind -> TypeQ sigT t k = do t' <- t return $ SigT t' k -equalityT :: TypeQ -equalityT = return EqualityT - -wildCardT :: TypeQ -wildCardT = return WildCardT - -{-# 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 - -noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ -noSourceUnpackedness = return NoSourceUnpackedness -sourceNoUnpack = return SourceNoUnpack -sourceUnpack = return SourceUnpack - -noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ -noSourceStrictness = return NoSourceStrictness -sourceLazy = return SourceLazy -sourceStrict = return SourceStrict - -{-# DEPRECATED isStrict - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-} -{-# DEPRECATED notStrict - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-} -{-# DEPRECATED unpacked - ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", - "Example usage: 'bang sourceUnpack sourceStrict'"] #-} -isStrict, notStrict, unpacked :: Q Strict -isStrict = bang noSourceUnpackedness sourceStrict -notStrict = bang noSourceUnpackedness noSourceStrictness -unpacked = bang sourceUnpack sourceStrict - -bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ -bang u s = do u' <- u - s' <- s - return (Bang u' s') - -bangType :: BangQ -> TypeQ -> BangTypeQ -bangType = liftM2 (,) - -varBangType :: Name -> BangTypeQ -> VarBangTypeQ -varBangType v bt = do (b, t) <- bt - return (v, b, t) - -{-# DEPRECATED strictType - "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} -strictType :: Q Strict -> TypeQ -> StrictTypeQ -strictType = bangType - -{-# DEPRECATED varStrictType - "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} -varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ -varStrictType = varBangType - --- * 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 @@ -864,24 +245,6 @@ 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 @@ -899,104 +262,3 @@ tyVarSig :: TyVarBndr -> FamilyResultSig tyVarSig = TyVarSig - -------------------------------------------------------------------------------- --- * Injectivity annotation - -injectivityAnn :: Name -> [Name] -> InjectivityAnn -injectivityAnn = TH.InjectivityAnn - -------------------------------------------------------------------------------- --- * Role - -nominalR, representationalR, phantomR, inferR :: Role -nominalR = NominalR -representationalR = RepresentationalR -phantomR = PhantomR -inferR = InferR - -------------------------------------------------------------------------------- --- * Callconv - -cCall, stdCall, cApi, prim, javaScript :: Callconv -cCall = CCall -stdCall = StdCall -cApi = CApi -prim = Prim -javaScript = JavaScript - -------------------------------------------------------------------------------- --- * 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 - -------------------------------------------------------------------------------- --- * AnnTarget -valueAnnotation :: Name -> AnnTarget -valueAnnotation = ValueAnnotation - -typeAnnotation :: Name -> AnnTarget -typeAnnotation = TypeAnnotation - -moduleAnnotation :: AnnTarget -moduleAnnotation = ModuleAnnotation - -------------------------------------------------------------------------------- --- * Pattern Synonyms (sub constructs) - -unidir, implBidir :: PatSynDirQ -unidir = return Unidir -implBidir = return ImplBidir - -explBidir :: [ClauseQ] -> PatSynDirQ -explBidir cls = do - cls' <- sequence cls - return (ExplBidir cls') - -prefixPatSyn :: [Name] -> PatSynArgsQ -prefixPatSyn args = return $ PrefixPatSyn args - -recordPatSyn :: [Name] -> PatSynArgsQ -recordPatSyn sels = return $ RecordPatSyn sels - -infixPatSyn :: Name -> Name -> PatSynArgsQ -infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2 - --------------------------------------------------------------- --- * 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/Language/Haskell/TH/Lib/Internal.hs b/Language/Haskell/TH/Lib/Internal.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/Lib/Internal.hs @@ -0,0 +1,888 @@ +-- | +-- Language.Haskell.TH.Lib.Internal exposes some additional functionality that +-- is used internally in GHC's integration with Template Haskell. This is not a +-- part of the public API, and as such, there are no API guarantees for this +-- module from version to version. + +-- Why do we have both Language.Haskell.TH.Lib.Internal and +-- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the +-- former (which are tailored for GHC's use) need different type signatures +-- than the ones in the latter. Syncing up the Internal type signatures would +-- involve a massive amount of breaking changes, so for the time being, we +-- relegate as many changes as we can to just the Internal module, where it +-- is safe to break things. + +module Language.Haskell.TH.Lib.Internal where + +import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn) +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 KindQ = Q Kind +type TyVarBndrQ = Q TyVarBndr +type TyLitQ = Q TyLit +type CxtQ = Q Cxt +type PredQ = Q Pred +type DerivClauseQ = Q DerivClause +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 SourceStrictnessQ = Q SourceStrictness +type SourceUnpackednessQ = Q SourceUnpackedness +type BangQ = Q Bang +type BangTypeQ = Q BangType +type VarBangTypeQ = Q VarBangType +type StrictTypeQ = Q StrictType +type VarStrictTypeQ = Q VarStrictType +type FieldExpQ = Q FieldExp +type RuleBndrQ = Q RuleBndr +type TySynEqnQ = Q TySynEqn +type PatSynDirQ = Q PatSynDir +type PatSynArgsQ = Q PatSynArgs +type FamilyResultSigQ = Q FamilyResultSig + +-- must be defined here for DsMeta to find it +type Role = TH.Role +type InjectivityAnn = TH.InjectivityAnn + +---------------------------------------------------------- +-- * 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 +charPrimL :: Char -> Lit +charPrimL = CharPrimL +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)} + +unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ +unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) } + +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)) + +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)} + +appTypeE :: ExpQ -> TypeQ -> ExpQ +appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) } + +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)} + +unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ +unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) } + +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') } + +-- | @staticE x = [| static x |]@ +staticE :: ExpQ -> ExpQ +staticE = fmap StaticE + +unboundVarE :: Name -> ExpQ +unboundVarE s = return (UnboundVarE s) + +labelE :: String -> ExpQ +labelE s = return (LabelE s) + +-- ** '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 -> [TyVarBndrQ] -> TypeQ -> DecQ +tySynD tc tvs rhs = + do { tvs1 <- sequenceA tvs + ; rhs1 <- rhs + ; return (TySynD tc tvs1 rhs1) + } + +dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ] + -> [DerivClauseQ] -> DecQ +dataD ctxt tc tvs ksig cons derivs = + do + ctxt1 <- ctxt + tvs1 <- sequenceA tvs + ksig1 <- sequenceA ksig + cons1 <- sequence cons + derivs1 <- sequence derivs + return (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1) + +newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ + -> [DerivClauseQ] -> DecQ +newtypeD ctxt tc tvs ksig con derivs = + do + ctxt1 <- ctxt + tvs1 <- sequenceA tvs + ksig1 <- sequenceA ksig + con1 <- con + derivs1 <- sequence derivs + return (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) + +classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ +classD ctxt cls tvs fds decs = + do + tvs1 <- sequenceA tvs + decs1 <- sequenceA decs + ctxt1 <- ctxt + return $ ClassD ctxt1 cls tvs1 fds decs1 + +instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ +instanceD = instanceWithOverlapD Nothing + +instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ +instanceWithOverlapD o ctxt ty decs = + do + ctxt1 <- ctxt + decs1 <- sequence decs + ty1 <- ty + return $ InstanceD o 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 + +pragLineD :: Int -> String -> DecQ +pragLineD line file = return $ PragmaD $ LineP line file + +pragCompleteD :: [Name] -> Maybe Name -> DecQ +pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty + +dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> [ConQ] + -> [DerivClauseQ] -> DecQ +dataInstD ctxt tc tys ksig cons derivs = + do + ctxt1 <- ctxt + tys1 <- sequenceA tys + ksig1 <- sequenceA ksig + cons1 <- sequenceA cons + derivs1 <- sequenceA derivs + return (DataInstD ctxt1 tc tys1 ksig1 cons1 derivs1) + +newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> ConQ + -> [DerivClauseQ] -> DecQ +newtypeInstD ctxt tc tys ksig con derivs = + do + ctxt1 <- ctxt + tys1 <- sequenceA tys + ksig1 <- sequenceA ksig + con1 <- con + derivs1 <- sequence derivs + return (NewtypeInstD ctxt1 tc tys1 ksig1 con1 derivs1) + +tySynInstD :: Name -> TySynEqnQ -> DecQ +tySynInstD tc eqn = + do + eqn1 <- eqn + return (TySynInstD tc eqn1) + +dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ +dataFamilyD tc tvs kind = + do tvs' <- sequenceA tvs + kind' <- sequenceA kind + return $ DataFamilyD tc tvs' kind' + +openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ + -> Maybe InjectivityAnn -> DecQ +openTypeFamilyD tc tvs res inj = + do tvs' <- sequenceA tvs + res' <- res + return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj) + +closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ + -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ +closedTypeFamilyD tc tvs result injectivity eqns = + do tvs1 <- sequenceA tvs + result1 <- result + eqns1 <- sequenceA eqns + return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1) + +roleAnnotD :: Name -> [Role] -> DecQ +roleAnnotD name roles = return $ RoleAnnotD name roles + +standaloneDerivD :: CxtQ -> TypeQ -> DecQ +standaloneDerivD = standaloneDerivWithStrategyD Nothing + +standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD ds ctxtq tyq = + do + ctxt <- ctxtq + ty <- tyq + return $ StandaloneDerivD ds ctxt ty + +defaultSigD :: Name -> TypeQ -> DecQ +defaultSigD n tyq = + do + ty <- tyq + return $ DefaultSigD n ty + +-- | Pattern synonym declaration +patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ +patSynD name args dir pat = do + args' <- args + dir' <- dir + pat' <- pat + return (PatSynD name args' dir' pat') + +-- | Pattern synonym type signature +patSynSigD :: Name -> TypeQ -> DecQ +patSynSigD nm ty = + do ty' <- ty + return $ PatSynSigD nm ty' + +tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ +tySynEqn lhs rhs = + do + lhs1 <- sequence lhs + rhs1 <- rhs + return (TySynEqn lhs1 rhs1) + +cxt :: [PredQ] -> CxtQ +cxt = sequence + +derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause ds p = do p' <- cxt p + return $ DerivClause ds p' + +normalC :: Name -> [BangTypeQ] -> ConQ +normalC con strtys = liftM (NormalC con) $ sequence strtys + +recC :: Name -> [VarBangTypeQ] -> ConQ +recC con varstrtys = liftM (RecC con) $ sequence varstrtys + +infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ +infixC st1 con st2 = do st1' <- st1 + st2' <- st2 + return $ InfixC st1' con st2' + +forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ +forallC ns ctxt con = do + ns' <- sequenceA ns + ctxt' <- ctxt + con' <- con + pure $ ForallC ns' ctxt' con' + +gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ +gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty + +recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ +recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty + +------------------------------------------------------------------------------- +-- * Type + +forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ +forallT tvars ctxt ty = do + tvars1 <- sequenceA tvars + ctxt1 <- ctxt + ty1 <- ty + return $ ForallT tvars1 ctxt1 ty1 + +varT :: Name -> TypeQ +varT = return . VarT + +conT :: Name -> TypeQ +conT = return . ConT + +infixT :: TypeQ -> Name -> TypeQ -> TypeQ +infixT t1 n t2 = do t1' <- t1 + t2' <- t2 + return (InfixT t1' n t2') + +uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ +uInfixT t1 n t2 = do t1' <- t1 + t2' <- t2 + return (UInfixT t1' n t2') + +parensT :: TypeQ -> TypeQ +parensT t = do t' <- t + return (ParensT t') + +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) + +unboxedSumT :: SumArity -> TypeQ +unboxedSumT arity = return (UnboxedSumT arity) + +sigT :: TypeQ -> KindQ -> TypeQ +sigT t k + = do + t' <- t + k' <- k + return $ SigT t' k' + +equalityT :: TypeQ +equalityT = return EqualityT + +wildCardT :: TypeQ +wildCardT = return WildCardT + +{-# 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 + +noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ +noSourceUnpackedness = return NoSourceUnpackedness +sourceNoUnpack = return SourceNoUnpack +sourceUnpack = return SourceUnpack + +noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ +noSourceStrictness = return NoSourceStrictness +sourceLazy = return SourceLazy +sourceStrict = return SourceStrict + +{-# DEPRECATED isStrict + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-} +{-# DEPRECATED notStrict + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-} +{-# DEPRECATED unpacked + ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ", + "Example usage: 'bang sourceUnpack sourceStrict'"] #-} +isStrict, notStrict, unpacked :: Q Strict +isStrict = bang noSourceUnpackedness sourceStrict +notStrict = bang noSourceUnpackedness noSourceStrictness +unpacked = bang sourceUnpack sourceStrict + +bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ +bang u s = do u' <- u + s' <- s + return (Bang u' s') + +bangType :: BangQ -> TypeQ -> BangTypeQ +bangType = liftM2 (,) + +varBangType :: Name -> BangTypeQ -> VarBangTypeQ +varBangType v bt = do (b, t) <- bt + return (v, b, t) + +{-# DEPRECATED strictType + "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-} +strictType :: Q Strict -> TypeQ -> StrictTypeQ +strictType = bangType + +{-# DEPRECATED varStrictType + "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-} +varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ +varStrictType = varBangType + +-- * 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 -> TyVarBndrQ +plainTV = pure . PlainTV + +kindedTV :: Name -> KindQ -> TyVarBndrQ +kindedTV n = fmap (KindedTV n) + +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 :: KindQ +starK = pure StarT + +constraintK :: KindQ +constraintK = pure ConstraintT + +------------------------------------------------------------------------------- +-- * Type family result + +noSig :: FamilyResultSigQ +noSig = pure NoSig + +kindSig :: KindQ -> FamilyResultSigQ +kindSig = fmap KindSig + +tyVarSig :: TyVarBndrQ -> FamilyResultSigQ +tyVarSig = fmap TyVarSig + +------------------------------------------------------------------------------- +-- * Injectivity annotation + +injectivityAnn :: Name -> [Name] -> InjectivityAnn +injectivityAnn = TH.InjectivityAnn + +------------------------------------------------------------------------------- +-- * Role + +nominalR, representationalR, phantomR, inferR :: Role +nominalR = NominalR +representationalR = RepresentationalR +phantomR = PhantomR +inferR = InferR + +------------------------------------------------------------------------------- +-- * Callconv + +cCall, stdCall, cApi, prim, javaScript :: Callconv +cCall = CCall +stdCall = StdCall +cApi = CApi +prim = Prim +javaScript = JavaScript + +------------------------------------------------------------------------------- +-- * Safety + +unsafe, safe, interruptible :: Safety +unsafe = Unsafe +safe = Safe +interruptible = Interruptible + +------------------------------------------------------------------------------- +-- * FunDep + +funDep :: [Name] -> [Name] -> FunDep +funDep = FunDep + +------------------------------------------------------------------------------- +-- * RuleBndr +ruleVar :: Name -> RuleBndrQ +ruleVar = return . RuleVar + +typedRuleVar :: Name -> TypeQ -> RuleBndrQ +typedRuleVar n ty = ty >>= return . TypedRuleVar n + +------------------------------------------------------------------------------- +-- * AnnTarget +valueAnnotation :: Name -> AnnTarget +valueAnnotation = ValueAnnotation + +typeAnnotation :: Name -> AnnTarget +typeAnnotation = TypeAnnotation + +moduleAnnotation :: AnnTarget +moduleAnnotation = ModuleAnnotation + +------------------------------------------------------------------------------- +-- * Pattern Synonyms (sub constructs) + +unidir, implBidir :: PatSynDirQ +unidir = return Unidir +implBidir = return ImplBidir + +explBidir :: [ClauseQ] -> PatSynDirQ +explBidir cls = do + cls' <- sequence cls + return (ExplBidir cls') + +prefixPatSyn :: [Name] -> PatSynArgsQ +prefixPatSyn args = return $ PrefixPatSyn args + +recordPatSyn :: [Name] -> PatSynArgsQ +recordPatSyn sels = return $ RecordPatSyn sels + +infixPatSyn :: Name -> Name -> PatSynArgsQ +infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2 + +-------------------------------------------------------------- +-- * 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/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs --- a/Language/Haskell/TH/Ppr.hs +++ b/Language/Haskell/TH/Ppr.hs @@ -14,6 +14,7 @@ import GHC.Show ( showMultiLineString ) import GHC.Lexeme( startsVarSym ) import Data.Ratio ( numerator, denominator ) +import Prelude hiding ((<>)) nestDepth :: Int nestDepth = 4 @@ -143,6 +144,7 @@ pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1 <+> pprInfixExp op <+> pprMaybeExp noPrec me2 +pprExp i (LamE [] e) = pprExp i e -- #13856 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps) <+> text "->" <+> ppr e pprExp i (LamCaseE ms) = parensIf (i > noPrec) @@ -150,7 +152,7 @@ pprExp _ (TupE es) = parens (commaSep es) pprExp _ (UnboxedTupE es) = hashParens (commaSep es) pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity --- Nesting in Cond is to avoid potential problems in do statments +-- Nesting in Cond is to avoid potential problems in do statements pprExp i (CondE guard true false) = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, nest 1 $ text "then" <+> ppr true, @@ -198,6 +200,7 @@ pprExp i (StaticE e) = parensIf (i >= appPrec) $ text "static"<+> pprExp appPrec e pprExp _ (UnboundVarE v) = pprName' Applied v +pprExp _ (LabelE s) = text "#" <> text s pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) @@ -397,7 +400,7 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs = sep [text "data" <+> maybeInst <+> pprCxt ctxt - <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere, + <+> pprName' Applied t <+> argsDoc <+> ksigDoc <+> maybeWhere, nest nestDepth (sep (pref $ map ppr cs)), if null decs then empty @@ -463,11 +466,6 @@ ppr_list xs = bar <+> commaSep xs ------------------------------ -instance Ppr FamFlavour where - ppr DataFam = text "data" - ppr TypeFam = text "type" - ------------------------------- instance Ppr FamilyResultSig where ppr NoSig = empty ppr (KindSig k) = dcolon <+> ppr k @@ -677,8 +675,9 @@ ------------------------------ pprParendType :: Type -> Doc -pprParendType (VarT v) = ppr v -pprParendType (ConT c) = ppr c +pprParendType (VarT v) = pprName' Applied v +-- `Applied` is used here instead of `ppr` because of infix names (#13887) +pprParendType (ConT c) = pprName' Applied c pprParendType (TupleT 0) = text "()" pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma @@ -686,11 +685,11 @@ pprParendType ArrowT = parens (text "->") pprParendType ListT = text "[]" pprParendType (LitT l) = pprTyLit l -pprParendType (PromotedT c) = text "'" <> ppr c +pprParendType (PromotedT c) = text "'" <> pprName' Applied c pprParendType (PromotedTupleT 0) = text "'()" pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) pprParendType PromotedNilT = text "'[]" -pprParendType PromotedConsT = text "(':)" +pprParendType PromotedConsT = text "'(:)" pprParendType StarT = char '*' pprParendType ConstraintT = text "Constraint" pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) diff --git a/Language/Haskell/TH/PprLib.hs b/Language/Haskell/TH/PprLib.hs --- a/Language/Haskell/TH/PprLib.hs +++ b/Language/Haskell/TH/PprLib.hs @@ -41,6 +41,7 @@ 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 Prelude hiding ((<>)) infixl 6 <> infixl 6 <+> diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs --- a/Language/Haskell/TH/Syntax.hs +++ b/Language/Haskell/TH/Syntax.hs @@ -1,14 +1,10 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, DefaultSignatures, RankNTypes, RoleAnnotations, ScopedTypeVariables, Trustworthy #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} -#if MIN_VERSION_base(4,9,0) -# define HAS_MONADFAIL 1 -#endif - ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Syntax @@ -34,6 +30,7 @@ import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import Control.Monad (liftM) +import Control.Monad.IO.Class (MonadIO (..)) import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha, isAlphaNum, isUpper ) import Data.Int @@ -45,9 +42,7 @@ import Language.Haskell.TH.LanguageExtensions import Numeric.Natural -#if HAS_MONADFAIL import qualified Control.Monad.Fail as Fail -#endif ----------------------------------------------------- -- @@ -55,11 +50,7 @@ -- ----------------------------------------------------- -#if HAS_MONADFAIL -class Fail.MonadFail m => Quasi m where -#else -class Monad m => Quasi m where -#endif +class (MonadIO m, Fail.MonadFail m) => Quasi m where qNewName :: String -> m Name -- ^ Fresh names @@ -88,6 +79,7 @@ qLocation :: m Loc qRunIO :: IO a -> m a + qRunIO = liftIO -- ^ Input/output (dangerous) qAddDependentFile :: FilePath -> m () @@ -98,6 +90,8 @@ qAddModFinalizer :: Q () -> m () + qAddCorePlugin :: String -> m () + qGetQ :: Typeable a => m (Maybe a) qPutQ :: Typeable a => a -> m () @@ -137,13 +131,12 @@ qAddTopDecls _ = badIO "addTopDecls" qAddForeignFile _ _ = badIO "addForeignFile" qAddModFinalizer _ = badIO "addModFinalizer" + qAddCorePlugin _ = badIO "addCorePlugin" qGetQ = badIO "getQ" qPutQ _ = badIO "putQ" qIsExtEnabled _ = badIO "isExtEnabled" qExtsEnabled = badIO "extsEnabled" - qRunIO m = m - badIO :: String -> IO a badIO op = do { qReport True ("Can't do `" ++ op ++ "' in the IO monad") ; fail "Template Haskell failure" } @@ -179,14 +172,10 @@ instance Monad Q where Q m >>= k = Q (m >>= \x -> unQ (k x)) (>>) = (*>) -#if !HAS_MONADFAIL - fail s = report True s >> Q (fail "Q monad failure") -#else fail = Fail.fail instance Fail.MonadFail Q where fail s = report True s >> Q (Fail.fail "Q monad failure") -#endif instance Functor Q where fmap f (Q x) = Q (fmap f x) @@ -490,6 +479,16 @@ addModFinalizer :: Q () -> Q () addModFinalizer act = Q (qAddModFinalizer (unQ act)) +-- | Adds a core plugin to the compilation pipeline. +-- +-- @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc +-- in the command line. The major difference is that the plugin module @m@ +-- must not belong to the current package. When TH executes, it is too late +-- to tell the compiler that we needed to compile first a plugin module in the +-- current package. +addCorePlugin :: String -> Q () +addCorePlugin plugin = Q (qAddCorePlugin plugin) + -- | Get state from the 'Q' monad. Note that the state is local to the -- Haskell module in which the Template Haskell expression is executed. getQ :: Typeable a => Q (Maybe a) @@ -508,6 +507,9 @@ extsEnabled :: Q [Extension] extsEnabled = Q qExtsEnabled +instance MonadIO Q where + liftIO = runIO + instance Quasi Q where qNewName = newName qReport = report @@ -521,11 +523,11 @@ qReifyConStrictness = reifyConStrictness qLookupName = lookupName qLocation = location - qRunIO = runIO qAddDependentFile = addDependentFile qAddTopDecls = addTopDecls qAddForeignFile = addForeignFile qAddModFinalizer = addModFinalizer + qAddCorePlugin = addCorePlugin qGetQ = getQ qPutQ = putQ qIsExtEnabled = isExtEnabled @@ -563,6 +565,9 @@ -- Template Haskell has no way of knowing what value @x@ will take on at -- splice-time, so it requires the type of @x@ to be an instance of 'Lift'. -- +-- A 'Lift' instance must satisfy @$(lift x) ≡ x@ for all @x@, where @$(...)@ +-- is a Template Haskell splice. +-- -- 'Lift' instances can be derived automatically by use of the @-XDeriveLift@ -- GHC language extension: -- @@ -1538,7 +1543,7 @@ | ConE Name -- ^ @data T1 = C1 t1 t2; p = {C1} e1 e2 @ | LitE Lit -- ^ @{ 5 or \'c\'}@ | AppE Exp Exp -- ^ @{ f x }@ - | AppTypeE Exp Type -- ^ @{ f \@Int } + | AppTypeE Exp Type -- ^ @{ f \@Int }@ | InfixE (Maybe Exp) Exp (Maybe Exp) -- ^ @{x + y} or {(x+)} or {(+ x)} or {(+)}@ @@ -1582,6 +1587,7 @@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ | StaticE Exp -- ^ @{ static e }@ | UnboundVarE Name -- ^ @{ _x }@ (hole) + | LabelE String -- ^ @{ #x }@ ( Overloaded label ) deriving( Show, Eq, Ord, Data, Generic ) type FieldExp = (Name,Exp) @@ -1770,9 +1776,6 @@ data FunDep = FunDep [Name] [Name] deriving( Show, Eq, Ord, Data, Generic ) -data FamFlavour = TypeFam | DataFam - deriving( Show, Eq, Ord, Data, Generic ) - data Foreign = ImportF Callconv Safety String Name Type | ExportF Callconv String Name Type deriving( Show, Eq, Ord, Data, Generic ) @@ -1844,6 +1847,35 @@ | DecidedUnpack deriving (Show, Eq, Ord, Data, Generic) +-- | A single data constructor. +-- +-- The constructors for 'Con' can roughly be divided up into two categories: +-- those for constructors with \"vanilla\" syntax ('NormalC', 'RecC', and +-- 'InfixC'), and those for constructors with GADT syntax ('GadtC' and +-- 'RecGadtC'). The 'ForallC' constructor, which quantifies additional type +-- variables and class contexts, can surround either variety of constructor. +-- However, the type variables that it quantifies are different depending +-- on what constructor syntax is used: +-- +-- * If a 'ForallC' surrounds a constructor with vanilla syntax, then the +-- 'ForallC' will only quantify /existential/ type variables. For example: +-- +-- @ +-- data Foo a = forall b. MkFoo a b +-- @ +-- +-- In @MkFoo@, 'ForallC' will quantify @b@, but not @a@. +-- +-- * If a 'ForallC' surrounds a constructor with GADT syntax, then the +-- 'ForallC' will quantify /all/ type variables used in the constructor. +-- For example: +-- +-- @ +-- data Bar a b where +-- MkBar :: (a ~ b) => c -> MkBar a b +-- @ +-- +-- In @MkBar@, 'ForallC' will quantify @a@, @b@, and @c@. data Con = NormalC Name [BangType] -- ^ @C Int a@ | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ | InfixC BangType Name BangType -- ^ @Int :+ a@ @@ -1916,7 +1948,7 @@ | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ deriving( Show, Eq, Ord, Data, Generic ) -data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \. \ -> \@ +data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \. \ => \@ | AppT Type Type -- ^ @T a b@ | SigT Type Kind -- ^ @t :: k@ | VarT Name -- ^ @a@ @@ -1941,7 +1973,7 @@ | StarT -- ^ @*@ | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@ - | WildCardT -- ^ @_, + | WildCardT -- ^ @_@ deriving( Show, Eq, Ord, Data, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ @@ -1959,7 +1991,7 @@ deriving ( Show, Eq, Ord, Data, Generic ) data TyLit = NumTyLit Integer -- ^ @2@ - | StrTyLit String -- ^ @"Hello"@ + | StrTyLit String -- ^ @\"Hello\"@ deriving ( Show, Eq, Ord, Data, Generic ) -- | Role annotations diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,8 +1,30 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) +## 2.13.0.0 *March 2018* + + * Bundled with GHC 8.4.1 + + * `Language.Haskell.TH.FamFlavour`, which was deprecated in 2.11, + has been removed. + + * Add support for overloaded labels. Introduces `labelE :: String -> ExpQ`. + + * Add `KindQ`, `TyVarBndrQ`, and `FamilyResultSigQ` aliases to + `Language.Haskell.TH.Lib`. + + * Add `Language.Haskell.TH.Lib.Internal` module, which exposes some + additional functionality that is used internally in GHC's integration + with Template Haskell. This is not a part of the public API, and as + such, there are no API guarantees for this module from version to version. + + * `MonadIO` is now a superclass of `Quasi`, `qRunIO` has a default + implementation `qRunIO = liftIO` + + * Add `MonadIO Q` instance + ## 2.12.0.0 *July 2017* - * Bundled with GHC 8.2.1. + * Bundled with GHC 8.2.1 * Add support for pattern synonyms. This introduces one new constructor to `Info` (`PatSynI`), two new constructors to `Dec` (`PatSynD` and @@ -31,6 +53,8 @@ - `plainTV` and `kindedTV` - `interruptible` and `funDep` - `valueAnnotation`, `typeAnnotation`, and `moduleAnnotation` + + * Add support for overloaded labels. ## 2.11.0.0 *May 2016* diff --git a/template-haskell.cabal b/template-haskell.cabal --- a/template-haskell.cabal +++ b/template-haskell.cabal @@ -1,5 +1,5 @@ name: template-haskell -version: 2.12.0.0 +version: 2.13.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -45,22 +45,18 @@ Language.Haskell.TH.Syntax Language.Haskell.TH.LanguageExtensions + Language.Haskell.TH.Lib.Internal + other-modules: Language.Haskell.TH.Lib.Map build-depends: - base >= 4.8 && < 4.11, - ghc-boot-th == 8.2.*, + base >= 4.9 && < 4.12, + ghc-boot-th == 8.4.*, pretty == 1.1.* - -- We need to set the unit ID to template-haskell (without a - -- version number) as it's magic. ghc-options: -Wall - if impl( ghc >= 7.11 ) - ghc-options: -this-unit-id template-haskell - else - if impl( ghc >= 7.9 ) - ghc-options: -this-package-key template-haskell - else - ghc-options: -package-name template-haskell + -- We need to set the unit ID to template-haskell (without a + -- version number) as it's magic. + ghc-options: -this-unit-id template-haskell