diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/GHC/Iface/Type.hs | 5 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 49 | ||||
| -rw-r--r-- | compiler/types/TyCoRep.hs | 4 |
3 files changed, 28 insertions, 30 deletions
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 184849d319..f879013283 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -1102,10 +1102,7 @@ pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc pprIfaceForAllBndr bndr = case bndr of Bndr (IfaceTvBndr tv) Inferred -> - sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitForalls dflags - then braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) - else pprIfaceTvBndr tv suppress_sig (UseBndrParens True) + braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) Bndr (IfaceTvBndr tv) _ -> pprIfaceTvBndr tv suppress_sig (UseBndrParens True) Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 0f1386d76d..b752b43004 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -278,14 +278,15 @@ ds_expr _ (HsOverLit _ lit) = do { warnAboutOverflowedOverLit lit ; dsOverLit lit } -ds_expr _ (HsWrap _ co_fn e) +ds_expr _ hswrap@(HsWrap _ co_fn e) = do { e' <- ds_expr True e -- This is the one place where we recurse to -- ds_expr (passing True), rather than dsExpr ; wrap' <- dsHsWrapper co_fn ; dflags <- getDynFlags ; let wrapped_e = wrap' e' wrapped_ty = exprType wrapped_e - ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion] + ; checkForcedEtaExpansion e (ppr hswrap) wrapped_ty -- See Note [Detecting forced eta expansion] + -- Pass HsWrap, so that the user can see entire expression with -fprint-typechecker-elaboration ; warnAboutIdentities dflags e' wrapped_ty ; return wrapped_e } @@ -1022,14 +1023,8 @@ dsHsVar :: Bool -- are we directly inside an HsWrap? -- See Wrinkle in Note [Detecting forced eta expansion] -> Id -> DsM CoreExpr dsHsVar w var - | not w - , let bad_tys = badUseOfLevPolyPrimop var ty - , not (null bad_tys) - = do { levPolyPrimopErr var ty bad_tys - ; return unitExpr } -- return something eminently safe - - | otherwise - = return (varToCoreExpr var) -- See Note [Desugaring vars] + = ASSERT2(w || null (badUseOfLevPolyPrimop var ty), ppr var $$ ppr ty) + return (varToCoreExpr var) -- See Note [Desugaring vars] where ty = idType var @@ -1129,30 +1124,32 @@ So, either way, we're good to reject. Wrinkle ~~~~~~~ -Not all polymorphic Ids are wrapped in -HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type -application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id -without a wrapper, then that is surely problem and we can reject. +Currently, all levity-polymorphic Ids are wrapped in HsWrap. + +However, this is not set in stone, in the future we might make +instantiation more lazy. (See "Visible type application", ESOP '16.) +If we spot a levity-polymorphic hasNoBinding Id without a wrapper, +then that is surely a problem. We thus have a parameter to `dsExpr` that tracks whether or not we are directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when -we're not directly in an HsWrap, reject. - +we're not directly in an HsWrap, we raise an assertion failure. +This might be changed to a call to `levPolyPrimopErr` if it ever happens. -} -- | Takes an expression and its instantiated type. If the expression is an -- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments, -- issue an error. See Note [Detecting forced eta expansion] -checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM () -checkForcedEtaExpansion expr ty +checkForcedEtaExpansion :: HsExpr GhcTc -> SDoc -> Type -> DsM () +checkForcedEtaExpansion expr expr_doc ty | Just var <- case expr of HsVar _ (L _ var) -> Just var HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc) _ -> Nothing , let bad_tys = badUseOfLevPolyPrimop var ty , not (null bad_tys) - = levPolyPrimopErr var ty bad_tys -checkForcedEtaExpansion _ _ = return () + = levPolyPrimopErr expr_doc ty bad_tys +checkForcedEtaExpansion _ _ _ = return () -- | Is this a hasNoBinding Id with a levity-polymorphic type? -- Returns the arguments that are levity polymorphic if they are bad; @@ -1168,11 +1165,17 @@ badUseOfLevPolyPrimop id ty (binders, _) = splitPiTys ty arg_tys = mapMaybe binderRelevantType_maybe binders -levPolyPrimopErr :: Id -> Type -> [Type] -> DsM () -levPolyPrimopErr primop ty bad_tys +levPolyPrimopErr :: SDoc -> Type -> [Type] -> DsM () +levPolyPrimopErr expr_doc ty bad_tys = errDs $ vcat [ hang (text "Cannot use function with levity-polymorphic arguments:") - 2 (ppr primop <+> dcolon <+> pprWithTYPE ty) + 2 (expr_doc <+> dcolon <+> pprWithTYPE ty) + , sdocWithDynFlags $ \dflags -> + if not (gopt Opt_PrintTypecheckerElaboration dflags) then vcat + [ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples" + , text "are eta-expanded internally because they must occur fully saturated." + , text "Use -fprint-typechecker-elaboration to display the full expression.)" + ] else empty , hang (text "Levity-polymorphic arguments:") 2 $ vcat $ map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index f55141d928..65120ba3f0 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -812,10 +812,8 @@ See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls Specified: a list of Specified binders is written between `forall` and `.`: const :: forall a b. a -> b -> a - Inferred: with -fprint-explicit-foralls, Inferred binders are written - in braces: + Inferred: like Specified, but every binder is written in braces: f :: forall {k} (a:k). S k a -> Int - Otherwise, they are printed like Specified binders. Required: binders are put between `forall` and `->`: T :: forall k -> * |