summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--compiler/GHC/Core/Coercion/Axiom.hs11
-rw-r--r--compiler/GHC/Core/DataCon.hs19
-rw-r--r--compiler/GHC/Hs/Binds.hs1
-rw-r--r--compiler/GHC/Hs/Decls.hs33
-rw-r--r--compiler/GHC/Hs/Expr.hs197
-rw-r--r--compiler/GHC/Hs/Extension.hs19
-rw-r--r--compiler/GHC/Hs/Pat.hs3
-rw-r--r--compiler/GHC/Hs/Type.hs8
-rw-r--r--compiler/GHC/Hs/Utils.hs2
-rw-r--r--compiler/GHC/HsToCore/Expr.hs2
-rw-r--r--compiler/GHC/HsToCore/Match.hs2
-rw-r--r--compiler/GHC/HsToCore/Utils.hs2
-rw-r--r--compiler/GHC/Parser.y8
-rw-r--r--compiler/GHC/Parser/PostProcess.hs2
-rw-r--r--compiler/GHC/Rename/Expr.hs2
-rw-r--r--compiler/GHC/Rename/Pat.hs8
-rw-r--r--compiler/GHC/Tc/Gen/App.hs2
-rw-r--r--compiler/GHC/Tc/Instance/Typeable.hs2
-rw-r--r--compiler/GHC/ThToHs.hs2
-rw-r--r--compiler/GHC/Types/Basic.hs1
-rw-r--r--compiler/GHC/Types/FieldLabel.hs6
-rw-r--r--compiler/Language/Haskell/Syntax/Basic.hs57
-rw-r--r--compiler/Language/Haskell/Syntax/Binds.hs4
-rw-r--r--compiler/Language/Haskell/Syntax/Decls.hs80
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs205
-rw-r--r--compiler/Language/Haskell/Syntax/Extension.hs25
-rw-r--r--compiler/Language/Haskell/Syntax/Lit.hs10
-rw-r--r--compiler/Language/Haskell/Syntax/Pat.hs20
-rw-r--r--compiler/Language/Haskell/Syntax/Type.hs40
-rw-r--r--testsuite/tests/count-deps/CountDepsAst.stdout1
-rw-r--r--testsuite/tests/count-deps/CountDepsParser.stdout1
-rw-r--r--testsuite/tests/module/mod185.stderr5
-rw-r--r--testsuite/tests/parser/should_compile/DumpParsedAst.stderr5
-rw-r--r--testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr8
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr3
-rw-r--r--testsuite/tests/parser/should_compile/DumpSemis.stderr35
-rw-r--r--testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr7
-rw-r--r--testsuite/tests/parser/should_compile/KindSigs.stderr8
-rw-r--r--testsuite/tests/parser/should_compile/T20718.stderr5
-rw-r--r--testsuite/tests/parser/should_compile/T20846.stderr5
-rw-r--r--testsuite/tests/perf/compiler/hard_hole_fits.stderr15
-rw-r--r--testsuite/tests/printer/Test20297.stdout19
-rw-r--r--utils/check-exact/ExactPrint.hs52
-rw-r--r--utils/check-exact/Main.hs2
-rw-r--r--utils/check-exact/Transform.hs24
m---------utils/haddock0
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