Commit 9c6b7493 authored by Michael Sloan's avatar Michael Sloan Committed by Krzysztof Gogolewski

Add support for ImplicitParams and RecursiveDo in TH

Summary:
This adds TH support for the ImplicitParams and RecursiveDo extensions.

I'm submitting this as one review because I cannot cleanly make
the two commits independent.

Initially, my goal was just to add ImplicitParams support, and
I found that reasonably straightforward, so figured I might
as well use my newfound knowledge to address some other TH omissions.

Test Plan: Validate

Reviewers: goldfire, austin, bgamari, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: carter, RyanGlScott, thomie

GHC Trac Issues: #1262

Differential Revision: https://phabricator.haskell.org/D1979
parent ce240b3f
......@@ -1137,6 +1137,10 @@ repTy (HsTyLit _ lit) = do
lit' <- repTyLit lit
repTLit lit'
repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
repTy (HsIParamTy _ n t) = do
n' <- rep_implicit_param_name (unLoc n)
t' <- repLTy t
repTImplicitParam n' t'
repTy ty = notHandled "Exotic form of type" (ppr ty)
......@@ -1206,7 +1210,7 @@ repE (HsVar _ (L _ x)) =
Just (DsBound y) -> repVarOrCon x (coreVar y)
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
repE e@(HsIPVar {}) = notHandled "Implicit parameters" (ppr e)
repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
repE (HsOverLabel _ _ s) = repOverLabel s
repE e@(HsRecFld _ f) = case f of
......@@ -1271,8 +1275,13 @@ repE e@(HsDo _ ctxt (L _ sts))
e' <- repComp (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| MDoExpr <- ctxt
= do { (ss,zs) <- repLSts sts;
e' <- repMDoE (nonEmptyCoreList zs);
wrapGenSyms ss e' }
| otherwise
= notHandled "mdo, monad comprehension and [: :]" (ppr e)
= notHandled "monad comprehension and [: :]" (ppr e)
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitTuple _ es boxed)
......@@ -1467,6 +1476,16 @@ repSts [LastStmt _ e _ _]
= do { e2 <- repLE e
; z <- repNoBindSt e2
; return ([], [z]) }
repSts (stmt@RecStmt{} : ss)
= do { let binders = collectLStmtsBinders (recS_stmts stmt)
; ss1 <- mkGenSyms binders
-- Bring all of binders in the recursive group into scope for the
-- whole group.
; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
; MASSERT(sort ss1 == sort ss1_other)
; z <- repRecSt (nonEmptyCoreList rss)
; (ss2,zs) <- addBinds ss1 (repSts ss)
; return (ss1++ss2, z : zs) }
repSts [] = return ([],[])
repSts other = notHandled "Exotic statement" (ppr other)
......@@ -1480,7 +1499,15 @@ repBinds (EmptyLocalBinds _)
= do { core_list <- coreList decQTyConName []
; return ([], core_list) }
repBinds b@(HsIPBinds {}) = notHandled "Implicit parameters" (ppr b)
repBinds (HsIPBinds _ (IPBinds _ decs))
= do { ips <- mapM rep_implicit_param_bind decs
; core_list <- coreList decQTyConName
(de_loc (sort_by_loc ips))
; return ([], core_list)
}
repBinds b@(HsIPBinds _ XHsIPBinds {})
= notHandled "Implicit parameter binds extension" (ppr b)
repBinds (HsValBinds _ decs)
= do { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
......@@ -1496,6 +1523,21 @@ repBinds (HsValBinds _ decs)
; return (ss, core_list) }
repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
rep_implicit_param_bind (L loc (IPBind _ ename (L _ rhs)))
= do { name <- case ename of
Left (L _ n) -> rep_implicit_param_name n
Right _ ->
panic "rep_implicit_param_bind: post typechecking"
; rhs' <- repE rhs
; ipb <- repImplicitParamBind name rhs'
; return (loc, ipb) }
rep_implicit_param_bind (L _ b@(XIPBind _))
= notHandled "Implicit parameter bind extension" (ppr b)
rep_implicit_param_name :: HsIPName -> DsM (Core String)
rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
-- Assumes: all the binders of the binding are already in the meta-env
rep_val_binds (XValBindsLR (NValBinds binds sigs))
......@@ -2008,6 +2050,9 @@ repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
repDoE (MkC ss) = rep2 doEName [ss]
repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
repMDoE (MkC ss) = rep2 mdoEName [ss]
repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
repComp (MkC ss) = rep2 compEName [ss]
......@@ -2035,6 +2080,9 @@ repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
------------ Right hand sides (guarded expressions) ----
repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
repGuarded (MkC pairs) = rep2 guardedBName [pairs]
......@@ -2068,6 +2116,9 @@ repNoBindSt (MkC e) = rep2 noBindSName [e]
repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
repParSt (MkC sss) = rep2 parSName [sss]
repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
repRecSt (MkC ss) = rep2 recSName [ss]
-------------- Range (Arithmetic sequences) -----------
repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
repFrom (MkC x) = rep2 fromEName [x]
......@@ -2249,6 +2300,9 @@ repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
repCtxt (MkC tys) = rep2 cxtName [tys]
......@@ -2350,6 +2404,9 @@ repTLit (MkC lit) = rep2 litTName [lit]
repTWildCard :: DsM (Core TH.TypeQ)
repTWildCard = rep2 wildCardTName []
repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
repTStar :: DsM (Core TH.TypeQ)
repTStar = rep2 starKName []
......
......@@ -399,6 +399,12 @@ cvtDec (TH.PatSynSigD nm ty)
; ty' <- cvtPatSynSigTy ty
; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}
-- Implicit parameter bindings are handled in cvtLocalDecs and
-- cvtImplicitParamBind. They are not allowed in any other scope, so
-- reaching this case indicates an error.
cvtDec (TH.ImplicitParamBindD _ _)
= failWith (text "Implicit parameter binding only allowed in let or where")
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn tc (TySynEqn lhs rhs)
......@@ -496,6 +502,10 @@ is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
is_bind decl = Right decl
is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
is_ip_bind decl = Right decl
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg doc bads
= sep [ text "Illegal declaration(s) in" <+> doc <> colon
......@@ -766,14 +776,19 @@ cvtRuleBndr (TypedRuleVar n ty)
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
cvtLocalDecs doc ds
| null ds
= return (EmptyLocalBinds noExt)
| otherwise
= do { ds' <- cvtDecs ds
; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs)) }
= case partitionWith is_ip_bind ds of
([], []) -> return (EmptyLocalBinds noExt)
([], _) -> do
ds' <- cvtDecs ds
let (binds, prob_sigs) = partitionWith is_bind ds'
let (sigs, bads) = partitionWith is_sig prob_sigs
unless (null bads) (failWith (mkBadDecMsg doc bads))
return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))
(ip_binds, []) -> do
binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
return (HsIPBinds noExt (IPBinds noExt binds))
((_:_), (_:_)) ->
failWith (text "Implicit parameters mixed with other bindings")
cvtClause :: HsMatchContext RdrName
-> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
......@@ -784,6 +799,11 @@ cvtClause ctxt (Clause ps body wheres)
; ds' <- cvtLocalDecs (text "a where clause") wheres
; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind n e = do
n' <- wrapL (ipName n)
e' <- cvtl e
returnL (IPBind noExt (Left n') e')
-------------------------------------------------------------------
-- Expressions
......@@ -859,6 +879,7 @@ cvtl e = wrapL (cvt e)
; return $ HsCase noExt e'
(mkMatchGroup FromSource ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (MDoE ss) = cvtHsDo MDoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
; return $ ArithSeq noExt Nothing dd' }
......@@ -918,6 +939,7 @@ cvtl e = wrapL (cvt e)
{ s' <- vcName s
; return $ HsVar noExt (noLoc s') }
cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }
cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1045,6 +1067,7 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss
where
cvt_one ds = do { ds' <- cvtStmts ds
; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }
cvtMatch :: HsMatchContext RdrName
-> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
......@@ -1396,6 +1419,11 @@ cvtTypeKind ty_str ty
| otherwise ->
mk_apps (HsTyVar noExt NotPromoted
(noLoc eqTyCon_RDR)) tys'
ImplicitParamT n t
-> do { n' <- wrapL $ ipName n
; t' <- cvtType t
; returnL (HsIParamTy noExt n' t')
}
_ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
}
......@@ -1632,6 +1660,11 @@ tName n = cvtName OccName.tvName n
tconNameL n = wrapL (tconName n)
tconName n = cvtName OccName.tcClsName n
ipName :: String -> CvtM HsIPName
ipName n
= do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))
; return (HsIPName (fsLit n)) }
cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName ctxt_ns (TH.Name occ flavour)
| not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
......
This diff is collapsed.
......@@ -1772,7 +1772,7 @@ reifyKind :: Kind -> TcM TH.Kind
reifyKind = reifyType
reifyCxt :: [PredType] -> TcM [TH.Pred]
reifyCxt = mapM reifyPred
reifyCxt = mapM reifyType
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
......@@ -1933,13 +1933,6 @@ reify_tc_app tc tys
in not (subVarSet result_vars dropped_vars)
reifyPred :: TyCoRep.PredType -> TcM TH.Pred
reifyPred ty
-- We could reify the invisible parameter as a class but it seems
-- nicer to support them properly...
| isIPPred ty = noTH (sLit "implicit parameters") (ppr ty)
| otherwise = reifyType ty
------------------------------
reifyName :: NamedThing n => n -> TH.Name
reifyName thing
......
......@@ -76,6 +76,8 @@ Template Haskell
longer included when reifying ``C``. It's possible that this may break some
code which assumes the existence of ``forall a. C a =>``.
- Template Haskell now supports implicit parameters and recursive do.
``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~
......
......@@ -37,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
......@@ -48,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
......@@ -113,6 +113,9 @@ module Language.Haskell.TH.Lib (
patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn,
infixPatSyn, recordPatSyn,
-- **** Implicit Parameters
implicitParamBindD,
-- ** Reify
thisModule
......
......@@ -165,6 +165,9 @@ 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
......@@ -305,6 +308,9 @@ 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) }
......@@ -339,6 +345,9 @@ 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)) }
......@@ -563,6 +572,14 @@ 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
......@@ -681,6 +698,12 @@ 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
......
......@@ -179,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 ';'
......@@ -203,6 +208,7 @@ pprExp i (StaticE e) = parensIf (i >= appPrec) $
text "static"<+> pprExp appPrec e
pprExp _ (UnboundVarE v) = pprName' Applied v
pprExp _ (LabelE s) = text "#" <> text s
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 @@ 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
......@@ -386,6 +393,8 @@ 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 =
......@@ -716,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
......@@ -784,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)
......
......@@ -1601,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
......@@ -1628,6 +1629,7 @@ data Exp
-- 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)
......@@ -1647,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
......@@ -1729,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.
......@@ -2015,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@
......
......@@ -18,6 +18,11 @@
* 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*
* Bundled with GHC 8.4.1
......
{-# LANGUAGE ImplicitParams #-}
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
funcToReify :: (?z :: Int) => Int
funcToReify = ?z
$( [d|
f :: (?x :: Int) => Int
f = let ?y = 2 in ?x + ?y |] )
main = do
putStrLn $(lift . pprint =<< reify 'funcToReify)
print (let ?x = 3 in f)
print $( [| let ?x = 1 in ?x |] )
print $(letE [implicitParamBindD "y" (lift (2 :: Int))]
(implicitParamVarE "y") )
putStrLn $( lift . pprint =<< [d|
f :: (?x :: Int) => Int
f = let ?y = 2 in ?x + ?y |] )
Main.funcToReify :: GHC.Classes.IP "z" GHC.Types.Int =>
GHC.Types.Int
5
1
2
f_0 :: (?x :: GHC.Types.Int) => GHC.Types.Int
f_0 = let ?y = 2
in ?x GHC.Num.+ ?y
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH
$(fmap (:[]) (implicitParamBindD "x" [e| 1 |]))
TH_implicitParamsErr1.hs:5:3: error:
Implicit parameter binding only allowed in let or where
When splicing a TH declaration: ?x = 1
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH
main = $(letE [ implicitParamBindD "x" [e| 1 |]
, funD (mkName "y") [clause [] (normalB [e| 2 |]) []]
]
(varE (mkName "y")))
TH_implicitParamsErr2.hs:5:10: error:
• Implicit parameters mixed with other bindings
When splicing a TH expression: let {?x = 1; y = 2}
in y
• In the untyped splice:
$(letE
[implicitParamBindD "x" [| 1 |],
funD (mkName "y") [clause [] (normalB [| 2 |]) []]]
(varE (mkName "y")))
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH
main = print $(letE [implicitParamBindD "invalid name" [e| "hi" |]]
(implicitParamVarE "invalid name"))
TH_implicitParamsErr3.hs:5:16: error:
• Illegal variable name: ‘invalid name’
When splicing a TH expression:
let ?invalid name = "hi"
in ?invalid name
• In the untyped splice:
$(letE
[implicitParamBindD "invalid name" [| "hi" |]]
(implicitParamVarE "invalid name"))
{-# LANGUAGE RecursiveDo #-}
import Data.IORef
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import TH_recursiveDoImport
main = testRec >> testMdo
testRec = do
putStrLn $(lift . pprint =<< recIO)
-- Test that we got the expected structure.
SelfRef r1 <- $(recIO)
r2 <- readIORef r1
SelfRef r1' <- readIORef r2
print (r1 == r1')
testMdo =
putStrLn $(lift . pprint =<< mdoIO)
do {rec {r1_0 <- GHC.IORef.newIORef r2_1;
r2_1 <- GHC.IORef.newIORef (TH_recursiveDoImport.SelfRef r1_0)};
GHC.IORef.readIORef r2_1}
True
mdo {rec {r1_0 <- GHC.Base.return r2_1;
r2_1 <- GHC.Base.return (GHC.Base.const 1 r1_0)};
GHC.Base.return r1_0}
{-# LANGUAGE RecursiveDo #-}
module TH_recursiveDoImport where
import Data.IORef
import Language.Haskell.TH
data SelfRef = SelfRef (IORef (IORef SelfRef))
recIO :: ExpQ
recIO = [e|
do rec r1 <- newIORef r2
r2 <- newIORef (SelfRef r1)
readIORef r2 |]
mdoIO :: ExpQ
mdoIO = [e|
mdo r1 <- return r2
r2 <- return (const 1 r1)
return r1 |]
emptyRecIO :: ExpQ
emptyRecIO = [e|
do rec {}
return () |]
......@@ -429,3 +429,8 @@ test('T15550', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T15502', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T15518', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T15572', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('TH_implicitParams', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
test('TH_implicitParamsErr1', normal, compile_fail, ['-v0 -dsuppress-uniques'])
test('TH_implicitParamsErr2', normal, compile_fail, ['-v0 -dsuppress-uniques'])
test('TH_implicitParamsErr3', normal, compile_fail, ['-v0 -dsuppress-uniques'])
test('TH_recursiveDo', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment