diff options
46 files changed, 493 insertions, 475 deletions
diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs index 4e0aa45abc..1dd27952f6 100644 --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} @@ -35,6 +36,8 @@ module GHC.Core.Coercion.Axiom ( import GHC.Prelude +import Language.Haskell.Syntax.Basic (Role(..)) + import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon ) @@ -495,14 +498,6 @@ instance Outputable CoAxBranch where Roles are defined here to avoid circular dependencies. -} --- See Note [Roles] in GHC.Core.Coercion --- defined here to avoid cyclic dependency with GHC.Core.Coercion --- --- Order of constructors matters: the Ord instance coincides with the *super*typing --- relation on roles. -data Role = Nominal | Representational | Phantom - deriving (Eq, Ord, Data.Data) - -- These names are slurped into the parser code. Changing these strings -- will change the **surface syntax** that GHC accepts! If you want to -- change only the pretty-printing, do some replumbing. See diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 0d436a93f0..4f82cd3d68 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary module GHC.Core.DataCon ( -- * Main data types @@ -67,6 +68,8 @@ module GHC.Core.DataCon ( import GHC.Prelude +import Language.Haskell.Syntax.Basic + import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type import GHC.Core.Coercion @@ -753,22 +756,6 @@ data HsImplBang -- co :: arg-ty ~ product-ty HsBang deriving Data.Data --- | Source Strictness --- --- What strictness annotation the user wrote -data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' - | SrcStrict -- ^ Strict, ie '!' - | NoSrcStrict -- ^ no strictness annotation - deriving (Eq, Data.Data) - --- | Source Unpackedness --- --- What unpackedness the user requested -data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified - | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified - | NoSrcUnpack -- ^ no unpack pragma - deriving (Eq, Data.Data) - ------------------------- 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) diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 7c1ab4ba5a..1acc52fad0 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -532,7 +532,7 @@ dsExpr (SectionL x _ _) = dataConCantHappen x dsExpr (SectionR x _ _) = dataConCantHappen x ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr -ds_prag_expr (HsPragSCC _ _ cc) expr = do +ds_prag_expr (HsPragSCC _ cc) expr = do dflags <- getDynFlags if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags then do diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 86b6347e09..4e3df9b3ae 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -25,6 +25,8 @@ where import GHC.Prelude import GHC.Platform +import Language.Haskell.Syntax.Basic (Boxity(..)) + import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) import GHC.Types.Basic ( Origin(..), isGenerated ) diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 083c59b3cf..e6ecf795dd 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -46,6 +46,8 @@ module GHC.HsToCore.Utils ( import GHC.Prelude +import Language.Haskell.Syntax.Basic (Boxity(..)) + import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr ) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index f0a7d69251..280bbbfe43 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2757,13 +2757,13 @@ prag_e :: { Located (HsPragE GhcPs) } : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2 ; acs (\cs -> (sLL $1 $> (HsPragSCC - (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs) - (getSCC_PRAGs $1) + ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs), + (getSCC_PRAGs $1)) (StringLiteral (getSTRINGs $2) scc Nothing))))} } | '{-# SCC' VARID '#-}' {% acs (\cs -> (sLL $1 $> (HsPragSCC - (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs) - (getSCC_PRAGs $1) + ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs), + (getSCC_PRAGs $1)) (StringLiteral NoSourceText (getVARID $2) Nothing)))) } fexp :: { ECP } diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 97768931e9..3f99b1bfa4 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -2580,7 +2580,7 @@ mkRdrRecordCon con flds anns mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs - , rec_dotdot = Just (L s (length fs)) } + , rec_dotdot = Just (L s (RecFieldsDotDot $ length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun) diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 8503dc400c..6316ecea63 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -404,7 +404,7 @@ rnExpr (HsPragE x prag expr) ; return (HsPragE x (rn_prag prag) expr', fvs_expr) } where rn_prag :: HsPragE GhcPs -> HsPragE GhcRn - rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann + rn_prag (HsPragSCC x ann) = HsPragSCC x ann rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 7886cebdf3..2d6cb57bd1 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -689,13 +689,13 @@ rnHsRecPatsAndThen mk (L _ con) where mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n) rn_field (L l fld, n') = - do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld) + do { arg' <- rnLPatAndThen (nested_mk dd mk (RecFieldsDotDot n')) (hfbRHS fld) ; return (L l (fld { hfbRHS = arg' })) } loc = maybe noSrcSpan getLoc dd -- Get the arguments of the implicit binders - implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats + implicit_binders fs (unLoc -> RecFieldsDotDot n) = collectPatsBinders CollNoDictBinders implicit_pats where implicit_pats = map (hfbRHS . unLoc) (drop n fs) @@ -794,12 +794,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) , hfbPun = pun })) } - rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat + rn_dotdot :: Maybe (Located RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields -> RnM ([LHsRecField GhcRn (LocatedA arg)]) -- Field Labels we need to fill in - rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match + rn_dotdot (Just (L loc (RecFieldsDotDot n))) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add -- an error but still return an unbound name. We diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 02cce2e38a..f037d7f9d7 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -1219,4 +1219,4 @@ tcTagToEnum tc_fun fun_ctxt tc_args res_ty ********************************************************************* -} tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc -tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann +tcExprPrag (HsPragSCC x1 ann) = HsPragSCC x1 ann diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index f1a576dcbc..3dc6154c84 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -13,7 +13,7 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where import GHC.Prelude import GHC.Platform -import GHC.Types.Basic ( neverInlinePragma ) +import GHC.Types.Basic ( Boxity(..), neverInlinePragma ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 04ba20804f..8d795d7fe2 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -788,7 +788,7 @@ cvtForD (ExportF callconv as nm ty) ; l <- getL ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as) (mkFastString as) - (cvt_conv callconv))) + (cvt_conv callconv))) ; return $ ForeignExport { fd_e_ext = noAnn , fd_name = nm' , fd_sig_ty = ty' diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index d5eba8c4ad..027fe63bad 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -14,6 +14,7 @@ types that \end{itemize} -} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs index 12dedda5ca..4521b06874 100644 --- a/compiler/GHC/Types/FieldLabel.hs +++ b/compiler/GHC/Types/FieldLabel.hs @@ -92,13 +92,11 @@ import GHC.Data.FastString.Env import GHC.Utils.Outputable import GHC.Utils.Binary +import Language.Haskell.Syntax.Basic (FieldLabelString) + import Data.Bool import Data.Data --- | Field labels are just represented as strings; --- they are not necessarily unique (even within a module) -type FieldLabelString = FastString - -- | A map from labels to all the auxiliary information type FieldLabelEnv = DFastStringEnv FieldLabel diff --git a/compiler/Language/Haskell/Syntax/Basic.hs b/compiler/Language/Haskell/Syntax/Basic.hs index ad3e0e94ba..092231b7d1 100644 --- a/compiler/Language/Haskell/Syntax/Basic.hs +++ b/compiler/Language/Haskell/Syntax/Basic.hs @@ -1,12 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} module Language.Haskell.Syntax.Basic where -import Data.Int (Int) - +import Data.Data import Data.Eq +import Data.Ord import Data.Bool -import Data.Data +import Data.Int (Int) +import GHC.Data.FastString (FastString) {- ************************************************************************ @@ -42,4 +43,54 @@ type SumWidth = Int -- selector type ConTag = Int +{- +************************************************************************ +* * +Field Labels +* * +************************************************************************ +-} + +-- | Field labels are just represented as strings; +-- they are not necessarily unique (even within a module) +type FieldLabelString = FastString + + +{- +************************************************************************ +* * +Field Labels +* * +************************************************************************ +-} + +-- | See Note [Roles] in GHC.Core.Coercion +-- +-- Order of constructors matters: the Ord instance coincides with the *super*typing +-- relation on roles. +data Role = Nominal | Representational | Phantom + deriving (Eq, Ord, Data) + +{- +************************************************************************ +* * +Source Strictness and Unpackedness +* * +************************************************************************ +-} + +-- | Source Strictness +-- +-- What strictness annotation the user wrote +data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + deriving (Eq, Data) +-- | Source Unpackedness +-- +-- What unpackedness the user requested +data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + deriving (Eq, Data) diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs index c6193af03b..7ac866cfb2 100644 --- a/compiler/Language/Haskell/Syntax/Binds.hs +++ b/compiler/Language/Haskell/Syntax/Binds.hs @@ -31,8 +31,8 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type -import GHC.Types.Fixity -import GHC.Data.Bag +import GHC.Types.Fixity (Fixity) +import GHC.Data.Bag (Bag) import GHC.Types.Basic (InlinePragma) import GHC.Data.BooleanFormula (LBooleanFormula) diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index 0e013b3eea..56b32bb97f 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -30,18 +30,17 @@ module Language.Haskell.Syntax.Decls ( -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, - NewOrData(..), newOrDataToFlavour, + NewOrData(..), StandaloneKindSig(..), LStandaloneKindSig, -- ** Class or type declarations - TyClDecl(..), LTyClDecl, DataDeclRn(..), + TyClDecl(..), LTyClDecl, TyClGroup(..), tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, tyClGroupKindSigs, isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, - countTyClDecls, tyClDeclTyVars, FamilyDecl(..), LFamilyDecl, @@ -58,7 +57,7 @@ module Language.Haskell.Syntax.Decls ( -- ** Deriving strategies DerivStrategy(..), LDerivStrategy, -- ** @RULE@ declarations - LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), + LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl, RuleBndr(..),LRuleBndr, collectRuleBndrSigTys, -- ** @default@ declarations @@ -90,8 +89,6 @@ module Language.Haskell.Syntax.Decls ( ) where -- friends: -import GHC.Prelude - import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsExpr, HsUntypedSplice ) -- Because Expr imports Decls via HsBracket @@ -99,23 +96,28 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Basic (Role) -import GHC.Hs.Doc -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST +import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation) +import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) +import GHC.Types.Fixity (LexicalFixity) -import GHC.Core.TyCon -import GHC.Types.Basic -import GHC.Types.ForeignCall -import GHC.Types.Name.Set -import GHC.Types.Fixity +import GHC.Core.Type (Specificity) +import GHC.Unit.Module.Warnings (WarningTxt) --- others: -import GHC.Utils.Misc -import GHC.Types.SrcLoc -import GHC.Core.Type -import GHC.Unit.Module.Warnings +import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST +import Control.Monad import Data.Data hiding (TyCon, Fixity, Infix) import Data.Void +import Data.Maybe +import Data.String +import Data.Function +import Data.Eq +import Data.Int +import Data.Bool +import Prelude (Show) +import qualified Data.List {- ************************************************************************ @@ -470,12 +472,6 @@ data FunDep pass type LHsFunDep pass = XRec pass (FunDep pass) -data DataDeclRn = DataDeclRn - { tcdDataCusk :: Bool -- ^ does this have a CUSK? - -- See Note [CUSKs: complete user-supplied kind signatures] - , tcdFVs :: NameSet } - deriving Data - {- Note [TyVar binders for associated decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For an /associated/ data, newtype, or type-family decl, the LHsQTyVars @@ -569,21 +565,6 @@ tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs tyClDeclTyVars d = tcdTyVars d -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 - {- Note [CUSKs: complete user-supplied kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -715,16 +696,16 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis] tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] -tyClGroupTyClDecls = concatMap group_tyclds +tyClGroupTyClDecls = Data.List.concatMap group_tyclds tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] -tyClGroupInstDecls = concatMap group_instds +tyClGroupInstDecls = Data.List.concatMap group_instds tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] -tyClGroupRoleDecls = concatMap group_roles +tyClGroupRoleDecls = Data.List.concatMap group_roles tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass] -tyClGroupKindSigs = concatMap group_kisigs +tyClGroupKindSigs = Data.List.concatMap group_kisigs {- ********************************************************************* @@ -1005,12 +986,6 @@ data NewOrData | DataType -- ^ @data Blah ...@ deriving( Eq, Data ) -- Needed because Demand derives Eq --- | Convert a 'NewOrData' to a 'TyConFlavour' -newOrDataToFlavour :: NewOrData -> TyConFlavour -newOrDataToFlavour NewType = NewtypeFlavour -newOrDataToFlavour DataType = DataTypeFlavour - - -- | Located data Constructor Declaration type LConDecl pass = XRec pass (ConDecl pass) -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when @@ -1548,8 +1523,8 @@ data ForeignImport pass = -- import of a C entity -- * `Safety' is irrelevant for `CLabel' and `CWrapper' -- CImport (XCImport pass) - (Located CCallConv) -- ccall or stdcall - (Located Safety) -- interruptible, safe or unsafe + (XRec pass CCallConv) -- ccall or stdcall + (XRec pass Safety) -- interruptible, safe or unsafe (Maybe Header) -- name of C header CImportSpec -- details of the C entity | XForeignImport !(XXForeignImport pass) @@ -1565,7 +1540,7 @@ data CImportSpec = CLabel CLabelString -- import address of a C label -- specification of an externally exported entity in dependence on the calling -- convention -- -data ForeignExport pass = CExport (XCExport pass) (Located CExportSpec) -- contains the calling convention +data ForeignExport pass = CExport (XCExport pass) (XRec pass CExportSpec) -- contains the calling convention | XForeignExport !(XXForeignExport pass) @@ -1613,9 +1588,6 @@ data RuleDecl pass -- 'GHC.Parser.Annotation.AnnEqual', | XRuleDecl !(XXRuleDecl pass) -data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS - deriving Data - -- | Located Rule Binder type LRuleBndr pass = XRec pass (RuleBndr pass) diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 6d57489eb5..326c9903dc 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension @@ -23,8 +22,6 @@ -- | Abstract Haskell syntax for expressions. module Language.Haskell.Syntax.Expr where -import GHC.Prelude - import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat @@ -34,19 +31,19 @@ import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Binds -- others: -import GHC.Core.DataCon (FieldLabelString) -import GHC.Types.Name -import GHC.Types.Fixity -import GHC.Types.SourceText -import GHC.Types.SrcLoc +import GHC.Types.Name (OccName) +import GHC.Types.Fixity (LexicalFixity(Infix), Fixity) +import GHC.Types.SourceText (StringLiteral) + import GHC.Unit.Module (ModuleName) -import GHC.Utils.Outputable -import GHC.Utils.Panic -import GHC.Data.FastString +import GHC.Data.FastString (FastString) -- libraries: import Data.Data hiding (Fixity(..)) - +import Data.Bool +import Data.Either +import Data.Eq +import Data.Maybe import Data.List.NonEmpty ( NonEmpty ) {- Note [RecordDotSyntax field updates] @@ -138,26 +135,6 @@ type LFieldLabelStrings p = XRec p (FieldLabelStrings p) newtype FieldLabelStrings p = FieldLabelStrings [XRec p (DotFieldOcc p)] -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" - -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates]. type RecProj p arg = HsFieldBind (LFieldLabelStrings p) arg @@ -223,46 +200,6 @@ for several reasons: -- etc type family SyntaxExpr p --- | 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.) --} - {- Note [Record selectors in the AST] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -648,7 +585,6 @@ data DotFieldOcc p -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p) - SourceText -- Note [Pragma source text] in GHC.Types.SourceText StringLiteral -- "set cost centre" SCC pragma -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', @@ -686,10 +622,6 @@ data LamCaseVariant | LamCases -- ^ `\cases` deriving (Data, Eq) -lamCaseKeyword :: LamCaseVariant -> SDoc -lamCaseKeyword LamCase = text "\\case" -lamCaseKeyword LamCases = text "\\cases" - {- Note [Parens in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~ @@ -834,11 +766,6 @@ See also #13680, which requested [] @Int to work. -} ------------------------ -pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc -pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4)) - = ppr (src,(n1,n2),(n3,n4)) - {- HsSyn records exactly where the user put parens, with HsPar. So generally speaking we print without adding any parens. @@ -981,10 +908,6 @@ data HsArrAppType | HsFirstOrderApp deriving Data -pprHsArrType :: HsArrAppType -> SDoc -pprHsArrType HsHigherOrderApp = text "higher order arrow application" -pprHsArrType HsFirstOrderApp = text "first order arrow application" - {- | Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an argument of a command-forming operator. @@ -1716,113 +1639,3 @@ isMonadDoCompContext GhciStmtCtxt = False isMonadDoCompContext (DoExpr _) = False isMonadDoCompContext (MDoExpr _) = False -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 diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index 7bc4685194..4bdb3ce3cb 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -- for unXRec, etc. +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -21,12 +22,17 @@ module Language.Haskell.Syntax.Extension where -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -import GHC.Prelude +import GHC.TypeLits (Symbol, KnownSymbol) + +#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) +import Data.Type.Equality (type (~)) +#endif -import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) import Data.Data hiding ( Fixity ) import Data.Kind (Type) -import GHC.Utils.Outputable + +import Data.Eq +import Data.Ord {- Note [Trees That Grow] @@ -73,9 +79,6 @@ See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension. data NoExtField = NoExtField deriving (Data,Eq,Ord) -instance Outputable NoExtField where - ppr _ = text "NoExtField" - -- | Used when constructing a term with an unused extension point. noExtField :: NoExtField noExtField = NoExtField @@ -111,9 +114,6 @@ See also [DataConCantHappen and strict fields]. data DataConCantHappen deriving (Data,Eq,Ord) -instance Outputable DataConCantHappen where - ppr = dataConCantHappen - -- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur]. dataConCantHappen :: DataConCantHappen -> a dataConCantHappen x = case x of {} @@ -755,10 +755,3 @@ type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) - -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/Language/Haskell/Syntax/Lit.hs b/compiler/Language/Haskell/Syntax/Lit.hs index a6f3e015b7..fcb923169d 100644 --- a/compiler/Language/Haskell/Syntax/Lit.hs +++ b/compiler/Language/Haskell/Syntax/Lit.hs @@ -20,11 +20,11 @@ module Language.Haskell.Syntax.Lit where import Language.Haskell.Syntax.Extension -import GHC.Utils.Panic -import GHC.Types.SourceText -import GHC.Core.Type +import GHC.Utils.Panic (panic) +import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText, negateIntegralLit, negateFractionalLit) +import GHC.Core.Type (Type) -import GHC.Data.FastString +import GHC.Data.FastString (FastString, lexicalCompareFS) import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) @@ -32,7 +32,7 @@ import Data.Bool import Data.Ord import Data.Eq import Data.Char -import GHC.Integer (Integer) -- ROMES:TODO where is integer +import Prelude (Integer) {- ************************************************************************ diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs index 5846796de4..95abde9ce0 100644 --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -1,4 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,7 +9,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} {- (c) The University of Glasgow 2006 @@ -27,7 +27,7 @@ module Language.Haskell.Syntax.Pat ( HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, - RecFieldsDotDot, + RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldsArgs, ) where @@ -45,9 +45,12 @@ import Data.Functor import Data.Foldable import Data.Traversable import Data.Bool +import Data.Data +import Data.Eq +import Data.Ord import Data.Int import Data.Function -import Data.List +import qualified Data.List type LPat p = XRec p (Pat p) @@ -236,7 +239,7 @@ type HsConPatDetails p = HsConDetails (HsConPatTyArg (NoGhcTc p)) (LPat p) (HsRe hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps -hsConPatArgs (RecCon fs) = map (hfbRHS . unXRec @p) (rec_flds fs) +hsConPatArgs (RecCon fs) = Data.List.map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] -- | Haskell Record Fields @@ -251,8 +254,9 @@ data HsRecFields p arg -- A bunch of record fields -- AZ:The XRec for LHsRecField makes the derivings fail. -- deriving (Functor, Foldable, Traversable) --- Type synonym to be able to have a specific XRec instance for the Int in `rec_dotdot` -type RecFieldsDotDot = Int +-- | Newtype to be able to have a specific XRec instance for the Int in `rec_dotdot` +newtype RecFieldsDotDot = RecFieldsDotDot { unRecFieldsDotDot :: Int } + deriving (Data, Eq, Ord) -- Note [DotDot fields] -- ~~~~~~~~~~~~~~~~~~~~ @@ -351,10 +355,10 @@ data HsFieldBind lhs rhs = HsFieldBind { -- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p] -hsRecFields rbinds = map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) +hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg] -hsRecFieldsArgs rbinds = map (hfbRHS . unXRec @p) (rec_flds rbinds) +hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unXRec @p) (rec_flds rbinds) hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p hsRecFieldSel = foExt . unXRec @p . hfbLHS diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 8d3ed8b4dc..67bb8eabd3 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension @@ -20,12 +19,12 @@ GHC.Hs.Type: Abstract syntax: user-defined types -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Type ( - Mult, HsScaled(..), + HsScaled(..), hsMult, hsScaledThing, HsArrow(..), HsLinearArrowTokens(..), - HsType(..), HsCoreTy, LHsType, HsKind, LHsKind, + HsType(..), LHsType, HsKind, LHsKind, HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, @@ -40,10 +39,8 @@ module Language.Haskell.Syntax.Type ( LHsTypeArg, LBangType, BangType, - HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..), - Boxity(..), PromotionFlag(..), - isBoxed, isPromoted, + HsSrcBang(..), + PromotionFlag(..), isPromoted, ConDeclField(..), LConDeclField, @@ -61,17 +58,14 @@ module Language.Haskell.Syntax.Type ( import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) import Language.Haskell.Syntax.Extension -import Language.Haskell.Syntax.Basic import GHC.Types.Name.Reader ( RdrName ) -import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), - SrcStrictness(..), SrcUnpackedness(..) ) -import GHC.Core.Type -import GHC.Types.SrcLoc -import GHC.Parser.Annotation +import GHC.Core.DataCon( HsSrcBang(..) ) +import GHC.Core.Type (Specificity) +import GHC.Types.SrcLoc (SrcSpan) -import GHC.Hs.Doc -import GHC.Data.FastString +import GHC.Hs.Doc (LHsDoc) +import GHC.Data.FastString (FastString) import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Void @@ -79,7 +73,7 @@ import Data.Maybe import Data.Eq import Data.Bool import Data.Char -import GHC.Num (Integer) +import Prelude (Integer) {- ************************************************************************ @@ -899,14 +893,6 @@ data HsType pass | XHsType !(XXType pass) --- 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 - -- | Haskell Type Literal data HsTyLit pass @@ -1191,7 +1177,7 @@ if they correspond to a visible 'forall'. ************************************************************************ -} --- Arguments in an expression/type after splitting +-- | Arguments in an expression/type after splitting data HsArg tm ty = HsValArg tm -- Argument is an ordinary expression (f arg) | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) @@ -1265,8 +1251,8 @@ type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass) -- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat". -- See Note [Located RdrNames] in "GHC.Hs.Expr". data AmbiguousFieldOcc pass - = Unambiguous (XUnambiguous pass) (LocatedN RdrName) - | Ambiguous (XAmbiguous pass) (LocatedN RdrName) + = Unambiguous (XUnambiguous pass) (XRec pass RdrName) + | Ambiguous (XAmbiguous pass) (XRec pass RdrName) | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass) diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index e801360c11..d471670b49 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -280,6 +280,7 @@ GHC.Utils.Ppr.Colour GHC.Utils.TmpFs GHC.Utils.Trace Language.Haskell.Syntax +Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 86ab7d3e18..f1882b5f0f 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -287,6 +287,7 @@ GHC.Utils.Ppr.Colour GHC.Utils.TmpFs GHC.Utils.Trace Language.Haskell.Syntax +Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr index b5af7f60ba..f5dbe2fa70 100644 --- a/testsuite/tests/module/mod185.stderr +++ b/testsuite/tests/module/mod185.stderr @@ -128,7 +128,4 @@ {ModuleName: Prelude} {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))])) - [])))])) - - + (NoExtField)))))])))))])) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index f11708fa06..7ab8440879 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -1532,7 +1532,4 @@ (SourceText "hello") {FastString: "hello"})))))))] (EmptyLocalBinds - (NoExtField)))))])) - [])))])) - - + (NoExtField)))))])))))])) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr index fd620baf4b..d453ae5de1 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr @@ -188,8 +188,7 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -279,7 +278,4 @@ (SourceText "hello") {FastString: "hello"})))))))] (EmptyLocalBinds - (NoExtField)))))])) - [])))])) - - + (NoExtField)))))])))))])) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 290d505195..456117aa2c 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -81,8 +81,7 @@ (SourceText "hello") {FastString: "hello"})))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))]})] + (NoExtField)))))]))))]})] [])) [] [(TyClGroup diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr index 3d0a47521e..9147e29ec4 100644 --- a/testsuite/tests/parser/should_compile/DumpSemis.stderr +++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr @@ -386,8 +386,7 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -597,8 +596,7 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -834,8 +832,7 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -902,8 +899,7 @@ (Unqual {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -970,8 +966,7 @@ (Unqual {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -1039,8 +1034,7 @@ (Unqual {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -1441,8 +1435,7 @@ (Unqual {OccName: x}))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -1623,8 +1616,7 @@ (False) (2))))))))] (EmptyLocalBinds - (NoExtField)))))])) - [])) + (NoExtField)))))])))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -1705,8 +1697,7 @@ (False) (3))))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))]} + (NoExtField)))))]))))]} [])) (L (TokenLoc @@ -1721,8 +1712,7 @@ (Unqual {OccName: y}))))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -2121,7 +2111,4 @@ (EmptyLocalBinds (NoExtField)))))]))))))] (EmptyLocalBinds - (NoExtField)))))])) - [])))])) - - + (NoExtField)))))])))))])) diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 8cc15cc04c..d0c6b5cf13 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -1536,7 +1536,9 @@ (EpaComments [])) { DumpTypecheckedAst.hs:19:1-23 }) (FunBind - (WpHole) + ((,) + (WpHole) + []) (L (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 }) {Var: main}) @@ -1597,8 +1599,7 @@ (SourceText "hello") {FastString: "hello"})))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))]} + (NoExtField)))))]))))]} (False))))]} diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 7794fda45e..f9b9a986e4 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -919,8 +919,7 @@ (Exact {Name: ()}))))))] (EmptyLocalBinds - (NoExtField)))))])) - []))) + (NoExtField)))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -1515,7 +1514,4 @@ (Unqual {OccName: True}))))))] (EmptyLocalBinds - (NoExtField)))))])) - [])))])) - - + (NoExtField)))))])))))])) diff --git a/testsuite/tests/parser/should_compile/T20718.stderr b/testsuite/tests/parser/should_compile/T20718.stderr index fd8fbfb261..ab90eb29bc 100644 --- a/testsuite/tests/parser/should_compile/T20718.stderr +++ b/testsuite/tests/parser/should_compile/T20718.stderr @@ -158,7 +158,4 @@ (False) (1))))))))] (EmptyLocalBinds - (NoExtField)))))])) - [])))])) - - + (NoExtField)))))])))))])) diff --git a/testsuite/tests/parser/should_compile/T20846.stderr b/testsuite/tests/parser/should_compile/T20846.stderr index 5d2cf5c0ea..edacbd9ff6 100644 --- a/testsuite/tests/parser/should_compile/T20846.stderr +++ b/testsuite/tests/parser/should_compile/T20846.stderr @@ -151,7 +151,4 @@ (Unqual {OccName: undefined}))))))] (EmptyLocalBinds - (NoExtField)))))])) - [])))])) - - + (NoExtField)))))])))))])) diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.stderr b/testsuite/tests/perf/compiler/hard_hole_fits.stderr index 01df15c56c..a81e8362c3 100644 --- a/testsuite/tests/perf/compiler/hard_hole_fits.stderr +++ b/testsuite/tests/perf/compiler/hard_hole_fits.stderr @@ -300,7 +300,8 @@ hard_hole_fits.hs:29:38: warning: [-Wtyped-holes (in -Wdefault)] • In an equation for ‘testMe’: testMe (ExplicitTuple xet gls box) = _ • Relevant bindings include - box :: GHC.Types.Basic.Boxity (bound at hard_hole_fits.hs:29:31) + box :: Language.Haskell.Syntax.Basic.Boxity + (bound at hard_hole_fits.hs:29:31) gls :: [HsTupArg GhcPs] (bound at hard_hole_fits.hs:29:27) xet :: Language.Haskell.Syntax.Extension.XExplicitTuple GhcPs (bound at hard_hole_fits.hs:29:23) @@ -320,14 +321,18 @@ hard_hole_fits.hs:30:35: warning: [-Wtyped-holes (in -Wdefault)] • In an equation for ‘testMe’: testMe (ExplicitSum xes n i gl) = _ • Relevant bindings include gl :: LHsExpr GhcPs (bound at hard_hole_fits.hs:30:29) - i :: GHC.Types.Basic.Arity (bound at hard_hole_fits.hs:30:27) - n :: GHC.Types.Basic.ConTag (bound at hard_hole_fits.hs:30:25) + i :: Language.Haskell.Syntax.Basic.SumWidth + (bound at hard_hole_fits.hs:30:27) + n :: Language.Haskell.Syntax.Basic.ConTag + (bound at hard_hole_fits.hs:30:25) xes :: Language.Haskell.Syntax.Extension.XExplicitSum GhcPs (bound at hard_hole_fits.hs:30:21) testMe :: HsExpr GhcPs -> Int (bound at hard_hole_fits.hs:14:1) Valid hole fits include - n :: GHC.Types.Basic.ConTag (bound at hard_hole_fits.hs:30:25) - i :: GHC.Types.Basic.Arity (bound at hard_hole_fits.hs:30:27) + n :: Language.Haskell.Syntax.Basic.ConTag + (bound at hard_hole_fits.hs:30:25) + i :: Language.Haskell.Syntax.Basic.SumWidth + (bound at hard_hole_fits.hs:30:27) maxBound :: forall a. Bounded a => a with maxBound @Int (imported from ‘Prelude’ at hard_hole_fits.hs:8:8-20 diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout index 9bda031e23..9a220e21db 100644 --- a/testsuite/tests/printer/Test20297.stdout +++ b/testsuite/tests/printer/Test20297.stdout @@ -143,8 +143,7 @@ (NoAnnSortKey) {Bag(LocatedA (HsBind GhcPs)): []} - [])))))])) - []))) + [])))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -342,10 +341,8 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))])) - []))]} - [])))))])) - [])))])) + (NoExtField)))))]))))]} + [])))))])))))])) @@ -479,8 +476,7 @@ (NoAnnSortKey) {Bag(LocatedA (HsBind GhcPs)): []} - [])))))])) - []))) + [])))))]))))) ,(L (SrcSpanAnn (EpAnn (Anchor @@ -671,9 +667,6 @@ (NoExtField) (NoExtField)))])))))] (EmptyLocalBinds - (NoExtField)))))])) - []))]} - [])))))])) - [])))])) - + (NoExtField)))))]))))]} + [])))))])))))])) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 1255d492e0..ef2e98841b 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -944,18 +944,18 @@ instance ExactPrint (ForeignDecl GhcPs) where -- --------------------------------------------------------------------- -instance ExactPrint ForeignImport where +instance ExactPrint (ForeignImport GhcPs) where getAnnotationEntry = const NoEntryVal - exact (CImport cconv safety@(L ll _) _mh _imp (L ls src)) = do + exact (CImport (L ls src) cconv safety@(L ll _) _mh _imp) = do markAnnotated cconv unless (ll == noSrcSpan) $ markAnnotated safety unless (ls == noSrcSpan) $ markExternalSourceText ls src "" -- --------------------------------------------------------------------- -instance ExactPrint ForeignExport where +instance ExactPrint (ForeignExport GhcPs) where getAnnotationEntry = const NoEntryVal - exact (CExport spec (L ls src)) = do + exact (CExport (L ls src) spec) = do debugM $ "CExport starting" markAnnotated spec unless (ls == noSrcSpan) $ markExternalSourceText ls src "" @@ -983,8 +983,8 @@ instance ExactPrint CCallConv where -- --------------------------------------------------------------------- instance ExactPrint (WarnDecls GhcPs) where - getAnnotationEntry (Warnings an _ _) = fromAnn an - exact (Warnings an src warns) = do + getAnnotationEntry (Warnings (an,_) _) = fromAnn an + exact (Warnings (an,src) warns) = do markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED markAnnotated warns markLocatedAALS an id AnnClose (Just "#-}") @@ -1024,8 +1024,8 @@ instance ExactPrint FastString where -- --------------------------------------------------------------------- instance ExactPrint (RuleDecls GhcPs) where - getAnnotationEntry (HsRules an _ _) = fromAnn an - exact (HsRules an src rules) = do + getAnnotationEntry (HsRules (an,_) _) = fromAnn an + exact (HsRules (an, src) rules) = do case src of NoSourceText -> markLocatedAALS an id AnnOpen (Just "{-# RULES") SourceText srcTxt -> markLocatedAALS an id AnnOpen (Just srcTxt) @@ -1036,8 +1036,8 @@ instance ExactPrint (RuleDecls GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (RuleDecl GhcPs) where - getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an - exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do + getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an + exact (HsRule (an,_) ln act mtybndrs termbndrs lhs rhs) = do debugM "HsRule entered" markAnnotated ln debugM "HsRule after ln" @@ -1309,9 +1309,9 @@ instance ExactPrint (HsBind GhcPs) where getAnnotationEntry VarBind{} = NoEntryVal getAnnotationEntry PatSynBind{} = NoEntryVal - exact (FunBind _ _ matches _) = do + exact (FunBind _ _ matches) = do markAnnotated matches - exact (PatBind _ pat grhss _) = do + exact (PatBind _ pat grhss) = do markAnnotated pat markAnnotated grhss exact (PatSynBind _ bind) = markAnnotated bind @@ -1593,14 +1593,13 @@ instance ExactPrint (Sig GhcPs) where getAnnotationEntry (TypeSig a _ _) = fromAnn a getAnnotationEntry (PatSynSig a _ _) = fromAnn a getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a - getAnnotationEntry (IdSig {}) = NoEntryVal getAnnotationEntry (FixSig a _) = fromAnn a getAnnotationEntry (InlineSig a _ _) = fromAnn a getAnnotationEntry (SpecSig a _ _ _) = fromAnn a - getAnnotationEntry (SpecInstSig a _ _) = fromAnn a - getAnnotationEntry (MinimalSig a _ _) = fromAnn a - getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a - getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a + getAnnotationEntry (SpecInstSig (a, _) _) = fromAnn a + getAnnotationEntry (MinimalSig (a, _) _) = fromAnn a + getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a + getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a -- instance Annotate (Sig GhcPs) where @@ -1616,9 +1615,6 @@ instance ExactPrint (Sig GhcPs) where | is_deflt = markLocatedAAL an asRest AnnDefault >> exactVarSig an vars ty | otherwise = exactVarSig an vars ty --- markAST _ (IdSig {}) = --- traceM "warning: Introduced after renaming" - exact (FixSig an (FixitySig _ names (Fixity src v fdir))) = do let fixstr = case fdir of InfixL -> "infixl" @@ -1650,7 +1646,7 @@ instance ExactPrint (Sig GhcPs) where markAnnotated typs markLocatedAALS an id AnnClose (Just "#-}") - exact (SpecInstSig an src typ) = do + exact (SpecInstSig (an, src) typ) = do markAnnOpen an src "{-# SPECIALISE" markEpAnn an AnnInstance markAnnotated typ @@ -1663,7 +1659,7 @@ instance ExactPrint (Sig GhcPs) where -- markWithString AnnClose "#-}" -- '#-}' -- markTrailingSemi - exact (MinimalSig an src formula) = do + exact (MinimalSig (an, src) formula) = do markAnnOpen an src "{-# MINIMAL" markAnnotated formula markLocatedAALS an id AnnClose (Just "#-}") @@ -1674,13 +1670,13 @@ instance ExactPrint (Sig GhcPs) where -- markWithString AnnClose "#-}" -- markTrailingSemi - exact (SCCFunSig an src ln ml) = do + exact (SCCFunSig (an, src) ln ml) = do markAnnOpen an src "{-# SCC" markAnnotated ln markAnnotated ml markLocatedAALS an id AnnClose (Just "#-}") - exact (CompleteMatchSig an src cs mty) = do + exact (CompleteMatchSig (an, src) cs mty) = do markAnnOpen an src "{-# COMPLETE" markAnnotated cs case mty of @@ -1690,8 +1686,6 @@ instance ExactPrint (Sig GhcPs) where markAnnotated ty markLocatedAALS an id AnnClose (Just "#-}") - exact x = error $ "exact Sig for:" ++ showAst x - -- --------------------------------------------------------------------- exactVarSig :: (ExactPrint a) => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EPP () @@ -1746,9 +1740,9 @@ instance ExactPrint (DefaultDecl GhcPs) where -- --------------------------------------------------------------------- instance ExactPrint (AnnDecl GhcPs) where - getAnnotationEntry (HsAnnotation an _ _ _) = fromAnn an + getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an - exact (HsAnnotation an src prov e) = do + exact (HsAnnotation (an, src) prov e) = do markAnnOpenP an src "{-# ANN" case prov of (ValueAnnProvenance n) -> markAnnotated n @@ -2126,7 +2120,7 @@ exactMdo an (Just module_name) kw = markLocatedAALS an al_rest kw (Just n) instance ExactPrint (HsPragE GhcPs) where getAnnotationEntry HsPragSCC{} = NoEntryVal - exact (HsPragSCC an st sl) = do + exact (HsPragSCC (an, st) sl) = do markAnnOpenP an st "{-# SCC" let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) markLocatedAALS an apr_rest AnnVal (Just txt) -- optional diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index 8e79de24b3..122c63990a 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -692,7 +692,7 @@ addLocaLDecl6 libdir lp = do [de1'',d2] <- balanceCommentsList decls0 let de1 = captureMatchLineSpacing de1'' - let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)) _)) = de1 + let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1 let [ma1,_ma2] = ms (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index 08b335291c..3009160c89 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -263,8 +263,8 @@ captureOrder ls = AnnSortKey $ map (rs . getLocA) ls -- --------------------------------------------------------------------- captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs -captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )) f))) - = L l (ValD x (FunBind a b (MG c (L d ms')) f)) +captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ))))) + = L l (ValD x (FunBind a b (MG c (L d ms')))) where ms' :: [LMatch GhcPs (LHsExpr GhcPs)] ms' = captureLineSpacing ms @@ -447,8 +447,8 @@ getEntryDP anns ast = -- --------------------------------------------------------------------- setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs -setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms )) f))) dp - = L l' (ValD x (FunBind a b (MG c (L d ms')) f)) +setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ))))) dp + = L l' (ValD x (FunBind a b (MG c (L d ms')))) where L l' _ = setEntryDP' decl dp ms' :: [LMatch GhcPs (LHsExpr GhcPs)] @@ -552,8 +552,8 @@ transferEntryDP' la lb = do pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs -pushDeclDP (ValD x (FunBind a b (MG c (L d ms )) f)) dp - = ValD x (FunBind a b (MG c (L d' ms')) f) +pushDeclDP (ValD x (FunBind a b (MG c (L d ms )))) dp + = ValD x (FunBind a b (MG c (L d' ms'))) where L d' _ = setEntryDP' (L d ms) dp ms' :: [LMatch GhcPs (LHsExpr GhcPs)] @@ -623,7 +623,7 @@ balanceComments first second = do -- 'Match' if that 'Match' needs to be manipulated. balanceCommentsFB :: (Monad m) => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) -balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)) t)) second = do +balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) -- There are comments on lf. We need to -- + Keep the prior ones here @@ -655,7 +655,7 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)) t)) second = do _ -> (m'',lf') logTr $ "balanceCommentsMatch done" -- return (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t), second') - balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))) t)) second' + balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))) second' balanceCommentsFB f s = balanceComments' f s -- | Move comments on the same line as the end of the match into the @@ -1221,7 +1221,7 @@ hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent. hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] -hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb) _)) = hsDeclsValBinds lb +hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb))) = hsDeclsValBinds lb hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x -- ------------------------------------- @@ -1243,7 +1243,7 @@ replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc -- idempotent. replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsBind GhcPs) -replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) newDecls +replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds))) newDecls = do logTr "replaceDecls PatBind" -- Need to throw in a fresh where clause if the binds were empty, @@ -1261,7 +1261,7 @@ replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) newDecls -- modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls) binds'' <- replaceDeclsValbinds WithWhere binds newDecls -- let binds' = L (getLoc binds) binds'' - return (L l (PatBind x a (GRHSs xr rhss binds'') b)) + return (L l (PatBind x a (GRHSs xr rhss binds''))) replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x -- --------------------------------------------------------------------- @@ -1372,7 +1372,7 @@ hsDeclsGeneric t = q t -- --------------------------------- lhsbind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] - lhsbind (L _ (FunBind _ _ (MG _ (L _ matches)) _)) = do + lhsbind (L _ (FunBind _ _ (MG _ (L _ matches)))) = do dss <- mapM hsDecls matches return (concat dss) lhsbind p@(L _ (PatBind{})) = do diff --git a/utils/haddock b/utils/haddock -Subproject 8976930748c4c9ba19cede2f0f29037d1cbce5e +Subproject 7bd04379ada2d9ff1c406d258629f8abdf617b3 |