diff options
Diffstat (limited to 'libraries/template-haskell/Language')
8 files changed, 1167 insertions, 849 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index fd5c06f2f1..213c70e58f 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -73,7 +73,7 @@ module Language.Haskell.TH( 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/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' diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs new file mode 100644 index 0000000000..989e8168ba --- /dev/null +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -0,0 +1,927 @@ +-- | +-- 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 ) +import Prelude + +---------------------------------------------------------- +-- * 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 +type DerivStrategyQ = Q DerivStrategy + +-- 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) } + +recS :: [StmtQ] -> StmtQ +recS ss = do { ss1 <- sequence ss; return (RecS ss1) } + +------------------------------------------------------------------------------- +-- * 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) } + +mdoE :: [StmtQ] -> ExpQ +mdoE ss = do { ss1 <- sequence ss; return (MDoE 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) + +implicitParamVarE :: String -> ExpQ +implicitParamVarE n = return (ImplicitParamVarE n) + +-- ** '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 DerivStrategyQ -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD mdsq ctxtq tyq = + do + mds <- sequenceA mdsq + ctxt <- ctxtq + ty <- tyq + return $ StandaloneDerivD mds 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' + +-- | Implicit parameter binding declaration. Can only be used in let +-- and where clauses which consist entirely of implicit bindings. +implicitParamBindD :: String -> ExpQ -> DecQ +implicitParamBindD n e = + do + e' <- e + return $ ImplicitParamBindD n e' + +tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ +tySynEqn lhs rhs = + do + lhs1 <- sequence lhs + rhs1 <- rhs + return (TySynEqn lhs1 rhs1) + +cxt :: [PredQ] -> CxtQ +cxt = sequence + +derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ +derivClause mds p = do mds' <- sequenceA mds + p' <- cxt p + return $ DerivClause mds' p' + +stockStrategy :: DerivStrategyQ +stockStrategy = pure StockStrategy + +anyclassStrategy :: DerivStrategyQ +anyclassStrategy = pure AnyclassStrategy + +newtypeStrategy :: DerivStrategyQ +newtypeStrategy = pure NewtypeStrategy + +viaStrategy :: TypeQ -> DerivStrategyQ +viaStrategy = fmap ViaStrategy + +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 + +implicitParamT :: String -> TypeQ -> TypeQ +implicitParamT n t + = do + t' <- t + return $ ImplicitParamT n t' + +{-# 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/libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs index ac241515b8..b11139c2cb 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Map.hs @@ -16,6 +16,8 @@ module Language.Haskell.TH.Lib.Map , Language.Haskell.TH.Lib.Map.lookup ) where +import Prelude + data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a) | Tip diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 696c4454c7..8158af6ffd 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -14,15 +14,17 @@ import Data.Char ( toLower, chr) import GHC.Show ( showMultiLineString ) import GHC.Lexeme( startsVarSym ) import Data.Ratio ( numerator, denominator ) +import Prelude hiding ((<>)) nestDepth :: Int nestDepth = 4 type Precedence = Int -appPrec, unopPrec, opPrec, noPrec :: Precedence -appPrec = 3 -- Argument of a function application -opPrec = 2 -- Argument of an infix operator -unopPrec = 1 -- Argument of an unresolved infix operator +appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence +appPrec = 4 -- Argument of a function application +opPrec = 3 -- Argument of an infix operator +unopPrec = 2 -- Argument of an unresolved infix operator +sigPrec = 1 -- Argument of an explicit type signature noPrec = 0 -- Others parensIf :: Bool -> Doc -> Doc @@ -177,6 +179,11 @@ pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_ pprStms [] = empty pprStms [s] = ppr s pprStms ss = braces (semiSep ss) +pprExp i (MDoE ss_) = parensIf (i > noPrec) $ text "mdo" <+> pprStms ss_ + where + pprStms [] = empty + pprStms [s] = ppr s + pprStms ss = braces (semiSep ss) pprExp _ (CompE []) = text "<<Empty CompExp>>" -- This will probably break with fixity declarations - would need a ';' @@ -193,13 +200,15 @@ pprExp _ (CompE ss) = ss' = init ss pprExp _ (ArithSeqE d) = ppr d pprExp _ (ListE es) = brackets (commaSep es) -pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t +pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e + <+> dcolon <+> ppr t pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) pprExp i (StaticE e) = parensIf (i >= appPrec) $ text "static"<+> pprExp appPrec e pprExp _ (UnboundVarE v) = pprName' Applied v pprExp _ (LabelE s) = text "#" <> text s +pprExp _ (ImplicitParamVarE n) = text ('?' : n) pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) @@ -215,12 +224,18 @@ instance Ppr Stmt where ppr (NoBindS e) = ppr e ppr (ParS sss) = sep $ punctuate bar $ map commaSep sss + ppr (RecS ss) = text "rec" <+> (braces (semiSep ss)) ------------------------------ instance Ppr Match where - ppr (Match p rhs ds) = ppr p <+> pprBody False rhs + ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs $$ where_clause ds +pprMatchPat :: Pat -> Doc +-- Everything except pattern signatures bind more tightly than (->) +pprMatchPat p@(SigP {}) = parens (ppr p) +pprMatchPat p = ppr p + ------------------------------ pprGuarded :: Doc -> (Guard, Exp) -> Doc pprGuarded eqDoc (guard, expr) = case guard of @@ -378,13 +393,16 @@ ppr_dec _ (PatSynD name args dir pat) | otherwise = ppr pat ppr_dec _ (PatSynSigD name ty) = pprPatSynSig name ty +ppr_dec _ (ImplicitParamBindD n e) + = hsep [text ('?' : n), text "=", ppr e] ppr_deriv_strategy :: DerivStrategy -> Doc -ppr_deriv_strategy ds = text $ +ppr_deriv_strategy ds = case ds of - StockStrategy -> "stock" - AnyclassStrategy -> "anyclass" - NewtypeStrategy -> "newtype" + StockStrategy -> text "stock" + AnyclassStrategy -> text "anyclass" + NewtypeStrategy -> text "newtype" + ViaStrategy ty -> text "via" <+> pprParendType ty ppr_overlap :: Overlap -> Doc ppr_overlap o = text $ @@ -444,8 +462,16 @@ ppr_newtype maybeInst ctxt t argsDoc ksig c decs ppr_deriv_clause :: DerivClause -> Doc ppr_deriv_clause (DerivClause ds ctxt) - = text "deriving" <+> maybe empty ppr_deriv_strategy ds + = text "deriving" <+> pp_strat_before <+> ppr_cxt_preds ctxt + <+> pp_strat_after + where + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case ds of + Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via) + _ -> (maybe empty ppr_deriv_strategy ds, empty) ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs @@ -465,11 +491,6 @@ instance Ppr FunDep where 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 @@ -689,11 +710,11 @@ pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar 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) @@ -704,6 +725,7 @@ pprParendType (ParensT t) = ppr t pprParendType tuple | (TupleT n, args) <- split tuple , length args == n = parens (commaSep args) +pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t pprParendType other = parens (ppr other) pprUInfixT :: Type -> Doc @@ -772,6 +794,7 @@ pprCxt ts = ppr_cxt_preds ts <+> text "=>" ppr_cxt_preds :: Cxt -> Doc ppr_cxt_preds [] = empty +ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t) ppr_cxt_preds [t] = ppr t ppr_cxt_preds ts = parens (commaSep ts) diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs index 32980ab6cc..7e05d05d83 100644 --- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs @@ -41,6 +41,7 @@ import qualified Text.PrettyPrint as HPJ 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/libraries/template-haskell/Language/Haskell/TH/Quote.hs b/libraries/template-haskell/Language/Haskell/TH/Quote.hs index 91e37399e6..4ff5a2041b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Quote.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Quote.hs @@ -21,6 +21,7 @@ module Language.Haskell.TH.Quote( ) where import Language.Haskell.TH.Syntax +import Prelude -- | The 'QuasiQuoter' type, a value @q@ of this type can be used -- in the syntax @[q| ... string to parse ...|]@. In fact, for diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 14aeaeb380..294e443afb 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/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.Data hiding (Fixity(..)) 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 @@ -44,10 +41,9 @@ import GHC.Lexeme ( startsVarSym, startsVarId ) import GHC.ForeignSrcLang.Type import Language.Haskell.TH.LanguageExtensions import Numeric.Natural +import Prelude -#if HAS_MONADFAIL import qualified Control.Monad.Fail as Fail -#endif ----------------------------------------------------- -- @@ -55,11 +51,7 @@ import qualified Control.Monad.Fail as Fail -- ----------------------------------------------------- -#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,16 +80,21 @@ class Monad m => Quasi m where qLocation :: m Loc qRunIO :: IO a -> m a + qRunIO = liftIO -- ^ Input/output (dangerous) qAddDependentFile :: FilePath -> m () + qAddTempFile :: String -> m FilePath + qAddTopDecls :: [Dec] -> m () - qAddForeignFile :: ForeignSrcLang -> String -> m () + qAddForeignFilePath :: ForeignSrcLang -> String -> m () qAddModFinalizer :: Q () -> m () + qAddCorePlugin :: String -> m () + qGetQ :: Typeable a => m (Maybe a) qPutQ :: Typeable a => a -> m () @@ -134,16 +131,16 @@ instance Quasi IO where qLocation = badIO "currentLocation" qRecover _ _ = badIO "recover" -- Maybe we could fix this? qAddDependentFile _ = badIO "addDependentFile" + qAddTempFile _ = badIO "addTempFile" qAddTopDecls _ = badIO "addTopDecls" - qAddForeignFile _ _ = badIO "addForeignFile" + qAddForeignFilePath _ _ = badIO "addForeignFilePath" 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 +176,10 @@ runQ (Q m) = m 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) @@ -456,11 +449,23 @@ runIO m = Q (qRunIO m) addDependentFile :: FilePath -> Q () addDependentFile fp = Q (qAddDependentFile fp) +-- | Obtain a temporary file path with the given suffix. The compiler will +-- delete this file after compilation. +addTempFile :: String -> Q FilePath +addTempFile suffix = Q (qAddTempFile suffix) + -- | Add additional top-level declarations. The added declarations will be type -- checked along with the current declaration group. addTopDecls :: [Dec] -> Q () addTopDecls ds = Q (qAddTopDecls ds) +-- | +addForeignFile :: ForeignSrcLang -> String -> Q () +addForeignFile = addForeignSource +{-# DEPRECATED addForeignFile + "Use 'Language.Haskell.TH.Syntax.addForeignSource' instead" + #-} -- deprecated in 8.6 + -- | Emit a foreign file which will be compiled and linked to the object for -- the current module. Currently only languages that can be compiled with -- the C compiler are supported, and the flags passed as part of -optc will @@ -469,17 +474,35 @@ addTopDecls ds = Q (qAddTopDecls ds) -- Note that for non-C languages (for example C++) @extern "C"@ directives -- must be used to get symbols that we can access from Haskell. -- --- To get better errors, it is reccomended to use #line pragmas when +-- To get better errors, it is recommended to use #line pragmas when -- emitting C files, e.g. -- -- > {-# LANGUAGE CPP #-} -- > ... --- > addForeignFile LangC $ unlines +-- > addForeignSource LangC $ unlines -- > [ "#line " ++ show (__LINE__ + 1) ++ " " ++ show __FILE__ -- > , ... -- > ] -addForeignFile :: ForeignSrcLang -> String -> Q () -addForeignFile lang str = Q (qAddForeignFile lang str) +addForeignSource :: ForeignSrcLang -> String -> Q () +addForeignSource lang src = do + let suffix = case lang of + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" + LangObjcxx -> "mm" + RawObject -> "a" + path <- addTempFile suffix + runIO $ writeFile path src + addForeignFilePath lang path + +-- | Same as 'addForeignSource', but expects to receive a path pointing to the +-- foreign file instead of a 'String' of its contents. Consider using this in +-- conjunction with 'addTempFile'. +-- +-- This is a good alternative to 'addForeignSource' when you are trying to +-- directly link in an object file. +addForeignFilePath :: ForeignSrcLang -> FilePath -> Q () +addForeignFilePath lang fp = Q (qAddForeignFilePath lang fp) -- | Add a finalizer that will run in the Q monad after the current module has -- been type checked. This only makes sense when run within a top-level splice. @@ -490,6 +513,16 @@ addForeignFile lang str = Q (qAddForeignFile lang str) 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 +541,9 @@ isExtEnabled ext = Q (qIsExtEnabled ext) extsEnabled :: Q [Extension] extsEnabled = Q qExtsEnabled +instance MonadIO Q where + liftIO = runIO + instance Quasi Q where qNewName = newName qReport = report @@ -521,11 +557,12 @@ instance Quasi Q where qReifyConStrictness = reifyConStrictness qLookupName = lookupName qLocation = location - qRunIO = runIO qAddDependentFile = addDependentFile + qAddTempFile = addTempFile qAddTopDecls = addTopDecls - qAddForeignFile = addForeignFile + qAddForeignFilePath = addForeignFilePath qAddModFinalizer = addModFinalizer + qAddCorePlugin = addCorePlugin qGetQ = getQ qPutQ = putQ qIsExtEnabled = isExtEnabled @@ -563,6 +600,9 @@ sequenceQ = sequence -- 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: -- @@ -692,8 +732,8 @@ trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" nothingName, justName :: Name -nothingName = mkNameG DataName "base" "GHC.Base" "Nothing" -justName = mkNameG DataName "base" "GHC.Base" "Just" +nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing" +justName = mkNameG DataName "base" "GHC.Maybe" "Just" leftName, rightName :: Name leftName = mkNameG DataName "base" "Data.Either" "Left" @@ -1561,9 +1601,10 @@ data Exp | UnboxedSumE Exp SumAlt SumArity -- ^ @{ (\#|e|\#) }@ | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@ | MultiIfE [(Guard, Exp)] -- ^ @{ if | g1 -> e1 | g2 -> e2 }@ - | LetE [Dec] Exp -- ^ @{ let x=e1; y=e2 in e3 }@ + | LetE [Dec] Exp -- ^ @{ let { x=e1; y=e2 } in e3 }@ | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@ | DoE [Stmt] -- ^ @{ do { p <- e1; e2 } }@ + | MDoE [Stmt] -- ^ @{ mdo { x <- e1 y; y <- e2 x; } }@ | CompE [Stmt] -- ^ @{ [ (x,y) | x <- xs, y <- ys ] }@ -- -- The result expression of the comprehension is @@ -1581,8 +1622,14 @@ data Exp | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ | StaticE Exp -- ^ @{ static e }@ - | UnboundVarE Name -- ^ @{ _x }@ (hole) + | UnboundVarE Name -- ^ @{ _x }@ + -- + -- This is used for holes or unresolved + -- identifiers in AST quotes. Note that + -- it could either have a variable name + -- or constructor name. | LabelE String -- ^ @{ #x }@ ( Overloaded label ) + | ImplicitParamVarE String -- ^ @{ ?x }@ ( Implicit parameter ) deriving( Show, Eq, Ord, Data, Generic ) type FieldExp = (Name,Exp) @@ -1602,10 +1649,11 @@ data Guard deriving( Show, Eq, Ord, Data, Generic ) data Stmt - = BindS Pat Exp - | LetS [ Dec ] - | NoBindS Exp - | ParS [[Stmt]] + = BindS Pat Exp -- ^ @p <- e@ + | LetS [ Dec ] -- ^ @{ let { x=e1; y=e2 } }@ + | NoBindS Exp -- ^ @e@ + | ParS [[Stmt]] -- ^ @x <- e1 | s2, s3 | s4@ (in 'CompE') + | RecS [Stmt] -- ^ @rec { s1; s2 }@ deriving( Show, Eq, Ord, Data, Generic ) data Range = FromR Exp | FromThenR Exp Exp @@ -1684,6 +1732,12 @@ data Dec -- pattern synonyms are supported. See 'PatSynArgs' for details | PatSynSigD Name PatSynType -- ^ A pattern synonym's type signature. + + | ImplicitParamBindD String Exp + -- ^ @{ ?x = expr }@ + -- + -- Implicit parameter binding declaration. Can only be used in let + -- and where clauses which consist entirely of implicit bindings. deriving( Show, Eq, Ord, Data, Generic ) -- | Varieties of allowed instance overlap. @@ -1704,6 +1758,7 @@ data DerivClause = DerivClause (Maybe DerivStrategy) Cxt data DerivStrategy = StockStrategy -- ^ A \"standard\" derived instance | AnyclassStrategy -- ^ @-XDeriveAnyClass@ | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy Type -- ^ @-XDerivingVia@ deriving( Show, Eq, Ord, Data, Generic ) -- | A Pattern synonym's type. Note that a pattern synonym's *fully* @@ -1771,9 +1826,6 @@ data TySynEqn = TySynEqn [Type] Type 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 ) @@ -1845,6 +1897,35 @@ data DecidedStrictness = DecidedLazy | 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@ @@ -1917,7 +1998,7 @@ data PatSynArgs | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ deriving( Show, Eq, Ord, Data, Generic ) -data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<type\>@ +data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@ | AppT Type Type -- ^ @T a b@ | SigT Type Kind -- ^ @t :: k@ | VarT Name -- ^ @a@ @@ -1943,6 +2024,7 @@ data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> -> \<t | ConstraintT -- ^ @Constraint@ | LitT TyLit -- ^ @0,1,2, etc.@ | WildCardT -- ^ @_@ + | ImplicitParamT String Type -- ^ @?x :: t@ deriving( Show, Eq, Ord, Data, Generic ) data TyVarBndr = PlainTV Name -- ^ @a@ |