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>

4 files changed, 242 insertions, 9 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"