summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2021-04-23 19:48:03 -0400
committerZubin Duggal <zubin.duggal@gmail.com>2021-06-08 01:07:10 +0530
commit7ea3b7eb37ac87917ab490c835e8405646891be3 (patch)
treeb2720484d7da45cb97ee3efe6a0bcfec412be0d0
parent9e724f6e5bcb31abd270ea44fb01b1edb18f626f (diff)
downloadhaskell-7ea3b7eb37ac87917ab490c835e8405646891be3.tar.gz
Introduce `hsExprType :: HsExpr GhcTc -> Type` in the new modulewip/hsExprType
`GHC.Hs.Syn.Type` The existing `hsPatType`, `hsLPatType` and `hsLitType` functions have also been moved to this module This is a less ambitious take on the same problem that !2182 and !3866 attempt to solve. Rather than have the `hsExprType` function attempt to efficiently compute the `Type` of every subexpression in an `HsExpr`, this simply computes the overall `Type` of a single `HsExpr`. - Explicitly forbids the `SplicePat` `HsIPVar`, `HsBracket`, `HsRnBracketOut` and `HsTcBracketOut` constructors during the typechecking phase by using `Void` as the TTG extension field - Also introduces `dataConCantHappen` as a domain specific alternative to `absurd` to handle cases where the TTG extension points forbid a constructor. - Turns HIE file generation into a pure function that doesn't need access to the `DsM` monad to compute types, but uses `hsExprType` instead. - Computes a few more types during HIE file generation - Makes GHCi's `:set +c` command also use `hsExprType` instead of going through the desugarer to compute types. Updates haddock submodule Co-authored-by: Zubin Duggal <zubin.duggal@gmail.com>
-rw-r--r--compiler/GHC/Hs/Expr.hs37
-rw-r--r--compiler/GHC/Hs/Extension.hs6
-rw-r--r--compiler/GHC/Hs/Pat.hs6
-rw-r--r--compiler/GHC/Hs/Syn/Type.hs202
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs2
-rw-r--r--compiler/GHC/HsToCore/Expr.hs20
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs2
-rw-r--r--compiler/GHC/HsToCore/Match.hs2
-rw-r--r--compiler/GHC/HsToCore/Utils.hs2
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs175
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs1
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs1
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs11
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs1
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs88
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--docs/users_guide/9.4.1-notes.rst8
-rw-r--r--ghc/GHCi/UI/Info.hs42
-rw-r--r--testsuite/tests/package/package07e.stderr11
-rw-r--r--testsuite/tests/package/package08e.stderr11
m---------utils/haddock0
23 files changed, 401 insertions, 232 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 006c8a2e8e..72ac021e45 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -196,13 +196,25 @@ type instance PendingTcSplice' (GhcPass _) = PendingTcSplice
{- Note [Constructor cannot occur]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Some data constructors can't occur in certain phases; e.g. the output
-of the type checker never has OverLabel. We signal this by setting
-the extension field to Void. For example:
+of the type checker never has OverLabel. We signal this by
+* setting the extension field to Void
+* using dataConCantHappen in the cases that can't happen
+
+For example:
+
type instance XOverLabel GhcTc = Void
- dsExpr (HsOverLabel x _) = absurd x
+
+ dsExpr :: HsExpr GhcTc -> blah
+ dsExpr (HsOverLabel x _) = dataConCantHappen x
+
+The function dataConCantHappen is defined thus:
+ dataConCantHappen :: Void -> a
+ dataConCantHappen x = case x of {}
+(i.e. identically to Data.Void.absurd, but more helpfully named).
+Remember Void is a type whose only element is bottom.
It would be better to omit the pattern match altogether, but we
-could only do that if the extension field was strict (#18764)
+could only do that if the extension field was strict (#18764).
-}
-- API Annotations types
@@ -246,7 +258,9 @@ type instance XUnboundVar GhcTc = HoleExprRef
-- Much, much easier just to define HoleExprRef with a Data instance and
-- store the whole structure.
-type instance XIPVar (GhcPass _) = EpAnnCO
+type instance XIPVar GhcPs = EpAnnCO
+type instance XIPVar GhcRn = EpAnnCO
+type instance XIPVar GhcTc = Void -- See Note [Constructor cannot occur]
type instance XOverLitE (GhcPass _) = EpAnnCO
type instance XLitE (GhcPass _) = EpAnnCO
@@ -348,10 +362,17 @@ type instance XArithSeq GhcPs = EpAnn [AddEpAnn]
type instance XArithSeq GhcRn = NoExtField
type instance XArithSeq GhcTc = PostTcExpr
-type instance XBracket (GhcPass _) = EpAnn [AddEpAnn]
+type instance XBracket GhcPs = EpAnn [AddEpAnn]
+type instance XBracket GhcRn = EpAnn [AddEpAnn]
+type instance XBracket GhcTc = Void -- See Note [Constructor cannot occur]
+
+type instance XRnBracketOut GhcPs = Void -- See Note [Constructor cannot occur]
+type instance XRnBracketOut GhcRn = NoExtField
+type instance XRnBracketOut GhcTc = Void -- See Note [Constructor cannot occur]
-type instance XRnBracketOut (GhcPass _) = NoExtField
-type instance XTcBracketOut (GhcPass _) = NoExtField
+type instance XTcBracketOut GhcPs = Void -- See Note [Constructor cannot occur]
+type instance XTcBracketOut GhcRn = Void -- See Note [Constructor cannot occur]
+type instance XTcBracketOut GhcTc = Type -- Type of the TcBracketOut
type instance XSpliceE (GhcPass _) = EpAnnCO
type instance XProc (GhcPass _) = EpAnn [AddEpAnn]
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 0a43cb8aa6..99b0bbc1ab 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -32,6 +32,8 @@ import GHC.Types.SrcLoc (GenLocated(..), unLoc)
import GHC.Utils.Panic
import GHC.Parser.Annotation
+import Data.Void
+
{-
Note [IsPass]
~~~~~~~~~~~~~
@@ -217,6 +219,10 @@ type OutputableBndrId pass =
, IsPass pass
)
+-- | See Note [Constructor cannot occur]
+dataConCantHappen :: Void -> a
+dataConCantHappen = absurd
+
-- useful helper functions:
pprIfPs :: forall p. IsPass p => (p ~ 'Parsed => SDoc) -> SDoc
pprIfPs pp = case ghcPass @p of GhcPs -> pp
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 68d76909a2..3f856ec06d 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -82,6 +82,7 @@ import GHC.Types.Name (Name)
import GHC.Driver.Session
import qualified GHC.LanguageExtensions as LangExt
import Data.Data
+import Data.Void
data ListPatTc
@@ -132,7 +133,10 @@ type instance XViewPat GhcPs = EpAnn [AddEpAnn]
type instance XViewPat GhcRn = NoExtField
type instance XViewPat GhcTc = Type
-type instance XSplicePat (GhcPass _) = NoExtField
+type instance XSplicePat GhcPs = NoExtField
+type instance XSplicePat GhcRn = NoExtField
+type instance XSplicePat GhcTc = Void -- See Note [Constructor cannot occur]
+
type instance XLitPat (GhcPass _) = NoExtField
type instance XNPat GhcPs = EpAnn [AddEpAnn]
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
new file mode 100644
index 0000000000..6428a99ff4
--- /dev/null
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -0,0 +1,202 @@
+-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
+--
+-- Note that this does /not/ currently support the use case of annotating
+-- every subexpression in an 'HsExpr' with its 'Type'. For more information on
+-- this task, see #12706, #15320, #16804, and #17331.
+module GHC.Hs.Syn.Type (
+ -- * Extracting types from HsExpr
+ lhsExprType, hsExprType,
+ -- * Extracting types from HsSyn
+ hsLitType, hsPatType, hsLPatType
+
+ ) where
+
+import GHC.Prelude
+
+import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim
+import GHC.Core.Coercion
+import GHC.Core.ConLike
+import GHC.Core.DataCon
+import GHC.Core.PatSyn
+import GHC.Core.TyCo.Rep
+import GHC.Core.Type
+import GHC.Core.Utils
+import GHC.Hs
+import GHC.Tc.Types.Evidence
+import GHC.Types.Id
+import GHC.Types.SrcLoc
+import GHC.Utils.Outputable
+import GHC.Utils.Panic
+
+{-
+************************************************************************
+* *
+ Extracting the type from HsSyn
+* *
+************************************************************************
+
+-}
+
+hsLPatType :: LPat GhcTc -> Type
+hsLPatType (L _ p) = hsPatType p
+
+hsPatType :: Pat GhcTc -> Type
+hsPatType (ParPat _ _ pat _) = hsLPatType pat
+hsPatType (WildPat ty) = ty
+hsPatType (VarPat _ lvar) = idType (unLoc lvar)
+hsPatType (BangPat _ pat) = hsLPatType pat
+hsPatType (LazyPat _ pat) = hsLPatType pat
+hsPatType (LitPat _ lit) = hsLitType lit
+hsPatType (AsPat _ var _) = idType (unLoc var)
+hsPatType (ViewPat ty _ _) = ty
+hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty
+hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
+hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys
+ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
+hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
+hsPatType (ConPat { pat_con = lcon
+ , pat_con_ext = ConPatTc
+ { cpt_arg_tys = tys
+ }
+ })
+ = conLikeResTy (unLoc lcon) tys
+hsPatType (SigPat ty _ _) = ty
+hsPatType (NPat ty _ _ _) = ty
+hsPatType (NPlusKPat ty _ _ _ _ _) = ty
+hsPatType (XPat (CoPat _ _ ty)) = ty
+hsPatType (SplicePat v _) = dataConCantHappen v
+
+hsLitType :: HsLit (GhcPass p) -> Type
+hsLitType (HsChar _ _) = charTy
+hsLitType (HsCharPrim _ _) = charPrimTy
+hsLitType (HsString _ _) = stringTy
+hsLitType (HsStringPrim _ _) = addrPrimTy
+hsLitType (HsInt _ _) = intTy
+hsLitType (HsIntPrim _ _) = intPrimTy
+hsLitType (HsWordPrim _ _) = wordPrimTy
+hsLitType (HsInt64Prim _ _) = int64PrimTy
+hsLitType (HsWord64Prim _ _) = word64PrimTy
+hsLitType (HsInteger _ _ ty) = ty
+hsLitType (HsRat _ _ ty) = ty
+hsLitType (HsFloatPrim _ _) = floatPrimTy
+hsLitType (HsDoublePrim _ _) = doublePrimTy
+
+
+-- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.
+lhsExprType :: LHsExpr GhcTc -> Type
+lhsExprType (L _ e) = hsExprType e
+
+-- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
+hsExprType :: HsExpr GhcTc -> Type
+hsExprType (HsVar _ (L _ id)) = idType id
+hsExprType (HsUnboundVar (HER _ ty _) _) = ty
+hsExprType (HsRecSel _ (FieldOcc id _)) = idType id
+hsExprType (HsOverLabel v _) = dataConCantHappen v
+hsExprType (HsIPVar v _) = dataConCantHappen v
+hsExprType (HsOverLit _ lit) = overLitType lit
+hsExprType (HsLit _ lit) = hsLitType lit
+hsExprType (HsLam _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
+hsExprType (HsLamCase _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
+hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f
+hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x
+hsExprType (OpApp v _ _ _) = dataConCantHappen v
+hsExprType (NegApp _ _ se) = syntaxExprType se
+hsExprType (HsPar _ _ e _) = lhsExprType e
+hsExprType (SectionL v _ _) = dataConCantHappen v
+hsExprType (SectionR v _ _) = dataConCantHappen v
+hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args
+hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys
+hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group
+hsExprType (HsIf _ _ t _) = lhsExprType t
+hsExprType (HsMultiIf ty _) = ty
+hsExprType (HsLet _ _ body) = lhsExprType body
+hsExprType (HsDo ty _ _) = ty
+hsExprType (ExplicitList ty _) = mkListTy ty
+hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
+hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) =
+ case cons of
+ con_like:_ -> conLikeResTy con_like out_tys
+ [] -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons"
+ (ppr e)
+hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v
+hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v
+hsExprType (ExprWithTySig _ e _) = lhsExprType e
+hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
+ Just op -> piResultTy (syntaxExprType op) asi_ty
+ Nothing -> asi_ty
+ where
+ asi_ty = arithSeqInfoType asi
+hsExprType (HsBracket v _) = dataConCantHappen v
+hsExprType (HsRnBracketOut v _ _) = dataConCantHappen v
+hsExprType (HsTcBracketOut ty _wrap _bracket _pending) = ty
+hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"
+ (ppr e)
+ -- Typed splices should have been eliminated during zonking, but we
+ -- can't use `dataConCantHappen` since they are still present before
+ -- than in the typechecked AST.
+hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
+hsExprType (HsStatic _ e) = lhsExprType e
+hsExprType (HsTick _ _ e) = lhsExprType e
+hsExprType (HsBinTick _ _ _ e) = lhsExprType e
+hsExprType (HsPragE _ _ e) = lhsExprType e
+hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
+hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
+hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
+
+arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
+arithSeqInfoType asi = mkListTy $ case asi of
+ From x -> lhsExprType x
+ FromThen x _ -> lhsExprType x
+ FromTo x _ -> lhsExprType x
+ FromThenTo x _ _ -> lhsExprType x
+
+conLikeType :: ConLike -> Type
+conLikeType (RealDataCon con) = dataConNonlinearType con
+conLikeType (PatSynCon patsyn) = case patSynBuilder patsyn of
+ Just (_, ty, _) -> ty
+ Nothing -> pprPanic "conLikeType: Unidirectional pattern synonym in expression position"
+ (ppr patsyn)
+
+hsTupArgType :: HsTupArg GhcTc -> Type
+hsTupArgType (Present _ e) = lhsExprType e
+hsTupArgType (Missing (Scaled _ ty)) = ty
+
+
+-- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))
+type PRType = (Type, [Type])
+
+prTypeType :: PRType -> Type
+prTypeType (ty, tys)
+ | null tys = ty
+ | otherwise = piResultTys ty (reverse tys)
+
+liftPRType :: (Type -> Type) -> PRType -> PRType
+liftPRType f pty = (f (prTypeType pty), [])
+
+hsWrapperType :: HsWrapper -> Type -> Type
+hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
+ where
+ go WpHole = id
+ go (w1 `WpCompose` w2) = go w1 . go w2
+ go (WpFun _ w2 (Scaled m exp_arg) _) = liftPRType $ \t ->
+ let act_res = funResultTy t
+ exp_res = hsWrapperType w2 act_res
+ in mkFunctionType m exp_arg exp_res
+ go (WpCast co) = liftPRType $ \_ -> coercionRKind co
+ go (WpEvLam v) = liftPRType $ mkInvisFunTyMany (idType v)
+ go (WpEvApp _) = liftPRType $ funResultTy
+ go (WpTyLam tv) = liftPRType $ mkForAllTy tv Inferred
+ go (WpTyApp ta) = \(ty,tas) -> (ty, ta:tas)
+ go (WpLet _) = id
+ go (WpMultCoercion _) = id
+
+lhsCmdTopType :: LHsCmdTop GhcTc -> Type
+lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty
+
+matchGroupTcType :: MatchGroupTc -> Type
+matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res
+
+syntaxExprType :: SyntaxExpr GhcTc -> Type
+syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
+syntaxExprType NoSyntaxExprTc = panic "syntaxExprType: Unexpected NoSyntaxExprTc"
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index cad3e82154..4a31b9fc8d 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -20,7 +20,7 @@ import GHC.HsToCore.Utils
import GHC.HsToCore.Monad
import GHC.Hs
-import GHC.Tc.Utils.Zonk
+import GHC.Hs.Syn.Type
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types (newtypes etc), and sometimes not
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index bd84e21ace..602950bf3e 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -71,7 +71,6 @@ import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Core.PatSyn
import Control.Monad
-import Data.Void( absurd )
{-
************************************************************************
@@ -262,10 +261,10 @@ dsExpr (HsUnboundVar (HER ref _ _) _) = dsEvTerm =<< readMutVar ref
dsExpr (HsPar _ _ e _) = dsLExpr e
dsExpr (ExprWithTySig _ e _) = dsLExpr e
-dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar"
+dsExpr (HsIPVar x _) = dataConCantHappen x
-dsExpr (HsGetField x _ _) = absurd x
-dsExpr (HsProjection x _) = absurd x
+dsExpr (HsGetField x _ _) = dataConCantHappen x
+dsExpr (HsProjection x _) = dataConCantHappen x
dsExpr (HsLit _ lit)
= do { warnAboutOverflowedLit lit
@@ -736,7 +735,7 @@ Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
-- Template Haskell stuff
-dsExpr (HsRnBracketOut _ _ _) = panic "dsExpr HsRnBracketOut"
+dsExpr (HsRnBracketOut x _ _) = dataConCantHappen x
dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps
dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
@@ -766,13 +765,12 @@ dsExpr (HsBinTick _ ixT ixF e) = do
-- HsSyn constructs that just shouldn't be here, because
-- the renamer removed them. See GHC.Rename.Expr.
-- Note [Handling overloaded and rebindable constructs]
-dsExpr (HsOverLabel x _) = absurd x
-dsExpr (OpApp x _ _ _) = absurd x
-dsExpr (SectionL x _ _) = absurd x
-dsExpr (SectionR x _ _) = absurd x
-
+dsExpr (HsOverLabel x _) = dataConCantHappen x
+dsExpr (OpApp x _ _ _) = dataConCantHappen x
+dsExpr (SectionL x _ _) = dataConCantHappen x
+dsExpr (SectionR x _ _) = dataConCantHappen x
+dsExpr (HsBracket x _) = dataConCantHappen x
-- HsSyn constructs that just shouldn't be here:
-dsExpr (HsBracket {}) = panic "dsExpr:HsBracket"
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
index 0816bf3c1c..ee5edd8ac5 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ b/compiler/GHC/HsToCore/ListComp.hs
@@ -17,7 +17,7 @@ import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalB
import GHC.Hs
import GHC.Tc.Errors.Types ( LevityCheckProvenance(..) )
-import GHC.Tc.Utils.Zonk
+import GHC.Hs.Syn.Type
import GHC.Core
import GHC.Core.Make
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 50aaef9b56..6576add1a2 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -29,7 +29,7 @@ import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )
import GHC.Types.SourceText
import GHC.Driver.Session
import GHC.Hs
-import GHC.Tc.Utils.Zonk
+import GHC.Hs.Syn.Type
import GHC.Tc.Types.Evidence
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Pmc
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 49b21e2111..d5cbed2e36 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -51,7 +51,7 @@ import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr )
import GHC.Hs
-import GHC.Tc.Utils.Zonk
+import GHC.Hs.Syn.Type
import GHC.Tc.Utils.TcType( tcSplitTyConApp )
import GHC.Core
import GHC.HsToCore.Monad
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 94da21083f..4920f1eac8 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -30,24 +30,21 @@ import GHC.Data.Bag ( Bag, bagToList )
import GHC.Types.Basic
import GHC.Data.BooleanFormula
import GHC.Core.Class ( className, classSCSelIds )
-import GHC.Core.Utils ( exprType )
-import GHC.Core.ConLike ( conLikeName, ConLike(RealDataCon) )
+import GHC.Core.ConLike ( conLikeName )
import GHC.Core.TyCon ( TyCon, tyConClass_maybe )
import GHC.Core.FVs
import GHC.Core.DataCon ( dataConNonlinearType )
import GHC.Types.FieldLabel
import GHC.Hs
-import GHC.Driver.Env
-import GHC.Utils.Monad ( concatMapM, liftIO )
+import GHC.Hs.Syn.Type
+import GHC.Utils.Monad ( concatMapM, MonadIO(liftIO) )
import GHC.Types.Id ( isDataConId_maybe )
import GHC.Types.Name ( Name, nameSrcSpan, nameUnique )
import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
import GHC.Types.SrcLoc
-import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType )
-import GHC.Core.Type ( mkVisFunTys, Type )
+import GHC.Core.Type ( Type )
import GHC.Core.Predicate
import GHC.Core.InstEnv
-import GHC.Builtin.Types ( mkListTy, mkSumTy )
import GHC.Tc.Types
import GHC.Tc.Types.Evidence
import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique )
@@ -72,14 +69,13 @@ import qualified Data.ByteString as BS
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Data ( Data, Typeable )
+import Data.Functor.Identity ( Identity(..) )
import Data.Void ( Void, absurd )
import Control.Monad ( forM_ )
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class ( lift )
-import GHC.HsToCore.Types
-import GHC.HsToCore.Expr
-import GHC.HsToCore.Monad
+import Control.Applicative ( (<|>) )
{- Note [Updating HieAst for changes in the GHC AST]
@@ -277,16 +273,17 @@ modifyState = foldr go id
= addSubstitution mono poly . f
go _ f = f
-type HieM = ReaderT NodeOrigin (StateT HieState DsM)
+type HieM = ReaderT NodeOrigin (State HieState)
-- | Construct an 'HieFile' from the outputs of the typechecker.
-mkHieFile :: ModSummary
+mkHieFile :: MonadIO m
+ => ModSummary
-> TcGblEnv
- -> RenamedSource -> Hsc HieFile
+ -> RenamedSource -> m HieFile
mkHieFile ms ts rs = do
let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms)
src <- liftIO $ BS.readFile src_file
- mkHieFileWithSource src_file src ms ts rs
+ pure $ mkHieFileWithSource src_file src ms ts rs
-- | Construct an 'HieFile' from the outputs of the typechecker but don't
-- read the source file again from disk.
@@ -294,16 +291,14 @@ mkHieFileWithSource :: FilePath
-> BS.ByteString
-> ModSummary
-> TcGblEnv
- -> RenamedSource -> Hsc HieFile
-mkHieFileWithSource src_file src ms ts rs = do
+ -> RenamedSource -> HieFile
+mkHieFileWithSource src_file src ms ts rs =
let tc_binds = tcg_binds ts
top_ev_binds = tcg_ev_binds ts
insts = tcg_insts ts
tcs = tcg_tcs ts
- hsc_env <- Hsc $ \e w -> return (e, w)
- (_msgs, res) <- liftIO $ initDs hsc_env ts $ getCompressedAsts tc_binds rs top_ev_binds insts tcs
- let (asts',arr) = expectJust "mkHieFileWithSource" res
- return $ HieFile
+ (asts',arr) = getCompressedAsts tc_binds rs top_ev_binds insts tcs in
+ HieFile
{ hie_hs_file = src_file
, hie_module = ms_mod ms
, hie_types = arr
@@ -314,15 +309,15 @@ mkHieFileWithSource src_file src ms ts rs = do
}
getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
- -> DsM (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
-getCompressedAsts ts rs top_ev_binds insts tcs = do
- asts <- enrichHie ts rs top_ev_binds insts tcs
- return $ compressTypes asts
+ -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
+getCompressedAsts ts rs top_ev_binds insts tcs =
+ let asts = enrichHie ts rs top_ev_binds insts tcs in
+ compressTypes asts
enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
- -> DsM (HieASTs Type)
+ -> HieASTs Type
enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
- flip evalStateT initState $ flip runReaderT SourceInfo $ do
+ runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do
tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
rasts <- processGrp hsGrp
imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
@@ -713,70 +708,74 @@ instance HiePass p => HasType (LocatedA (Pat (GhcPass p))) where
-- the expression. It is not yet possible to do this efficiently for all
-- expression forms, so we skip filling in the type for those inputs.
--
--- 'HsApp', for example, doesn't have any type information available directly on
--- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
--- query the type of that. Yet both the desugaring call and the type query both
--- involve recursive calls to the function and argument! This is particularly
--- problematic when you realize that the HIE traversal will eventually visit
--- those nodes too and ask for their types again.
---
--- Since the above is quite costly, we just skip cases where computing the
--- expression's type is going to be expensive.
---
--- See #16233
+-- See Note [Computing the type of every node in the tree]
instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
- getTypeNode e@(L spn e') =
+ getTypeNode (L spn e) =
case hiePass @p of
- HieRn -> makeNodeA e' spn
- HieTc ->
- -- Some expression forms have their type immediately available
- let tyOpt = case e' of
- HsUnboundVar (HER _ ty _) _ -> Just ty
- HsLit _ l -> Just (hsLitType l)
- HsOverLit _ o -> Just (overLitType o)
-
- XExpr (ConLikeTc (RealDataCon con) _ _) -> Just (dataConNonlinearType con)
-
- HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
- HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
- HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
-
- ExplicitList ty _ -> Just (mkListTy ty)
- ExplicitSum ty _ _ _ -> Just (mkSumTy ty)
- HsDo ty _ _ -> Just ty
- HsMultiIf ty _ -> Just ty
-
- _ -> Nothing
-
- in
- case tyOpt of
- Just t -> makeTypeNodeA e' spn t
- Nothing
- | skipDesugaring e' -> fallback
- | otherwise -> do
- (e, no_errs) <- lift $ lift $ discardWarningsDs $ askNoErrsDs $ dsLExpr e
- if no_errs
- then makeTypeNodeA e' spn . exprType $ e
- else fallback
- where
- fallback = makeNodeA e' spn
-
- matchGroupType :: MatchGroupTc -> Type
- matchGroupType (MatchGroupTc args res) = mkVisFunTys args res
-
- -- | Skip desugaring of these expressions for performance reasons.
- --
- -- See impact on Haddock output (esp. missing type annotations or links)
- -- before marking more things here as 'False'. See impact on Haddock
- -- performance before marking more things as 'True'.
- skipDesugaring :: HsExpr GhcTc -> Bool
- skipDesugaring e = case e of
- HsVar{} -> False
- HsRecSel{} -> False
- HsOverLabel{} -> False
- HsIPVar{} -> False
- XExpr (WrapExpr {}) -> False
- _ -> True
+ HieRn -> fallback
+ HieTc -> case computeType e of
+ Just ty -> makeTypeNodeA e spn ty
+ Nothing -> fallback
+ where
+ fallback :: HieM [HieAST Type]
+ fallback = makeNodeA e spn
+
+ -- | Skip computing the type of some expressions for performance reasons.
+ --
+ -- See impact on Haddock output (esp. missing type annotations or links)
+ -- before skipping more kinds of expressions. See impact on Haddock
+ -- performance before computing the types of more expressions.
+ --
+ -- See Note [Computing the type of every node in the tree]
+ computeType :: HsExpr GhcTc -> Maybe Type
+ computeType e = case e of
+ HsApp{} -> Nothing
+ HsAppType{} -> Nothing
+ NegApp{} -> Nothing
+ HsPar _ _ e _ -> computeLType e
+ ExplicitTuple{} -> Nothing
+ HsIf _ _ t f -> computeLType t <|> computeLType f
+ HsLet _ _ body -> computeLType body
+ RecordCon con_expr _ _ -> computeType con_expr
+ ExprWithTySig _ e _ -> computeLType e
+ HsStatic _ e -> computeLType e
+ HsTick _ _ e -> computeLType e
+ HsBinTick _ _ _ e -> computeLType e
+ HsPragE _ _ e -> computeLType e
+ XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e
+ e -> Just (hsExprType e)
+
+ computeLType :: LHsExpr GhcTc -> Maybe Type
+ computeLType (L _ e) = computeType e
+
+{- Note [Computing the type of every node in the tree]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In GHC.Iface.Ext.Ast we decorate every node in the AST with its
+type, computed by `hsExprType` applied to that node. So it's
+important that `hsExprType` takes roughly constant time per node.
+There are three cases to consider:
+
+1. For many nodes (e.g. HsVar, HsDo, HsCase) it is easy to get their
+ type -- e.g. it is stored in the node, or in sub-node thereof.
+
+2. For some nodes (e.g. HsPar, HsTick, HsIf) the type of the node is
+ the type of a child, so we can recurse, fast. We don't expect the
+ nesting to be very deep, so while this is theoretically non-linear,
+ we don't expect it to be a problem in practice.
+
+3. A very few nodes (e.g. HsApp) are more troublesome because we need to
+ take the type of a child, and then do some non-trivial processing.
+ To be conservative on computation, we decline to decorate these
+ nodes, using `fallback` instead.
+
+The function `computeType e` returns `Just t` if we can find the type
+of `e` cheaply, and `Nothing` otherwise. The base `Nothing` cases
+are the troublesome ones in (3) above. Hopefully we can ultimately
+get rid of them all.
+
+See #16233
+
+-}
data HiePassEv p where
HieRn :: HiePassEv 'Renamed
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index d6bf3ae129..2d957fd217 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -18,9 +18,9 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp
, tcCheckPolyExpr )
import GHC.Hs
+import GHC.Hs.Syn.Type
import GHC.Tc.Gen.Match
import GHC.Tc.Gen.Head( tcCheckId )
-import GHC.Tc.Utils.Zonk( hsLPatType )
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.TcMType
import GHC.Tc.Gen.Bind
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 992c00428e..40c7052de5 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -30,6 +30,7 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
import GHC.Hs
+import GHC.Hs.Syn.Type
import GHC.Rename.Utils
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index dd46120ea5..4164bd26b0 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -47,11 +47,11 @@ import GHC.Rename.Utils ( unknownSubordinateErr )
import GHC.Tc.Errors.Types
import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Zonk ( hsLitType )
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.TcType as TcType
import GHC.Hs
+import GHC.Hs.Syn.Type
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Core.PatSyn( PatSyn )
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 32f8b15f4b..0564d15cf9 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -30,6 +30,7 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )
import GHC.Hs
+import GHC.Hs.Syn.Type
import GHC.Rename.Utils
import GHC.Tc.Utils.Zonk
import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags )
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 056855469d..72fc259e83 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -210,12 +210,13 @@ tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
; let rep = getRuntimeRep expr_ty
; meta_ty <- tcTExpTy m_var expr_ty
; ps' <- readMutVar ps_ref
- ; texpco <- tcLookupId unsafeCodeCoerceName
+ ; codeco <- tcLookupId unsafeCodeCoerceName
+ ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName
; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
rn_expr
(unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
- (nlHsTyApp texpco [rep, expr_ty]))
- (noLocA (HsTcBracketOut noExtField (Just wrapper) brack ps'))))
+ (nlHsTyApp codeco [rep, expr_ty]))
+ (noLocA (HsTcBracketOut bracket_ty (Just wrapper) brack ps'))))
meta_ty res_ty }
tcTypedBracket _ other_brack _
= pprPanic "tcTypedBracket" (ppr other_brack)
@@ -244,7 +245,7 @@ tcUntypedBracket rn_expr brack ps res_ty
-- Unify the overall type of the bracket with the expected result
-- type
; tcWrapResultO BracketOrigin rn_expr
- (HsTcBracketOut noExtField brack_info brack ps')
+ (HsTcBracketOut expected_type brack_info brack ps')
expected_type res_ty
}
@@ -690,7 +691,7 @@ runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
; mod_finalizers <- readTcRef modfinalizers_ref
; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
-- We use orig_expr here and not q_expr when tracing as a call to
- -- unsafeTExpCoerce is added to the original expression by the
+ -- unsafeCodeCoerce is added to the original expression by the
-- typechecker when typed quotes are type checked.
; traceSplice (SpliceInfo { spliceDescription = "expression"
, spliceIsDecl = False
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 68839981ca..ded9d8eff5 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -47,6 +47,7 @@ import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName )
import GHC.Builtin.Names
import GHC.Hs
+import GHC.Hs.Syn.Type ( hsLitType )
import GHC.Core.InstEnv
import GHC.Core.Predicate
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index 7755ff0f14..b7d6f9cd27 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -14,9 +14,6 @@
--
-- This module is an extension of @HsSyn@ syntax, for use in the type checker.
module GHC.Tc.Utils.Zonk (
- -- * Extracting types from HsSyn
- hsLitType, hsPatType, hsLPatType,
-
-- * Other HsSyn functions
mkHsDictLet, mkHsApp,
mkHsAppTy, mkHsCaseAlt,
@@ -48,7 +45,6 @@ import GHC.Prelude
import GHC.Platform
import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Hs
@@ -100,59 +96,6 @@ import Control.Monad
import Data.List ( partition )
import Control.Arrow ( second )
-{-
-************************************************************************
-* *
- Extracting the type from HsSyn
-* *
-************************************************************************
-
--}
-
-hsLPatType :: LPat GhcTc -> Type
-hsLPatType (L _ p) = hsPatType p
-
-hsPatType :: Pat GhcTc -> Type
-hsPatType (ParPat _ _ pat _) = hsLPatType pat
-hsPatType (WildPat ty) = ty
-hsPatType (VarPat _ lvar) = idType (unLoc lvar)
-hsPatType (BangPat _ pat) = hsLPatType pat
-hsPatType (LazyPat _ pat) = hsLPatType pat
-hsPatType (LitPat _ lit) = hsLitType lit
-hsPatType (AsPat _ var _) = idType (unLoc var)
-hsPatType (ViewPat ty _ _) = ty
-hsPatType (ListPat (ListPatTc ty Nothing) _) = mkListTy ty
-hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
-hsPatType (TuplePat tys _ bx) = mkTupleTy1 bx tys
- -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
-hsPatType (SumPat tys _ _ _ ) = mkSumTy tys
-hsPatType (ConPat { pat_con = lcon
- , pat_con_ext = ConPatTc
- { cpt_arg_tys = tys
- }
- })
- = conLikeResTy (unLoc lcon) tys
-hsPatType (SigPat ty _ _) = ty
-hsPatType (NPat ty _ _ _) = ty
-hsPatType (NPlusKPat ty _ _ _ _ _) = ty
-hsPatType (XPat (CoPat _ _ ty)) = ty
-hsPatType SplicePat{} = panic "hsPatType: SplicePat"
-
-hsLitType :: HsLit (GhcPass p) -> TcType
-hsLitType (HsChar _ _) = charTy
-hsLitType (HsCharPrim _ _) = charPrimTy
-hsLitType (HsString _ _) = stringTy
-hsLitType (HsStringPrim _ _) = addrPrimTy
-hsLitType (HsInt _ _) = intTy
-hsLitType (HsIntPrim _ _) = intPrimTy
-hsLitType (HsWordPrim _ _) = wordPrimTy
-hsLitType (HsInt64Prim _ _) = int64PrimTy
-hsLitType (HsWord64Prim _ _) = word64PrimTy
-hsLitType (HsInteger _ _ ty) = ty
-hsLitType (HsRat _ _ ty) = ty
-hsLitType (HsFloatPrim _ _) = floatPrimTy
-hsLitType (HsDoublePrim _ _) = doublePrimTy
-
{- *********************************************************************
* *
Short-cuts for overloaded numeric literals
@@ -808,10 +751,9 @@ zonkExpr env (HsUnboundVar her occ)
zonkExpr env (HsRecSel _ (FieldOcc v occ))
= return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ))
-zonkExpr _ (HsIPVar x id)
- = return (HsIPVar x id)
+zonkExpr _ (HsIPVar x _) = dataConCantHappen x
-zonkExpr _ e@HsOverLabel{} = return e
+zonkExpr _ (HsOverLabel x _) = dataConCantHappen x
zonkExpr env (HsLit x (HsRat e f ty))
= do new_ty <- zonkTcTypeToTypeX env ty
@@ -843,13 +785,13 @@ zonkExpr env (HsAppType ty e t)
return (HsAppType new_ty new_e t)
-- NB: the type is an HsType; can't zonk that!
-zonkExpr _ e@(HsRnBracketOut _ _ _)
- = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
+zonkExpr _ (HsRnBracketOut x _ _) = dataConCantHappen x
-zonkExpr env (HsTcBracketOut x wrap body bs)
+zonkExpr env (HsTcBracketOut ty wrap body bs)
= do wrap' <- traverse zonkQuoteWrap wrap
bs' <- mapM (zonk_b env) bs
- return (HsTcBracketOut x wrap' body bs')
+ new_ty <- zonkTcTypeToTypeX env ty
+ return (HsTcBracketOut new_ty wrap' body bs')
where
zonkQuoteWrap (QuoteWrapper ev ty) = do
let ev' = zonkIdOcc env ev
@@ -864,11 +806,7 @@ zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =
zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e)
-zonkExpr env (OpApp fixity e1 op e2)
- = do new_e1 <- zonkLExpr env e1
- new_op <- zonkLExpr env op
- new_e2 <- zonkLExpr env e2
- return (OpApp fixity new_e1 new_op new_e2)
+zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x
zonkExpr env (NegApp x expr op)
= do (env', new_op) <- zonkSyntaxExpr env op
@@ -879,16 +817,8 @@ zonkExpr env (HsPar x lpar e rpar)
= do new_e <- zonkLExpr env e
return (HsPar x lpar new_e rpar)
-zonkExpr env (SectionL x expr op)
- = do new_expr <- zonkLExpr env expr
- new_op <- zonkLExpr env op
- return (SectionL x new_expr new_op)
-
-zonkExpr env (SectionR x op expr)
- = do new_op <- zonkLExpr env op
- new_expr <- zonkLExpr env expr
- return (SectionR x new_op new_expr)
-
+zonkExpr _ (SectionL x _ _) = dataConCantHappen x
+zonkExpr _ (SectionR x _ _) = dataConCantHappen x
zonkExpr env (ExplicitTuple x tup_args boxed)
= do { new_tup_args <- mapM zonk_tup_arg tup_args
; return (ExplicitTuple x new_tup_args boxed) }
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index a1a1d967cd..b896cbbfb8 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -414,6 +414,7 @@ Library
GHC.Hs.Doc
GHC.Hs.Dump
GHC.Hs.Expr
+ GHC.Hs.Syn.Type
GHC.Hs.Extension
GHC.Hs.ImpExp
GHC.Hs.Instances
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 73901ad8be..68417b0a6b 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -40,3 +40,11 @@ Version 9.4.1
- The ``GHC.Exts.RuntimeRep`` parameter to ``GHC.Exts.raise#`` is now inferred: ::
raise# :: forall (a :: Type) {r :: RuntimeRep} (b :: TYPE r). a -> b
+
+``ghc`` library
+~~~~~~~~~~~~~~~
+
+- A new ``GHC.Hs.Syn.Type`` module has been introduced which defines functions
+ for computing the ``Type`` of an ``HsExpr GhcTc`` in a pure fashion.
+ The ``hsLitType`` and ``hsPatType`` functions that previously lived in
+ ``GHC.Tc.Utils.Zonk`` have been moved to this module.
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index dcda66e634..7fb13316e9 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/ghc/GHCi/UI/Info.hs
@@ -34,8 +34,7 @@ import Data.Time
import Prelude hiding (mod,(<>))
import System.Directory
-import qualified GHC.Core.Utils
-import GHC.HsToCore
+import GHC.Hs.Syn.Type
import GHC.Driver.Session (HasDynFlags(..))
import GHC.Data.FastString
import GHC
@@ -46,7 +45,6 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Utils.Outputable
import GHC.Types.SrcLoc
-import GHC.Tc.Utils.Zonk
import GHC.Types.Var
import qualified GHC.Data.Strict as Strict
@@ -312,36 +310,33 @@ getModInfo name = do
m <- getModSummary name
p <- parseModule m
typechecked <- typecheckModule p
- allTypes <- processAllTypeCheckedModule typechecked
+ let allTypes = processAllTypeCheckedModule typechecked
let i = tm_checked_module_info typechecked
ts <- liftIO $ getModificationTime $ srcFilePath m
return (ModInfo m allTypes i ts)
-- | Get ALL source spans in the module.
-processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
- -> m [SpanInfo]
-processAllTypeCheckedModule tcm = do
- bts <- mapM (getTypeLHsBind ) $ listifyAllSpans tcs
- ets <- mapM (getTypeLHsExpr ) $ listifyAllSpans tcs
- pts <- mapM (getTypeLPat ) $ listifyAllSpans tcs
- return $ mapMaybe toSpanInfo
- $ sortBy cmpSpan
- $ catMaybes (bts ++ ets ++ pts)
+processAllTypeCheckedModule :: TypecheckedModule -> [SpanInfo]
+processAllTypeCheckedModule tcm
+ = mapMaybe toSpanInfo
+ $ sortBy cmpSpan
+ $ catMaybes (bts ++ ets ++ pts)
where
+ bts = map getTypeLHsBind $ listifyAllSpans tcs
+ ets = map getTypeLHsExpr $ listifyAllSpans tcs
+ pts = map getTypeLPat $ listifyAllSpans tcs
+
tcs = tm_typechecked_source tcm
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
- getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
+ getTypeLHsBind :: LHsBind GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
getTypeLHsBind (L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})
- = pure $ Just (Just (unLoc pid), getLocA pid,varType (unLoc pid))
- getTypeLHsBind _ = pure Nothing
+ = Just (Just (unLoc pid), getLocA pid,varType (unLoc pid))
+ getTypeLHsBind _ = Nothing
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
- getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
- getTypeLHsExpr e = do
- hs_env <- getSession
- (_,mbe) <- liftIO $ deSugarExpr hs_env e
- return $ fmap (\expr -> (mid, getLocA e, GHC.Core.Utils.exprType expr)) mbe
+ getTypeLHsExpr :: LHsExpr GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
+ getTypeLHsExpr e = Just (mid, getLocA e, lhsExprType e)
where
mid :: Maybe Id
mid | HsVar _ (L _ i) <- unwrapVar (unLoc e) = Just i
@@ -351,9 +346,8 @@ processAllTypeCheckedModule tcm = do
unwrapVar e' = e'
-- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
- getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
- getTypeLPat (L spn pat) =
- pure (Just (getMaybeId pat,locA spn,hsPatType pat))
+ getTypeLPat :: LPat GhcTc -> Maybe (Maybe Id,SrcSpan,Type)
+ getTypeLPat (L spn pat) = Just (getMaybeId pat,locA spn,hsPatType pat)
where
getMaybeId :: Pat GhcTc -> Maybe Id
getMaybeId (VarPat _ (L _ vid)) = Just vid
diff --git a/testsuite/tests/package/package07e.stderr b/testsuite/tests/package/package07e.stderr
index 646ba5a4ed..e5efa7e910 100644
--- a/testsuite/tests/package/package07e.stderr
+++ b/testsuite/tests/package/package07e.stderr
@@ -2,27 +2,28 @@
package07e.hs:2:1: error:
Could not find module ‘GHC.Hs.MyTypes’
Perhaps you meant
- GHC.Hs.Type (needs flag -package-id ghc-8.11.0.20200401)
- GHC.Tc.Types (needs flag -package-id ghc-8.11.0.20200401)
+ GHC.Hs.Type (needs flag -package-id ghc-9.3)
+ GHC.Hs.Syn.Type (needs flag -package-id ghc-9.3)
+ GHC.Tc.Types (needs flag -package-id ghc-9.3)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package07e.hs:3:1: error:
Could not load module ‘GHC.Hs.Type’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.3’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package07e.hs:4:1: error:
Could not load module ‘GHC.Hs.Utils’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.3’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package07e.hs:5:1: error:
Could not load module ‘GHC.Types.Unique.FM’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.3’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
diff --git a/testsuite/tests/package/package08e.stderr b/testsuite/tests/package/package08e.stderr
index 8493fe77a6..0f84655e60 100644
--- a/testsuite/tests/package/package08e.stderr
+++ b/testsuite/tests/package/package08e.stderr
@@ -2,27 +2,28 @@
package08e.hs:2:1: error:
Could not find module ‘GHC.Hs.MyTypes’
Perhaps you meant
- GHC.Hs.Type (needs flag -package-id ghc-8.11.0.20200401)
- GHC.Tc.Types (needs flag -package-id ghc-8.11.0.20200401)
+ GHC.Hs.Type (needs flag -package-id ghc-9.3)
+ GHC.Hs.Syn.Type (needs flag -package-id ghc-9.3)
+ GHC.Tc.Types (needs flag -package-id ghc-9.3)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package08e.hs:3:1: error:
Could not load module ‘GHC.Hs.Type’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.3’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package08e.hs:4:1: error:
Could not load module ‘GHC.Hs.Utils’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.3’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
package08e.hs:5:1: error:
Could not load module ‘GHC.Types.Unique.FM’
- It is a member of the hidden package ‘ghc-8.11.0.20200401’.
+ It is a member of the hidden package ‘ghc-9.3’.
You can run ‘:set -package ghc’ to expose it.
(Note: this unloads all the modules in the current scope.)
Use -v (or `:set -v` in ghci) to see a list of the files searched for.
diff --git a/utils/haddock b/utils/haddock
-Subproject 1ceb34bf20ef4f226a4152264505826d3138957
+Subproject caee7fce3032ac08c38a591de5e31f37eedf681