diff --git a/Language/Haskell/TH/Lib.hs b/Language/Haskell/TH/Lib.hs --- a/Language/Haskell/TH/Lib.hs +++ b/Language/Haskell/TH/Lib.hs @@ -37,8 +37,8 @@ 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 @@ -48,13 +48,14 @@ 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, + forallT, varT, conT, appT, appKindT, arrowT, infixT, uInfixT, parensT, + equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, + wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT, + implicitParamT, -- **** Type literals numTyLit, strTyLit, -- **** Strictness @@ -113,6 +114,9 @@ patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn, infixPatSyn, recordPatSyn, + -- **** Implicit Parameters + implicitParamBindD, + -- ** Reify thisModule @@ -123,11 +127,13 @@ , dataD , newtypeD , classD + , pragRuleD , dataInstD , newtypeInstD , dataFamilyD , openTypeFamilyD , closedTypeFamilyD + , tySynEqn , forallC , forallT @@ -151,6 +157,7 @@ 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 @@ -188,25 +195,33 @@ ctxt1 <- ctxt return $ ClassD ctxt1 cls tvs fds decs1 +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 Nothing bndrs1 lhs1 rhs1 phases + dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] -> DecQ dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt - tys1 <- sequence tys + ty1 <- foldl appT (conT tc) tys cons1 <- sequence cons derivs1 <- sequence derivs - return (DataInstD ctxt1 tc tys1 ksig cons1 derivs1) + return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1) newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ] -> DecQ newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt - tys1 <- sequence tys + ty1 <- foldl appT (conT tc) tys con1 <- con derivs1 <- sequence derivs - return (NewtypeInstD ctxt1 tc tys1 ksig con1 derivs1) + return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ dataFamilyD tc tvs kind @@ -222,6 +237,13 @@ closedTypeFamilyD tc tvs result injectivity eqns = do eqns1 <- sequence eqns return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) + +tySynEqn :: (Maybe [TyVarBndr]) -> TypeQ -> TypeQ -> TySynEqnQ +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 diff --git a/Language/Haskell/TH/Lib/Internal.hs b/Language/Haskell/TH/Lib/Internal.hs --- a/Language/Haskell/TH/Lib/Internal.hs +++ b/Language/Haskell/TH/Lib/Internal.hs @@ -18,6 +18,7 @@ import qualified Language.Haskell.TH.Syntax as TH import Control.Monad( liftM, liftM2 ) import Data.Word( Word8 ) +import Prelude ---------------------------------------------------------- -- * Type synonyms @@ -164,6 +165,9 @@ 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 @@ -304,6 +308,9 @@ 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) } @@ -338,6 +345,9 @@ 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)) } @@ -459,13 +469,15 @@ ty1 <- ty return $ PragmaD $ SpecialiseInstP ty1 -pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ -pragRuleD n bndrs lhs rhs phases +pragRuleD :: String -> Maybe [TyVarBndrQ] -> [RuleBndrQ] -> ExpQ -> ExpQ + -> Phases -> DecQ +pragRuleD n ty_bndrs tm_bndrs lhs rhs phases = do - bndrs1 <- sequence bndrs + ty_bndrs1 <- traverse sequence ty_bndrs + tm_bndrs1 <- sequence tm_bndrs lhs1 <- lhs rhs1 <- rhs - return $ PragmaD $ RuleP n bndrs1 lhs1 rhs1 phases + return $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases pragAnnD :: AnnTarget -> ExpQ -> DecQ pragAnnD target expr @@ -479,33 +491,35 @@ pragCompleteD :: [Name] -> Maybe Name -> DecQ pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty -dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> [ConQ] +dataInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> [ConQ] -> [DerivClauseQ] -> DecQ -dataInstD ctxt tc tys ksig cons derivs = +dataInstD ctxt mb_bndrs ty ksig cons derivs = do ctxt1 <- ctxt - tys1 <- sequenceA tys + mb_bndrs1 <- traverse sequence mb_bndrs + ty1 <- ty ksig1 <- sequenceA ksig cons1 <- sequenceA cons derivs1 <- sequenceA derivs - return (DataInstD ctxt1 tc tys1 ksig1 cons1 derivs1) + return (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1) -newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe KindQ -> ConQ +newtypeInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> ConQ -> [DerivClauseQ] -> DecQ -newtypeInstD ctxt tc tys ksig con derivs = +newtypeInstD ctxt mb_bndrs ty ksig con derivs = do ctxt1 <- ctxt - tys1 <- sequenceA tys + mb_bndrs1 <- traverse sequence mb_bndrs + ty1 <- ty ksig1 <- sequenceA ksig con1 <- con derivs1 <- sequence derivs - return (NewtypeInstD ctxt1 tc tys1 ksig1 con1 derivs1) + return (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1) -tySynInstD :: Name -> TySynEqnQ -> DecQ -tySynInstD tc eqn = +tySynInstD :: TySynEqnQ -> DecQ +tySynInstD eqn = do eqn1 <- eqn - return (TySynInstD tc eqn1) + return (TySynInstD eqn1) dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ dataFamilyD tc tvs kind = @@ -562,12 +576,21 @@ do ty' <- ty return $ PatSynSigD nm ty' -tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ -tySynEqn lhs rhs = +-- | 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 - lhs1 <- sequence lhs + e' <- e + return $ ImplicitParamBindD n e' + +tySynEqn :: (Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ +tySynEqn mb_bndrs lhs rhs = + do + mb_bndrs1 <- traverse sequence mb_bndrs + lhs1 <- lhs rhs1 <- rhs - return (TySynEqn lhs1 rhs1) + return (TySynEqn mb_bndrs1 lhs1 rhs1) cxt :: [PredQ] -> CxtQ cxt = sequence @@ -649,6 +672,12 @@ t2' <- t2 return $ AppT t1' t2' +appKindT :: TypeQ -> KindQ -> TypeQ +appKindT ty ki = do + ty' <- ty + ki' <- ki + return $ AppKindT ty' ki' + arrowT :: TypeQ arrowT = return ArrowT @@ -679,6 +708,12 @@ 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 diff --git a/Language/Haskell/TH/Lib/Map.hs b/Language/Haskell/TH/Lib/Map.hs --- a/Language/Haskell/TH/Lib/Map.hs +++ b/Language/Haskell/TH/Lib/Map.hs @@ -16,6 +16,8 @@ , 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/Language/Haskell/TH/Ppr.hs b/Language/Haskell/TH/Ppr.hs --- a/Language/Haskell/TH/Ppr.hs +++ b/Language/Haskell/TH/Ppr.hs @@ -179,6 +179,11 @@ 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 "<>" -- This will probably break with fixity declarations - would need a ';' @@ -203,6 +208,7 @@ 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) @@ -218,6 +224,7 @@ 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 @@ -318,11 +325,11 @@ ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r $$ where_clause ds ppr_dec _ (TySynD t xs rhs) - = ppr_tySyn empty t (hsep (map ppr xs)) rhs + = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs ppr_dec _ (DataD ctxt t xs ksig cs decs) - = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs + = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs ppr_dec _ (NewtypeD ctxt t xs ksig c decs) - = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs + = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs ppr_dec _ (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds @@ -340,18 +347,21 @@ | otherwise = empty maybeKind | (Just k') <- kind = dcolon <+> ppr k' | otherwise = empty -ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs) - = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs +ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs) + = ppr_data (maybeInst <+> ppr_bndrs bndrs) + ctxt Nothing (ppr ty) ksig cs decs where maybeInst | isTop = text "instance" | otherwise = empty -ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs) - = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs +ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs) + = ppr_newtype (maybeInst <+> ppr_bndrs bndrs) + ctxt Nothing (ppr ty) ksig c decs where maybeInst | isTop = text "instance" | otherwise = empty -ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs)) - = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs +ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs)) + = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs) + Nothing (ppr ty) rhs where maybeInst | isTop = text "instance" | otherwise = empty @@ -360,12 +370,12 @@ where maybeFamily | isTop = text "family" | otherwise = empty -ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns) +ppr_dec _ (ClosedTypeFamilyD tfhead eqns) = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where") nestDepth (vcat (map ppr_eqn eqns)) where - ppr_eqn (TySynEqn lhs rhs) - = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs + ppr_eqn (TySynEqn mb_bndrs lhs rhs) + = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs ppr_dec _ (RoleAnnotD name roles) = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) ppr_dec _ (StandaloneDerivD ds cxt ty) @@ -386,6 +396,8 @@ | 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 = @@ -403,12 +415,15 @@ Overlapping -> "{-# OVERLAPPING #-}" Incoherent -> "{-# INCOHERENT #-}" -ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] +ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc ppr_data maybeInst ctxt t argsDoc ksig cs decs = sep [text "data" <+> maybeInst <+> pprCxt ctxt - <+> pprName' Applied t <+> argsDoc <+> ksigDoc <+> maybeWhere, + <+> case t of + Just n -> pprName' Applied n <+> argsDoc + Nothing -> argsDoc + <+> ksigDoc <+> maybeWhere, nest nestDepth (sep (pref $ map ppr cs)), if null decs then empty @@ -435,12 +450,15 @@ Nothing -> empty Just k -> dcolon <+> ppr k -ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause] +ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause] -> Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs = sep [text "newtype" <+> maybeInst <+> pprCxt ctxt - <+> ppr t <+> argsDoc <+> ksigDoc, + <+> case t of + Just n -> ppr n <+> argsDoc + Nothing -> argsDoc + <+> ksigDoc, nest 2 (char '=' <+> ppr c), if null decs then empty @@ -464,9 +482,13 @@ Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via) _ -> (maybe empty ppr_deriv_strategy ds, empty) -ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc +ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs - = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs + = text "type" <+> maybeInst + <+> case t of + Just n -> ppr n <+> argsDoc + Nothing -> argsDoc + <+> text "=" <+> ppr rhs ppr_tf_head :: TypeFamilyHead -> Doc ppr_tf_head (TypeFamilyHead tc tvs res inj) @@ -475,6 +497,10 @@ maybeInj | (Just inj') <- inj = ppr inj' | otherwise = empty +ppr_bndrs :: Maybe [TyVarBndr] -> Doc +ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "." +ppr_bndrs Nothing = empty + ------------------------------ instance Ppr FunDep where ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys) @@ -526,14 +552,19 @@ <+> text "#-}" ppr (SpecialiseInstP inst) = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}" - ppr (RuleP n bndrs lhs rhs phases) + ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases) = sep [ text "{-# RULES" <+> pprString n <+> ppr phases - , nest 4 $ ppr_forall <+> ppr lhs + , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs + <+> ppr lhs , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ] - where ppr_forall | null bndrs = empty - | otherwise = text "forall" - <+> fsep (map ppr bndrs) - <+> char '.' + where ppr_ty_forall Nothing = empty + ppr_ty_forall (Just bndrs) = text "forall" + <+> fsep (map ppr bndrs) + <+> char '.' + ppr_tm_forall Nothing | null tm_bndrs = empty + ppr_tm_forall _ = text "forall" + <+> fsep (map ppr tm_bndrs) + <+> char '.' ppr (AnnP tgt expr) = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}" where target1 ModuleAnnotation = text "module" @@ -716,7 +747,11 @@ pprParendType tuple | (TupleT n, args) <- split tuple , length args == n = parens (commaSep args) -pprParendType other = parens (ppr other) +pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t +pprParendType EqualityT = text "(~)" +pprParendType t@(ForallT {}) = parens (ppr t) +pprParendType t@(AppT {}) = parens (ppr t) +pprParendType t@(AppKindT {}) = parens (ppr t) pprUInfixT :: Type -> Doc pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y @@ -727,7 +762,13 @@ ppr ty = pprTyApp (split ty) -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind) -- See Note [Pretty-printing kind signatures] +instance Ppr TypeArg where + ppr (TANormal ty) = ppr ty + ppr (TyArg ki) = char '@' <> ppr ki +pprParendTypeArg :: TypeArg -> Doc +pprParendTypeArg (TANormal ty) = pprParendType ty +pprParendTypeArg (TyArg ki) = char '@' <> pprParendType ki {- Note [Pretty-printing kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC's parser only recognises a kind signature in a type when there are @@ -736,16 +777,16 @@ type instance F Int = (Bool :: *) So we always print a SigT with parens (see Trac #10050). -} -pprTyApp :: (Type, [Type]) -> Doc -pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] -pprTyApp (EqualityT, [arg1, arg2]) = +pprTyApp :: (Type, [TypeArg]) -> Doc +pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] +pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "~", ppr arg2] -pprTyApp (ListT, [arg]) = brackets (ppr arg) +pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg) pprTyApp (TupleT n, args) | length args == n = parens (commaSep args) pprTyApp (PromotedTupleT n, args) | length args == n = quoteParens (commaSep args) -pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args) +pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args) pprFunArgType :: Type -> Doc -- Should really use a precedence argument -- Everything except forall and (->) binds more tightly than (->) @@ -754,9 +795,13 @@ pprFunArgType ty@(SigT _ _) = parens (ppr ty) pprFunArgType ty = ppr ty -split :: Type -> (Type, [Type]) -- Split into function and args +data TypeArg = TANormal Type + | TyArg Kind + +split :: Type -> (Type, [TypeArg]) -- Split into function and args split t = go t [] - where go (AppT t1 t2) args = go t1 (t2:args) + where go (AppT t1 t2) args = go t1 (TANormal t2:args) + go (AppKindT ty ki) args = go ty (TyArg ki:args) go ty args = (ty, args) pprTyLit :: TyLit -> Doc @@ -784,6 +829,8 @@ ppr_cxt_preds :: Cxt -> Doc ppr_cxt_preds [] = empty +ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t) +ppr_cxt_preds [t@ForallT{}] = parens (ppr t) ppr_cxt_preds [t] = ppr t ppr_cxt_preds ts = parens (commaSep ts) diff --git a/Language/Haskell/TH/Quote.hs b/Language/Haskell/TH/Quote.hs --- a/Language/Haskell/TH/Quote.hs +++ b/Language/Haskell/TH/Quote.hs @@ -21,6 +21,7 @@ ) 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 @@ -41,7 +42,7 @@ } -- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read --- the data out of a file. For example, suppose 'asmq' is an +-- the data out of a file. For example, suppose @asmq@ is an -- assembly-language quoter, so that you can write [asmq| ld r1, r2 |] -- as an expression. Then if you define @asmq_f = quoteFile asmq@, then -- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead diff --git a/Language/Haskell/TH/Syntax.hs b/Language/Haskell/TH/Syntax.hs --- a/Language/Haskell/TH/Syntax.hs +++ b/Language/Haskell/TH/Syntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, DefaultSignatures, RankNTypes, RoleAnnotations, ScopedTypeVariables, Trustworthy #-} @@ -34,6 +34,8 @@ import System.IO ( hPutStrLn, stderr ) import Data.Char ( isAlpha, isAlphaNum, isUpper ) import Data.Int +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Void ( Void, absurd ) import Data.Word import Data.Ratio import GHC.Generics ( Generic ) @@ -41,6 +43,7 @@ import GHC.ForeignSrcLang.Type import Language.Haskell.TH.LanguageExtensions import Numeric.Natural +import Prelude import qualified Control.Monad.Fail as Fail @@ -175,7 +178,9 @@ instance Monad Q where Q m >>= k = Q (m >>= \x -> unQ (k x)) (>>) = (*>) +#if !MIN_VERSION_base(4,13,0) fail = Fail.fail +#endif instance Fail.MonadFail Q where fail s = report True s >> Q (Fail.fail "Q monad failure") @@ -376,6 +381,19 @@ if @nm@ is the name of a type class, then all instances of this class at the types @tys@ are returned. Alternatively, if @nm@ is the name of a data family or type family, all instances of this family at the types @tys@ are returned. + +Note that this is a \"shallow\" test; the declarations returned merely have +instance heads which unify with @nm tys@, they need not actually be satisfiable. + + - @reifyInstances ''Eq [ 'TupleT' 2 \``AppT`\` 'ConT' ''A \``AppT`\` 'ConT' ''B ]@ contains + the @instance (Eq a, Eq b) => Eq (a, b)@ regardless of whether @A@ and + @B@ themselves implement 'Eq' + + - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available + instance of 'Eq' + +There is one edge case: @reifyInstances ''Typeable tys@ currently always +produces an empty list (no matter what @tys@ are given). -} reifyInstances :: Name -> [Type] -> Q [InstanceDec] reifyInstances cls tys = Q (qReifyInstances cls tys) @@ -396,7 +414,7 @@ -- | @reifyModule mod@ looks up information about module @mod@. To -- look up the current module, call this function with the return --- value of @thisModule@. +-- value of 'Language.Haskell.TH.Lib.thisModule'. reifyModule :: Module -> Q ModuleInfo reifyModule m = Q (qReifyModule m) @@ -473,7 +491,7 @@ -- 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 #-} @@ -485,11 +503,12 @@ addForeignSource :: ForeignSrcLang -> String -> Q () addForeignSource lang src = do let suffix = case lang of - LangC -> "c" - LangCxx -> "cpp" - LangObjc -> "m" + LangC -> "c" + LangCxx -> "cpp" + LangObjc -> "m" LangObjcxx -> "mm" - RawObject -> "a" + LangAsm -> "s" + RawObject -> "a" path <- addTempFile suffix runIO $ writeFile path src addForeignFilePath lang path @@ -687,6 +706,17 @@ -- Used in TcExpr to short-circuit the lifting for strings liftString s = return (LitE (StringL s)) +-- | @since 2.15.0.0 +instance Lift a => Lift (NonEmpty a) where + lift (x :| xs) = do + x' <- lift x + xs' <- lift xs + return (InfixE (Just x') (ConE nonemptyName) (Just xs')) + +-- | @since 2.15.0.0 +instance Lift Void where + lift = pure . absurd + instance Lift () where lift () = return (ConE (tupleDataName 0)) @@ -738,6 +768,9 @@ leftName = mkNameG DataName "base" "Data.Either" "Left" rightName = mkNameG DataName "base" "Data.Either" "Right" +nonemptyName :: Name +nonemptyName = mkNameG DataName "base" "GHC.Base" ":|" + ----------------------------------------------------- -- -- Generic Lift implementations @@ -891,7 +924,7 @@ newtype PkgName = PkgName String -- package name deriving (Show,Eq,Ord,Data,Generic) --- | Obtained from 'reifyModule' and 'thisModule'. +-- | Obtained from 'reifyModule' and 'Language.Haskell.TH.Lib.thisModule'. data Module = Module PkgName ModName -- package qualified module name deriving (Show,Eq,Ord,Data,Generic) @@ -1115,7 +1148,7 @@ > mkName "Prelude.pi" See also 'Language.Haskell.TH.Lib.dyn' for a useful combinator. The above example could -be rewritten using 'dyn' as +be rewritten using 'Language.Haskell.TH.Lib.dyn' as > f = [| pi + $(dyn "pi") |] -} @@ -1343,7 +1376,10 @@ Type ParentName - -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned using 'PrimTyConI' or 'FamilyI' as appropriate + -- | A \"plain\" type constructor. \"Fancier\" type constructors are returned + -- using 'PrimTyConI' or 'FamilyI' as appropriate. At present, this reified + -- declaration will never have derived instances attached to it (if you wish + -- to check for an instance, see 'reifyInstances'). | TyConI Dec @@ -1353,7 +1389,8 @@ Dec [InstanceDec] - -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'. Examples: @(->)@, @Int#@. + -- | A \"primitive\" type constructor, which can't be expressed with a 'Dec'. + -- Examples: @(->)@, @Int#@. | PrimTyConI Name Arity @@ -1365,7 +1402,7 @@ Type ParentName - -- | A pattern synonym. + -- | A pattern synonym | PatSynI Name PatSynType @@ -1374,9 +1411,9 @@ A \"value\" variable (as opposed to a type variable, see 'TyVarI'). The @Maybe Dec@ field contains @Just@ the declaration which - defined the variable -- including the RHS of the declaration -- + defined the variable - including the RHS of the declaration - or else @Nothing@, in the case where the RHS is unavailable to - the compiler. At present, this value is _always_ @Nothing@: + the compiler. At present, this value is /always/ @Nothing@: returning the RHS has not yet been implemented because of lack of interest. -} @@ -1600,9 +1637,10 @@ | 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 @@ -1620,8 +1658,14 @@ | 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) @@ -1641,10 +1685,11 @@ 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 @@ -1685,20 +1730,20 @@ (Maybe Kind) -- ^ @{ data family T a b c :: * }@ - | DataInstD Cxt Name [Type] + | DataInstD Cxt (Maybe [TyVarBndr]) Type (Maybe Kind) -- Kind signature [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x] -- = A x | B (T x) -- deriving (Z,W) -- deriving stock Eq }@ - | NewtypeInstD Cxt Name [Type] + | NewtypeInstD Cxt (Maybe [TyVarBndr]) Type -- Quantified type vars (Maybe Kind) -- Kind signature Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x] -- = A (B x) -- deriving (Z,W) -- deriving stock Eq }@ - | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ + | TySynInstD TySynEqn -- ^ @{ type instance ... }@ -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') | OpenTypeFamilyD TypeFamilyHead @@ -1723,6 +1768,12 @@ -- 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. @@ -1746,51 +1797,51 @@ | ViaStrategy Type -- ^ @-XDerivingVia@ deriving( Show, Eq, Ord, Data, Generic ) --- | A Pattern synonym's type. Note that a pattern synonym's *fully* +-- | A pattern synonym's type. Note that a pattern synonym's /fully/ -- specified type has a peculiar shape coming with two forall -- quantifiers and two constraint contexts. For example, consider the -- pattern synonym -- --- pattern P x1 x2 ... xn = +-- > pattern P x1 x2 ... xn = -- -- P's complete type is of the following form -- --- forall universals. required constraints --- => forall existentials. provided constraints --- => t1 -> t2 -> ... -> tn -> t +-- > pattern P :: forall universals. required constraints +-- > => forall existentials. provided constraints +-- > => t1 -> t2 -> ... -> tn -> t -- -- consisting of four parts: -- --- 1) the (possibly empty lists of) universally quantified type +-- 1. the (possibly empty lists of) universally quantified type -- variables and required constraints on them. --- 2) the (possibly empty lists of) existentially quantified +-- 2. the (possibly empty lists of) existentially quantified -- type variables and the provided constraints on them. --- 3) the types t1, t2, .., tn of x1, x2, .., xn, respectively --- 4) the type t of , mentioning only universals. +-- 3. the types @t1@, @t2@, .., @tn@ of @x1@, @x2@, .., @xn@, respectively +-- 4. the type @t@ of @\@, mentioning only universals. -- -- Pattern synonym types interact with TH when (a) reifying a pattern -- synonym, (b) pretty printing, or (c) specifying a pattern synonym's -- type signature explicitly: -- --- (a) Reification always returns a pattern synonym's *fully* specified +-- * Reification always returns a pattern synonym's /fully/ specified -- type in abstract syntax. -- --- (b) Pretty printing via 'pprPatSynType' abbreviates a pattern --- synonym's type unambiguously in concrete syntax: The rule of +-- * Pretty printing via 'Language.Haskell.TH.Ppr.pprPatSynType' abbreviates +-- a pattern synonym's type unambiguously in concrete syntax: The rule of -- thumb is to print initial empty universals and the required --- context as `() =>`, if existentials and a provided context +-- context as @() =>@, if existentials and a provided context -- follow. If only universals and their required context, but no -- existentials are specified, only the universals and their -- required context are printed. If both or none are specified, so -- both (or none) are printed. -- --- (c) When specifying a pattern synonym's type explicitly with +-- * When specifying a pattern synonym's type explicitly with -- 'PatSynSigD' either one of the universals, the existentials, or -- their contexts may be left empty. -- -- See the GHC user's guide for more information on pattern synonyms --- and their types: https://downloads.haskell.org/~ghc/latest/docs/html/ --- users_guide/syntax-extns.html#pattern-synonyms. +-- and their types: +-- . type PatSynType = Type -- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'. By @@ -1803,9 +1854,23 @@ deriving( Show, Eq, Ord, Data, Generic ) -- | One equation of a type family instance or closed type family. The --- arguments are the left-hand-side type patterns and the right-hand-side --- result. -data TySynEqn = TySynEqn [Type] Type +-- arguments are the left-hand-side type and the right-hand-side result. +-- +-- For instance, if you had the following type family: +-- +-- @ +-- type family Foo (a :: k) :: k where +-- forall k (a :: k). Foo \@k a = a +-- @ +-- +-- The @Foo \@k a = a@ equation would be represented as follows: +-- +-- @ +-- 'TySynEqn' ('Just' ['PlainTV' k, 'KindedTV' a ('VarT' k)]) +-- ('AppT' ('AppKindT' ('ConT' ''Foo) ('VarT' k)) ('VarT' a)) +-- ('VarT' a) +-- @ +data TySynEqn = TySynEqn (Maybe [TyVarBndr]) Type Type deriving( Show, Eq, Ord, Data, Generic ) data FunDep = FunDep [Name] [Name] @@ -1825,7 +1890,7 @@ data Pragma = InlineP Name Inline RuleMatch Phases | SpecialiseP Name Type (Maybe Inline) Phases | SpecialiseInstP Type - | RuleP String [RuleBndr] Exp Exp Phases + | RuleP String (Maybe [TyVarBndr]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP Int String | CompleteP [Name] (Maybe Name) @@ -1985,6 +2050,7 @@ data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \. \ => \@ | AppT Type Type -- ^ @T a b@ + | AppKindT Type Kind -- ^ @T \@k t@ | SigT Type Kind -- ^ @t :: k@ | VarT Name -- ^ @a@ | ConT Name -- ^ @T@ @@ -2009,6 +2075,7 @@ | 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@ diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,4 @@ module Main (main) where - import Distribution.Simple - main :: IO () main = defaultMain diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,7 +1,29 @@ # Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell) -## 2.14.0.0 *August 2018* +## 2.15.0.0 *May 2019 + * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`, + and `RuleP` now all have a `Maybe [TyVarBndr]` argument, which contains a + list of quantified type variables if an explicit `forall` is present, and + `Nothing` otherwise. `DataInstD`, `NewTypeInstD`, `TySynEqn` also now use + a single `Type` argument to represent the left-hand-side to avoid + malformed type family equations and allow visible kind application. + + Correspondingly, in `Language.Haskell.TH.Lib.Internal`, `pragRuleD`, + `dataInstD`, `newtypeInstD`, and `tySynEqn` now all have a + `Maybe [TyVarBndrQ]` argument. Non-API-breaking versions of these + functions can be found in `Language.Haskell.TH.Lib`. The type signature + of `tySynEqn` has also changed from `[TypeQ] -> TypeQ -> TySynEqnQ` to + `(Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ`, for the same reason + as in `Language.Haskell.TH.Syntax` above. Consequently, `tySynInstD` also + changes from `Name -> TySynEqnQ -> DecQ` to `TySynEqnQ -> DecQ`. + + * Add `Lift` instances for `NonEmpty` and `Void` + + * `addForeignFilePath` now support assembler sources (#16180). + +## 2.14.0.0 *September 2018 + * Introduce an `addForeignFilePath` function, as well as a corresponding `qAddForeignFile` class method to `Quasi`. Unlike `addForeignFile`, which takes the contents of the file as an argument, `addForeignFilePath` takes @@ -17,6 +39,11 @@ a given suffix. * Add a `ViaStrategy` constructor to `DerivStrategy`. + + * Add support for `-XImplicitParams` via `ImplicitParamT`, + `ImplicitParamVarE`, and `ImplicitParamBindD`. + + * Add support for `-XRecursiveDo` via `MDoE` and `RecS`. ## 2.13.0.0 *March 2018* diff --git a/template-haskell.cabal b/template-haskell.cabal --- a/template-haskell.cabal +++ b/template-haskell.cabal @@ -1,11 +1,11 @@ name: template-haskell -version: 2.14.0.0 +version: 2.15.0.0 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE category: Template Haskell maintainer: libraries@haskell.org -bug-reports: http://ghc.haskell.org/trac/ghc/newticket?component=Template%20Haskell +bug-reports: https://gitlab.haskell.org/ghc/ghc/issues synopsis: Support library for Template Haskell build-type: Simple Cabal-Version: >= 1.10 @@ -20,7 +20,7 @@ source-repository head type: git - location: http://git.haskell.org/ghc.git + location: https://gitlab.haskell.org/ghc/ghc.git subdir: libraries/template-haskell Library @@ -51,8 +51,8 @@ Language.Haskell.TH.Lib.Map build-depends: - base >= 4.9 && < 4.13, - ghc-boot-th == 8.6.*, + base >= 4.11 && < 4.14, + ghc-boot-th == 8.8.*, pretty == 1.1.* ghc-options: -Wall @@ -60,3 +60,8 @@ -- We need to set the unit ID to template-haskell (without a -- version number) as it's magic. ghc-options: -this-unit-id template-haskell + + -- This should match the default-extensions used in 'ghc.cabal'. This way, + -- GHCi can be used to load it along with the compiler. + Default-Extensions: + NoImplicitPrelude