[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: compiler: Allow more types in GHCForeignImportPrim
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Fri Apr 5 18:08:27 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9b9e031b by Ben Gamari at 2024-04-04T21:30:08-04:00
compiler: Allow more types in GHCForeignImportPrim
For many, many years `GHCForeignImportPrim` has suffered from the rather
restrictive limitation of not allowing any non-trivial types in arguments
or results. This limitation was justified by the code generator allegely
barfing in the presence of such types.
However, this restriction appears to originate well before the NCG
rewrite and the new NCG does not appear to have any trouble with such
types (see the added `T24598` test). Lift this restriction.
Fixes #24598.
- - - - -
1324b862 by Alan Zimmerman at 2024-04-04T21:30:44-04:00
EPA: Use EpaLocation not SrcSpan in ForeignDecls
This allows us to update them for makeDeltaAst in ghc-exactprint
- - - - -
f7f3164e by Alan Zimmerman at 2024-04-05T14:08:10-04:00
EPA: Use EpaLocation for RecFieldsDotDot
So we can update it to a delta position in makeDeltaAst if needed.
- - - - -
81bbfde9 by Matthew Pickering at 2024-04-05T14:08:11-04:00
Remove accidentally committed test.hs
- - - - -
23 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- compiler/GHC/ThToHs.hs
- − test.hs
- testsuite/tests/ffi/should_fail/ccfail001.stderr
- + testsuite/tests/ffi/should_run/T24598.hs
- + testsuite/tests/ffi/should_run/T24598.stdout
- + testsuite/tests/ffi/should_run/T24598_cmm.cmm
- + testsuite/tests/ffi/should_run/T24598b.hs
- + testsuite/tests/ffi/should_run/T24598b.stdout
- + testsuite/tests/ffi/should_run/T24598b_cmm.cmm
- + testsuite/tests/ffi/should_run/T24598c.hs
- + testsuite/tests/ffi/should_run/T24598c.stdout
- + testsuite/tests/ffi/should_run/T24598c_cmm.cmm
- testsuite/tests/ffi/should_run/all.T
- utils/check-exact/ExactPrint.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -1131,10 +1131,10 @@ type instance XForeignExport GhcTc = Coercion
type instance XXForeignDecl (GhcPass _) = DataConCantHappen
-type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity
+type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
type instance XXForeignImport (GhcPass _) = DataConCantHappen
-type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity
+type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity
type instance XXForeignExport (GhcPass _) = DataConCantHappen
-- pretty printing of foreign declarations
@@ -1399,6 +1399,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) = EpAnnCO
-type instance Anno CCallConv = SrcSpan
-type instance Anno Safety = SrcSpan
-type instance Anno CExportSpec = SrcSpan
+type instance Anno CCallConv = EpaLocation
+type instance Anno Safety = EpaLocation
+type instance Anno CExportSpec = EpaLocation
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -350,7 +350,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
instance Outputable (HsTyPat p) => Outputable (HsConPatTyArg p) where
ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty
-instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot)
+instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ LocatedE RecFieldsDotDot)
=> Outputable (HsRecFields p arg) where
ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
= braces (fsep (punctuate comma (map ppr flds)))
@@ -976,4 +976,4 @@ type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA
type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO
type instance Anno ConLike = SrcSpanAnnN
type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA
-type instance Anno RecFieldsDotDot = SrcSpan
+type instance Anno RecFieldsDotDot = EpaLocation
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1830,7 +1830,7 @@ lPatImplicits = hs_lpat
details (RecCon (HsRecFields { rec_dotdot = Nothing, rec_flds }))
= hs_lpats $ map (hfbRHS . unLoc) rec_flds
details (RecCon (HsRecFields { rec_dotdot = Just (L err_loc rec_dotdot), rec_flds }))
- = [(err_loc, implicit_field_binders)]
+ = [(l2l err_loc, implicit_field_binders)]
++ hs_lpats explicit_pats
where (explicit_pats, implicit_field_binders)
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -2095,15 +2095,15 @@ instance ToHie (LocatedA (ForeignDecl GhcRn)) where
instance ToHie (ForeignImport GhcRn) where
toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $
- [ locOnly a
- , locOnly b
- , locOnly c
+ [ locOnlyE a
+ , locOnlyE b
+ , locOnlyE c
]
instance ToHie (ForeignExport GhcRn) where
toHie (CExport (L b _) (L a _)) = concatM $
- [ locOnly a
- , locOnly b
+ [ locOnlyE a
+ , locOnlyE b
]
instance ToHie (LocatedA (WarnDecls GhcRn)) where
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -533,6 +533,10 @@ locOnly (RealSrcSpan span _) = do
pure [Node e span []]
locOnly _ = pure []
+locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a]
+locOnlyE (EpaSpan s) = locOnly s
+locOnlyE _ = pure []
+
mkScope :: (HasLoc a) => a -> Scope
mkScope a = case getHasLoc a of
(RealSrcSpan sp _) -> LocalScope sp
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -39,6 +39,7 @@ module GHC.Parser.Annotation (
-- ** Annotations in 'GenLocated'
LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,
SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,
+ LocatedE,
-- ** Annotation data types used in 'GenLocated'
@@ -644,6 +645,8 @@ type SrcSpanAnnL = EpAnn AnnList
type SrcSpanAnnP = EpAnn AnnPragma
type SrcSpanAnnC = EpAnn AnnContext
+type LocatedE = GenLocated EpaLocation
+
-- | General representation of a 'GenLocated' type carrying a
-- parameterised annotation type.
type LocatedAn an = GenLocated (EpAnn an)
@@ -1049,9 +1052,12 @@ reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a
class HasAnnotation e where
noAnnSrcSpan :: SrcSpan -> e
-instance HasAnnotation (SrcSpan) where
+instance HasAnnotation SrcSpan where
noAnnSrcSpan l = l
+instance HasAnnotation EpaLocation where
+ noAnnSrcSpan l = EpaSpan l
+
instance (NoAnn ann) => HasAnnotation (EpAnn ann) where
noAnnSrcSpan l = EpAnn (spanAsAnchor l) noAnn emptyComments
@@ -1452,6 +1458,10 @@ instance (Outputable a, OutputableBndr e)
pprInfixOcc = pprInfixOcc . unLoc
pprPrefixOcc = pprPrefixOcc . unLoc
+instance (Outputable e)
+ => Outputable (GenLocated EpaLocation e) where
+ ppr = pprLocated
+
instance Outputable ParenType where
ppr t = text (show t)
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2679,7 +2679,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 (RecFieldsDotDot $ length fs)) }
+ , rec_dotdot = Just (L (l2l s) (RecFieldsDotDot $ length fs)) }
mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs
mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)
@@ -2766,7 +2766,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
-- name (cf section 8.5.1 in Haskell 2010 report).
mkCImport = do
let e = unpackFS entity
- case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of
+ case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of
Nothing -> addFatalError $ mkPlainErrorMsgEnvelope loc $
PsErrMalformedEntityString
Just importSpec -> return importSpec
@@ -2782,7 +2782,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
then mkExtName (unLoc v)
else entity
funcTarget = CFunction (StaticTarget esrc entity' Nothing True)
- importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget
+ importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget
returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport
{ fd_i_ext = ann
@@ -2796,7 +2796,7 @@ mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =
-- the string "foo" is ambiguous: either a header or a C identifier. The
-- C identifier case comes first in the alternatives below, so we pick
-- that one.
-parseCImport :: Located CCallConv -> Located Safety -> FastString -> String
+parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String
-> Located SourceText
-> Maybe (ForeignImport (GhcPass p))
parseCImport cconv safety nm str sourceText =
@@ -2826,7 +2826,7 @@ parseCImport cconv safety nm str sourceText =
| id_char c -> pfail
_ -> return ()
- mk h n = CImport sourceText cconv safety h n
+ mk h n = CImport (reLoc sourceText) (reLoc cconv) (reLoc safety) h n
hdr_char c = not (isSpace c)
-- header files are filenames, which can contain
@@ -2861,7 +2861,7 @@ mkExport :: Located CCallConv
mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)
= return $ \ann -> ForD noExtField $
ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty
- , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) }
+ , fd_fe = CExport (L (l2l le) esrc) (L (l2l lc) (CExportStatic esrc entity' cconv)) }
where
entity' | nullFS entity = mkExtName (unLoc v)
| otherwise = entity
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -775,7 +775,7 @@ rnHsRecPatsAndThen mk (L _ con)
do { arg' <- rnLPatAndThen (nested_mk dd mk (RecFieldsDotDot n')) (hfbRHS fld)
; return (L l (fld { hfbRHS = arg' })) }
- loc = maybe noSrcSpan getLoc dd
+ loc = maybe noSrcSpan getLocA dd
-- Don't warn for let P{..} = ... in ...
check_unused_wildcard = case mk of
@@ -873,12 +873,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
, hfbRHS = arg'
, hfbPun = pun } }
- rn_dotdot :: Maybe (Located RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat
+ rn_dotdot :: Maybe (LocatedE 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 (RecFieldsDotDot n))) (Just con) flds -- ".." on record construction / pat match
+ rn_dotdot (Just (L loc_e (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
@@ -910,6 +910,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
_other -> True ]
; addUsedGREs NoDeprecationWarnings dot_dot_gres
+ ; let loc = locA loc_e
; let locn = noAnnSrcSpan loc
; return [ L (noAnnSrcSpan loc) (HsFieldBind
{ hfbAnn = noAnn
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -84,7 +84,6 @@ import Control.Monad.Trans.Writer.CPS
import Control.Monad.Trans.Class
( lift )
import Data.Maybe (isJust)
-import GHC.Types.RepType (tyConPrimRep)
import GHC.Builtin.Types (unitTyCon)
-- Defines a binding
@@ -737,7 +736,6 @@ marshalablePrimTyCon tc = isPrimTyCon tc && not (isLiftedTypeKind (tyConResKind
marshalableTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledReason
marshalableTyCon dflags tc
| marshalablePrimTyCon tc
- , not (null (tyConPrimRep tc)) -- Note [Marshalling void]
= validIfUnliftedFFITypes dflags
| otherwise
= boxedMarshalableTyCon tc
@@ -772,7 +770,6 @@ legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity' TypeCannotBeMarshaledRe
-- types and also unboxed tuple and sum result types.
legalFIPrimResultTyCon dflags tc
| marshalablePrimTyCon tc
- , not (null (tyConPrimRep tc)) -- Note [Marshalling void]
= validIfUnliftedFFITypes dflags
| isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc
@@ -786,13 +783,3 @@ validIfUnliftedFFITypes dflags
| xopt LangExt.UnliftedFFITypes dflags = IsValid
| otherwise = NotValid UnliftedFFITypesNeeded
-{-
-Note [Marshalling void]
-~~~~~~~~~~~~~~~~~~~~~~~
-We don't treat State# (whose PrimRep is VoidRep) as marshalable.
-In turn that means you can't write
- foreign import foo :: Int -> State# RealWorld
-
-Reason: the back end falls over with panic "primRepHint:VoidRep";
- and there is no compelling reason to permit it
--}
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -799,7 +799,8 @@ cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
cvtForD (ImportF callconv safety from nm ty) =
- do { l <- getL
+ do { ls <- getL
+ ; let l = l2l ls
; if -- the prim and javascript calling conventions do not support headers
-- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
| callconv == TH.Prim || callconv == TH.JavaScript
@@ -809,7 +810,7 @@ cvtForD (ImportF callconv safety from nm ty) =
True)))
| Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')
(mkFastString (TH.nameBase nm))
- from (L l $ quotedSourceText from)
+ from (L ls $ quotedSourceText from)
-> mk_imp impspec
| otherwise
-> failWith $ InvalidCCallImpent from }
@@ -831,7 +832,8 @@ cvtForD (ImportF callconv safety from nm ty) =
cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameN nm
; ty' <- cvtSigType ty
- ; l <- getL
+ ; ls <- getL
+ ; let l = l2l ls
; let astxt = mkFastString as
; let e = CExport (L l (SourceText astxt)) (L l (CExportStatic (SourceText astxt)
astxt
=====================================
test.hs deleted
=====================================
@@ -1,14 +0,0 @@
-import Data.Char
-import Data.Foldable
--- | Just like 'GHC.ResponseFile.escapeArg', but it is not exposed from base.
-escapeArg :: String -> String
-escapeArg = reverse . foldl' escape []
-
-escape :: String -> Char -> String
-escape cs c
- | isSpace c
- || '\\' == c
- || '\'' == c
- || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result
- | otherwise = c:cs
-
=====================================
testsuite/tests/ffi/should_fail/ccfail001.stderr
=====================================
@@ -1,6 +1,8 @@
-ccfail001.hs:10:1: error: [GHC-89401]
+ccfail001.hs:10:1: error: [GHC-10964]
• Unacceptable result type in foreign declaration:
‘State# RealWorld’ cannot be marshalled in a foreign call
+ UnliftedFFITypes is required to marshal unlifted types
• When checking declaration:
foreign import ccall safe foo :: Int -> State# RealWorld
+ Suggested fix: Perhaps you intended to use UnliftedFFITypes
=====================================
testsuite/tests/ffi/should_run/T24598.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+
+-- | Test that `foreign import prim` imports handle `State#` in results correctly.
+module Main where
+
+import GHC.IO
+import GHC.Int
+import GHC.Exts
+
+foreign import prim "hello"
+ hello# :: State# RealWorld -> (# State# RealWorld, Int# #)
+
+main :: IO ()
+main = hello >>= print
+
+hello :: IO Int
+hello = IO $ \s -> case hello# s of (# s', n# #) -> (# s', I# n# #)
=====================================
testsuite/tests/ffi/should_run/T24598.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/ffi/should_run/T24598_cmm.cmm
=====================================
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+
+hello() {
+ return (42);
+}
=====================================
testsuite/tests/ffi/should_run/T24598b.hs
=====================================
@@ -0,0 +1,22 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+
+-- | Test that `foreign import prim` imports handle `State#` in arguments correctly.
+module Main where
+
+import GHC.IO
+import GHC.Int
+import GHC.Exts
+
+foreign import prim "hello"
+ hello# :: Int# -> State# RealWorld -> (# State# RealWorld, Int# #)
+
+main :: IO ()
+main = hello 21 >>= print
+
+hello :: Int -> IO Int
+hello (I# n#) = IO $ \s ->
+ case hello# n# s of (# s', n# #) -> (# s', I# n# #)
+
=====================================
testsuite/tests/ffi/should_run/T24598b.stdout
=====================================
@@ -0,0 +1 @@
+42
=====================================
testsuite/tests/ffi/should_run/T24598b_cmm.cmm
=====================================
@@ -0,0 +1,5 @@
+#include "Cmm.h"
+
+hello(W_ n) {
+ return (2*n);
+}
=====================================
testsuite/tests/ffi/should_run/T24598c.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+
+-- | Test that `foreign import prim` imports handle `State#` in arguments correctly.
+module Main where
+
+import GHC.IO
+import GHC.Exts
+
+foreign import prim "hello"
+ hello# :: State# RealWorld -> State# RealWorld
+
+main :: IO ()
+main = hello
+
+hello :: IO ()
+hello = IO $ \s ->
+ case hello# s of s' -> (# s', () #)
+
=====================================
testsuite/tests/ffi/should_run/T24598c.stdout
=====================================
@@ -0,0 +1 @@
+hello
=====================================
testsuite/tests/ffi/should_run/T24598c_cmm.cmm
=====================================
@@ -0,0 +1,15 @@
+#include "Cmm.h"
+
+#if !defined(UnregisterisedCompiler)
+import CLOSURE test_str;
+#endif
+
+section "data" {
+ test_str: bits8[] "hello";
+}
+
+hello() {
+ CInt r;
+ (r) = ccall puts(test_str "ptr");
+ return ();
+}
=====================================
testsuite/tests/ffi/should_run/all.T
=====================================
@@ -268,3 +268,7 @@ test('T24314',
# libffi-wasm doesn't support more than 4 args yet
when(arch('wasm32'), skip)],
compile_and_run, ['T24314_c.c'])
+
+test('T24598', req_cmm, compile_and_run, ['T24598_cmm.cmm'])
+test('T24598b', req_cmm, compile_and_run, ['T24598b_cmm.cmm'])
+test('T24598c', req_cmm, compile_and_run, ['T24598c_cmm.cmm'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -738,9 +738,9 @@ printStringAtAAC capture (EpaDelta d cs) s = do
-- ---------------------------------------------------------------------
-markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m ()
-markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return ()
-markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return ()
+markExternalSourceTextE :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation
+markExternalSourceTextE l NoSourceText txt = printStringAtAA l txt
+markExternalSourceTextE l (SourceText txt) _ = printStringAtAA l (unpackFS txt)
-- ---------------------------------------------------------------------
@@ -1587,6 +1587,15 @@ instance (ExactPrint a) => ExactPrint (Located a) where
exact (L l a) = L l <$> markAnnotated a
+instance (ExactPrint a) => ExactPrint (LocatedE a) where
+ getAnnotationEntry (L l _) = Entry l [] emptyComments NoFlushComments CanUpdateAnchorOnly
+ setAnnotationAnchor (L _ a) anc _ts _cs = L anc a
+
+ exact (L la a) = do
+ debugM $ "LocatedE a:la loc=" ++ show (ss2range $ locA la)
+ a' <- markAnnotated a
+ return (L la a')
+
instance (ExactPrint a) => ExactPrint (LocatedA a) where
getAnnotationEntry = entryFromLocatedA
setAnnotationAnchor la anc ts cs = setAnchorAn la anc ts cs
@@ -2009,11 +2018,15 @@ instance ExactPrint (ForeignDecl GhcPs) where
instance ExactPrint (ForeignImport GhcPs) where
getAnnotationEntry = const NoEntryVal
setAnnotationAnchor a _ _ _ = a
- exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do
+ exact (CImport (L ls src) cconv safety@(L l _) mh imp) = do
cconv' <- markAnnotated cconv
- unless (ll == noSrcSpan) $ markAnnotated safety >> return ()
- unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return ()
- return (CImport (L ls src) cconv' safety mh imp)
+ safety' <- if notDodgyE l
+ then markAnnotated safety
+ else return safety
+ ls' <- if notDodgyE ls
+ then markExternalSourceTextE ls src ""
+ else return ls
+ return (CImport (L ls' src) cconv' safety' mh imp)
-- ---------------------------------------------------------------------
@@ -2023,8 +2036,10 @@ instance ExactPrint (ForeignExport GhcPs) where
exact (CExport (L ls src) spec) = do
debugM $ "CExport starting"
spec' <- markAnnotated spec
- unless (ls == noSrcSpan) $ markExternalSourceText ls src ""
- return (CExport (L ls src) spec')
+ ls' <- if notDodgyE ls
+ then markExternalSourceTextE ls src ""
+ else return ls
+ return (CExport (L ls' src) spec')
-- ---------------------------------------------------------------------
@@ -3240,6 +3255,12 @@ markMaybeDodgyStmts an stmts =
return (an, r)
else return (an, stmts)
+notDodgyE :: EpaLocation -> Bool
+notDodgyE anc =
+ case anc of
+ EpaSpan s -> isGoodSrcSpan s
+ EpaDelta{} -> True
+
-- ---------------------------------------------------------------------
instance ExactPrint (HsPragE GhcPs) where
getAnnotationEntry HsPragSCC{} = NoEntryVal
@@ -3307,12 +3328,13 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where
setAnnotationAnchor a _ _ _ = a
exact (HsRecFields fields mdot) = do
fields' <- markAnnotated fields
- case mdot of
- Nothing -> return ()
- Just (L ss _) ->
- printStringAtSs ss ".." >> return ()
+ mdot' <- case mdot of
+ Nothing -> return Nothing
+ Just (L ss d) -> do
+ ss' <- printStringAtAA ss ".."
+ return $ Just (L ss' d)
-- Note: mdot contains the SrcSpan where the ".." appears, if present
- return (HsRecFields fields' mdot)
+ return (HsRecFields fields' mdot')
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c52eb51a530ef4e6e6cf108056e87a74aecdeae1...81bbfde980e4a60daafd22de09609e91c261ae4a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c52eb51a530ef4e6e6cf108056e87a74aecdeae1...81bbfde980e4a60daafd22de09609e91c261ae4a
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/20240405/190dd992/attachment-0001.html>
More information about the ghc-commits
mailing list