Commit 175cb5b4 authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

DynFlags: don't use sdocWithDynFlags in datacon ppr

We don't need to use `sdocWithDynFlags` to know whether we should
display linear types for datacon types, we already have
`sdocLinearTypes` field in `SDocContext`.  Moreover we want to remove
`sdocWithDynFlags` (#10143, #17957)).
parent 7c274cd5
Pipeline #22839 canceled with stages
......@@ -87,9 +87,6 @@ import GHC.Utils.Binary
import GHC.Types.Unique.Set
import GHC.Types.Unique( mkAlphaTyVarUnique )
import GHC.Driver.Session
import GHC.LanguageExtensions as LangExt
import Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as LBS
......@@ -1337,7 +1334,7 @@ The type of the constructor, with linear arrows replaced by unrestricted ones.
Used when we don't want to introduce linear types to user (in holes
and in types in hie used by haddock).
3. dataConDisplayType (depends on DynFlags):
3. dataConDisplayType (take a boolean indicating if -XLinearTypes is enabled):
The type we'd like to show in error messages, :info and -ddump-types.
Ideally, it should reflect the type written by the user;
the function returns a type with arrows that would be required
......@@ -1384,9 +1381,9 @@ dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs,
mkVisFunTys arg_tys' $
res_ty
dataConDisplayType :: DynFlags -> DataCon -> Type
dataConDisplayType dflags dc
= if xopt LangExt.LinearTypes dflags
dataConDisplayType :: Bool -> DataCon -> Type
dataConDisplayType show_linear_types dc
= if show_linear_types
then dataConWrapperType dc
else dataConNonlinearType dc
......
......@@ -166,7 +166,8 @@ pprTyThing :: ShowSub -> TyThing -> SDoc
-- We pretty-print 'TyThing' via 'IfaceDecl'
-- See Note [Pretty-printing TyThings]
pprTyThing ss ty_thing
= sdocWithDynFlags (\dflags -> pprIfaceDecl ss' (tyThingToIfaceDecl dflags ty_thing))
= sdocOption sdocLinearTypes $ \show_linear_types ->
pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)
where
ss' = case ss_how_much ss of
ShowHeader (AltPpr Nothing) -> ss { ss_how_much = ShowHeader ppr' }
......
......@@ -28,6 +28,7 @@ import GHC.Iface.Recomp
import GHC.Iface.Load
import GHC.CoreToIface
import qualified GHC.LanguageExtensions as LangExt
import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )
import GHC.Types.Id
import GHC.Types.Annotations
......@@ -225,7 +226,8 @@ mkIface_ hsc_env
= do
let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
entities = typeEnvElts type_env
decls = [ tyThingToIfaceDecl (hsc_dflags hsc_env) entity
show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)
decls = [ tyThingToIfaceDecl show_linear_types entity
| entity <- entities,
let name = getName entity,
not (isImplicitTyThing entity),
......@@ -376,12 +378,12 @@ so we may need to split up a single Avail into multiple ones.
************************************************************************
-}
tyThingToIfaceDecl :: DynFlags -> TyThing -> IfaceDecl
tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl
tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id
tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax
tyThingToIfaceDecl dflags (AConLike cl) = case cl of
RealDataCon dc -> dataConToIfaceDecl dflags dc -- for ppr purposes only
tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of
RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only
PatSynCon ps -> patSynToIfaceDecl ps
--------------------------
......@@ -397,10 +399,10 @@ idToIfaceDecl id
ifIdInfo = toIfaceIdInfo (idInfo id) }
--------------------------
dataConToIfaceDecl :: DynFlags -> DataCon -> IfaceDecl
dataConToIfaceDecl dflags dataCon
dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl
dataConToIfaceDecl show_linear_types dataCon
= IfaceId { ifName = getName dataCon,
ifType = toIfaceType (dataConDisplayType dflags dataCon),
ifType = toIfaceType (dataConDisplayType show_linear_types dataCon),
ifIdDetails = IfVanillaId,
ifIdInfo = [] }
......
......@@ -2973,8 +2973,8 @@ ppr_datacons debug type_env
= ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs
-- The filter gets rid of class data constructors
where
ppr_dc dc = sdocWithDynFlags (\dflags ->
ppr dc <+> dcolon <+> ppr (dataConDisplayType dflags dc))
ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types ->
ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc))
all_dcs = typeEnvDataCons type_env
wanted_dcs | debug = all_dcs
| otherwise = filterOut is_cls_dc all_dcs
......
......@@ -4136,7 +4136,8 @@ checkValidDataCon dflags existential_ok tc con
= hang herald 2 (text "on the" <+> speakNth n
<+> text "argument of" <+> quotes (ppr con))
data_con_display_type = dataConDisplayType dflags con
show_linear_types = xopt LangExt.LinearTypes dflags
data_con_display_type = dataConDisplayType show_linear_types con
-------------------------------
checkNewDataCon :: DataCon -> TcM ()
......@@ -4152,10 +4153,10 @@ checkNewDataCon con
[ text "A newtype cannot have an unlifted argument type"
, text "Perhaps you intended to use UnliftedNewtypes"
]
; dflags <- getDynFlags
; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags
; let check_con what msg =
checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con))
checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))
; checkTc (ok_mult (scaledMult arg_ty1)) $
text "A newtype constructor must be linear"
......@@ -4843,10 +4844,10 @@ badGadtDecl tc_name
badExistential :: DataCon -> SDoc
badExistential con
= sdocWithDynFlags (\dflags ->
= sdocOption sdocLinearTypes (\show_linear_types ->
hang (text "Data constructor" <+> quotes (ppr con) <+>
text "has existential type variables, a context, or a specialised result type")
2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con)
2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)
, parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]))
badStupidTheta :: Name -> SDoc
......
......@@ -286,10 +286,10 @@ pprSigSkolInfo ctxt ty
pprPatSkolInfo :: ConLike -> SDoc
pprPatSkolInfo (RealDataCon dc)
= sdocWithDynFlags (\dflags ->
= sdocOption sdocLinearTypes (\show_linear_types ->
sep [ text "a pattern with constructor:"
, nest 2 $ ppr dc <+> dcolon
<+> pprType (dataConDisplayType dflags dc) <> comma ])
<+> pprType (dataConDisplayType show_linear_types dc) <> comma ])
-- pprType prints forall's regardless of -fprint-explicit-foralls
-- which is what we want here, since we might be saying
-- type variable 't' is bound by ...
......
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