diff options
Diffstat (limited to 'libraries/template-haskell/Language/Haskell/TH/Lib.hs')
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Lib.hs | 866 |
1 files changed, 74 insertions, 792 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 78fbc41d6f..778e6c0553 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/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 @@ module Language.Haskell.TH.Lib ( -- * 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, DerivStrategyQ, -- ** Constructors lifted to 'Q' -- *** Literals @@ -31,8 +37,8 @@ module Language.Haskell.TH.Lib ( normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, -- *** Expressions - dyn, varE, unboundVarE, labelE, conE, litE, appE, appTypeE, uInfixE, parensE, - staticE, infixE, infixApp, sectionL, sectionR, + dyn, varE, unboundVarE, labelE, implicitParamVarE, conE, litE, staticE, + appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR, lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, -- **** Ranges @@ -42,13 +48,13 @@ module Language.Haskell.TH.Lib ( arithSeqE, fromR, fromThenR, fromToR, fromThenToR, -- **** Statements - doE, compE, - bindS, letS, noBindS, parS, + doE, mdoE, compE, + bindS, letS, noBindS, parS, recS, -- *** Types forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT, - promotedT, promotedTupleT, promotedNilT, promotedConsT, + promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT, -- **** Type literals numTyLit, strTyLit, -- **** Strictness @@ -73,7 +79,9 @@ module Language.Haskell.TH.Lib ( -- *** Top Level Declarations -- **** Data valD, funD, tySynD, dataD, newtypeD, - derivClause, DerivClause(..), DerivStrategy(..), + derivClause, DerivClause(..), + stockStrategy, anyclassStrategy, newtypeStrategy, + viaStrategy, DerivStrategy(..), -- **** Class classD, instanceD, instanceWithOverlapD, Overlap(..), sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD, @@ -82,9 +90,8 @@ module Language.Haskell.TH.Lib ( 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, @@ -106,363 +113,57 @@ module Language.Haskell.TH.Lib ( patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn, infixPatSyn, recordPatSyn, + -- **** Implicit Parameters + implicitParamBindD, + -- ** Reify thisModule ) 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 - -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)) } - +import Language.Haskell.TH.Lib.Internal hiding + ( tySynD + , dataD + , newtypeD + , classD + , dataInstD + , newtypeInstD + , dataFamilyD + , openTypeFamilyD + , closedTypeFamilyD + , forallC + + , forallT + , sigT + + , plainTV + , kindedTV + , starK + , constraintK + + , noSig + , kindSig + , tyVarSig + + , derivClause + , standaloneDerivWithStrategyD + + , Role + , InjectivityAnn + ) +import Language.Haskell.TH.Syntax + +import Control.Monad (liftM2) +import Prelude + +-- 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) } @@ -491,78 +192,6 @@ classD ctxt cls tvs fds decs = 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 = @@ -583,12 +212,6 @@ newtypeInstD ctxt tc tys ksig con derivs = 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 @@ -604,112 +227,9 @@ closedTypeFamilyD tc tvs result injectivity eqns = 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 @@ -719,145 +239,12 @@ forallT tvars ctxt ty = do 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 @@ -867,24 +254,6 @@ 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 @@ -904,102 +273,15 @@ 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 +-- * Top Level Declarations -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 ) +derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause mds p = do + p' <- cxt p + return $ DerivClause mds p' --- | 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) +standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD mds ctxt ty = do + ctxt' <- ctxt + ty' <- ty + return $ StandaloneDerivD mds ctxt' ty' |