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>

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