From 7ea3b7eb37ac87917ab490c835e8405646891be3 Mon Sep 17 00:00:00 2001 From: Ryan Scott Date: Fri, 23 Apr 2021 19:48:03 -0400 Subject: Introduce `hsExprType :: HsExpr GhcTc -> Type` in the new module `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 --- compiler/GHC/Hs/Expr.hs | 37 ++++-- compiler/GHC/Hs/Extension.hs | 6 + compiler/GHC/Hs/Pat.hs | 6 +- compiler/GHC/Hs/Syn/Type.hs | 202 ++++++++++++++++++++++++++++++ compiler/GHC/HsToCore/Arrows.hs | 2 +- compiler/GHC/HsToCore/Expr.hs | 20 ++- compiler/GHC/HsToCore/ListComp.hs | 2 +- compiler/GHC/HsToCore/Match.hs | 2 +- compiler/GHC/HsToCore/Utils.hs | 2 +- compiler/GHC/Iface/Ext/Ast.hs | 175 +++++++++++++------------- compiler/GHC/Tc/Gen/Arrow.hs | 2 +- compiler/GHC/Tc/Gen/Expr.hs | 1 + compiler/GHC/Tc/Gen/Head.hs | 2 +- compiler/GHC/Tc/Gen/Pat.hs | 1 + compiler/GHC/Tc/Gen/Splice.hs | 11 +- compiler/GHC/Tc/Utils/Instantiate.hs | 1 + compiler/GHC/Tc/Utils/Zonk.hs | 88 ++----------- compiler/ghc.cabal.in | 1 + docs/users_guide/9.4.1-notes.rst | 8 ++ ghc/GHCi/UI/Info.hs | 42 +++---- testsuite/tests/package/package07e.stderr | 11 +- testsuite/tests/package/package08e.stderr | 11 +- utils/haddock | 2 +- 23 files changed, 402 insertions(+), 233 deletions(-) create mode 100644 compiler/GHC/Hs/Syn/Type.hs 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 index 1ceb34bf20..caee7fce30 160000 --- a/utils/haddock +++ b/utils/haddock @@ -1 +1 @@ -Subproject commit 1ceb34bf20ef4f226a4152264505826d3138957e +Subproject commit caee7fce3032ac08c38a591de5e31f37eedf681f -- cgit v1.2.1