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
g = PmGrd [PmVar (unLoc lid)] e
return (ps ++ [g])
SigPat _ty p -> translatePat fam_insts (unLoc p)
SigPat _ p _ty -> translatePat fam_insts (unLoc p)
-- See Note [Translate CoPats]
CoPat _ wrapper p ty
......
......@@ -500,9 +500,9 @@ addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)
(addTickMatchGroup True mgs)
addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)
(addTickLHsExpr e2)
addTickHsExpr (HsAppType ty e) = liftM2 HsAppType (return ty)
(addTickLHsExprNever e)
addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)
(addTickLHsExprNever e)
(return ty)
addTickHsExpr (OpApp fix e1 e2 e3) =
liftM4 OpApp
......@@ -578,11 +578,12 @@ addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
; flds' <- mapM addTickHsRecField flds
; return (expr { rupd_expr = e', rupd_flds = flds' }) }
addTickHsExpr (ExprWithTySig ty e) =
liftM2 ExprWithTySig
(return ty)
addTickHsExpr (ExprWithTySig x e ty) =
liftM3 ExprWithTySig
(return x)
(addTickLHsExprNever e) -- No need to tick the inner expression
-- for expressions with signatures
(return ty)
addTickHsExpr (ArithSeq ty wit arith_seq) =
liftM3 ArithSeq
(return ty)
......
......@@ -379,7 +379,11 @@ Reason
-}
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 $
do { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
......@@ -497,7 +501,7 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList.
That keeps the desugaring of list comprehensions simple too.
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 #-}
Note [Desugaring coerce as cast]
......
......@@ -1224,7 +1224,7 @@ collectl (L _ pat) bndrs
go (NPat {}) = 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 (ViewPat _ _ pat) = collectl pat bndrs
go p@(SplicePat {}) = pprPanic "collectl/go" (ppr p)
......
......@@ -257,7 +257,7 @@ ds_expr :: Bool -- are we directly inside an HsWrap?
-- See Wrinkle in Note [Detecting forced eta expansion]
-> HsExpr GhcTc -> DsM CoreExpr
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 _ (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
ds_expr w (HsConLikeOut _ con) = dsConLike w con
......@@ -302,7 +302,7 @@ ds_expr _ e@(HsApp _ fun arg)
; dsWhenNoErrs (dsLExprNoLP 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
= dsLExpr e
......
......@@ -310,7 +310,7 @@ repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
repTyClD (L loc (DataDecl { tcdLName = tc, tcdTyVars = tvs, tcdDataDefn = defn }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; dec <- addTyClTyVarBinds tvs $ \bndrs ->
repDataDefn tc1 bndrs Nothing defn
repDataDefn tc1 (Left bndrs) defn
; return (Just (loc, dec)) }
repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
......@@ -344,11 +344,14 @@ repRoleD (L loc (RoleAnnotDecl _ tycon roles))
repRoleD (L _ (XRoleAnnotDecl _)) = panic "repRoleD"
-------------------------
repDataDefn :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> Maybe (Core [TH.TypeQ])
repDataDefn :: Core TH.Name
-> Either (Core [TH.TyVarBndrQ])
-- the repTyClD case
(Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
-- the repDataFamInstD case
-> HsDataDefn GhcRn
-> DsM (Core TH.DecQ)
repDataDefn tc bndrs opt_tys
repDataDefn tc opts
(HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
, dd_cons = cons, dd_derivs = mb_derivs })
= do { cxt1 <- repLContext cxt
......@@ -356,7 +359,7 @@ repDataDefn tc bndrs opt_tys
; case (new_or_data, cons) of
(NewType, [con]) -> do { con' <- repC con
; ksig' <- repMaybeLTy ksig
; repNewtype cxt1 tc bndrs opt_tys ksig' con'
; repNewtype cxt1 tc opts ksig' con'
derivs1 }
(NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
<+> pprQuotedList
......@@ -364,10 +367,10 @@ repDataDefn tc bndrs opt_tys
(DataType, _) -> do { ksig' <- repMaybeLTy ksig
; consL <- mapM repC cons
; cons1 <- coreList conQTyConName consL
; repData cxt1 tc bndrs opt_tys ksig' cons1
; repData cxt1 tc opts ksig' cons1
derivs1 }
}
repDataDefn _ _ _ (XHsDataDefn _) = panic "repDataDefn"
repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> LHsType GhcRn
......@@ -455,14 +458,17 @@ repAssocTyFamDefaults = mapM rep_deflt
-- very like repTyFamEqn, but different in the details
rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
rep_deflt (L _ (FamEqn { feqn_tycon = tc
, feqn_pats = bndrs
, feqn_bndrs = bndrs
, feqn_pats = tys
, feqn_rhs = rhs }))
= addTyClTyVarBinds bndrs $ \ _ ->
= addTyClTyVarBinds tys $ \ _ ->
do { tc1 <- lookupLOcc tc
; tys1 <- repLTys (hsLTyVarBndrsToTypes bndrs)
; no_bndrs <- ASSERT( isNothing bndrs )
coreNothingList tyVarBndrQTyConName
; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
; tys2 <- coreList typeQTyConName tys1
; rhs1 <- repLTy rhs
; eqn1 <- repTySynEqn tys2 rhs1
; eqn1 <- repTySynEqn no_bndrs tys2 rhs1
; repTySynInst tc1 eqn1 }
rep_deflt (L _ (XFamEqn _)) = panic "repAssocTyFamDefaults"
......@@ -544,17 +550,21 @@ repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
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 }})
= do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = var_names
, hsq_dependent = emptyNameSet } -- Yuk
, hsq_explicit = [] }
, hsq_explicit = fromMaybe [] mb_bndrs }
; addTyClTyVarBinds hs_tvs $ \ _ ->
do { tys1 <- repLTys tys
do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
repTyVarBndr
mb_bndrs
; tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1
; rhs1 <- repLTy rhs
; repTySynEqn tys2 rhs1 } }
; repTySynEqn mb_bndrs1 tys2 rhs1 } }
repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
......@@ -562,16 +572,20 @@ repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repDataFamInstD (DataFamInstDecl { dfid_eqn =
(HsIB { hsib_ext = var_names
, hsib_body = FamEqn { feqn_tycon = tc_name
, feqn_bndrs = mb_bndrs
, feqn_pats = tys
, feqn_rhs = defn }})})
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
{ hsq_implicit = var_names
, hsq_dependent = emptyNameSet } -- Yuk
, hsq_explicit = [] }
; addTyClTyVarBinds hs_tvs $ \ bndrs ->
do { tys1 <- repList typeQTyConName repLTy tys
; repDataDefn tc bndrs (Just tys1) defn } }
, hsq_explicit = fromMaybe [] mb_bndrs }
; addTyClTyVarBinds hs_tvs $ \ _ ->
do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
repTyVarBndr
mb_bndrs
; tys1 <- repList typeQTyConName repLTy tys
; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
= panic "repDataFamInstD"
repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
......@@ -633,18 +647,29 @@ repFixD (L loc (FixitySig _ names (Fixity _ prec dir)))
repFixD (L _ (XFixitySig _)) = panic "repFixD"
repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
repRuleD (L loc (HsRule _ n act bndrs lhs rhs))
= do { let bndr_names = concatMap ruleBndrNames bndrs
; ss <- mkGenSyms bndr_names
; rule1 <- addBinds ss $
do { bndrs' <- repList ruleBndrQTyConName repRuleBndr bndrs
; n' <- coreStringLit $ unpackFS $ snd $ unLoc n
; act' <- repPhases act
; lhs' <- repLE lhs
; rhs' <- repLE rhs
; repPragRule n' bndrs' lhs' rhs' act' }
; rule2 <- wrapGenSyms ss rule1
; return (loc, rule2) }
repRuleD (L loc (HsRule { rd_name = n
, rd_act = act
, rd_tyvs = ty_bndrs
, rd_tmvs = tm_bndrs
, rd_lhs = lhs
, rd_rhs = rhs }))
= do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
; ss <- mkGenSyms tm_bndr_names
; rule <- addBinds ss $
do { ty_bndrs' <- case ty_bndrs of
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"
ruleBndrNames :: LRuleBndr GhcRn -> [Name]
......@@ -936,15 +961,10 @@ rep_complete_sig :: Located [Located Name]
-> SrcSpan
-> DsM [(SrcSpan, Core TH.DecQ)]
rep_complete_sig (L _ cls) mty loc
= do { mty' <- rep_maybe_name mty
= do { mty' <- repMaybe nameTyConName lookupLOcc mty
; cls' <- repList nameTyConName lookupLOcc cls
; sig <- repPragComplete cls' mty'
; return [(loc, sig)] }
where
rep_maybe_name Nothing = coreNothing nameTyConName
rep_maybe_name (Just n) = do
cn <- lookupLOcc n
coreJust nameTyConName cn
-------------------------------------------------------
-- Types
......@@ -1154,11 +1174,7 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
-- | Represent a type wrapped in a Maybe
repMaybeLTy :: Maybe (LHsKind GhcRn)
-> DsM (Core (Maybe TH.TypeQ))
repMaybeLTy Nothing =
do { coreNothing kindQTyConName }
repMaybeLTy (Just ki) =
do { ki' <- repLTy ki
; coreJust kindQTyConName ki' }
repMaybeLTy = repMaybe kindQTyConName repLTy
repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
repRole (L _ (Just Nominal)) = rep2 nominalRName []
......@@ -1228,9 +1244,9 @@ repE (HsLamCase _ (MG { mg_alts = L _ ms }))
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (HsAppType t e) = do { a <- repLE e
; s <- repLTy (hswc_body t)
; repAppType a s }
repE (HsAppType _ e t) = do { a <- repLE e
; s <- repLTy (hswc_body t)
; repAppType a s }
repE (OpApp _ e1 op e2) =
do { arg1 <- repLE e1;
......@@ -1303,7 +1319,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds;
repRecUpd x fs }
repE (ExprWithTySig ty e)
repE (ExprWithTySig _ e ty)
= do { e1 <- repLE e
; t1 <- repHsSigWcType ty
; repSigExp e1 t1 }
......@@ -1772,9 +1788,9 @@ repP (ConPatIn dc details)
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 p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
repP (SigPat t p) = do { p' <- repLP p
; t' <- repLTy (hsSigWcType t)
; repPsig p' t' }
repP (SigPat _ p t) = do { p' <- repLP p
; t' <- repLTy (hsSigWcType t)
; repPsig p' t' }
repP (SplicePat _ splice) = repSplice splice
repP other = notHandled "Exotic pattern" (ppr other)
......@@ -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 (MkC nm) (MkC b) = rep2 funDName [nm, b]
repData :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
-> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
-> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
repData (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC cons) (MkC derivs)
repData :: Core TH.CxtQ -> Core TH.Name
-> Either (Core [TH.TyVarBndrQ])
(Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
-> 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]
repData (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC cons)
(MkC derivs)
= rep2 dataInstDName [cxt, nm, tys, ksig, cons, derivs]
repNewtype :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
-> Maybe (Core [TH.TypeQ]) -> Core (Maybe TH.KindQ)
-> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ)
repNewtype (MkC cxt) (MkC nm) (MkC tvs) Nothing (MkC ksig) (MkC con)
repData (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
(MkC cons) (MkC derivs)
= rep2 dataInstDName [cxt, nm, mb_bndrs, tys, ksig, cons, derivs]
repNewtype :: Core TH.CxtQ -> Core TH.Name
-> Either (Core [TH.TyVarBndrQ])
(Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ])
-> 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)
= rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
repNewtype (MkC cxt) (MkC nm) (MkC _) (Just (MkC tys)) (MkC ksig) (MkC con)
(MkC derivs)
= rep2 newtypeInstDName [cxt, nm, tys, ksig, con, derivs]
repNewtype (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig)
(MkC con) (MkC derivs)
= rep2 newtypeInstDName [cxt, nm, mb_bndrs, tys, ksig, con, derivs]
repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
-> Core TH.TypeQ -> DsM (Core TH.DecQ)
......@@ -2253,10 +2273,11 @@ repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
repPragRule :: Core String -> Core [TH.RuleBndrQ] -> Core TH.ExpQ
-> Core TH.ExpQ -> Core TH.Phases -> DsM (Core TH.DecQ)
repPragRule (MkC nm) (MkC bndrs) (MkC lhs) (MkC rhs) (MkC phases)
= rep2 pragRuleDName [nm, bndrs, lhs, rhs, phases]
repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
-> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
-> Core TH.Phases -> DsM (Core TH.DecQ)
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 (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
......@@ -2287,9 +2308,10 @@ repClosedFamilyD :: Core TH.Name
repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
= rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
repTySynEqn :: Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
repTySynEqn (MkC lhs) (MkC rhs)
= rep2 tySynEqnName [lhs, rhs]
repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
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 (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
......@@ -2591,6 +2613,11 @@ coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
------------------- 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
coreNothing :: Name -- ^ Name of the TyCon of the element type
-> DsM (Core (Maybe a))
......@@ -2613,6 +2640,26 @@ coreJust' :: Type -- ^ The element type
-> Core a -> Core (Maybe a)
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 -------------------
coreIntLit :: Int -> DsM (Core Int)
......
......@@ -402,7 +402,7 @@ tidy1 :: Id -- The Id being scrutinised
-- list patterns, etc) and returns any created bindings in the wrapper.
tidy1 v (ParPat _ pat) = tidy1 v (unLoc pat)
tidy1 v (SigPat _ pat) = tidy1 v (unLoc pat)
tidy1 v (SigPat _ pat _) = tidy1 v (unLoc pat)
tidy1 _ (WildPat ty) = return (idDsWrapper, WildPat ty)
tidy1 v (BangPat _ (L l p)) = tidy_bang_pat v l p
......@@ -480,7 +480,7 @@ tidy_bang_pat :: Id -> SrcSpan -> Pat GhcTc -> DsM (DsWrapper, Pat GhcTc)
-- Discard par/sig under a bang
tidy_bang_pat v _ (ParPat _ (L l p)) = tidy_bang_pat v l p
tidy_bang_pat v _ (SigPat _ (L l p)) = tidy_bang_pat v l p
tidy_bang_pat v _ (SigPat _ (L l p) _) = tidy_bang_pat v l p
-- Push the bang-pattern inwards, in the hope that
-- it may disappear next time
......
......@@ -292,7 +292,7 @@ hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e
hsExprToPmExpr (ExprWithTySig _ e _) = lhsExprToPmExpr e
hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e
hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
......
......@@ -294,8 +294,8 @@ cvtDec (DataFamilyD tc tvs kind)
; returnJustL $ TyClD noExt $ FamDecl noExt $
FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
; ksig' <- cvtKind `traverse` ksig
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
......@@ -309,12 +309,14 @@ cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
{ dfid_ext = noExt
, dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
FamEqn { feqn_ext = noExt
, feqn_tycon = tc', feqn_pats = typats'
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
, feqn_pats = typats'
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs)
= do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
......@@ -327,7 +329,9 @@ cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
{ dfid_ext = noExt
, dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
FamEqn { feqn_ext = noExt
, feqn_tycon = tc', feqn_pats = typats'
, feqn_tycon = tc'
, feqn_bndrs = bndrs'
, feqn_pats = typats'
, feqn_rhs = defn
, feqn_fixity = Prefix } }}}
......@@ -407,12 +411,14 @@ cvtDec (TH.ImplicitParamBindD _ _)
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn tc (TySynEqn lhs rhs)
= do { lhs' <- mapM (wrap_apps <=< cvtType) lhs
cvtTySynEqn tc (TySynEqn mb_bndrs lhs rhs)
= do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
; lhs' <- mapM (wrap_apps <=< cvtType) lhs
; rhs' <- cvtType rhs
; returnL $ mkHsImplicitBndrs
$ FamEqn { feqn_ext = noExt
, feqn_tycon = tc
, feqn_bndrs = mb_bndrs'
, feqn_pats = lhs'
, feqn_fixity = Prefix
, feqn_rhs = rhs' } }
......@@ -450,15 +456,17 @@ cvt_tycl_hdr cxt tc tvs
; return (cxt', tc', tvs')
}
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> Maybe [TH.TyVarBndr] -> [TH.Type]
-> CvtM ( LHsContext GhcPs
, Located RdrName
, Maybe [LHsTyVarBndr GhcPs]
, HsTyPats GhcPs)
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tys' <- mapM (wrap_apps <=< cvtType) tys
; return (cxt', tc', tys') }
cvt_tyinst_hdr cxt tc bndrs tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; bndrs' <- traverse (mapM cvt_tv) bndrs
; tys' <- mapM (wrap_apps <=< cvtType) tys
; return (cxt', tc', bndrs', tys') }
----------------
cvt_tyfam_head :: TypeFamilyHead
......@@ -707,17 +715,26 @@ cvtPragmaD (SpecialiseInstP ty)
; returnJustL $ Hs.SigD noExt $
SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
cvtPragmaD (RuleP nm bndrs lhs rhs phases)
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
; let act = cvtPhases phases AlwaysActive
; bndrs' <- mapM cvtRuleBndr bndrs
; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs
; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
; lhs' <- cvtl lhs
; rhs' <- cvtl rhs
; returnJustL $ Hs.RuleD noExt
$ HsRules noExt (SourceText "{-# RULES")
[noLoc $ HsRule noExt (noLoc (quotedSourceText nm,nm'))
act bndrs' lhs' rhs']
}
$ HsRules { rds_ext = noExt
, rds_src = SourceText "{-# RULES"
, rds_rules = [noLoc $
HsRule { rd_ext = noExt
, rd_name = (noLoc (quotedSourceText nm,nm'))
, rd_act = act
, rd_tyvs = ty_bndrs'
, rd_tmvs = tm_bndrs'
, rd_lhs = lhs'
, rd_rhs = rhs' }] }
}
cvtPragmaD (AnnP target exp)
= do { exp' <- cvtl exp
......@@ -838,7 +855,7 @@ cvtl e = wrapL (cvt e)
; t' <- cvtType t
; tp <- wrap_apps t'
; let tp' = parenthesizeHsType appPrec tp
; return $ HsAppType (mkHsWildCardBndrs tp') e' }
; return $ HsAppType noExt e' (mkHsWildCardBndrs tp') }
cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its
-- own expression to avoid pretty-printing
-- oddities that can result from zero-argument
......@@ -923,7 +940,7 @@ cvtl e = wrapL (cvt e)
cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }