diff options
Diffstat (limited to 'libraries/template-haskell/Language/Haskell')
4 files changed, 481 insertions, 457 deletions
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 5b03b2649c..b818535576 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -8,6 +8,7 @@ module Language.Haskell.TH( -- * The monad and its operations Q, runQ, + Quote(..), -- ** Administration: errors, locations and IO reportError, -- :: String -> Q () reportWarning, -- :: String -> Q () @@ -53,7 +54,6 @@ module Language.Haskell.TH( Name, NameSpace, -- Abstract -- ** Constructing names mkName, -- :: String -> Name - newName, -- :: String -> Q Name -- ** Deconstructing names nameBase, -- :: Name -> String nameModule, -- :: Name -> Maybe String @@ -84,7 +84,7 @@ module Language.Haskell.TH( Pat(..), FieldExp, FieldPat, -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), - FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, + FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType, -- * Library functions module Language.Haskell.TH.Lib, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 7bb4eb50dd..77c85d907c 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -159,7 +159,7 @@ import Language.Haskell.TH.Lib.Internal hiding ) import Language.Haskell.TH.Syntax -import Control.Monad (liftM2) +import Control.Applicative ( liftA2 ) import Foreign.ForeignPtr import Data.Word import Prelude @@ -172,97 +172,97 @@ import Prelude ------------------------------------------------------------------------------- -- * Dec -tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ +tySynD :: Quote m => Name -> [TyVarBndr] -> m Type -> m Dec tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] - -> DecQ +dataD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> [m Con] -> [m DerivClause] + -> m Dec dataD ctxt tc tvs ksig cons derivs = do ctxt1 <- ctxt - cons1 <- sequence cons - derivs1 <- sequence derivs + cons1 <- sequenceA cons + derivs1 <- sequenceA derivs return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> [DerivClauseQ] - -> DecQ +newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> m Con -> [m DerivClause] + -> m Dec newtypeD ctxt tc tvs ksig con derivs = do ctxt1 <- ctxt con1 <- con - derivs1 <- sequence derivs + derivs1 <- sequenceA derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) -classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ +classD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do - decs1 <- sequence decs + decs1 <- sequenceA decs ctxt1 <- ctxt return $ ClassD ctxt1 cls tvs fds decs1 -pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ +pragRuleD :: Quote m => String -> [m RuleBndr] -> m Exp -> m Exp -> Phases -> m Dec pragRuleD n bndrs lhs rhs phases = do - bndrs1 <- sequence bndrs + bndrs1 <- sequenceA bndrs lhs1 <- lhs rhs1 <- rhs return $ PragmaD $ RuleP n Nothing bndrs1 lhs1 rhs1 phases -dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] - -> DecQ +dataInstD :: Quote m => m Cxt -> Name -> [m Type] -> Maybe Kind -> [m Con] -> [m DerivClause] + -> m Dec dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt ty1 <- foldl appT (conT tc) tys - cons1 <- sequence cons - derivs1 <- sequence derivs + cons1 <- sequenceA cons + derivs1 <- sequenceA derivs return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1) -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ] - -> DecQ +newtypeInstD :: Quote m => m Cxt -> Name -> [m Type] -> Maybe Kind -> m Con -> [m DerivClause] + -> m Dec newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt ty1 <- foldl appT (conT tc) tys con1 <- con - derivs1 <- sequence derivs + derivs1 <- sequenceA derivs return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) -dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ +dataFamilyD :: Quote m => Name -> [TyVarBndr] -> Maybe Kind -> m Dec dataFamilyD tc tvs kind - = return $ DataFamilyD tc tvs kind + = pure $ DataFamilyD tc tvs kind -openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig - -> Maybe InjectivityAnn -> DecQ +openTypeFamilyD :: Quote m => Name -> [TyVarBndr] -> FamilyResultSig + -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj - = return $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) + = pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) -closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig - -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ +closedTypeFamilyD :: Quote m => Name -> [TyVarBndr] -> FamilyResultSig + -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns = - do eqns1 <- sequence eqns + do eqns1 <- sequenceA eqns return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) -tySynEqn :: (Maybe [TyVarBndr]) -> TypeQ -> TypeQ -> TySynEqnQ +tySynEqn :: Quote m => (Maybe [TyVarBndr]) -> m Type -> m Type -> m TySynEqn tySynEqn tvs lhs rhs = do lhs1 <- lhs rhs1 <- rhs return (TySynEqn tvs lhs1 rhs1) -forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ -forallC ns ctxt con = liftM2 (ForallC ns) ctxt con +forallC :: Quote m => [TyVarBndr] -> m Cxt -> m Con -> m Con +forallC ns ctxt con = liftA2 (ForallC ns) ctxt con ------------------------------------------------------------------------------- -- * Type -forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ +forallT :: Quote m => [TyVarBndr] -> m Cxt -> m Type -> m Type forallT tvars ctxt ty = do ctxt1 <- ctxt ty1 <- ty return $ ForallT tvars ctxt1 ty1 -sigT :: TypeQ -> Kind -> TypeQ +sigT :: Quote m => m Type -> Kind -> m Type sigT t k = do t' <- t @@ -298,12 +298,12 @@ tyVarSig = TyVarSig ------------------------------------------------------------------------------- -- * Top Level Declarations -derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ +derivClause :: Quote m => Maybe DerivStrategy -> [m Pred] -> m DerivClause derivClause mds p = do p' <- cxt p return $ DerivClause mds p' -standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD :: Quote m => Maybe DerivStrategy -> m Cxt -> m Type -> m Dec standaloneDerivWithStrategyD mds ctxt ty = do ctxt' <- ctxt ty' <- ty @@ -326,8 +326,8 @@ mkBytes = Bytes ------------------------------------------------------------------------------- -- * Tuple expressions -tupE :: [ExpQ] -> ExpQ -tupE es = do { es1 <- sequence es; return (TupE $ map Just es1)} +tupE :: Quote m => [m Exp] -> m Exp +tupE es = do { es1 <- sequenceA es; return (TupE $ map Just es1)} -unboxedTupE :: [ExpQ] -> ExpQ -unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE $ map Just es1)} +unboxedTupE :: Quote m => [m Exp] -> m Exp +unboxedTupE es = do { es1 <- sequenceA es; return (UnboxedTupE $ map Just es1)} diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 4d3887baf2..3a55f7a96a 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -16,7 +16,7 @@ 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 Control.Applicative(liftA, liftA2) import Data.Word( Word8 ) import Prelude @@ -31,6 +31,7 @@ type ExpQ = Q Exp type TExpQ a = Q (TExp a) type DecQ = Q Dec type DecsQ = Q [Dec] +type Decs = [Dec] -- Defined as it is more convenient to wire-in type ConQ = Q Con type TypeQ = Q Type type KindQ = Q Kind @@ -91,675 +92,675 @@ bytesPrimL = BytesPrimL rationalL :: Rational -> Lit rationalL = RationalL -litP :: Lit -> PatQ -litP l = return (LitP l) +litP :: Quote m => Lit -> m Pat +litP l = pure (LitP l) -varP :: Name -> PatQ -varP v = return (VarP v) +varP :: Quote m => Name -> m Pat +varP v = pure (VarP v) -tupP :: [PatQ] -> PatQ -tupP ps = do { ps1 <- sequence ps; return (TupP ps1)} +tupP :: Quote m => [m Pat] -> m Pat +tupP ps = do { ps1 <- sequenceA ps; pure (TupP ps1)} -unboxedTupP :: [PatQ] -> PatQ -unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)} +unboxedTupP :: Quote m => [m Pat] -> m Pat +unboxedTupP ps = do { ps1 <- sequenceA ps; pure (UnboxedTupP ps1)} -unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ -unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) } +unboxedSumP :: Quote m => m Pat -> SumAlt -> SumArity -> m Pat +unboxedSumP p alt arity = do { p1 <- p; pure (UnboxedSumP p1 alt arity) } -conP :: Name -> [PatQ] -> PatQ -conP n ps = do ps' <- sequence ps - return (ConP n ps') -infixP :: PatQ -> Name -> PatQ -> PatQ +conP :: Quote m => Name -> [m Pat] -> m Pat +conP n ps = do ps' <- sequenceA ps + pure (ConP n ps') +infixP :: Quote m => m Pat -> Name -> m Pat -> m Pat infixP p1 n p2 = do p1' <- p1 p2' <- p2 - return (InfixP p1' n p2') -uInfixP :: PatQ -> Name -> PatQ -> PatQ + pure (InfixP p1' n p2') +uInfixP :: Quote m => m Pat -> Name -> m Pat -> m Pat uInfixP p1 n p2 = do p1' <- p1 p2' <- p2 - return (UInfixP p1' n p2') -parensP :: PatQ -> PatQ + pure (UInfixP p1' n p2') +parensP :: Quote m => m Pat -> m Pat parensP p = do p' <- p - return (ParensP p') + pure (ParensP p') -tildeP :: PatQ -> PatQ +tildeP :: Quote m => m Pat -> m Pat tildeP p = do p' <- p - return (TildeP p') -bangP :: PatQ -> PatQ + pure (TildeP p') +bangP :: Quote m => m Pat -> m Pat bangP p = do p' <- p - return (BangP p') -asP :: Name -> PatQ -> PatQ + pure (BangP p') +asP :: Quote m => Name -> m Pat -> m Pat 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 + pure (AsP n p') +wildP :: Quote m => m Pat +wildP = pure WildP +recP :: Quote m => Name -> [m FieldPat] -> m Pat +recP n fps = do fps' <- sequenceA fps + pure (RecP n fps') +listP :: Quote m => [m Pat] -> m Pat +listP ps = do ps' <- sequenceA ps + pure (ListP ps') +sigP :: Quote m => m Pat -> m Type -> m Pat sigP p t = do p' <- p t' <- t - return (SigP p' t') -viewP :: ExpQ -> PatQ -> PatQ + pure (SigP p' t') +viewP :: Quote m => m Exp -> m Pat -> m Pat viewP e p = do e' <- e p' <- p - return (ViewP e' p') + pure (ViewP e' p') -fieldPat :: Name -> PatQ -> FieldPatQ +fieldPat :: Quote m => Name -> m Pat -> m FieldPat fieldPat n p = do p' <- p - return (n, p') + pure (n, p') ------------------------------------------------------------------------------- -- * Stmt -bindS :: PatQ -> ExpQ -> StmtQ -bindS p e = liftM2 BindS p e +bindS :: Quote m => m Pat -> m Exp -> m Stmt +bindS p e = liftA2 BindS p e -letS :: [DecQ] -> StmtQ -letS ds = do { ds1 <- sequence ds; return (LetS ds1) } +letS :: Quote m => [m Dec] -> m Stmt +letS ds = do { ds1 <- sequenceA ds; pure (LetS ds1) } -noBindS :: ExpQ -> StmtQ -noBindS e = do { e1 <- e; return (NoBindS e1) } +noBindS :: Quote m => m Exp -> m Stmt +noBindS e = do { e1 <- e; pure (NoBindS e1) } -parS :: [[StmtQ]] -> StmtQ -parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) } +parS :: Quote m => [[m Stmt]] -> m Stmt +parS sss = do { sss1 <- traverse sequenceA sss; pure (ParS sss1) } -recS :: [StmtQ] -> StmtQ -recS ss = do { ss1 <- sequence ss; return (RecS ss1) } +recS :: Quote m => [m Stmt] -> m Stmt +recS ss = do { ss1 <- sequenceA ss; pure (RecS ss1) } ------------------------------------------------------------------------------- -- * Range -fromR :: ExpQ -> RangeQ -fromR x = do { a <- x; return (FromR a) } +fromR :: Quote m => m Exp -> m Range +fromR x = do { a <- x; pure (FromR a) } -fromThenR :: ExpQ -> ExpQ -> RangeQ -fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) } +fromThenR :: Quote m => m Exp -> m Exp -> m Range +fromThenR x y = do { a <- x; b <- y; pure (FromThenR a b) } -fromToR :: ExpQ -> ExpQ -> RangeQ -fromToR x y = do { a <- x; b <- y; return (FromToR a b) } +fromToR :: Quote m => m Exp -> m Exp -> m Range +fromToR x y = do { a <- x; b <- y; pure (FromToR a b) } -fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ +fromThenToR :: Quote m => m Exp -> m Exp -> m Exp -> m Range fromThenToR x y z = do { a <- x; b <- y; c <- z; - return (FromThenToR a b c) } + pure (FromThenToR a b c) } ------------------------------------------------------------------------------- -- * Body -normalB :: ExpQ -> BodyQ -normalB e = do { e1 <- e; return (NormalB e1) } +normalB :: Quote m => m Exp -> m Body +normalB e = do { e1 <- e; pure (NormalB e1) } -guardedB :: [Q (Guard,Exp)] -> BodyQ -guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') } +guardedB :: Quote m => [m (Guard,Exp)] -> m Body +guardedB ges = do { ges' <- sequenceA ges; pure (GuardedB ges') } ------------------------------------------------------------------------------- -- * Guard -normalG :: ExpQ -> GuardQ -normalG e = do { e1 <- e; return (NormalG e1) } +normalG :: Quote m => m Exp -> m Guard +normalG e = do { e1 <- e; pure (NormalG e1) } -normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp) -normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) } +normalGE :: Quote m => m Exp -> m Exp -> m (Guard, Exp) +normalGE g e = do { g1 <- g; e1 <- e; pure (NormalG g1, e1) } -patG :: [StmtQ] -> GuardQ -patG ss = do { ss' <- sequence ss; return (PatG ss') } +patG :: Quote m => [m Stmt] -> m Guard +patG ss = do { ss' <- sequenceA ss; pure (PatG ss') } -patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp) -patGE ss e = do { ss' <- sequence ss; +patGE :: Quote m => [m Stmt] -> m Exp -> m (Guard, Exp) +patGE ss e = do { ss' <- sequenceA ss; e' <- e; - return (PatG ss', e') } + pure (PatG ss', e') } ------------------------------------------------------------------------------- -- * Match and Clause -- | Use with 'caseE' -match :: PatQ -> BodyQ -> [DecQ] -> MatchQ +match :: Quote m => m Pat -> m Body -> [m Dec] -> m Match match p rhs ds = do { p' <- p; r' <- rhs; - ds' <- sequence ds; - return (Match p' r' ds') } + ds' <- sequenceA ds; + pure (Match p' r' ds') } -- | Use with 'funD' -clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ -clause ps r ds = do { ps' <- sequence ps; +clause :: Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause +clause ps r ds = do { ps' <- sequenceA ps; r' <- r; - ds' <- sequence ds; - return (Clause ps' r' ds') } + ds' <- sequenceA ds; + pure (Clause ps' r' ds') } --------------------------------------------------------------------------- -- * Exp -- | Dynamically binding a variable (unhygenic) -dyn :: String -> ExpQ -dyn s = return (VarE (mkName s)) +dyn :: Quote m => String -> m Exp +dyn s = pure (VarE (mkName s)) -varE :: Name -> ExpQ -varE s = return (VarE s) +varE :: Quote m => Name -> m Exp +varE s = pure (VarE s) -conE :: Name -> ExpQ -conE s = return (ConE s) +conE :: Quote m => Name -> m Exp +conE s = pure (ConE s) -litE :: Lit -> ExpQ -litE c = return (LitE c) +litE :: Quote m => Lit -> m Exp +litE c = pure (LitE c) -appE :: ExpQ -> ExpQ -> ExpQ -appE x y = do { a <- x; b <- y; return (AppE a b)} +appE :: Quote m => m Exp -> m Exp -> m Exp +appE x y = do { a <- x; b <- y; pure (AppE a b)} -appTypeE :: ExpQ -> TypeQ -> ExpQ -appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) } +appTypeE :: Quote m => m Exp -> m Type -> m Exp +appTypeE x t = do { a <- x; s <- t; pure (AppTypeE a s) } -parensE :: ExpQ -> ExpQ -parensE x = do { x' <- x; return (ParensE x') } +parensE :: Quote m => m Exp -> m Exp +parensE x = do { x' <- x; pure (ParensE x') } -uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ +uInfixE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp uInfixE x s y = do { x' <- x; s' <- s; y' <- y; - return (UInfixE x' s' y') } + pure (UInfixE x' s' y') } -infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ +infixE :: Quote m => Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y; - return (InfixE (Just a) s' (Just b))} + pure (InfixE (Just a) s' (Just b))} infixE Nothing s (Just y) = do { s' <- s; b <- y; - return (InfixE Nothing s' (Just b))} + pure (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) } + pure (InfixE (Just a) s' Nothing)} +infixE Nothing s Nothing = do { s' <- s; pure (InfixE Nothing s' Nothing) } -infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ +infixApp :: Quote m => m Exp -> m Exp -> m Exp -> m Exp infixApp x y z = infixE (Just x) y (Just z) -sectionL :: ExpQ -> ExpQ -> ExpQ +sectionL :: Quote m => m Exp -> m Exp -> m Exp sectionL x y = infixE (Just x) y Nothing -sectionR :: ExpQ -> ExpQ -> ExpQ +sectionR :: Quote m => m Exp -> m Exp -> m Exp sectionR x y = infixE Nothing x (Just y) -lamE :: [PatQ] -> ExpQ -> ExpQ -lamE ps e = do ps' <- sequence ps +lamE :: Quote m => [m Pat] -> m Exp -> m Exp +lamE ps e = do ps' <- sequenceA ps e' <- e - return (LamE ps' e') + pure (LamE ps' e') -- | Single-arg lambda -lam1E :: PatQ -> ExpQ -> ExpQ +lam1E :: Quote m => m Pat -> m Exp -> m Exp lam1E p e = lamE [p] e -lamCaseE :: [MatchQ] -> ExpQ -lamCaseE ms = sequence ms >>= return . LamCaseE +lamCaseE :: Quote m => [m Match] -> m Exp +lamCaseE ms = LamCaseE <$> sequenceA ms -tupE :: [Maybe ExpQ] -> ExpQ -tupE es = do { es1 <- traverse sequence es; return (TupE es1)} +tupE :: Quote m => [Maybe (m Exp)] -> m Exp +tupE es = do { es1 <- traverse sequenceA es; pure (TupE es1)} -unboxedTupE :: [Maybe ExpQ] -> ExpQ -unboxedTupE es = do { es1 <- traverse sequence es; return (UnboxedTupE es1)} +unboxedTupE :: Quote m => [Maybe (m Exp)] -> m Exp +unboxedTupE es = do { es1 <- traverse sequenceA es; pure (UnboxedTupE es1)} -unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ -unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) } +unboxedSumE :: Quote m => m Exp -> SumAlt -> SumArity -> m Exp +unboxedSumE e alt arity = do { e1 <- e; pure (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)} +condE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp +condE x y z = do { a <- x; b <- y; c <- z; pure (CondE a b c)} -multiIfE :: [Q (Guard, Exp)] -> ExpQ -multiIfE alts = sequence alts >>= return . MultiIfE +multiIfE :: Quote m => [m (Guard, Exp)] -> m Exp +multiIfE alts = MultiIfE <$> sequenceA alts -letE :: [DecQ] -> ExpQ -> ExpQ -letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) } +letE :: Quote m => [m Dec] -> m Exp -> m Exp +letE ds e = do { ds2 <- sequenceA ds; e2 <- e; pure (LetE ds2 e2) } -caseE :: ExpQ -> [MatchQ] -> ExpQ -caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) } +caseE :: Quote m => m Exp -> [m Match] -> m Exp +caseE e ms = do { e1 <- e; ms1 <- sequenceA ms; pure (CaseE e1 ms1) } -doE :: [StmtQ] -> ExpQ -doE ss = do { ss1 <- sequence ss; return (DoE ss1) } +doE :: Quote m => [m Stmt] -> m Exp +doE ss = do { ss1 <- sequenceA ss; pure (DoE ss1) } -mdoE :: [StmtQ] -> ExpQ -mdoE ss = do { ss1 <- sequence ss; return (MDoE ss1) } +mdoE :: Quote m => [m Stmt] -> m Exp +mdoE ss = do { ss1 <- sequenceA ss; pure (MDoE ss1) } -compE :: [StmtQ] -> ExpQ -compE ss = do { ss1 <- sequence ss; return (CompE ss1) } +compE :: Quote m => [m Stmt] -> m Exp +compE ss = do { ss1 <- sequenceA ss; pure (CompE ss1) } -arithSeqE :: RangeQ -> ExpQ -arithSeqE r = do { r' <- r; return (ArithSeqE r') } +arithSeqE :: Quote m => m Range -> m Exp +arithSeqE r = do { r' <- r; pure (ArithSeqE r') } -listE :: [ExpQ] -> ExpQ -listE es = do { es1 <- sequence es; return (ListE es1) } +listE :: Quote m => [m Exp] -> m Exp +listE es = do { es1 <- sequenceA es; pure (ListE es1) } -sigE :: ExpQ -> TypeQ -> ExpQ -sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) } +sigE :: Quote m => m Exp -> m Type -> m Exp +sigE e t = do { e1 <- e; t1 <- t; pure (SigE e1 t1) } -recConE :: Name -> [Q (Name,Exp)] -> ExpQ -recConE c fs = do { flds <- sequence fs; return (RecConE c flds) } +recConE :: Quote m => Name -> [m (Name,Exp)] -> m Exp +recConE c fs = do { flds <- sequenceA fs; pure (RecConE c flds) } -recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ -recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) } +recUpdE :: Quote m => m Exp -> [m (Name,Exp)] -> m Exp +recUpdE e fs = do { e1 <- e; flds <- sequenceA fs; pure (RecUpdE e1 flds) } -stringE :: String -> ExpQ +stringE :: Quote m => String -> m Exp stringE = litE . stringL -fieldExp :: Name -> ExpQ -> Q (Name, Exp) -fieldExp s e = do { e' <- e; return (s,e') } +fieldExp :: Quote m => Name -> m Exp -> m (Name, Exp) +fieldExp s e = do { e' <- e; pure (s,e') } -- | @staticE x = [| static x |]@ -staticE :: ExpQ -> ExpQ +staticE :: Quote m => m Exp -> m Exp staticE = fmap StaticE -unboundVarE :: Name -> ExpQ -unboundVarE s = return (UnboundVarE s) +unboundVarE :: Quote m => Name -> m Exp +unboundVarE s = pure (UnboundVarE s) -labelE :: String -> ExpQ -labelE s = return (LabelE s) +labelE :: Quote m => String -> m Exp +labelE s = pure (LabelE s) -implicitParamVarE :: String -> ExpQ -implicitParamVarE n = return (ImplicitParamVarE n) +implicitParamVarE :: Quote m => String -> m Exp +implicitParamVarE n = pure (ImplicitParamVarE n) -- ** 'arithSeqE' Shortcuts -fromE :: ExpQ -> ExpQ -fromE x = do { a <- x; return (ArithSeqE (FromR a)) } +fromE :: Quote m => m Exp -> m Exp +fromE x = do { a <- x; pure (ArithSeqE (FromR a)) } -fromThenE :: ExpQ -> ExpQ -> ExpQ -fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) } +fromThenE :: Quote m => m Exp -> m Exp -> m Exp +fromThenE x y = do { a <- x; b <- y; pure (ArithSeqE (FromThenR a b)) } -fromToE :: ExpQ -> ExpQ -> ExpQ -fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) } +fromToE :: Quote m => m Exp -> m Exp -> m Exp +fromToE x y = do { a <- x; b <- y; pure (ArithSeqE (FromToR a b)) } -fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ +fromThenToE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp fromThenToE x y z = do { a <- x; b <- y; c <- z; - return (ArithSeqE (FromThenToR a b c)) } + pure (ArithSeqE (FromThenToR a b c)) } ------------------------------------------------------------------------------- -- * Dec -valD :: PatQ -> BodyQ -> [DecQ] -> DecQ +valD :: Quote m => m Pat -> m Body -> [m Dec] -> m Dec valD p b ds = do { p' <- p - ; ds' <- sequence ds + ; ds' <- sequenceA ds ; b' <- b - ; return (ValD p' b' ds') + ; pure (ValD p' b' ds') } -funD :: Name -> [ClauseQ] -> DecQ +funD :: Quote m => Name -> [m Clause] -> m Dec funD nm cs = - do { cs1 <- sequence cs - ; return (FunD nm cs1) + do { cs1 <- sequenceA cs + ; pure (FunD nm cs1) } -tySynD :: Name -> [TyVarBndrQ] -> TypeQ -> DecQ +tySynD :: Quote m => Name -> [m TyVarBndr] -> m Type -> m Dec tySynD tc tvs rhs = do { tvs1 <- sequenceA tvs ; rhs1 <- rhs - ; return (TySynD tc tvs1 rhs1) + ; pure (TySynD tc tvs1 rhs1) } -dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ] - -> [DerivClauseQ] -> DecQ +dataD :: Quote m => m Cxt -> Name -> [m TyVarBndr] -> Maybe (m Kind) -> [m Con] + -> [m DerivClause] -> m Dec 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) + cons1 <- sequenceA cons + derivs1 <- sequenceA derivs + pure (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1) -newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ - -> [DerivClauseQ] -> DecQ +newtypeD :: Quote m => m Cxt -> Name -> [m TyVarBndr] -> Maybe (m Kind) -> m Con + -> [m DerivClause] -> m Dec 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) + derivs1 <- sequenceA derivs + pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) -classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ +classD :: Quote m => m Cxt -> Name -> [m TyVarBndr] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do tvs1 <- sequenceA tvs decs1 <- sequenceA decs ctxt1 <- ctxt - return $ ClassD ctxt1 cls tvs1 fds decs1 + pure $ ClassD ctxt1 cls tvs1 fds decs1 -instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ +instanceD :: Quote m => m Cxt -> m Type -> [m Dec] -> m Dec instanceD = instanceWithOverlapD Nothing -instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ +instanceWithOverlapD :: Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec instanceWithOverlapD o ctxt ty decs = do ctxt1 <- ctxt - decs1 <- sequence decs + decs1 <- sequenceA decs ty1 <- ty - return $ InstanceD o ctxt1 ty1 decs1 + pure $ InstanceD o ctxt1 ty1 decs1 -sigD :: Name -> TypeQ -> DecQ -sigD fun ty = liftM (SigD fun) $ ty +sigD :: Quote m => Name -> m Type -> m Dec +sigD fun ty = liftA (SigD fun) $ ty -kiSigD :: Name -> KindQ -> DecQ -kiSigD fun ki = liftM (KiSigD fun) $ ki +kiSigD :: Quote m => Name -> m Kind -> m Dec +kiSigD fun ki = liftA (KiSigD fun) $ ki -forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ +forImpD :: Quote m => Callconv -> Safety -> String -> Name -> m Type -> m Dec forImpD cc s str n ty = do ty' <- ty - return $ ForeignD (ImportF cc s str n ty') + pure $ ForeignD (ImportF cc s str n ty') -infixLD :: Int -> Name -> DecQ -infixLD prec nm = return (InfixD (Fixity prec InfixL) nm) +infixLD :: Quote m => Int -> Name -> m Dec +infixLD prec nm = pure (InfixD (Fixity prec InfixL) nm) -infixRD :: Int -> Name -> DecQ -infixRD prec nm = return (InfixD (Fixity prec InfixR) nm) +infixRD :: Quote m => Int -> Name -> m Dec +infixRD prec nm = pure (InfixD (Fixity prec InfixR) nm) -infixND :: Int -> Name -> DecQ -infixND prec nm = return (InfixD (Fixity prec InfixN) nm) +infixND :: Quote m => Int -> Name -> m Dec +infixND prec nm = pure (InfixD (Fixity prec InfixN) nm) -pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ +pragInlD :: Quote m => Name -> Inline -> RuleMatch -> Phases -> m Dec pragInlD name inline rm phases - = return $ PragmaD $ InlineP name inline rm phases + = pure $ PragmaD $ InlineP name inline rm phases -pragSpecD :: Name -> TypeQ -> Phases -> DecQ +pragSpecD :: Quote m => Name -> m Type -> Phases -> m Dec pragSpecD n ty phases = do ty1 <- ty - return $ PragmaD $ SpecialiseP n ty1 Nothing phases + pure $ PragmaD $ SpecialiseP n ty1 Nothing phases -pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ +pragSpecInlD :: Quote m => Name -> m Type -> Inline -> Phases -> m Dec pragSpecInlD n ty inline phases = do ty1 <- ty - return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases + pure $ PragmaD $ SpecialiseP n ty1 (Just inline) phases -pragSpecInstD :: TypeQ -> DecQ +pragSpecInstD :: Quote m => m Type -> m Dec pragSpecInstD ty = do ty1 <- ty - return $ PragmaD $ SpecialiseInstP ty1 + pure $ PragmaD $ SpecialiseInstP ty1 -pragRuleD :: String -> Maybe [TyVarBndrQ] -> [RuleBndrQ] -> ExpQ -> ExpQ - -> Phases -> DecQ +pragRuleD :: Quote m => String -> Maybe [m TyVarBndr] -> [m RuleBndr] -> m Exp -> m Exp + -> Phases -> m Dec pragRuleD n ty_bndrs tm_bndrs lhs rhs phases = do - ty_bndrs1 <- traverse sequence ty_bndrs - tm_bndrs1 <- sequence tm_bndrs + ty_bndrs1 <- traverse sequenceA ty_bndrs + tm_bndrs1 <- sequenceA tm_bndrs lhs1 <- lhs rhs1 <- rhs - return $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases + pure $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases -pragAnnD :: AnnTarget -> ExpQ -> DecQ +pragAnnD :: Quote m => AnnTarget -> m Exp -> m Dec pragAnnD target expr = do exp1 <- expr - return $ PragmaD $ AnnP target exp1 + pure $ PragmaD $ AnnP target exp1 -pragLineD :: Int -> String -> DecQ -pragLineD line file = return $ PragmaD $ LineP line file +pragLineD :: Quote m => Int -> String -> m Dec +pragLineD line file = pure $ PragmaD $ LineP line file -pragCompleteD :: [Name] -> Maybe Name -> DecQ -pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty +pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec +pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty -dataInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> [ConQ] - -> [DerivClauseQ] -> DecQ +dataInstD :: Quote m => m Cxt -> (Maybe [m TyVarBndr]) -> m Type -> Maybe (m Kind) -> [m Con] + -> [m DerivClause] -> m Dec dataInstD ctxt mb_bndrs ty ksig cons derivs = do ctxt1 <- ctxt - mb_bndrs1 <- traverse sequence mb_bndrs + mb_bndrs1 <- traverse sequenceA mb_bndrs ty1 <- ty ksig1 <- sequenceA ksig cons1 <- sequenceA cons derivs1 <- sequenceA derivs - return (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1) + pure (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1) -newtypeInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> ConQ - -> [DerivClauseQ] -> DecQ +newtypeInstD :: Quote m => m Cxt -> (Maybe [m TyVarBndr]) -> m Type -> Maybe (m Kind) -> m Con + -> [m DerivClause] -> m Dec newtypeInstD ctxt mb_bndrs ty ksig con derivs = do ctxt1 <- ctxt - mb_bndrs1 <- traverse sequence mb_bndrs + mb_bndrs1 <- traverse sequenceA mb_bndrs ty1 <- ty ksig1 <- sequenceA ksig con1 <- con - derivs1 <- sequence derivs - return (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1) + derivs1 <- sequenceA derivs + pure (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1) -tySynInstD :: TySynEqnQ -> DecQ +tySynInstD :: Quote m => m TySynEqn -> m Dec tySynInstD eqn = do eqn1 <- eqn - return (TySynInstD eqn1) + pure (TySynInstD eqn1) -dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ +dataFamilyD :: Quote m => Name -> [m TyVarBndr] -> Maybe (m Kind) -> m Dec dataFamilyD tc tvs kind = do tvs' <- sequenceA tvs kind' <- sequenceA kind - return $ DataFamilyD tc tvs' kind' + pure $ DataFamilyD tc tvs' kind' -openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ - -> Maybe InjectivityAnn -> DecQ +openTypeFamilyD :: Quote m => Name -> [m TyVarBndr] -> m FamilyResultSig + -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj = do tvs' <- sequenceA tvs res' <- res - return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj) + pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj) -closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ - -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ +closedTypeFamilyD :: Quote m => Name -> [m TyVarBndr] -> m FamilyResultSig + -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns = do tvs1 <- sequenceA tvs result1 <- result eqns1 <- sequenceA eqns - return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1) + pure (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1) -roleAnnotD :: Name -> [Role] -> DecQ -roleAnnotD name roles = return $ RoleAnnotD name roles +roleAnnotD :: Quote m => Name -> [Role] -> m Dec +roleAnnotD name roles = pure $ RoleAnnotD name roles -standaloneDerivD :: CxtQ -> TypeQ -> DecQ +standaloneDerivD :: Quote m => m Cxt -> m Type -> m Dec standaloneDerivD = standaloneDerivWithStrategyD Nothing -standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ +standaloneDerivWithStrategyD :: Quote m => Maybe (m DerivStrategy) -> m Cxt -> m Type -> m Dec standaloneDerivWithStrategyD mdsq ctxtq tyq = do mds <- sequenceA mdsq ctxt <- ctxtq ty <- tyq - return $ StandaloneDerivD mds ctxt ty + pure $ StandaloneDerivD mds ctxt ty -defaultSigD :: Name -> TypeQ -> DecQ +defaultSigD :: Quote m => Name -> m Type -> m Dec defaultSigD n tyq = do ty <- tyq - return $ DefaultSigD n ty + pure $ DefaultSigD n ty -- | Pattern synonym declaration -patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ +patSynD :: Quote m => Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec patSynD name args dir pat = do args' <- args dir' <- dir pat' <- pat - return (PatSynD name args' dir' pat') + pure (PatSynD name args' dir' pat') -- | Pattern synonym type signature -patSynSigD :: Name -> TypeQ -> DecQ +patSynSigD :: Quote m => Name -> m Type -> m Dec patSynSigD nm ty = do ty' <- ty - return $ PatSynSigD nm ty' + pure $ 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 :: Quote m => String -> m Exp -> m Dec implicitParamBindD n e = do e' <- e - return $ ImplicitParamBindD n e' + pure $ ImplicitParamBindD n e' -tySynEqn :: (Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ +tySynEqn :: Quote m => (Maybe [m TyVarBndr]) -> m Type -> m Type -> m TySynEqn tySynEqn mb_bndrs lhs rhs = do - mb_bndrs1 <- traverse sequence mb_bndrs + mb_bndrs1 <- traverse sequenceA mb_bndrs lhs1 <- lhs rhs1 <- rhs - return (TySynEqn mb_bndrs1 lhs1 rhs1) + pure (TySynEqn mb_bndrs1 lhs1 rhs1) -cxt :: [PredQ] -> CxtQ -cxt = sequence +cxt :: Quote m => [m Pred] -> m Cxt +cxt = sequenceA -derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ +derivClause :: Quote m => Maybe (m DerivStrategy) -> [m Pred] -> m DerivClause derivClause mds p = do mds' <- sequenceA mds p' <- cxt p - return $ DerivClause mds' p' + pure $ DerivClause mds' p' -stockStrategy :: DerivStrategyQ +stockStrategy :: Quote m => m DerivStrategy stockStrategy = pure StockStrategy -anyclassStrategy :: DerivStrategyQ +anyclassStrategy :: Quote m => m DerivStrategy anyclassStrategy = pure AnyclassStrategy -newtypeStrategy :: DerivStrategyQ +newtypeStrategy :: Quote m => m DerivStrategy newtypeStrategy = pure NewtypeStrategy -viaStrategy :: TypeQ -> DerivStrategyQ +viaStrategy :: Quote m => m Type -> m DerivStrategy viaStrategy = fmap ViaStrategy -normalC :: Name -> [BangTypeQ] -> ConQ -normalC con strtys = liftM (NormalC con) $ sequence strtys +normalC :: Quote m => Name -> [m BangType] -> m Con +normalC con strtys = liftA (NormalC con) $ sequenceA strtys -recC :: Name -> [VarBangTypeQ] -> ConQ -recC con varstrtys = liftM (RecC con) $ sequence varstrtys +recC :: Quote m => Name -> [m VarBangType] -> m Con +recC con varstrtys = liftA (RecC con) $ sequenceA varstrtys -infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ +infixC :: Quote m => m (Bang, Type) -> Name -> m (Bang, Type) -> m Con infixC st1 con st2 = do st1' <- st1 st2' <- st2 - return $ InfixC st1' con st2' + pure $ InfixC st1' con st2' -forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ +forallC :: Quote m => [m TyVarBndr] -> m Cxt -> m Con -> m Con 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 +gadtC :: Quote m => [Name] -> [m StrictType] -> m Type -> m Con +gadtC cons strtys ty = liftA2 (GadtC cons) (sequenceA strtys) ty -recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ -recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty +recGadtC :: Quote m => [Name] -> [m VarStrictType] -> m Type -> m Con +recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty ------------------------------------------------------------------------------- -- * Type -forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ +forallT :: Quote m => [m TyVarBndr] -> m Cxt -> m Type -> m Type forallT tvars ctxt ty = do tvars1 <- sequenceA tvars ctxt1 <- ctxt ty1 <- ty - return $ ForallT tvars1 ctxt1 ty1 + pure $ ForallT tvars1 ctxt1 ty1 -forallVisT :: [TyVarBndrQ] -> TypeQ -> TypeQ +forallVisT :: Quote m => [m TyVarBndr] -> m Type -> m Type forallVisT tvars ty = ForallVisT <$> sequenceA tvars <*> ty -varT :: Name -> TypeQ -varT = return . VarT +varT :: Quote m => Name -> m Type +varT = pure . VarT -conT :: Name -> TypeQ -conT = return . ConT +conT :: Quote m => Name -> m Type +conT = pure . ConT -infixT :: TypeQ -> Name -> TypeQ -> TypeQ +infixT :: Quote m => m Type -> Name -> m Type -> m Type infixT t1 n t2 = do t1' <- t1 t2' <- t2 - return (InfixT t1' n t2') + pure (InfixT t1' n t2') -uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ +uInfixT :: Quote m => m Type -> Name -> m Type -> m Type uInfixT t1 n t2 = do t1' <- t1 t2' <- t2 - return (UInfixT t1' n t2') + pure (UInfixT t1' n t2') -parensT :: TypeQ -> TypeQ +parensT :: Quote m => m Type -> m Type parensT t = do t' <- t - return (ParensT t') + pure (ParensT t') -appT :: TypeQ -> TypeQ -> TypeQ +appT :: Quote m => m Type -> m Type -> m Type appT t1 t2 = do t1' <- t1 t2' <- t2 - return $ AppT t1' t2' + pure $ AppT t1' t2' -appKindT :: TypeQ -> KindQ -> TypeQ +appKindT :: Quote m => m Type -> m Kind -> m Type appKindT ty ki = do ty' <- ty ki' <- ki - return $ AppKindT ty' ki' + pure $ AppKindT ty' ki' -arrowT :: TypeQ -arrowT = return ArrowT +arrowT :: Quote m => m Type +arrowT = pure ArrowT -listT :: TypeQ -listT = return ListT +listT :: Quote m => m Type +listT = pure ListT -litT :: TyLitQ -> TypeQ +litT :: Quote m => m TyLit -> m Type litT l = fmap LitT l -tupleT :: Int -> TypeQ -tupleT i = return (TupleT i) +tupleT :: Quote m => Int -> m Type +tupleT i = pure (TupleT i) -unboxedTupleT :: Int -> TypeQ -unboxedTupleT i = return (UnboxedTupleT i) +unboxedTupleT :: Quote m => Int -> m Type +unboxedTupleT i = pure (UnboxedTupleT i) -unboxedSumT :: SumArity -> TypeQ -unboxedSumT arity = return (UnboxedSumT arity) +unboxedSumT :: Quote m => SumArity -> m Type +unboxedSumT arity = pure (UnboxedSumT arity) -sigT :: TypeQ -> KindQ -> TypeQ +sigT :: Quote m => m Type -> m Kind -> m Type sigT t k = do t' <- t k' <- k - return $ SigT t' k' + pure $ SigT t' k' -equalityT :: TypeQ -equalityT = return EqualityT +equalityT :: Quote m => m Type +equalityT = pure EqualityT -wildCardT :: TypeQ -wildCardT = return WildCardT +wildCardT :: Quote m => m Type +wildCardT = pure WildCardT -implicitParamT :: String -> TypeQ -> TypeQ +implicitParamT :: Quote m => String -> m Type -> m Type implicitParamT n t = do t' <- t - return $ ImplicitParamT n t' + pure $ 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 :: Quote m => Name -> [m Type] -> m Pred classP cla tys = do - tysl <- sequence tys - return (foldl AppT (ConT cla) tysl) + tysl <- sequenceA tys + pure (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 :: Quote m => m Type -> m Type -> m Pred equalP tleft tright = do tleft1 <- tleft tright1 <- tright eqT <- equalityT - return (foldl AppT eqT [tleft1, tright1]) + pure (foldl AppT eqT [tleft1, tright1]) -promotedT :: Name -> TypeQ -promotedT = return . PromotedT +promotedT :: Quote m => Name -> m Type +promotedT = pure . PromotedT -promotedTupleT :: Int -> TypeQ -promotedTupleT i = return (PromotedTupleT i) +promotedTupleT :: Quote m => Int -> m Type +promotedTupleT i = pure (PromotedTupleT i) -promotedNilT :: TypeQ -promotedNilT = return PromotedNilT +promotedNilT :: Quote m => m Type +promotedNilT = pure PromotedNilT -promotedConsT :: TypeQ -promotedConsT = return PromotedConsT +promotedConsT :: Quote m => m Type +promotedConsT = pure PromotedConsT -noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ -noSourceUnpackedness = return NoSourceUnpackedness -sourceNoUnpack = return SourceNoUnpack -sourceUnpack = return SourceUnpack +noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: Quote m => m SourceUnpackedness +noSourceUnpackedness = pure NoSourceUnpackedness +sourceNoUnpack = pure SourceNoUnpack +sourceUnpack = pure SourceUnpack -noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ -noSourceStrictness = return NoSourceStrictness -sourceLazy = return SourceLazy -sourceStrict = return SourceStrict +noSourceStrictness, sourceLazy, sourceStrict :: Quote m => m SourceStrictness +noSourceStrictness = pure NoSourceStrictness +sourceLazy = pure SourceLazy +sourceStrict = pure SourceStrict {-# DEPRECATED isStrict ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ", @@ -770,49 +771,52 @@ sourceStrict = return SourceStrict {-# DEPRECATED unpacked ["Use 'bang'. See https://gitlab.haskell.org/ghc/ghc/wikis/migration/8.0. ", "Example usage: 'bang sourceUnpack sourceStrict'"] #-} -isStrict, notStrict, unpacked :: Q Strict +isStrict, notStrict, unpacked :: Quote m => m Strict isStrict = bang noSourceUnpackedness sourceStrict notStrict = bang noSourceUnpackedness noSourceStrictness unpacked = bang sourceUnpack sourceStrict -bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ +bang :: Quote m => m SourceUnpackedness -> m SourceStrictness -> m Bang bang u s = do u' <- u s' <- s - return (Bang u' s') + pure (Bang u' s') -bangType :: BangQ -> TypeQ -> BangTypeQ -bangType = liftM2 (,) +bangType :: Quote m => m Bang -> m Type -> m BangType +bangType = liftA2 (,) -varBangType :: Name -> BangTypeQ -> VarBangTypeQ -varBangType v bt = do (b, t) <- bt - return (v, b, t) +varBangType :: Quote m => Name -> m BangType -> m VarBangType +varBangType v bt = (\(b, t) -> (v, b, t)) <$> bt {-# 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 :: Quote m => m Strict -> m Type -> m StrictType 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 :: Quote m => Name -> m StrictType -> m VarStrictType varStrictType = varBangType -- * Type Literals -numTyLit :: Integer -> TyLitQ -numTyLit n = if n >= 0 then return (NumTyLit n) - else fail ("Negative type-level number: " ++ show n) +-- MonadFail here complicates things (a lot) because it would mean we would +-- have to emit a MonadFail constraint during typechecking if there was any +-- chance the desugaring would use numTyLit, which in general is hard to +-- predict. +numTyLit :: Quote m => Integer -> m TyLit +numTyLit n = if n >= 0 then pure (NumTyLit n) + else error ("Negative type-level number: " ++ show n) -strTyLit :: String -> TyLitQ -strTyLit s = return (StrTyLit s) +strTyLit :: Quote m => String -> m TyLit +strTyLit s = pure (StrTyLit s) ------------------------------------------------------------------------------- -- * Kind -plainTV :: Name -> TyVarBndrQ +plainTV :: Quote m => Name -> m TyVarBndr plainTV = pure . PlainTV -kindedTV :: Name -> KindQ -> TyVarBndrQ +kindedTV :: Quote m => Name -> m Kind -> m TyVarBndr kindedTV n = fmap (KindedTV n) varK :: Name -> Kind @@ -824,31 +828,31 @@ conK = ConT tupleK :: Int -> Kind tupleK = TupleT -arrowK :: Kind +arrowK :: Kind arrowK = ArrowT -listK :: Kind +listK :: Kind listK = ListT appK :: Kind -> Kind -> Kind appK = AppT -starK :: KindQ +starK :: Quote m => m Kind starK = pure StarT -constraintK :: KindQ +constraintK :: Quote m => m Kind constraintK = pure ConstraintT ------------------------------------------------------------------------------- -- * Type family result -noSig :: FamilyResultSigQ +noSig :: Quote m => m FamilyResultSig noSig = pure NoSig -kindSig :: KindQ -> FamilyResultSigQ +kindSig :: Quote m => m Kind -> m FamilyResultSig kindSig = fmap KindSig -tyVarSig :: TyVarBndrQ -> FamilyResultSigQ +tyVarSig :: Quote m => m TyVarBndr -> m FamilyResultSig tyVarSig = fmap TyVarSig ------------------------------------------------------------------------------- @@ -887,23 +891,23 @@ interruptible = Interruptible ------------------------------------------------------------------------------- -- * FunDep -funDep :: [Name] -> [Name] -> FunDep +funDep :: [Name] -> [Name] -> FunDep funDep = FunDep ------------------------------------------------------------------------------- -- * RuleBndr -ruleVar :: Name -> RuleBndrQ -ruleVar = return . RuleVar +ruleVar :: Quote m => Name -> m RuleBndr +ruleVar = pure . RuleVar -typedRuleVar :: Name -> TypeQ -> RuleBndrQ -typedRuleVar n ty = ty >>= return . TypedRuleVar n +typedRuleVar :: Quote m => Name -> m Type -> m RuleBndr +typedRuleVar n ty = TypedRuleVar n <$> ty ------------------------------------------------------------------------------- -- * AnnTarget -valueAnnotation :: Name -> AnnTarget +valueAnnotation :: Name -> AnnTarget valueAnnotation = ValueAnnotation -typeAnnotation :: Name -> AnnTarget +typeAnnotation :: Name -> AnnTarget typeAnnotation = TypeAnnotation moduleAnnotation :: AnnTarget @@ -912,35 +916,35 @@ moduleAnnotation = ModuleAnnotation ------------------------------------------------------------------------------- -- * Pattern Synonyms (sub constructs) -unidir, implBidir :: PatSynDirQ -unidir = return Unidir -implBidir = return ImplBidir +unidir, implBidir :: Quote m => m PatSynDir +unidir = pure Unidir +implBidir = pure ImplBidir -explBidir :: [ClauseQ] -> PatSynDirQ +explBidir :: Quote m => [m Clause] -> m PatSynDir explBidir cls = do - cls' <- sequence cls - return (ExplBidir cls') + cls' <- sequenceA cls + pure (ExplBidir cls') -prefixPatSyn :: [Name] -> PatSynArgsQ -prefixPatSyn args = return $ PrefixPatSyn args +prefixPatSyn :: Quote m => [Name] -> m PatSynArgs +prefixPatSyn args = pure $ PrefixPatSyn args -recordPatSyn :: [Name] -> PatSynArgsQ -recordPatSyn sels = return $ RecordPatSyn sels +recordPatSyn :: Quote m => [Name] -> m PatSynArgs +recordPatSyn sels = pure $ RecordPatSyn sels -infixPatSyn :: Name -> Name -> PatSynArgsQ -infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2 +infixPatSyn :: Quote m => Name -> Name -> m PatSynArgs +infixPatSyn arg1 arg2 = pure $ InfixPatSyn arg1 arg2 -------------------------------------------------------------- -- * Useful helper function -appsE :: [ExpQ] -> ExpQ +appsE :: Quote m => [m Exp] -> m Exp 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 +-- | pure 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) + pure $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc) diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index fb9556db54..0abe15f3ea 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -204,6 +204,67 @@ instance Applicative Q where ----------------------------------------------------- -- +-- The Quote class +-- +----------------------------------------------------- + + + +-- | The 'Quote' class implements the minimal interface which is necessary for +-- desugaring quotations. +-- +-- * The @Monad m@ superclass is needed to stitch together the different +-- AST fragments. +-- * 'newName' is used when desugaring binding structures such as lambdas +-- to generate fresh names. +-- +-- Therefore the type of an untyped quotation in GHC is `Quote m => m Exp` +-- +-- For many years the type of a quotation was fixed to be `Q Exp` but by +-- more precisely specifying the minimal interface it enables the `Exp` to +-- be extracted purely from the quotation without interacting with `Q`. +class Monad m => Quote m where + {- | + Generate a fresh name, which cannot be captured. + + For example, this: + + @f = $(do + nm1 <- newName \"x\" + let nm2 = 'mkName' \"x\" + return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1))) + )@ + + will produce the splice + + >f = \x0 -> \x -> x0 + + In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@, + and is not captured by the binding @VarP nm2@. + + Although names generated by @newName@ cannot /be captured/, they can + /capture/ other names. For example, this: + + >g = $(do + > nm1 <- newName "x" + > let nm2 = mkName "x" + > return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2))) + > ) + + will produce the splice + + >g = \x -> \x0 -> x0 + + since the occurrence @VarE nm2@ is captured by the innermost binding + of @x@, namely @VarP nm1@. + -} + newName :: String -> m Name + +instance Quote Q where + newName s = Q (qNewName s) + +----------------------------------------------------- +-- -- The TExp type -- ----------------------------------------------------- @@ -250,7 +311,7 @@ newtype TExp (a :: TYPE (r :: RuntimeRep)) = TExp -- expression -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. -unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r). Q (TExp a) -> Q Exp +unTypeQ :: forall (r :: RuntimeRep) (a :: TYPE r) m . Quote m => m (TExp a) -> m Exp unTypeQ m = do { TExp e <- m ; return e } @@ -260,7 +321,8 @@ unTypeQ m = do { TExp e <- m -- really does have the type you claim it has. -- -- Levity-polymorphic since /template-haskell-2.16.0.0/. -unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r). Q Exp -> Q (TExp a) +unsafeTExpCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m . + Quote m => m Exp -> m (TExp a) unsafeTExpCoerce m = do { e <- m ; return (TExp e) } @@ -280,42 +342,6 @@ The splice will evaluate to (MkAge 3) and you can't add that to ---------------------------------------------------- -- Packaged versions for the programmer, hiding the Quasi-ness -{- | -Generate a fresh name, which cannot be captured. - -For example, this: - -@f = $(do - nm1 <- newName \"x\" - let nm2 = 'mkName' \"x\" - return ('LamE' ['VarP' nm1] (LamE [VarP nm2] ('VarE' nm1))) - )@ - -will produce the splice - ->f = \x0 -> \x -> x0 - -In particular, the occurrence @VarE nm1@ refers to the binding @VarP nm1@, -and is not captured by the binding @VarP nm2@. - -Although names generated by @newName@ cannot /be captured/, they can -/capture/ other names. For example, this: - ->g = $(do -> nm1 <- newName "x" -> let nm2 = mkName "x" -> return (LamE [VarP nm2] (LamE [VarP nm1] (VarE nm2))) -> ) - -will produce the splice - ->g = \x -> \x0 -> x0 - -since the occurrence @VarE nm2@ is captured by the innermost binding -of @x@, namely @VarP nm1@. --} -newName :: String -> Q Name -newName s = Q (qNewName s) -- | Report an error (True) or warning (False), -- but carry on; use 'fail' to stop. @@ -654,13 +680,7 @@ instance Quasi Q where -- The following operations are used solely in DsMeta when desugaring brackets -- They are not necessary for the user, who can use ordinary return and (>>=) etc -returnQ :: a -> Q a -returnQ = return - -bindQ :: Q a -> (a -> Q b) -> Q b -bindQ = (>>=) - -sequenceQ :: [Q a] -> Q [a] +sequenceQ :: forall m . Monad m => forall a . [m a] -> m [a] sequenceQ = sequence @@ -700,15 +720,15 @@ sequenceQ = sequence class Lift (t :: TYPE r) where -- | Turn a value into a Template Haskell expression, suitable for use in -- a splice. - lift :: t -> Q Exp - default lift :: (r ~ 'LiftedRep) => t -> Q Exp + lift :: Quote m => t -> m Exp + default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp lift = unTypeQ . liftTyped -- | Turn a value into a Template Haskell typed expression, suitable for use -- in a typed splice. -- -- @since 2.16.0.0 - liftTyped :: t -> Q (TExp t) + liftTyped :: Quote m => t -> m (TExp t) -- If you add any instances here, consider updating test th/TH_Lift @@ -832,7 +852,7 @@ instance Lift a => Lift [a] where liftTyped x = unsafeTExpCoerce (lift x) lift xs = do { xs' <- mapM lift xs; return (ListE xs') } -liftString :: String -> Q Exp +liftString :: Quote m => String -> m Exp -- Used in TcExpr to short-circuit the lifting for strings liftString s = return (LitE (StringL s)) |