[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Add BufSpan to EpaLocation (#22319, #22558)
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Dec 6 12:25:42 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
1a767fa3 by Vladislav Zavialov at 2022-12-05T05:18:50-05:00
Add BufSpan to EpaLocation (#22319, #22558)
The key part of this patch is the change to mkTokenLocation:
- mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r)
+ mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb)
mkTokenLocation used to discard the BufSpan, but now it is saved and can
be retrieved from LHsToken or LHsUniToken.
This is made possible by the following change to EpaLocation:
- data EpaLocation = EpaSpan !RealSrcSpan
+ data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)
| ...
The end goal is to make use of the BufSpan in Parser/PostProcess/Haddock.
- - - - -
7bfd32c4 by sheaf at 2022-12-06T07:25:14-05:00
Hadrian: fix ghcDebugAssertions off-by-one error
Commit 6b2f7ffe changed the logic that decided whether to enable debug
assertions. However, it had an off-by-one error, as the stage parameter
to the function inconsistently referred to the stage of the compiler
being used to build or the stage of the compiler we are building.
This patch makes it consistent. Now the parameter always refers to the
the compiler which is being built.
In particular, this patch re-enables
assertions in the stage 2 compiler when building with devel2 flavour,
and disables assertions in the stage 2 compiler when building with
validate flavour.
Some extra performance tests are now run in the "validate" jobs because
the stage2 compiler no longer contains assertions.
-------------------------
Metric Decrease:
CoOpt_Singletons
MultiComponentModules
MultiComponentModulesRecomp
MultiLayerModulesTH_OneShot
T11374
T12227
T12234
T13253-spj
T13701
T14683
T14697
T15703
T17096
T17516
T18304
T18478
T18923
T5030
T9872b
TcPlugin_RewritePerf
Metric Increase:
MultiComponentModules
MultiComponentModulesRecomp
MultiLayerModules
MultiLayerModulesRecomp
MultiLayerModulesTH_Make
T13386
T13719
T3294
T9233
T9675
parsing001
-------------------------
- - - - -
63f9a9ab by mrkun at 2022-12-06T07:25:24-05:00
Push DynFlags out of runInstallNameTool
- - - - -
35795f77 by mrkun at 2022-12-06T07:25:24-05:00
Push DynFlags out of askOtool
- - - - -
5611fd6e by mrkun at 2022-12-06T07:25:24-05:00
Push DynFlags out of runInjectRPaths
- - - - -
3610891d by mrkun at 2022-12-06T07:25:24-05:00
Push DynFlags out of Linker.MacOS
- - - - -
24 changed files:
- + compiler/GHC/Driver/Config/Linker.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Hs/Dump.hs
- + compiler/GHC/Linker/Config.hs
- compiler/GHC/Linker/Dynamic.hs
- compiler/GHC/Linker/MacOS.hs
- compiler/GHC/Linker/Static.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/SysTools/Tasks.hs
- compiler/GHC/Types/SrcLoc.hs
- compiler/ghc.cabal.in
- hadrian/doc/user-settings.md
- hadrian/src/Flavour/Type.hs
- hadrian/src/Settings/Builders/RunTest.hs
- hadrian/src/Settings/Flavours/Development.hs
- hadrian/src/Settings/Packages.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Parsers.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
compiler/GHC/Driver/Config/Linker.hs
=====================================
@@ -0,0 +1,13 @@
+module GHC.Driver.Config.Linker
+ ( initFrameworkOpts
+ ) where
+
+import GHC.Linker.Config
+
+import GHC.Driver.Session
+
+initFrameworkOpts :: DynFlags -> FrameworkOpts
+initFrameworkOpts dflags = FrameworkOpts
+ { foFrameworkPaths = frameworkPaths dflags
+ , foCmdlineFrameworks = cmdlineFrameworks dflags
+ }
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -130,7 +130,7 @@ module GHC.Driver.Session (
versionedAppDir, versionedFilePath,
extraGccViaCFlags, globalPackageDatabasePath,
pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,
- pgm_windres, pgm_ar, pgm_otool, pgm_install_name_tool,
+ pgm_windres, pgm_ar,
pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i,
opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,
opt_P_signature,
@@ -833,10 +833,6 @@ pgm_lcc :: DynFlags -> (String,[Option])
pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags
pgm_ar :: DynFlags -> String
pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags
-pgm_otool :: DynFlags -> String
-pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags
-pgm_install_name_tool :: DynFlags -> String
-pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ toolSettings dflags
pgm_ranlib :: DynFlags -> String
pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags
pgm_lo :: DynFlags -> (String,[Option])
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -144,7 +144,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
_ -> parens $ text "SourceText" <+> text "blanked"
epaAnchor :: EpaLocation -> SDoc
- epaAnchor (EpaSpan r) = parens $ text "EpaSpan" <+> realSrcSpan r
+ epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r
epaAnchor (EpaDelta d cs) = case ba of
NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs
BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"
=====================================
compiler/GHC/Linker/Config.hs
=====================================
@@ -0,0 +1,13 @@
+-- | Linker configuration
+
+module GHC.Linker.Config
+ ( FrameworkOpts(..)
+ ) where
+
+import GHC.Prelude
+
+-- used on darwin only
+data FrameworkOpts = FrameworkOpts
+ { foFrameworkPaths :: [String]
+ , foCmdlineFrameworks :: [String]
+ }
=====================================
compiler/GHC/Linker/Dynamic.hs
=====================================
@@ -12,6 +12,7 @@ import GHC.Prelude
import GHC.Platform
import GHC.Platform.Ways
+import GHC.Driver.Config.Linker
import GHC.Driver.Session
import GHC.Unit.Env
@@ -23,6 +24,7 @@ import GHC.SysTools.Tasks
import GHC.Utils.Logger
import GHC.Utils.TmpFs
+import Control.Monad (when)
import System.FilePath
linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
@@ -94,7 +96,7 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
-- frameworks
pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs)
- let framework_opts = getFrameworkOpts dflags platform
+ let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform
case os of
OSMinGW32 -> do
@@ -193,7 +195,9 @@ linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
-- See Note [Dynamic linking on macOS]
++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ]
)
- runInjectRPaths logger dflags pkg_lib_paths output_fn
+ -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
+ when (gopt Opt_RPath dflags) $
+ runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn
_ -> do
-------------------------------------------------------------------
-- Making a DSO
=====================================
compiler/GHC/Linker/MacOS.hs
=====================================
@@ -9,12 +9,15 @@ where
import GHC.Prelude
import GHC.Platform
+import GHC.Linker.Config
+
import GHC.Driver.Session
import GHC.Unit.Types
import GHC.Unit.State
import GHC.Unit.Env
+import GHC.Settings
import GHC.SysTools.Tasks
import GHC.Runtime.Interpreter
@@ -46,15 +49,13 @@ import Text.ParserCombinators.ReadP as Parser
-- dynamic library through @-add_rpath at .
--
-- See Note [Dynamic linking on macOS]
-runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()
--- Make sure to honour -fno-use-rpaths if set on darwin as well see #20004
-runInjectRPaths _ dflags _ _ | not (gopt Opt_RPath dflags) = return ()
-runInjectRPaths logger dflags lib_paths dylib = do
- info <- lines <$> askOtool logger dflags Nothing [Option "-L", Option dylib]
+runInjectRPaths :: Logger -> ToolSettings -> [FilePath] -> FilePath -> IO ()
+runInjectRPaths logger toolSettings lib_paths dylib = do
+ info <- lines <$> askOtool logger toolSettings Nothing [Option "-L", Option dylib]
-- filter the output for only the libraries. And then drop the @rpath prefix.
let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
-- find any pre-existing LC_PATH items
- info <- lines <$> askOtool logger dflags Nothing [Option "-l", Option dylib]
+ info <- lines <$> askOtool logger toolSettings Nothing [Option "-l", Option dylib]
let paths = mapMaybe get_rpath info
lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
-- only find those rpaths, that aren't already in the library.
@@ -62,7 +63,7 @@ runInjectRPaths logger dflags lib_paths dylib = do
-- inject the rpaths
case rpaths of
[] -> return ()
- _ -> runInstallNameTool logger dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
+ _ -> runInstallNameTool logger toolSettings $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
get_rpath :: String -> Maybe FilePath
get_rpath l = case readP_to_S rpath_parser l of
@@ -96,15 +97,15 @@ getUnitFrameworkOpts unit_env dep_packages
| otherwise = return []
-getFrameworkOpts :: DynFlags -> Platform -> [String]
-getFrameworkOpts dflags platform
+getFrameworkOpts :: FrameworkOpts -> Platform -> [String]
+getFrameworkOpts fwOpts platform
| platformUsesFrameworks platform = framework_path_opts ++ framework_opts
| otherwise = []
where
- framework_paths = frameworkPaths dflags
+ framework_paths = foFrameworkPaths fwOpts
framework_path_opts = map ("-F" ++) framework_paths
- frameworks = cmdlineFrameworks dflags
+ frameworks = foCmdlineFrameworks fwOpts
-- reverse because they're added in reverse order from the cmd line:
framework_opts = concat [ ["-framework", fw]
| fw <- reverse frameworks ]
=====================================
compiler/GHC/Linker/Static.hs
=====================================
@@ -29,6 +29,7 @@ import GHC.Linker.ExtraObj
import GHC.Linker.Windows
import GHC.Linker.Static.Utils
+import GHC.Driver.Config.Linker
import GHC.Driver.Session
import System.FilePath
@@ -171,7 +172,7 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
-- frameworks
pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units
- let framework_opts = getFrameworkOpts dflags platform
+ let framework_opts = getFrameworkOpts (initFrameworkOpts dflags) platform
-- probably _stub.o files
let extra_ld_inputs = ldInputs dflags
@@ -183,7 +184,9 @@ linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
let link dflags args | platformOS platform == OSDarwin
= do
GHC.SysTools.runLink logger tmpfs dflags args
- GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn
+ -- Make sure to honour -fno-use-rpaths if set on darwin as well; see #20004
+ when (gopt Opt_RPath dflags) $
+ GHC.Linker.MacOS.runInjectRPaths logger (toolSettings dflags) pkg_lib_paths output_fn
| otherwise
= GHC.SysTools.runLink logger tmpfs dflags args
=====================================
compiler/GHC/Parser.y
=====================================
@@ -3058,34 +3058,34 @@ tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }
: texp commas_tup_tail
{ unECP $1 >>= \ $1 ->
$2 >>= \ $2 ->
- do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)]
+ do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]
; return (Tuple (Right t : snd $2)) } }
| commas tup_tail
{ $2 >>= \ $2 ->
- do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (EpaSpan $ rs ll) emptyComments))) (fst $1) }
+ do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (srcSpan2e ll) emptyComments))) (fst $1) }
; return (Tuple (cos ++ $2)) } }
| texp bars { unECP $1 >>= \ $1 -> return $
- (Sum 1 (snd $2 + 1) $1 [] (map (EpaSpan . realSrcSpan) $ fst $2)) }
+ (Sum 1 (snd $2 + 1) $1 [] (map srcSpan2e $ fst $2)) }
| bars texp bars0
{ unECP $2 >>= \ $2 -> return $
(Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2
- (map (EpaSpan . realSrcSpan) $ fst $1)
- (map (EpaSpan . realSrcSpan) $ fst $3)) }
+ (map srcSpan2e $ fst $1)
+ (map srcSpan2e $ fst $3)) }
-- Always starts with commas; always follows an expr
commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) }
commas_tup_tail : commas tup_tail
{ $2 >>= \ $2 ->
- do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (EpaSpan $ rs l) emptyComments))) (tail $ fst $1) }
+ do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (srcSpan2e l) emptyComments))) (tail $ fst $1) }
; return ((head $ fst $1, cos ++ $2)) } }
-- Always follows a comma
tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)] }
: texp commas_tup_tail { unECP $1 >>= \ $1 ->
$2 >>= \ $2 ->
- do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)]
+ do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]
; return (Right t : snd $2) } }
| texp { unECP $1 >>= \ $1 ->
return [Right $1] }
@@ -3564,10 +3564,10 @@ qcon_list : qcon { sL1N $1 [$1] }
sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors
: '(' ')' {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }
| '(' commas ')' {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))
- (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(#' '#)' {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }
| '(#' commas '#)' {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))
- (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
-- See Note [Empty lists] in GHC.Hs.Expr
sysdcon :: { LocatedN DataCon }
@@ -3601,12 +3601,12 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit
: oqtycon { $1 }
| '(' commas ')' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed
(snd $2 + 1)))
- (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(#' commas '#)' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed
(snd $2 + 1)))
- (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))
- (NameAnnBars NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }
+ (NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
(NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
| '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR)
@@ -4210,27 +4210,27 @@ in GHC.Parser.Annotation
-- |Construct an AddEpAnn from the annotation keyword and the location
-- of the keyword itself
mj :: AnnKeywordId -> Located e -> AddEpAnn
-mj a l = AddEpAnn a (EpaSpan $ rs $ gl l)
+mj a l = AddEpAnn a (srcSpan2e $ gl l)
mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn
-mjN a l = AddEpAnn a (EpaSpan $ rs $ glN l)
+mjN a l = AddEpAnn a (srcSpan2e $ glN l)
-- |Construct an AddEpAnn from the annotation keyword and the location
-- of the keyword itself, provided the span is not zero width
mz :: AnnKeywordId -> Located e -> [AddEpAnn]
-mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (EpaSpan $ rs $ gl l)]
+mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)]
msemi :: Located e -> [TrailingAnn]
-msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)]
+msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)]
msemim :: Located e -> Maybe EpaLocation
-msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l)
+msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l)
-- |Construct an AddEpAnn from the annotation keyword and the Located Token. If
-- the token has a unicode equivalent and this has been used, provide the
-- unicode variant of the annotation.
mu :: AnnKeywordId -> Located Token -> AddEpAnn
-mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l)
+mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l)
-- | If the 'Token' is using its unicode variant return the unicode variant of
-- the annotation
@@ -4253,7 +4253,7 @@ glR :: Located a -> Anchor
glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor
glAA :: Located a -> EpaLocation
-glAA = EpaSpan <$> realSrcSpan . getLoc
+glAA = srcSpan2e . getLoc
glRR :: Located a -> RealSrcSpan
glRR = realSrcSpan . getLoc
@@ -4265,7 +4265,7 @@ glNR :: LocatedN a -> Anchor
glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor
glNRR :: LocatedN a -> EpaLocation
-glNRR = EpaSpan <$> realSrcSpan . getLocA
+glNRR = srcSpan2e . getLocA
anc :: RealSrcSpan -> Anchor
anc r = Anchor r UnchangedAnchor
@@ -4395,7 +4395,7 @@ rs _ = panic "Parser should only have RealSrcSpan"
hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList
hsDoAnn (L l _) (L ll _) kw
- = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (EpaSpan $ rs l)] []
+ = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []
listAsAnchor :: [LocatedAn t a] -> Anchor
listAsAnchor [] = spanAsAnchor noSrcSpan
@@ -4435,16 +4435,16 @@ addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do
let
anns' = if isZeroWidthSpan ss
then anns
- else addTrailingAnnToA l (ta (EpaSpan $ rs ss)) cs anns
+ else addTrailingAnnToA l (ta (srcSpan2e ss)) cs anns
return (L (SrcSpanAnn anns' l) a)
-- -------------------------------------
addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)
-addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (EpaSpan $ rs span))
+addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (srcSpan2e span))
addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)
-addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (EpaSpan $ rs span))
+addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span))
addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)
addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do
@@ -4462,7 +4462,7 @@ addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do
-- AZ:TODO: generalise updating comments into an annotation
let anns' = if isZeroWidthSpan span
then anns
- else addTrailingCommaToN l anns (EpaSpan $ rs span)
+ else addTrailingCommaToN l anns (srcSpan2e span)
return (L (SrcSpanAnn anns' l) a)
addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -51,7 +51,7 @@ module GHC.Parser.Annotation (
la2na, na2la, n2l, l2n, l2l, la2la,
reLoc, reLocA, reLocL, reLocC, reLocN,
- la2r, realSrcSpan,
+ srcSpan2e, la2e, realSrcSpan,
-- ** Building up annotations
extraToAnnList, reAnn,
@@ -403,7 +403,7 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
-- in the @'EpaDelta'@ variant captures any comments between the prior
-- output and the thing being marked here, since we cannot otherwise
-- sort the relative order.
-data EpaLocation = EpaSpan !RealSrcSpan
+data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)
| EpaDelta !DeltaPos ![LEpaComment]
deriving (Data,Eq)
@@ -447,15 +447,15 @@ getDeltaLine (DifferentLine r _) = r
-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the
-- partial function is safe.
epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan
-epaLocationRealSrcSpan (EpaSpan r) = r
+epaLocationRealSrcSpan (EpaSpan r _) = r
epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan"
epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation
-epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l)
-epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc)
+epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing
+epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing
instance Outputable EpaLocation where
- ppr (EpaSpan r) = text "EpaSpan" <+> ppr r
+ ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r
ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
instance Outputable AddEpAnn where
@@ -916,8 +916,12 @@ realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
where
l = mkRealSrcLoc (fsLit "foo") (-1) (-1)
-la2r :: SrcSpanAnn' a -> RealSrcSpan
-la2r l = realSrcSpan (locA l)
+srcSpan2e :: SrcSpan -> EpaLocation
+srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb
+srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing
+
+la2e :: SrcSpanAnn' a -> EpaLocation
+la2e = srcSpan2e . locA
extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList
extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t
@@ -976,7 +980,7 @@ widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan
widenSpan s as = foldl combineSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest
+ go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest
go (AddEpAnn _ (EpaDelta _ _):rest) = go rest
-- | The annotations need to all come after the anchor. Make sure
@@ -985,7 +989,7 @@ widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan
widenRealSpan s as = foldl combineRealSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s):rest) = s : go rest
+ go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest
go (AddEpAnn _ (EpaDelta _ _):rest) = go rest
widenAnchor :: Anchor -> [AddEpAnn] -> Anchor
=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -3646,7 +3646,7 @@ warn_unknown_prag prags span buf len buf2 = do
-- 'AddEpAnn' values for the opening and closing bordering on the start
-- and end of the span
mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)
-mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc))
+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing))
where
f = srcSpanFile ss
sl = srcSpanStartLine ss
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -471,13 +471,13 @@ annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing)
annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)
add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
-add_where an@(AddEpAnn _ (EpaSpan rs)) (EpAnn a (AnnList anc o c r t) cs) cs2
+add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2
| valid_anchor (anchor a)
= EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)
| otherwise
= EpAnn (patch_anchor rs a)
(AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)
-add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed cs
+add_where an@(AddEpAnn _ (EpaSpan rs _)) EpAnnNotUsed cs
= EpAnn (Anchor rs UnchangedAnchor)
(AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs
add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where"
@@ -501,7 +501,7 @@ fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
-- | The 'Anchor' for a stmtlist is based on either the location or
-- the first semicolon annotion.
stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor
-stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r)) _), _))
+stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r _)) _), _))
= widenAnchorR (Anchor (realSrcSpan l) UnchangedAnchor) r
stmtsAnchor (L l _) = Anchor (realSrcSpan l) UnchangedAnchor
@@ -1039,13 +1039,13 @@ checkTyClHdr is_cls ty
newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =
let
lr = combineRealSrcSpans (realSrcSpan l) (anchor as)
- an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs)
+ an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c []) cs)
in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
newAnns _ EpAnnNotUsed = panic "missing AnnParen"
newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =
let
lr = combineRealSrcSpans (anchor ap) (anchor as)
- an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs))
+ an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs))
in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
-- | Yield a parse error if we have a function applied directly to a do block
@@ -2855,7 +2855,7 @@ checkImportSpec ie@(L _ specs) =
mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
mkImpExpSubSpec [L la ImpExpQcWildcard] =
- return ([AddEpAnn AnnDotdot (EpaSpan $ la2r la)], ImpExpAll)
+ return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
then return $ ([], ImpExpAllWith xs)
@@ -3124,14 +3124,14 @@ mkMultTy pct t arr = HsExplicitMult pct t arr
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
-mkTokenLocation (RealSrcSpan r _) = TokenLoc (EpaSpan r)
+mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb)
-- Precondition: the TokenLocation has EpaSpan, never EpaDelta.
token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation
token_location_widenR NoTokenLoc _ = NoTokenLoc
token_location_widenR tl (UnhelpfulSpan _) = tl
-token_location_widenR (TokenLoc (EpaSpan r1)) (RealSrcSpan r2 _) =
- (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2)))
+token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) =
+ (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2)))
token_location_widenR (TokenLoc (EpaDelta _ _)) _ =
-- Never happens because the parser does not produce EpaDelta.
panic "token_location_widenR: EpaDelta"
=====================================
compiler/GHC/Rename/Names.hs
=====================================
@@ -2011,14 +2011,14 @@ printMinimalImports hsc_src imports_w_usage
to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn_var (L l n)
- | isDataOcc $ occName n = L l (IEPattern (EpaSpan $ la2r l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (la2na l) n))
+ | otherwise = L l (IEName noExtField (L (la2na l) n))
to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn (L l n)
- | isTcOcc occ && isSymOcc occ = L l (IEType (EpaSpan $ la2r l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (la2na l) n))
+ | otherwise = L l (IEName noExtField (L (la2na l) n))
where occ = occName n
{-
=====================================
compiler/GHC/SysTools/Tasks.hs
=====================================
@@ -16,6 +16,8 @@ import GHC.IO (catchException)
import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)
+import GHC.Settings
+
import GHC.SysTools.Process
import GHC.SysTools.Info
@@ -362,15 +364,15 @@ runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do
let ar = pgm_ar dflags
runSomethingFiltered logger id "Ar" ar args cwd Nothing
-askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String
-askOtool logger dflags mb_cwd args = do
- let otool = pgm_otool dflags
+askOtool :: Logger -> ToolSettings -> Maybe FilePath -> [Option] -> IO String
+askOtool logger toolSettings mb_cwd args = do
+ let otool = toolSettings_pgm_otool toolSettings
runSomethingWith logger "otool" otool args $ \real_args ->
readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }
-runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()
-runInstallNameTool logger dflags args = do
- let tool = pgm_install_name_tool dflags
+runInstallNameTool :: Logger -> ToolSettings -> [Option] -> IO ()
+runInstallNameTool logger toolSettings args = do
+ let tool = toolSettings_pgm_install_name_tool toolSettings
runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing
runRanlib :: Logger -> DynFlags -> [Option] -> IO ()
=====================================
compiler/GHC/Types/SrcLoc.hs
=====================================
@@ -70,6 +70,7 @@ module GHC.Types.SrcLoc (
BufSpan(..),
getBufSpan,
removeBufSpan,
+ combineBufSpans,
-- * Located
Located,
=====================================
compiler/ghc.cabal.in
=====================================
@@ -421,6 +421,7 @@ Library
GHC.Driver.Config.HsToCore
GHC.Driver.Config.HsToCore.Ticks
GHC.Driver.Config.HsToCore.Usage
+ GHC.Driver.Config.Linker
GHC.Driver.Config.Logger
GHC.Driver.Config.Parser
GHC.Driver.Config.Stg.Debug
@@ -529,6 +530,7 @@ Library
GHC.JS.Syntax
GHC.JS.Transform
GHC.Linker
+ GHC.Linker.Config
GHC.Linker.Dynamic
GHC.Linker.ExtraObj
GHC.Linker.Loader
=====================================
hadrian/doc/user-settings.md
=====================================
@@ -25,7 +25,7 @@ data Flavour = Flavour {
packages :: Stage -> Action [Package],
-- | Bignum backend: 'native', 'gmp', 'ffi', etc.
bignumBackend :: String,
- -- | Check bignum backend against native
+ -- | Check selected bignum backend against native backend
bignumCheck :: Bool,
-- | Build libraries these ways.
libraryWays :: Ways,
@@ -34,15 +34,20 @@ data Flavour = Flavour {
-- | Build dynamic GHC programs.
dynamicGhcPrograms :: Action Bool,
-- | Enable GHCi debugger.
- ghciWithDebugger :: Bool,
+ ghciWithDebugger :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build profiled GHC.
- ghcProfiled :: Bool,
+ ghcProfiled :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build GHC with the debug RTS.
- ghcDebugged :: Bool,
+ ghcDebugged :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build GHC with debug assertions (-DDEBUG).
- ghcDebugAssertions :: Bool,
+ ghcDebugAssertions :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build the GHC executable against the threaded runtime system.
- ghcThreaded :: Bool,
+ ghcThreaded :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Whether to build docs and which ones
-- (haddocks, user manual, haddock manual)
ghcDocs :: Action DocTargets }
=====================================
hadrian/src/Flavour/Type.hs
=====================================
@@ -18,9 +18,9 @@ data Flavour = Flavour {
args :: Args,
-- | Build these packages.
packages :: Stage -> Action [Package],
- -- | 'native', 'gmp', 'ffi'.
+ -- | Bignum backend: 'native', 'gmp', 'ffi', etc.
bignumBackend :: String,
- -- | Check selected backend against native backend
+ -- | Check selected bignum backend against native backend
bignumCheck :: Bool,
-- | Build libraries these ways.
libraryWays :: Ways,
@@ -29,15 +29,20 @@ data Flavour = Flavour {
-- | Build dynamic GHC programs.
dynamicGhcPrograms :: Action Bool,
-- | Enable GHCi debugger.
- ghciWithDebugger :: Stage -> Bool,
+ ghciWithDebugger :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build profiled GHC.
- ghcProfiled :: Stage -> Bool,
+ ghcProfiled :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build GHC with the debug RTS.
- ghcDebugged :: Stage -> Bool,
- -- | Build GHC with debug assertions.
- ghcDebugAssertions :: Stage -> Bool,
+ ghcDebugged :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
+ -- | Build GHC with debug assertions (-DDEBUG).
+ ghcDebugAssertions :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Build the GHC executable against the threaded runtime system.
- ghcThreaded :: Stage -> Bool,
+ ghcThreaded :: Stage -- ^ stage of the /built/ compiler
+ -> Bool,
-- | Whether to build docs and which ones
-- (haddocks, user manual, haddock manual)
ghcDocs :: Action DocTargets }
=====================================
hadrian/src/Settings/Builders/RunTest.hs
=====================================
@@ -101,7 +101,7 @@ inTreeCompilerArgs stg = do
unregisterised <- flag GhcUnregisterised
tables_next_to_code <- flag TablesNextToCode
withSMP <- targetSupportsSMP
- debugAssertions <- ($ stg) . ghcDebugAssertions <$> flavour
+ debugAssertions <- ($ succStage stg) . ghcDebugAssertions <$> flavour
profiled <- ghcProfiled <$> flavour <*> pure stg
os <- setting HostOs
=====================================
hadrian/src/Settings/Flavours/Development.hs
=====================================
@@ -16,12 +16,12 @@ developmentFlavour ghcStage = defaultFlavour
, libraryWays = pure $ Set.fromList [vanilla]
, rtsWays = Set.fromList <$> mconcat [pure [vanilla, debug], targetSupportsThreadedRts ? pure [threaded, threadedDebug]]
, dynamicGhcPrograms = return False
- , ghcDebugAssertions = (>= Stage2) }
+ , ghcDebugAssertions = (== ghcStage) }
where
stageString Stage2 = "2"
stageString Stage1 = "1"
stageString Stage3 = "3"
- stageString s = error ("developmentFlavour not support for " ++ show s)
+ stageString s = error ("developmentFlavour not supported for " ++ show s)
developmentArgs :: Stage -> Args
developmentArgs ghcStage = do
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -13,7 +13,6 @@ packageArgs :: Args
packageArgs = do
stage <- getStage
path <- getBuildPath
- root <- getBuildRoot
compilerPath <- expr $ buildPath (vanillaContext stage compiler)
let -- Do not bind the result to a Boolean: this forces the configure rule
@@ -29,7 +28,10 @@ packageArgs = do
cursesLibraryDir <- getSetting CursesLibDir
ffiIncludeDir <- getSetting FfiIncludeDir
ffiLibraryDir <- getSetting FfiLibDir
- debugAssertions <- ghcDebugAssertions <$> expr flavour
+ debugAssertions <- ( `ghcDebugAssertions` (succStage stage) ) <$> expr flavour
+ -- NB: in this function, "stage" is the stage of the compiler we are
+ -- using to build, but ghcDebugAssertions wants the stage of the compiler
+ -- we are building, which we get using succStage.
mconcat
--------------------------------- base ---------------------------------
@@ -52,7 +54,7 @@ packageArgs = do
[ builder Alex ? arg "--latin1"
, builder (Ghc CompileHs) ? mconcat
- [ debugAssertions stage ? arg "-DDEBUG"
+ [ debugAssertions ? arg "-DDEBUG"
, inputs ["**/GHC.hs", "**/GHC/Driver/Make.hs"] ? arg "-fprof-auto"
, input "**/Parser.hs" ?
@@ -83,7 +85,7 @@ packageArgs = do
, package ghc ? mconcat
[ builder Ghc ? mconcat
[ arg ("-I" ++ compilerPath)
- , debugAssertions stage ? arg "-DDEBUG" ]
+ , debugAssertions ? arg "-DDEBUG" ]
, builder (Cabal Flags) ? mconcat
[ andM [expr ghcWithInterpreter, notStage0] `cabalFlag` "internal-interpreter"
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -543,7 +543,7 @@ printStringAtAAL (EpAnn anc an cs) l str = do
printStringAtAAC :: (Monad m, Monoid w)
=> CaptureComments -> EpaLocation -> String -> EP w m EpaLocation
-printStringAtAAC capture (EpaSpan r) s = printStringAtRsC capture r s
+printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s
printStringAtAAC capture (EpaDelta d cs) s = do
mapM_ (printOneComment . tokComment) cs
pe1 <- getPriorEndD
@@ -4108,7 +4108,7 @@ printUnicode anc n = do
s -> s
loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str
case loc of
- EpaSpan _ -> return anc
+ EpaSpan _ _ -> return anc
EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp }
EpaDelta _ _cs -> error "printUnicode should not capture comments"
=====================================
utils/check-exact/Parsers.hs
=====================================
@@ -285,7 +285,7 @@ fixModuleTrailingComments (GHC.L l p) = GHC.L l p'
rebalance al cs = cs'
where
cs' = case GHC.al_close al of
- Just (GHC.AddEpAnn _ (GHC.EpaSpan ss)) ->
+ Just (GHC.AddEpAnn _ (GHC.EpaSpan ss _)) ->
let
pc = GHC.priorComments cs
fc = GHC.getFollowingComments cs
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -213,7 +213,7 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll
L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor?
dc' = case dca of
- EpaSpan r -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
+ EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) [])
EpaDelta _ _ -> AddEpAnn kw dca
-- ---------------------------------
@@ -223,7 +223,7 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
(L (SrcSpanAnn EpAnnNotUsed ll) b)
-> let
op = case dca of
- EpaSpan r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll))
+ EpaSpan r _ -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll))
EpaDelta _ _ -> MovedAnchor (SameLine 1)
in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty emptyComments) ll) b)
(L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b)
@@ -231,7 +231,7 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H
op' = case op of
MovedAnchor _ -> op
_ -> case dca of
- EpaSpan dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r)
+ EpaSpan dcr _ -> MovedAnchor (ss2delta (ss2posEnd dcr) r)
EpaDelta _ _ -> MovedAnchor (SameLine 1)
in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b)
@@ -341,13 +341,13 @@ getEntryDP _ = SameLine 1
addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation
addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs
-addEpaLocationDelta off anc (EpaSpan r)
+addEpaLocationDelta off anc (EpaSpan r _)
= EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) []
-- Set the entry DP for an element coming after an existing keyword annotation
setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t
setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a
-setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP ll dp'
+setEntryDPFromAnchor off (EpaSpan anc _) ll@(L la _) = setEntryDP ll dp'
where
r = case la of
(SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l
@@ -944,7 +944,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
(L (TokenLoc l) ls, L (TokenLoc i) is) ->
let
off = case l of
- (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r
+ (EpaSpan r _) -> LayoutStartCol $ snd $ ss2pos r
(EpaDelta (SameLine _) _) -> LayoutStartCol 0
(EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c
ex'' = setEntryDPFromAnchor off i ex
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -119,7 +119,7 @@ undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc)
fc = co + dc
undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn
-undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp)
+undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp Strict.Nothing)
where
(l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0)
len = length (keywordToString kw)
@@ -256,7 +256,7 @@ sortEpaComments cs = sortBy cmp cs
-- | Makes a comment which originates from a specific keyword.
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
-mkKWComment kw (EpaSpan ss)
+mkKWComment kw (EpaSpan ss _)
= Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw)
mkKWComment kw (EpaDelta dp _)
= Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw)
@@ -373,7 +373,7 @@ addEpAnnLoc (AddEpAnn _ l) = l
-- TODO: move this to GHC
anchorToEpaLocation :: Anchor -> EpaLocation
-anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r
+anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r Strict.Nothing
anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp []
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1edc25795ae09bfd39e5c0e5e185c64553f290c3...3610891d555379d2f79fdcbb3ada56d95032dbaa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1edc25795ae09bfd39e5c0e5e185c64553f290c3...3610891d555379d2f79fdcbb3ada56d95032dbaa
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221206/a8b4f5fe/attachment-0001.html>
More information about the ghc-commits
mailing list