Commit 512eeb9b authored by mayac's avatar mayac Committed by Richard Eisenberg

More explicit foralls (GHC Proposal 0007)

Allow the user to explicitly bind type/kind variables in type and data
family instances (including associated instances), closed type family
equations, and RULES pragmas. Follows the specification of GHC
Proposal 0007, also fixes #2600. Advised by Richard Eisenberg.

This modifies the Template Haskell AST -- old code may break!

Other Changes:
- convert HsRule to a record
- make rnHsSigWcType more general
- add repMaybe to DsMeta

Includes submodule update for Haddock.

Test Plan: validate

Reviewers: goldfire, bgamari, alanz

Subscribers: simonpj, RyanGlScott, goldfire, rwbarton,
             thomie, mpickering, carter

GHC Trac Issues: #2600, #14268

Differential Revision: https://phabricator.haskell.org/D4894
parent 23956b2a
...@@ -973,7 +973,7 @@ translatePat fam_insts pat = case pat of ...@@ -973,7 +973,7 @@ translatePat fam_insts pat = case pat of
g = PmGrd [PmVar (unLoc lid)] e g = PmGrd [PmVar (unLoc lid)] e
return (ps ++ [g]) return (ps ++ [g])
SigPat _ty p -> translatePat fam_insts (unLoc p) SigPat _ p _ty -> translatePat fam_insts (unLoc p)
-- See Note [Translate CoPats] -- See Note [Translate CoPats]
CoPat _ wrapper p ty CoPat _ wrapper p ty
......
...@@ -500,9 +500,9 @@ addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x) ...@@ -500,9 +500,9 @@ addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
(addTickMatchGroup True mgs) (addTickMatchGroup True mgs)
addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1) addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
(addTickLHsExpr e2) (addTickLHsExpr e2)
addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty) addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)
(addTickLHsExprNever e) (addTickLHsExprNever e)
(return ty)
addTickHsExpr (OpApp fix e1 e2 e3) = addTickHsExpr (OpApp fix e1 e2 e3) =
liftM4 OpApp liftM4 OpApp
...@@ -578,11 +578,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds }) ...@@ -578,11 +578,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds ; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) } ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
addTickHsExpr (ExprWithTySig ty e) = addTickHsExpr (ExprWithTySig x e ty) =
liftM2 ExprWithTySig liftM3 ExprWithTySig
(return ty) (return x)
(addTickLHsExprNever e) -- No need to tick the inner expression (addTickLHsExprNever e) -- No need to tick the inner expression
-- for expressions with signatures -- for expressions with signatures
(return ty)
addTickHsExpr (ArithSeq ty wit arith_seq) = addTickHsExpr (ArithSeq ty wit arith_seq) =
liftM3 ArithSeq liftM3 ArithSeq
(return ty) (return ty)
......
...@@ -379,7 +379,11 @@ Reason ...@@ -379,7 +379,11 @@ Reason
-} -}
dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
dsRule (L loc (HsRule _ name rule_act vars lhs rhs)) dsRule (L loc (HsRule { rd_name = name
, rd_act = rule_act
, rd_tmvs = vars
, rd_lhs = lhs
, rd_rhs = rhs }))
= putSrcSpanDs loc $ = putSrcSpanDs loc $
do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars] do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
...@@ -497,7 +501,7 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList. ...@@ -497,7 +501,7 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList.
That keeps the desugaring of list comprehensions simple too. That keeps the desugaring of list comprehensions simple too.
Nor do we want to warn of conversion identities on the LHS; Nor do we want to warn of conversion identities on the LHS;
the rule is precisly to optimise them: the rule is precisely to optimise them:
{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
Note [Desugaring coerce as cast] Note [Desugaring coerce as cast]
......
...@@ -1224,7 +1224,7 @@ collectl (L _ pat) bndrs ...@@ -1224,7 +1224,7 @@ collectl (L _ pat) bndrs
go (NPat {}) = bndrs go (NPat {}) = bndrs
go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs
go (SigPat _ pat) = collectl pat bndrs go (SigPat _ pat _) = collectl pat bndrs
go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs go (CoPat _ _ pat _) = collectl (noLoc pat) bndrs
go (ViewPat _ _ pat) = collectl pat bndrs go (ViewPat _ _ pat) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p) go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
......
...@@ -257,7 +257,7 @@ ds_expr :: Bool -- are we directly inside an HsWrap? ...@@ -257,7 +257,7 @@ ds_expr :: Bool -- are we directly inside an HsWrap?
-- See Wrinkle in Note [Detecting forced eta expansion] -- See Wrinkle in Note [Detecting forced eta expansion]
-> HsExpr GhcTc -> DsM CoreExpr -> HsExpr GhcTc -> DsM CoreExpr
ds_expr _ (HsPar _ e) = dsLExpr e ds_expr _ (HsPar _ e) = dsLExpr e
ds_expr _ (ExprWithTySig _ e) = dsLExpr e ds_expr _ (ExprWithTySig _ e _) = dsLExpr e
ds_expr w (HsVar _ (L _ var)) = dsHsVar w var ds_expr w (HsVar _ (L _ var)) = dsHsVar w var
ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them ds_expr _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
ds_expr w (HsConLikeOut _ con) = dsConLike w con ds_expr w (HsConLikeOut _ con) = dsConLike w con
...@@ -302,7 +302,7 @@ ds_expr _ e@(HsApp _ fun arg) ...@@ -302,7 +302,7 @@ ds_expr _ e@(HsApp _ fun arg)
; dsWhenNoErrs (dsLExprNoLP arg) ; dsWhenNoErrs (dsLExprNoLP arg)
(\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') } (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
ds_expr _ (HsAppType _ e) ds_expr _ (HsAppType _ e _)
-- ignore type arguments here; they're in the wrappers instead at this point -- ignore type arguments here; they're in the wrappers instead at this point
= dsLExpr e = dsLExpr e
......
...@@ -310,7 +310,7 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs })) ...@@ -310,7 +310,7 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn })) repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs -> ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
repDataDefn tc1 bndrs Nothing defn repDataDefn tc1 (Left bndrs) defn
; return (Just (loc, dec)) } ; return (Just (loc, dec)) }
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
...@@ -344,11 +344,14 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles)) ...@@ -344,11 +344,14 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD" repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD"
------------------------- -------------------------
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ] repDataDefn :: Core TH.Name
-> Maybe (Core [TH.TypeQ]) -> Either (Core [TH.TyVarBndrQ])
-- the repTyClD case
(Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
-- the repDataFamInstD case
-> HsDataDefn GhcRn -> HsDataDefn GhcRn
-> DsM (Core TH.DecQ) -> DsM (Core TH.DecQ)
repDataDefn tc bndrs opt_tys repDataDefn tc opts
(HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
, dd_cons = cons, dd_derivs = mb_derivs }) , dd_cons = cons, dd_derivs = mb_derivs })
= do { cxt1 <- repLContext cxt = do { cxt1 <- repLContext cxt
...@@ -356,7 +359,7 @@ repDataDefn tc bndrs opt_tys ...@@ -356,7 +359,7 @@ repDataDefn tc bndrs opt_tys
; case (new_or_data, cons) of ; case (new_or_data, cons) of
(NewType, [con]) -> do { con' <- repC con (NewType, [con]) -> do { con' <- repC con
; ksig' <- repMaybeLTy ksig ; ksig' <- repMaybeLTy ksig
; repNewtype cxt1 tc bndrs opt_tys ksig' con' ; repNewtype cxt1 tc opts ksig' con'
derivs1 } derivs1 }
(NewType, _) -> failWithDs (text "Multiple constructors for newtype:" (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
<+> pprQuotedList <+> pprQuotedList
...@@ -364,10 +367,10 @@ repDataDefn tc bndrs opt_tys ...@@ -364,10 +367,10 @@ repDataDefn tc bndrs opt_tys
(DataType, _) -> do { ksig' <- repMaybeLTy ksig (DataType, _) -> do { ksig' <- repMaybeLTy ksig
; consL <- mapM repC cons ; consL <- mapM repC cons
; cons1 <- coreList conQTyConName consL ; cons1 <- coreList conQTyConName consL
; repData cxt1 tc bndrs opt_tys ksig' cons1 ; repData cxt1 tc opts ksig' cons1
derivs1 } derivs1 }
} }
repDataDefn _ _ _ (XHsDataDefn _) = panic "repDataDefn" repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ] repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> LHsType GhcRn -> LHsType GhcRn
...@@ -455,14 +458,17 @@ repAssocTyFamDefaults = mapM rep_deflt ...@@ -455,14 +458,17 @@ repAssocTyFamDefaults = mapM rep_deflt
-- very like repTyFamEqn, but different in the details -- very like repTyFamEqn, but different in the details
rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ) rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
rep_deflt (L _ (FamEqn { feqn_tycon = tc rep_deflt (L _ (FamEqn { feqn_tycon = tc
, feqn_pats = bndrs , feqn_bndrs = bndrs
, feqn_pats = tys
, feqn_rhs = rhs })) , feqn_rhs = rhs }))
= addTyClTyVarBinds bndrs $ \ _ -> = addTyClTyVarBinds tys $ \ _ ->
do { tc1 <- lookupLOcc tc do { tc1 <- lookupLOcc tc
; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs) ; no_bndrs <- ASSERT( isNothing bndrs )
coreNothingList tyVarBndrQTyConName
; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
; tys2 <- coreList typeQTyConName tys1 ; tys2 <- coreList typeQTyConName tys1
; rhs1 <- repLTy rhs ; rhs1 <- repLTy rhs
; eqn1 <- repTySynEqn tys2 rhs1 ; eqn1 <- repTySynEqn no_bndrs tys2 rhs1
; repTySynInst tc1 eqn1 } ; repTySynInst tc1 eqn1 }
rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults" rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
...@@ -544,17 +550,21 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) ...@@ -544,17 +550,21 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
repTyFamEqn (HsIB { hsib_ext = var_names repTyFamEqn (HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_pats = tys , hsib_body = FamEqn { feqn_bndrs = mb_bndrs
, feqn_pats = tys
, feqn_rhs = rhs }}) , feqn_rhs = rhs }})
= do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = var_names { hsq_implicit = var_names
, hsq_dependent = emptyNameSet } -- Yuk , hsq_dependent = emptyNameSet } -- Yuk
, hsq_explicit = [] } , hsq_explicit = fromMaybe [] mb_bndrs }
; addTyClTyVarBinds hs_tvs $ \ _ -> ; addTyClTyVarBinds hs_tvs $ \ _ ->
do { tys1 <- repLTys tys do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
repTyVarBndr
mb_bndrs
; tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1 ; tys2 <- coreList typeQTyConName tys1
; rhs1 <- repLTy rhs ; rhs1 <- repLTy rhs
; repTySynEqn tys2 rhs1 } } ; repTySynEqn mb_bndrs1 tys2 rhs1 } }
repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn" repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn" repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
...@@ -562,16 +572,20 @@ repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) ...@@ -562,16 +572,20 @@ repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_eqn = repDataFamInstD (DataFamInstDecl { dfid_eqn =
(HsIB { hsib_ext = var_names (HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_tycon = tc_name , hsib_body = FamEqn { feqn_tycon = tc_name
, feqn_bndrs = mb_bndrs
, feqn_pats = tys , feqn_pats = tys
, feqn_rhs = defn }})}) , feqn_rhs = defn }})})
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = var_names { hsq_implicit = var_names
, hsq_dependent = emptyNameSet } -- Yuk , hsq_dependent = emptyNameSet } -- Yuk
, hsq_explicit = [] } , hsq_explicit = fromMaybe [] mb_bndrs }
; addTyClTyVarBinds hs_tvs $ \ bndrs -> ; addTyClTyVarBinds hs_tvs $ \ _ ->
do { tys1 <- repList typeQTyConName repLTy tys do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
; repDataDefn tc bndrs (Just tys1) defn } } repTyVarBndr
mb_bndrs
; tys1 <- repList typeQTyConName repLTy tys
; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _)) repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
= panic "repDataFamInstD" = panic "repDataFamInstD"
repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _))) repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
...@@ -633,18 +647,29 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir))) ...@@ -633,18 +647,29 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
repFixD (L _ (XFixitySig _)) = panic "repFixD" repFixD (L _ (XFixitySig _)) = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ) repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule _ n act bndrs lhs rhs)) repRuleD (L loc (HsRule { rd_name = n
= do { let bndr_names = concatMap ruleBndrNames bndrs , rd_act = act
; ss <- mkGenSyms bndr_names , rd_tyvs = ty_bndrs
; rule1 <- addBinds ss $ , rd_tmvs = tm_bndrs
do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs , rd_lhs = lhs
; n' <- coreStringLit $ unpackFS $ snd $ unLoc n , rd_rhs = rhs }))
; act' <- repPhases act = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
; lhs' <- repLE lhs do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
; rhs' <- repLE rhs ; ss <- mkGenSyms tm_bndr_names
; repPragRule n' bndrs' lhs' rhs' act' } ; rule <- addBinds ss $
; rule2 <- wrapGenSyms ss rule1 do { ty_bndrs' <- case ty_bndrs of
; return (loc, rule2) } Nothing -> coreNothingList tyVarBndrQTyConName
Just _ -> coreJustList tyVarBndrQTyConName ex_bndrs
; tm_bndrs' <- repList ruleBndrQTyConName
repRuleBndr
tm_bndrs
; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
; act' <- repPhases act
; lhs' <- repLE lhs
; rhs' <- repLE rhs
; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
; wrapGenSyms ss rule }
; return (loc, rule) }
repRuleD (L _ (XRuleDecl _)) = panic "repRuleD" repRuleD (L _ (XRuleDecl _)) = panic "repRuleD"
ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames :: LRuleBndr GhcRn -> [Name]
...@@ -936,15 +961,10 @@ rep_complete_sig :: Located [Located Name] ...@@ -936,15 +961,10 @@ rep_complete_sig :: Located [Located Name]
-> SrcSpan -> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)] -> DsM [(SrcSpan, Core TH.DecQ)]
rep_complete_sig (L _ cls) mty loc rep_complete_sig (L _ cls) mty loc
= do { mty' <- rep_maybe_name mty = do { mty' <- repMaybe nameTyConName lookupLOcc mty
; cls' <- repList nameTyConName lookupLOcc cls ; cls' <- repList nameTyConName lookupLOcc cls
; sig <- repPragComplete cls' mty' ; sig <- repPragComplete cls' mty'
; return [(loc, sig)] } ; return [(loc, sig)] }
where
rep_maybe_name Nothing = coreNothing nameTyConName
rep_maybe_name (Just n) = do
cn <- lookupLOcc n
coreJust nameTyConName cn
------------------------------------------------------- -------------------------------------------------------
-- Types -- Types
...@@ -1154,11 +1174,7 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s ...@@ -1154,11 +1174,7 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
-- | Represent a type wrapped in a Maybe -- | Represent a type wrapped in a Maybe
repMaybeLTy :: Maybe (LHsKind GhcRn) repMaybeLTy :: Maybe (LHsKind GhcRn)
-> DsM (Core (Maybe TH.TypeQ)) -> DsM (Core (Maybe TH.TypeQ))
repMaybeLTy Nothing = repMaybeLTy = repMaybe kindQTyConName repLTy
do { coreNothing kindQTyConName }
repMaybeLTy (Just ki) =
do { ki' <- repLTy ki
; coreJust kindQTyConName ki' }
repRole :: Located (Maybe Role) -> DsM (Core TH.Role) repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
repRole (L _ (Just Nominal)) = rep2 nominalRName [] repRole (L _ (Just Nominal)) = rep2 nominalRName []
...@@ -1228,9 +1244,9 @@ repE (HsLamCase _ (MG { mg_alts = L _ ms })) ...@@ -1228,9 +1244,9 @@ repE (HsLamCase _ (MG { mg_alts = L _ ms }))
; core_ms <- coreList matchQTyConName ms' ; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms } ; repLamCase core_ms }
repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b} repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (HsAppType t e) = do { a <- repLE e repE (HsAppType _ e t) = do { a <- repLE e
; s <- repLTy (hswc_body t) ; s <- repLTy (hswc_body t)
; repAppType a s } ; repAppType a s }
repE (OpApp _ e1 op e2) = repE (OpApp _ e1 op e2) =
do { arg1 <- repLE e1; do { arg1 <- repLE e1;
...@@ -1303,7 +1319,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds }) ...@@ -1303,7 +1319,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds; fs <- repUpdFields flds;
repRecUpd x fs } repRecUpd x fs }
repE (ExprWithTySig ty e) repE (ExprWithTySig _ e ty)
= do { e1 <- repLE e = do { e1 <- repLE e
; t1 <- repHsSigWcType ty ; t1 <- repHsSigWcType ty
; repSigExp e1 t1 } ; repSigExp e1 t1 }
...@@ -1772,9 +1788,9 @@ repP (ConPatIn dc details) ...@@ -1772,9 +1788,9 @@ repP (ConPatIn dc details)
repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a } repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l; repPlit a }
repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p) repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP (SigPat t p) = do { p' <- repLP p repP (SigPat _ p t) = do { p' <- repLP p
; t' <- repLTy (hsSigWcType t) ; t' <- repLTy (hsSigWcType t)
; repPsig p' t' } ; repPsig p' t' }
repP (SplicePat _ splice) = repSplice splice repP (SplicePat _ splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other) repP other = notHandled "Exotic pattern" (ppr other)
...@@ -2146,24 +2162,28 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds] ...@@ -2146,24 +2162,28 @@ repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ) repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] repData :: Core TH.CxtQ -> Core TH.Name
-> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ) -> Either (Core [TH.TyVarBndrQ])
-> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs) -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
-> DsM (Core TH.DecQ)
repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
= rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons) repData (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
(MkC derivs) (MkC cons) (MkC derivs)
= rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs] = rep2 dataInstDName [cxt, nm, mb_bndrs, tys, ksig, cons, derivs]
repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ] repNewtype :: Core TH.CxtQ -> Core TH.Name
-> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ) -> Either (Core [TH.TyVarBndrQ])
-> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con) -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
-> DsM (Core TH.DecQ)
repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
(MkC derivs) (MkC derivs)
= rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con) repNewtype (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
(MkC derivs) (MkC con) (MkC derivs)
= rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs] = rep2 newtypeInstDName [cxt, nm, mb_bndrs, tys, ksig, con, derivs]
repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ] repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> Core TH.TypeQ -> DsM (Core TH.DecQ) -> Core TH.TypeQ -> DsM (Core TH.DecQ)
...@@ -2253,10 +2273,11 @@ repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] ...@@ -2253,10 +2273,11 @@ repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ) repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
-> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ) -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases) -> Core TH.Phases -> DsM (Core TH.DecQ)
= rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases] repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
= rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ) repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
...@@ -2287,9 +2308,10 @@ repClosedFamilyD :: Core TH.Name ...@@ -2287,9 +2308,10 @@ repClosedFamilyD :: Core TH.Name
repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
= rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
repTySynEqn (MkC lhs) (MkC rhs) Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
= rep2 tySynEqnName [lhs, rhs] repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
= rep2 tySynEqnName [mb_bndrs, lhs, rhs]
repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ) repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles] repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
...@@ -2591,6 +2613,11 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } ...@@ -2591,6 +2613,11 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------------- Maybe ------------------ ------------------- Maybe ------------------
repMaybe :: Name -> (a -> DsM (Core b))
-> Maybe a -> DsM (Core (Maybe b))
repMaybe tc_name _ Nothing = coreNothing tc_name
repMaybe tc_name f (Just es) = coreJust tc_name =<< f es
-- | Construct Core expression for Nothing of a given type name -- | Construct Core expression for Nothing of a given type name
coreNothing :: Name -- ^ Name of the TyCon of the element type coreNothing :: Name -- ^ Name of the TyCon of the element type
-> DsM (Core (Maybe a)) -> DsM (Core (Maybe a))
...@@ -2613,6 +2640,26 @@ coreJust' :: Type -- ^ The element type ...@@ -2613,6 +2640,26 @@ coreJust' :: Type -- ^ The element type
-> Core a -> Core (Maybe a) -> Core a -> Core (Maybe a)
coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es)) coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
------------------- Maybe Lists ------------------
repMaybeList :: Name -> (a -> DsM (Core b))
-> Maybe [a] -> DsM (Core (Maybe [b]))
repMaybeList tc_name _ Nothing = coreNothingList tc_name
repMaybeList tc_name f (Just args)
= do { elt_ty <- lookupType tc_name
; args1 <- mapM f args
; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
coreNothingList :: Name -> DsM (Core (Maybe [a]))
coreNothingList tc_name
= do { elt_ty <- lookupType tc_name
; return $ coreNothing' (mkListTy elt_ty) }
coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))
coreJustList tc_name args
= do { elt_ty <- lookupType tc_name
; return $ coreJust' (mkListTy elt_ty) args }
------------ Literals & Variables ------------------- ------------ Literals & Variables -------------------
coreIntLit :: Int -> DsM (Core Int) coreIntLit :: Int -> DsM (Core Int)
......
...@@ -402,7 +402,7 @@ tidy1 :: Id -- The Id being scrutinised ...@@ -402,7 +402,7 @@ tidy1 :: Id -- The Id being scrutinised
-- list patterns, etc) and returns any created bindings in the wrapper. -- list patterns, etc) and returns any created bindings in the wrapper.