diff options
author | romes <rodrigo.m.mesquita@gmail.com> | 2022-06-14 00:56:14 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-07-06 13:50:27 -0400 |
commit | fd379d1b8e709f4eaa20a969bf9fffd40b8a4433 (patch) | |
tree | a168d8d325b6d7cc2170676a8822e8b38152a85f /compiler/GHC/Hs | |
parent | 371c5ecf6898294f4e5bf91784dc794e7e16b7cc (diff) | |
download | haskell-fd379d1b8e709f4eaa20a969bf9fffd40b8a4433.tar.gz |
Remove many GHC dependencies from L.H.S
Continue to prune the `Language.Haskell.Syntax.*` modules out of GHC
imports according to the plan in the linked issue.
Moves more GHC-specific declarations to `GHC.*` and brings more required
GHC-independent declarations to `Language.Haskell.Syntax.*` (extending
e.g. `Language.Haskell.Syntax.Basic`).
Progress towards #21592
Bump haddock submodule for !8308
-------------------------
Metric Decrease:
hard_hole_fits
-------------------------
Diffstat (limited to 'compiler/GHC/Hs')
-rw-r--r-- | compiler/GHC/Hs/Binds.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Hs/Decls.hs | 33 | ||||
-rw-r--r-- | compiler/GHC/Hs/Expr.hs | 197 | ||||
-rw-r--r-- | compiler/GHC/Hs/Extension.hs | 19 | ||||
-rw-r--r-- | compiler/GHC/Hs/Pat.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Hs/Type.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Hs/Utils.hs | 2 |
7 files changed, 258 insertions, 5 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index ed80c1349c..7ce59266c4 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -96,7 +96,6 @@ type instance XFunBind (GhcPass pL) GhcRn = NameSet -- extension field contains the locally-bound free variables of this -- defn. See Note [Bind free vars] - -- fun_tick :: [CoreTickish] type instance XFunBind (GhcPass pL) GhcTc = (HsWrapper, [CoreTickish]) -- ^ After the type-checker, the FunBind extension field contains -- the ticks to put on the rhs, if any, and a coercion from the diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index accc349a11..9264d6c7c2 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -120,11 +120,13 @@ import GHC.Types.Name.Set import GHC.Types.Fixity -- others: +import GHC.Utils.Misc (count) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Core.Type +import GHC.Core.TyCon (TyConFlavour(NewtypeFlavour,DataTypeFlavour)) import GHC.Types.ForeignCall import GHC.Data.Bag @@ -343,6 +345,12 @@ type instance XDataDecl GhcPs = EpAnn [AddEpAnn] type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn +data DataDeclRn = DataDeclRn + { tcdDataCusk :: Bool -- ^ does this have a CUSK? + -- See Note [CUSKs: complete user-supplied kind signatures] + , tcdFVs :: NameSet } + deriving Data + type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo] -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl GhcRn = NameSet -- FVs @@ -382,6 +390,21 @@ tyClDeclLName (SynDecl { tcdLName = ln }) = ln tyClDeclLName (DataDecl { tcdLName = ln }) = ln tyClDeclLName (ClassDecl { tcdLName = ln }) = ln +countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls +countTyClDecls decls + = (count isClassDecl decls, + count isSynDecl decls, -- excluding... + count isDataTy decls, -- ...family... + count isNewTy decls, -- ...instances + count isFamilyDecl decls) + where + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True + isDataTy _ = False + + isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True + isNewTy _ = False + -- FIXME: tcdName is commonly used by both GHC and third-party tools, so it -- needs to be polymorphic in the pass tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN @@ -900,6 +923,10 @@ instDeclDataFamInsts inst_decls do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] +-- | Convert a 'NewOrData' to a 'TyConFlavour' +newOrDataToFlavour :: NewOrData -> TyConFlavour +newOrDataToFlavour NewType = NewtypeFlavour +newOrDataToFlavour DataType = DataTypeFlavour instance Outputable NewOrData where ppr NewType = text "newtype" @@ -1090,6 +1117,9 @@ type instance XHsRule GhcPs = (EpAnn HsRuleAnn, SourceText) type instance XHsRule GhcRn = (HsRuleRn, SourceText) type instance XHsRule GhcTc = (HsRuleRn, SourceText) +data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + deriving Data + type instance XXRuleDecl (GhcPass _) = DataConCantHappen type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns @@ -1279,3 +1309,6 @@ type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (Maybe Role) = SrcAnn NoEpAnns +type instance Anno CCallConv = SrcSpan +type instance Anno Safety = SrcSpan +type instance Anno CExportSpec = SrcSpan diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 12e9e2d81c..405b772199 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -37,6 +37,7 @@ import GHC.Hs.Decls() -- import instances import GHC.Hs.Pat import GHC.Hs.Lit import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Basic (FieldLabelString) import GHC.Hs.Extension import GHC.Hs.Type import GHC.Hs.Binds @@ -386,7 +387,7 @@ data AnnsIf -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = EpAnn AnnPragma +type instance XSCC (GhcPass _) = (EpAnn AnnPragma, SourceText) type instance XXPragE (GhcPass _) = DataConCantHappen type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel @@ -871,7 +872,7 @@ isAtomicHsExpr (XExpr x) isAtomicHsExpr _ = False instance Outputable (HsPragE (GhcPass p)) where - ppr (HsPragSCC _ st (StringLiteral stl lbl _)) = + ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) = pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written -- without quotes. @@ -1110,6 +1111,46 @@ type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd -- wrap :: arg1 "->" arg2 -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res +-- | Command Syntax Table (for Arrow syntax) +type CmdSyntaxTable p = [(Name, HsExpr p)] +-- See Note [CmdSyntaxTable] + +{- +Note [CmdSyntaxTable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is an empty list + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, <expression>)] + where <expression> is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious GHC.Rename.Expr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) +-} + data CmdTopTc = CmdTopTc Type -- Nested tuple of inputs on the command's stack Type -- return type of the command @@ -1119,6 +1160,7 @@ type instance XCmdTop GhcPs = NoExtField type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop GhcTc = CmdTopTc + type instance XXCmdTop (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where @@ -1859,12 +1901,24 @@ instance Outputable LamCaseVariant where LamCase -> "LamCase" LamCases -> "LamCases" +lamCaseKeyword :: LamCaseVariant -> SDoc +lamCaseKeyword LamCase = text "\\case" +lamCaseKeyword LamCases = text "\\cases" + +pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc +pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) + = ppr (src,(n1,n2),(n3,n4)) + instance Outputable HsArrowMatchContext where ppr ProcExpr = text "ProcExpr" ppr ArrowCaseAlt = text "ArrowCaseAlt" ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant ppr KappaExpr = text "KappaExpr" +pprHsArrType :: HsArrAppType -> SDoc +pprHsArrType HsHigherOrderApp = text "higher order arrow application" +pprHsArrType HsFirstOrderApp = text "first order arrow application" + ----------------- instance OutputableBndrId p @@ -1932,6 +1986,145 @@ pprStmtInCtxt ctxt stmt , trS_form = form }) = pprTransStmt by using form ppr_stmt stmt = pprStmt stmt +matchSeparator :: HsMatchContext p -> SDoc +matchSeparator FunRhs{} = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator LamCaseAlt{} = text "->" +matchSeparator IfAlt = text "->" +matchSeparator LambdaExpr = text "->" +matchSeparator ArrowMatchCtxt{} = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator StmtCtxt{} = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern + -- match checker trace +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" +matchSeparator PatSyn = panic "unused" + +pprMatchContext :: (Outputable (IdP p), UnXRec p) + => HsMatchContext p -> SDoc +pprMatchContext ctxt + | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt + | otherwise = text "a" <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an (ArrowMatchCtxt ProcExpr) = True + want_an (ArrowMatchCtxt KappaExpr) = True + want_an _ = False + +pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p) + => HsMatchContext p -> SDoc +pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for" + <+> quotes (ppr (unXRec @p fun)) +pprMatchContextNoun CaseAlt = text "case alternative" +pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant + <+> text "alternative" +pprMatchContextNoun IfAlt = text "multi-way if alternative" +pprMatchContextNoun RecUpd = text "record-update construct" +pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" +pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" +pprMatchContextNoun PatBindRhs = text "pattern binding" +pprMatchContextNoun PatBindGuards = text "pattern binding guards" +pprMatchContextNoun LambdaExpr = text "lambda abstraction" +pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c +pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" + $$ pprAStmtContext ctxt +pprMatchContextNoun PatSyn = text "pattern synonym declaration" + +pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p) + => HsMatchContext p -> SDoc +pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for" + <+> quotes (ppr (unXRec @p fun)) +pprMatchContextNouns PatBindGuards = text "pattern binding guards" +pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c +pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in" + $$ pprAStmtContext ctxt +pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's' + +pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc +pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern" +pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation" +pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant + <+> text "alternative within arrow notation" +pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction" + +pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc +pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation" +pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant + <+> text "alternatives within arrow notation" +pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's' + +----------------- +pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p) + => HsStmtContext p -> SDoc +pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour +pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt + +----------------- +pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour +pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt +pprStmtContext ArrowExpr = text "'do' block in an arrow command" + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension +pprStmtContext (ParStmtCtxt c) = + ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) + (pprStmtContext c) +pprStmtContext (TransStmtCtxt c) = + ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) + (pprStmtContext c) + +pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc +pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour + where + pp_an = text "an" + pp_a = text "a" + article = case flavour of + MDoExpr Nothing -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a +pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block") +pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block") +pprHsDoFlavour ListComp = text "list comprehension" +pprHsDoFlavour MonadComp = text "monad comprehension" +pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command" + +prependQualified :: Maybe ModuleName -> SDoc -> SDoc +prependQualified Nothing t = t +prependQualified (Just _) t = text "qualified" <+> t + +{- +************************************************************************ +* * +FieldLabelStrings +* * +************************************************************************ +-} + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where + ppr (FieldLabelStrings flds) = + hcat (punctuate dot (map (ppr . unXRec @p) flds)) + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where + pprInfixOcc = pprFieldLabelStrings + pprPrefixOcc = pprFieldLabelStrings + +instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprInfixOcc . unLoc + +pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc +pprFieldLabelStrings (FieldLabelStrings flds) = + hcat (punctuate dot (map (ppr . unXRec @p) flds)) + +instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where + ppr (DotFieldOcc _ s) = ppr s + ppr XDotFieldOcc{} = text "XDotFieldOcc" + {- ************************************************************************ * * diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index d58bd9efbc..922288650f 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -15,6 +15,8 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable + module GHC.Hs.Extension where -- This module captures the type families to precisely identify the extension @@ -22,6 +24,8 @@ module GHC.Hs.Extension where import GHC.Prelude +import GHC.TypeLits (KnownSymbol, symbolVal) + import Data.Data hiding ( Fixity ) import Language.Haskell.Syntax.Extension import GHC.Types.Name @@ -239,3 +243,18 @@ type instance Anno (HsUniToken tok utok) = TokenLocation noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok) noHsUniTok = L NoTokenLoc HsNormalTok + +--- Outputable + +instance Outputable NoExtField where + ppr _ = text "NoExtField" + +instance Outputable DataConCantHappen where + ppr = dataConCantHappen + +instance KnownSymbol tok => Outputable (HsToken tok) where + ppr _ = text (symbolVal (Proxy :: Proxy tok)) + +instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where + ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok)) + ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok)) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 2b8eb269bb..3d251103ce 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -33,6 +33,7 @@ module GHC.Hs.Pat ( HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, + RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, @@ -268,7 +269,7 @@ instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFiel => Outputable (HsRecFields p arg) where ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) = braces (fsep (punctuate comma (map ppr flds))) - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> RecFieldsDotDot n) }) = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) where dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 73c7652dec..770a91b35a 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -95,6 +95,7 @@ import Language.Haskell.Syntax.Type import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) import Language.Haskell.Syntax.Extension +import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) ) import GHC.Hs.Extension import GHC.Parser.Annotation @@ -338,6 +339,13 @@ type instance XWildCardTy (GhcPass _) = NoExtField type instance XXType (GhcPass _) = HsCoreTy +-- An escape hatch for tunnelling a Core 'Type' through 'HsType'. +-- For more details on how this works, see: +-- +-- * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType" +-- +-- * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType" +type HsCoreTy = Type type instance XNumTy (GhcPass _) = SourceText type instance XStrTy (GhcPass _) = SourceText diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 557b3b2dd5..3e74eea3db 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1609,7 +1609,7 @@ lPatImplicits = hs_lpat (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld | (i, fld) <- [0..] `zip` rec_flds fs , let pat_explicit = - maybe True ((i<) . unLoc) + maybe True ((i<) . unRecFieldsDotDot . unLoc) (rec_dotdot fs)] err_loc = maybe (getLocA n) getLoc (rec_dotdot fs) |