[Git][ghc/ghc][wip/az/locateda-epa-improve] Variants of AnnSortKey
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun Nov 20 23:34:06 UTC 2022
Alan Zimmerman pushed to branch wip/az/locateda-epa-improve at Glasgow Haskell Compiler / GHC
Commits:
f8aada24 by Alan Zimmerman at 2022-11-20T23:33:11+00:00
Variants of AnnSortKey
For future, just a list of which type comes next.
Example for ValBinds
- - - - -
10 changed files:
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
- utils/check-exact/Types.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -84,7 +84,7 @@ data NHsValBindsLR idL
[(RecFlag, LHsBinds idL)]
[LSig GhcRn]
-type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey
+type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey [DeclTag]
type instance XXValBindsLR (GhcPass pL) pR
= NHsValBindsLR (GhcPass pL)
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -353,7 +353,7 @@ data DataDeclRn = DataDeclRn
, tcdFVs :: NameSet }
deriving Data
-type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo]
+type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey [RealSrcSpan], LayoutInfo) -- See Note [Class LayoutInfo]
-- TODO:AZ:tidy up AnnSortKey above
type instance XClassDecl GhcRn = NameSet -- FVs
type instance XClassDecl GhcTc = NameSet -- FVs
@@ -799,7 +799,7 @@ type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA
----------------- Class instances -------------
-type instance XCClsInstDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up
+type instance XCClsInstDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey [RealSrcSpan]) -- TODO:AZ:tidy up
type instance XCClsInstDecl GhcRn = NoExtField
type instance XCClsInstDecl GhcTc = NoExtField
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -615,6 +615,7 @@ instance ToHie (IEContext (LocatedA ModuleName)) where
pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]
where details = mempty{identInfo = S.singleton (IEThing c)}
idents = M.singleton (Left mname) details
+ toHie (IEC _ (L (EpAnnS (EpaDelta _ _) _ _) _)) = pure []
instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where
toHie (C c (L l a)) = toHie (C c (L (locN l) a))
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Parser.Annotation (
TokenLocation(..),
DeltaPos(..), deltaPos, getDeltaLine,
- EpAnn(..), Anchor(..), AnchorOperation(..),
+ EpAnn(..), Anchor, AnchorOperation(..),
anchor, anchor_op,
EpAnnS(..),
spanAsAnchor, realSpanAsAnchor,
@@ -46,7 +46,7 @@ module GHC.Parser.Annotation (
AnnContext(..),
NameAnn(..), NameAdornment(..),
NoEpAnns(..),
- AnnSortKey(..),
+ AnnSortKey(..), DeclTag(..),
-- ** Trailing annotations in lists
TrailingAnn(..), trailingAnnToAddEpAnn,
@@ -559,8 +559,8 @@ type Anchor = EpaLocation -- Transitional
anchor :: Anchor -> RealSrcSpan
anchor (EpaSpan r) = r
--- anchor (EpaDelta _ _) = panic "anchor"
-anchor (EpaDelta _ _) = placeholderRealSpan
+anchor (EpaDelta _ _) = panic "anchor"
+-- anchor (EpaDelta _ _) = placeholderRealSpan
anchor_op :: Anchor -> AnchorOperation
anchor_op (EpaSpan _) = UnchangedAnchor
@@ -851,11 +851,28 @@ data AnnPragma
-- SrcSpan is used purely as an index into the annotations, allowing
-- transformations of the AST including the introduction of new Located
-- items or re-arranging existing ones.
-data AnnSortKey
+data AnnSortKey a
= NoAnnSortKey
- | AnnSortKey [RealSrcSpan]
+ | AnnSortKey a
deriving (Data, Eq)
+data DeclTag
+ = TyClDTag
+ | InstDTag
+ | DerivDTag
+ | ValDTag
+ | SigDTag
+ | KindSigDTag
+ | DefDTag
+ | ForDTag
+ | WarningDTag
+ | AnnDTag
+ | RuleDTag
+ | SpliceDTag
+ | DocDTag
+ | RoleAnnotDTag
+ deriving (Eq,Data,Ord,Show)
+
-- ---------------------------------------------------------------------
-- | Convert a 'TrailingAnn' to an 'AddEpAnn'
@@ -1376,12 +1393,12 @@ instance Monoid NameAnn where
mempty = NameAnnTrailing []
-instance Semigroup AnnSortKey where
+instance (Semigroup a) => Semigroup (AnnSortKey a) where
NoAnnSortKey <> x = x
x <> NoAnnSortKey = x
AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)
-instance Monoid AnnSortKey where
+instance (Semigroup a) => Monoid (AnnSortKey a) where
mempty = NoAnnSortKey
instance (Outputable a) => Outputable (EpAnn a) where
@@ -1418,7 +1435,7 @@ instance (NamedThing (Located a)) => NamedThing (LocatedAnS an a) where
instance Outputable AnnContext where
ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c
-instance Outputable AnnSortKey where
+instance (Outputable a) => Outputable (AnnSortKey a) where
ppr NoAnnSortKey = text "NoAnnSortKey"
ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1039,8 +1039,17 @@ checkTyClHdr is_cls ty
let
lr = ap Semi.<> as
in (EpAnnS lr
- (NameAnn NameParens o lr c ta)
+ (NameAnn NameParens o ap c ta)
(csp Semi.<> cs))
+ -- (EpAnnS
+ -- (EpaSpan { tests/examples/ghc88/StarBinder.hs:6:13-14 })
+ -- (NameAnn
+ -- (NameParens)
+ -- (EpaSpan { tests/examples/ghc88/StarBinder.hs:6:13 })
+ -- (EpaSpan { tests/examples/ghc88/StarBinder.hs:6:13 })
+ -- (EpaSpan { tests/examples/ghc88/StarBinder.hs:6:15 })
+ -- [])
+
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
@@ -1459,8 +1468,8 @@ class DisambInfixOp b where
mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b)
instance DisambInfixOp (HsExpr GhcPs) where
- mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)
- mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)
+ mkHsVarOpPV v = return $ L (l2l $ getLoc v) (HsVar noExtField v)
+ mkHsConOpPV v = return $ L (l2l $ getLoc v) (HsVar noExtField v)
mkHsInfixHolePV l ann = do
cs <- getCommentsFor l
return $ L l (hsHoleExpr (ann cs))
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -110,6 +110,7 @@ defaultEPState = EPState
, dPriorEndPosition = (1,1)
, uAnchorSpan = badRealSrcSpan
, uExtraDP = Nothing
+ , pAcceptSpan = False
, epComments = []
, epCommentsApplied = []
}
@@ -170,6 +171,13 @@ data EPState = EPState
-- Annotation
, uExtraDP :: !(Maybe Anchor) -- ^ Used to anchor a
-- list
+ , pAcceptSpan :: Bool -- ^ When we have processed an
+ -- entry of EpaDelta, accept the
+ -- next `EpaSpan` start as the
+ -- current output position. i.e. do
+ -- not advance epPos. Achieved by
+ -- setting dPriorEndPosition to the
+ -- end of the span.
-- Print phase
, epPos :: !Pos -- ^ Current output position
@@ -270,10 +278,20 @@ enterAnn NoEntryVal a = do
debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a)
return r
enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
+ acceptSpan <- getAcceptSpan
+ setAcceptSpan False
+ case anchor' of
+ EpaDelta _ _ -> setAcceptSpan True
+ EpaSpan _ -> return ()
p <- getPosP
debugM $ "enterAnn:starting:(p,a) =" ++ show (p, astId a)
- -- debugM $ "enterAnn:(cs) =" ++ showGhc (cs)
- let curAnchor = anchor anchor' -- As a base for the current AST element
+ debugM $ "enterAnn:(anchor') =" ++ showGhc anchor'
+ debugM $ "enterAnn:anchor_op=" ++ showGhc (anchor_op anchor')
+ prevAnchor <- getAnchorU
+ let curAnchor = case anchor' of
+ EpaSpan r -> r
+ EpaDelta{} -> prevAnchor
+ -- anchor anchor' -- As a base for the current AST element
debugM $ "enterAnn:(curAnchor):=" ++ show (rs2range curAnchor)
case canUpdateAnchor of
CanUpdateAnchor -> pushAppliedComments
@@ -283,14 +301,17 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
printComments curAnchor
priorCs <- cua canUpdateAnchor takeAppliedComments -- no pop
-- -------------------------
- case anchor_op anchor' of
- MovedAnchor dp -> do
- debugM $ "enterAnn: MovedAnchor:" ++ show dp
+ case anchor' of
+ EpaDelta dp _ -> do
+ debugM $ "enterAnn: EpaDelta:" ++ show dp
-- Set the original anchor as prior end, so the rest of this AST
-- fragment has a reference
setPriorEndNoLayoutD (ss2pos curAnchor)
_ -> do
- return ()
+ if acceptSpan
+ then setPriorEndNoLayoutD (ss2pos curAnchor)
+ else return ()
+
-- -------------------------
if ((fst $ fst $ rs2range curAnchor) >= 0)
then
@@ -322,11 +343,10 @@ enterAnn (Entry anchor' cs flush canUpdateAnchor) a = do
-- changed.
off (ss2delta priorEndAfterComments curAnchor)
debugM $ "enterAnn: (edp',off,priorEndAfterComments,curAnchor):" ++ show (edp',off,priorEndAfterComments,rs2range curAnchor)
- let edp'' = case anchor_op anchor' of
- MovedAnchor dp -> dp
+ let edp'' = case anchor' of
+ EpaDelta dp _ -> dp
_ -> edp'
-- ---------------------------------------------
- -- let edp = edp''
med <- getExtraDP
setExtraDP Nothing
let edp = case med of
@@ -486,7 +506,7 @@ printSourceText (SourceText txt) _ = printStringAdvance txt >> return ()
-- ---------------------------------------------------------------------
printStringAtSs :: (Monad m, Monoid w) => SrcSpan -> String -> EP w m ()
-printStringAtSs ss str = printStringAtRs (realSrcSpan "aa" ss) str >> return ()
+printStringAtSs ss str = printStringAtRs (realSrcSpan "aa1" ss) str >> return ()
printStringAtRs :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m EpaLocation
printStringAtRs pa str = printStringAtRsC CaptureComments pa str
@@ -567,8 +587,8 @@ printStringAtAAC capture (EpaDelta d cs) s = do
-- ---------------------------------------------------------------------
markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m ()
-markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan "aa" l) txt >> return ()
-markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan "aa" l) txt >> return ()
+markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan "aa2" l) txt >> return ()
+markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan "aa3" l) txt >> return ()
-- ---------------------------------------------------------------------
@@ -1242,8 +1262,11 @@ printOneComment c@(Comment _str loc _r _mo) = do
MovedAnchor dp -> return dp
_ -> do
pe <- getPriorEndD
- let dp = ss2delta pe (anchor loc)
- debugM $ "printOneComment:(dp,pe,anchor loc)=" ++ showGhc (dp,pe,ss2pos $ anchor loc)
+ -- let dp = ss2delta pe (anchor loc)
+ let dp = case loc of
+ EpaSpan r -> ss2delta pe r
+ EpaDelta dp _ -> dp
+ debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc)
adjustDeltaForOffsetM dp
mep <- getExtraDP
dp' <- case mep of
@@ -1254,12 +1277,13 @@ printOneComment c@(Comment _str loc _r _mo) = do
fmap unTweakDelta $ adjustDeltaForOffsetM edp
_ -> return dp
-- Start of debug printing
- -- LayoutStartCol dOff <- getLayoutOffsetD
- -- debugM $ "printOneComment:(dp,dp',dOff)=" ++ showGhc (dp,dp',dOff)
+ LayoutStartCol dOff <- getLayoutOffsetD
+ debugM $ "printOneComment:(dp,dp',dOff,loc)=" ++ showGhc (dp,dp',dOff,loc)
-- End of debug printing
-- setPriorEndD (ss2posEnd (anchor loc))
updateAndApplyComment c dp'
- printQueuedComment (anchor loc) c dp'
+
+ printQueuedComment c dp'
-- | For comment-related deltas starting on a new line we have an
-- off-by-one problem. Adjust
@@ -1277,13 +1301,23 @@ updateAndApplyComment (Comment str anc pp mo) dp = do
anc' = op
(r,c) = ss2posEnd pp
- la = anchor anc
- dp'' = if r == 0
- then (ss2delta (r,c+0) la)
- else (ss2delta (r,c) la)
- dp' = if pp == anchor anc
- then dp
- else dp''
+ -- la = anchor anc
+ -- dp'' = if r == 0
+ -- then (ss2delta (r,c+0) la)
+ -- else (ss2delta (r,c) la)
+ -- la = anchor anc
+ dp'' = case anc of
+ EpaDelta dp _ -> dp
+ EpaSpan la ->
+ if r == 0
+ then (ss2delta (r,c+0) la)
+ else (ss2delta (r,c) la)
+ dp' = case anc of
+ EpaDelta _ _ -> dp''
+ EpaSpan r ->
+ if pp == r
+ then dp
+ else dp''
op' = case dp' of
SameLine n -> if n >= 0
then EpaDelta dp' []
@@ -1302,7 +1336,11 @@ commentAllocation ss = do
-- RealSrcSpan, which affects comparison, as the Ord instance for
-- RealSrcSpan compares the file first. So we sort via ss2pos
-- TODO: this is inefficient, use Pos all the way through
- let (earlier,later) = partition (\(Comment _str loc _r _mo) -> (ss2pos $ anchor loc) <= (ss2pos ss)) cs
+ let (earlier,later) = partition (\(Comment _str loc _r _mo) ->
+ case loc of
+ EpaSpan r -> (ss2pos r) <= (ss2pos ss)
+ EpaDelta _ _ -> True -- Choose one
+ ) cs
putUnallocatedComments later
-- debugM $ "commentAllocation:(ss,earlier,later)" ++ show (rs2range ss,earlier,later)
return earlier
@@ -1330,8 +1368,7 @@ instance (ExactPrint a) => ExactPrint (Located a) where
UnhelpfulSpan _ -> NoEntryVal
_ -> Entry (hackSrcSpanToAnchor l) emptyComments NoFlushComments CanUpdateAnchorOnly
- setAnnotationAnchor (L _ a) anc _cs = (L (hackAnchorToSrcSpan anc) a)
- `debug` ("setAnnotationAnchor(Located):" ++ showAst anc)
+ setAnnotationAnchor (L l a) _anc _cs = L l a
exact (L l a) = L l <$> markAnnotated a
@@ -2332,13 +2369,17 @@ instance ExactPrint (HsValBindsLR GhcPs GhcPs) where
setAnnotationAnchor a _ _ = a
exact (ValBinds sortKey binds sigs) = do
- ds <- setLayoutBoth $ withSortKey sortKey
- (prepareListAnnotationA (bagToList binds)
- ++ prepareListAnnotationA sigs
- )
+ -- ds <- setLayoutBoth $ withSortKeyBind sortKey
+ -- (prepareListAnnotationA (bagToList binds)
+ -- ++ prepareListAnnotationA sigs
+ -- )
+ -- let
+ -- binds' = listToBag $ undynamic ds
+ -- sigs' = undynamic ds
+ setLayoutBoth $ mapM markAnnotated $ hsDeclsValBinds (ValBinds sortKey binds sigs)
let
- binds' = listToBag $ undynamic ds
- sigs' = undynamic ds
+ binds' = binds
+ sigs' = sigs
return (ValBinds sortKey binds' sigs')
exact (XValBindsLR _) = panic "XValBindsLR"
@@ -2379,7 +2420,7 @@ instance ExactPrint HsIPName where
prepareListAnnotationF :: (Monad m, Monoid w) =>
EpAnn [AddEpAnn] -> [LDataFamInstDecl GhcPs] -> [(RealSrcSpan,EP w m Dynamic)]
-prepareListAnnotationF an ls = map (\b -> (realSrcSpan "aa" $ getLocA b, go b)) ls
+prepareListAnnotationF an ls = map (\b -> (realSrcSpan "aa4" $ getLocA b, go b)) ls
where
go (L l a) = do
d' <- markAnnotated (DataFamInstDeclWithContext an NotTopLevel a)
@@ -2387,13 +2428,29 @@ prepareListAnnotationF an ls = map (\b -> (realSrcSpan "aa" $ getLocA b, go b))
prepareListAnnotationA :: (Monad m, Monoid w, ExactPrint (LocatedAnS an a))
=> [LocatedAnS an a] -> [(RealSrcSpan,EP w m Dynamic)]
-prepareListAnnotationA ls = map (\b -> (realSrcSpan "aa" $ getLocA b,go b)) ls
+prepareListAnnotationA ls = map (\b -> (realSrcSpan "aa5" $ getLocA b,go b)) ls
where
go b = do
b' <- markAnnotated b
return (toDyn b')
-withSortKey :: (Monad m, Monoid w) => AnnSortKey -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic]
+-- withSortKeyBind :: (Monad m, Monoid w)
+-- => AnnSortKey [(DeclTag, Int)] -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic]
+-- withSortKeyBind annSortKey xs = do
+-- debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey
+-- let ordered = case annSortKey of
+-- NoAnnSortKey -> sortBy orderByFst xs
+-- -- Just keys -> error $ "withSortKey: keys" ++ show keys
+-- AnnSortKey keys -> orderByKey xs keys
+-- -- `debug` ("withSortKey:" ++
+-- -- showPprUnsafe (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs),
+-- -- map fst xs,
+-- -- keys)
+-- -- )
+-- mapM snd ordered
+
+withSortKey :: (Monad m, Monoid w)
+ => AnnSortKey [RealSrcSpan] -> [(RealSrcSpan, EP w m Dynamic)] -> EP w m [Dynamic]
withSortKey annSortKey xs = do
debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey
let ordered = case annSortKey of
@@ -2716,7 +2773,12 @@ instance ExactPrint (HsExpr GhcPs) where
setAnnotationAnchor a@(HsPragE{}) _ _s = a
exact (HsVar x n) = do
- n' <- markAnnotated n
+ -- The parser inserts a placeholder value for a record pun rhs. This must be
+ -- filtered.
+ let pun_RDR = "pun-right-hand-side"
+ n' <- if (showPprUnsafe n /= pun_RDR)
+ then markAnnotated n
+ else return n
return (HsVar x n')
exact x@(HsUnboundVar an _) = do
case an of
@@ -2875,7 +2937,9 @@ instance ExactPrint (HsExpr GhcPs) where
expr' <- markAnnotated expr
an0 <- markEpAnnL an lidl AnnOpenC
fields' <- markAnnotated fields
+ debugM $ "RecordUpd after fields"
an1 <- markEpAnnL an0 lidl AnnCloseC
+ debugM $ "RecordUpd after AnnCLoseC"
return (RecordUpd an1 expr' fields')
exact (HsGetField an expr field) = do
expr' <- markAnnotated expr
@@ -3111,9 +3175,9 @@ instance (ExactPrint body)
f' <- markAnnotated f
(an0, arg') <- if isPun then return (an, arg)
else do
- an0 <- markEpAnnL an lidl AnnEqual
- arg' <- markAnnotated arg
- return (an0, arg')
+ an0 <- markEpAnnL an lidl AnnEqual
+ arg' <- markAnnotated arg
+ return (an0, arg')
return (HsFieldBind an0 f' arg' isPun)
-- ---------------------------------------------------------------------
@@ -3128,9 +3192,9 @@ instance (ExactPrint body)
f' <- markAnnotated f
(an0, arg') <- if isPun then return (an, arg)
else do
- an0 <- markEpAnnL an lidl AnnEqual
- arg' <- markAnnotated arg
- return (an0, arg')
+ an0 <- markEpAnnL an lidl AnnEqual
+ arg' <- markAnnotated arg
+ return (an0, arg')
return (HsFieldBind an0 f' arg' isPun)
-- Odd that we need this one too.
@@ -3144,9 +3208,9 @@ instance (ExactPrint body)
f' <- markAnnotated f
(an0, arg') <- if isPun then return (an, arg)
else do
- an0 <- markEpAnnL an lidl AnnEqual
- arg' <- markAnnotated arg
- return (an0, arg')
+ an0 <- markEpAnnL an lidl AnnEqual
+ arg' <- markAnnotated arg
+ return (an0, arg')
return (HsFieldBind an0 f' arg' isPun)
-- ---------------------------------------------------------------------
@@ -3160,7 +3224,7 @@ instance (ExactPrint (LocatedA body))
f' <- markAnnotated f
an0 <- if isPun then return an
else markEpAnnL an lidl AnnEqual
- arg' <- if ((locA $ getLoc arg) == noSrcSpan )
+ arg' <- if isPun
then return arg
else markAnnotated arg
return (HsFieldBind an0 f' arg' isPun)
@@ -3168,9 +3232,7 @@ instance (ExactPrint (LocatedA body))
-- ---------------------------------------------------------------------
instance
- (Typeable a, Typeable b, Typeable body,
- ExactPrint (HsFieldBind (LocatedAnS NoEpAnns (a GhcPs)) body),
- ExactPrint (HsFieldBind (LocatedAnS NoEpAnns (b GhcPs)) body),
+ (ExactPrint (HsFieldBind (LocatedAnS NoEpAnns (a GhcPs)) body),
ExactPrint (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body))
=> ExactPrint
(Either [LocatedA (HsFieldBind (LocatedAnS NoEpAnns (a GhcPs)) body)]
@@ -4129,9 +4191,12 @@ printUnicode :: (Monad m, Monoid w) => Anchor -> RdrName -> EP w m Anchor
printUnicode anc n = do
let str = case (showPprUnsafe n) of
-- TODO: unicode support?
- "forall" -> if spanLength (anchor anc) == 1 then "∀" else "forall"
+ -- "forall" -> if spanLength (anchor anc) == 1 then "∀" else "forall"
+ "forall" -> case anc of
+ EpaSpan r -> if spanLength r == 1 then "∀" else "forall"
+ EpaDelta _ _ -> "forall"
s -> s
- loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str
+ loc <- printStringAtAAC NoCaptureComments anc str
case loc of
EpaSpan _ -> return anc
EpaDelta dp [] -> return $ EpaDelta dp []
@@ -4144,12 +4209,15 @@ markName :: (Monad m, Monoid w)
markName adorn open mname close = do
let (kwo,kwc) = adornments adorn
(AddEpAnn _ open') <- markKwC CaptureComments (AddEpAnn kwo open)
+ -- debugM $ "mname: " ++ showAst mname
mname' <-
case mname of
Nothing -> return Nothing
- Just (name, a) -> do
- name' <- printStringAtAAC CaptureComments name (showPprUnsafe a)
- return (Just (name',a))
+ Just (loc, name) -> do
+ debugM $ "(loc,name): " ++ showAst (loc,name)
+ -- debugM $ "name:[" ++ (showPprUnsafe name) ++ "]"
+ loc' <- printStringAtAAC CaptureComments loc (showPprUnsafe name)
+ return (Just (loc',name))
(AddEpAnn _ close') <- markKwC CaptureComments (AddEpAnn kwc close)
return (open', mname', close')
@@ -4798,8 +4866,8 @@ isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c)
-- | Print a comment, using the current layout offset to convert the
-- @DeltaPos@ to an absolute position.
-printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m ()
-printQueuedComment _loc Comment{commentContents} dp = do
+printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
+printQueuedComment Comment{commentContents} dp = do
p <- getPosP
d <- getPriorEndD
colOffset <- getLayoutOffsetP
@@ -4865,6 +4933,13 @@ getPriorEndD = gets dPriorEndPosition
getAnchorU :: (Monad m, Monoid w) => EP w m RealSrcSpan
getAnchorU = gets uAnchorSpan
+getAcceptSpan ::(Monad m, Monoid w) => EP w m Bool
+getAcceptSpan = gets pAcceptSpan
+
+setAcceptSpan ::(Monad m, Monoid w) => Bool -> EP w m ()
+setAcceptSpan f =
+ modify (\s -> s { pAcceptSpan = f })
+
setPriorEndD :: (Monad m, Monoid w) => Pos -> EP w m ()
setPriorEndD pe = do
setPriorEndNoLayoutD pe
=====================================
utils/check-exact/Main.hs
=====================================
@@ -462,10 +462,12 @@ changeAddDecl1 libdir top = do
Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2")
let decl' = setEntryDP decl (DifferentLine 2 0)
- let (p',_,_) = runTransform doAddDecl
+ let (p',_,_w) = runTransform doAddDecl
doAddDecl = everywhereM (mkM replaceTopLevelDecls) top
replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource
replaceTopLevelDecls m = insertAtStart m decl'
+
+ debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"
return p'
-- ---------------------------------------------------------------------
@@ -518,7 +520,7 @@ changeLocalDecls libdir (L l p) = do
let oldBinds = concatMap decl2Bind oldDecls'
(os:oldSigs) = concatMap decl2Sig oldDecls'
os' = setEntryDP os (DifferentLine 2 0)
- let sortKey = captureOrder decls
+ let sortKey = captureOrderBinds decls
let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van
let van' = (EpAnn anc (AnnList (Just (EpaDelta (DifferentLine 1 4) [])) a b c dd) cs)
let binds' = (HsValBinds van'
@@ -550,7 +552,7 @@ changeLocalDecls2 libdir (L l p) = do
[AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] [])
emptyComments
let decls = [s,d]
- let sortKey = captureOrder decls
+ let sortKey = captureOrderBinds decls
let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl'])
[sig']))
return (L lm (Match ma mln pats (GRHSs emptyComments rhs binds)))
@@ -795,7 +797,7 @@ rmDecl5 _libdir lp = do
let
go :: HsExpr GhcPs -> Transform (HsExpr GhcPs)
go (HsLet a tkLet lb tkIn expr) = do
- decs <- hsDeclsValBinds lb
+ let decs = hsDeclsLocalBinds lb
let dec = last decs
_ <- transferEntryDP (head decs) dec
lb' <- replaceDeclsValbinds WithoutWhere lb [dec]
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -68,7 +68,7 @@ module Transform
, anchorEof
-- ** Managing lists, pure functions
- , captureOrder
+ , captureOrder, captureOrderBinds
, captureLineSpacing, captureLineSpacingI
, captureMatchLineSpacing
, captureTypeSigSpacing
@@ -177,9 +177,28 @@ srcSpanStartLine' _ = 0
-- |If a list has been re-ordered or had items added, capture the new order in
-- the appropriate 'AnnSortKey' attached to the 'Annotation' for the list.
-captureOrder :: [LocatedA b] -> AnnSortKey
+captureOrder :: [LocatedA b] -> AnnSortKey [RealSrcSpan]
captureOrder ls = AnnSortKey $ map (rs . getLocA) ls
+captureOrderBinds :: [LHsDecl GhcPs] -> AnnSortKey [DeclTag]
+captureOrderBinds ls = AnnSortKey $ map go ls
+ where
+ go (L _ (TyClD _ _)) = TyClDTag
+ go (L _ (InstD _ _)) = InstDTag
+ go (L _ (DerivD _ _)) = DerivDTag
+ go (L _ (ValD _ _)) = ValDTag
+ go (L _ (SigD _ _)) = SigDTag
+ go (L _ (KindSigD _ _)) = KindSigDTag
+ go (L _ (DefD _ _)) = DefDTag
+ go (L _ (ForD _ _)) = ForDTag
+ go (L _ (WarningD _ _)) = WarningDTag
+ go (L _ (AnnD _ _)) = AnnDTag
+ go (L _ (RuleD _ _)) = RuleDTag
+ go (L _ (SpliceD _ _)) = SpliceDTag
+ go (L _ (DocD _ _)) = DocDTag
+ go (L _ (RoleAnnotD _ _)) = RoleAnnotDTag
+ go (L _ (XHsDecl _)) = error "captureOrderBinds"
+
-- ---------------------------------------------------------------------
captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs
@@ -265,15 +284,15 @@ decl2Sig _ = []
-- ---------------------------------------------------------------------
--- |Convert a 'LSig' into a 'LHsDecl'
-wrapSig :: LSig GhcPs -> LHsDecl GhcPs
-wrapSig (L l s) = L l (SigD NoExtField s)
+-- -- |Convert a 'LSig' into a 'LHsDecl'
+-- wrapSig :: LSig GhcPs -> LHsDecl GhcPs
+-- wrapSig (L l s) = L l (SigD NoExtField s)
-- ---------------------------------------------------------------------
--- |Convert a 'LHsBind' into a 'LHsDecl'
-wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs
-wrapDecl (L l s) = L l (ValD NoExtField s)
+-- -- |Convert a 'LHsBind' into a 'LHsDecl'
+-- wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs
+-- wrapDecl (L l s) = L l (ValD NoExtField s)
-- ---------------------------------------------------------------------
@@ -292,7 +311,7 @@ setEntryDPDecl d dp = setEntryDP d dp
-- |Set the true entry 'DeltaPos' from the annotation for a given AST
-- element. This is the 'DeltaPos' ignoring any comments.
-setEntryDP :: Default t => LocatedAnS t a -> DeltaPos -> LocatedAnS t a
+setEntryDP :: LocatedAnS t a -> DeltaPos -> LocatedAnS t a
setEntryDP (L (EpAnnS _ an (EpaComments [])) a) dp
= L (EpAnnS (EpaDelta dp []) an (EpaComments [])) a
setEntryDP (L (EpAnnS (EpaDelta d _) an cs) a) dp
@@ -320,12 +339,15 @@ setEntryDP (L (EpAnnS (EpaSpan r) an cs) a) dp
where
cs'' = setPriorComments cs (L (EpaDelta dp []) c:cs')
lc = head $ reverse $ (L ca c:cs')
- delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r
+ -- delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r
+ delta = case getLoc lc of
+ EpaSpan rr -> tweakDelta $ ss2delta (ss2pos rr) r
+ EpaDelta dp _ -> tweakDelta dp
line = getDeltaLine delta
col = deltaColumn delta
edp' = if line == 0 then SameLine col
else DifferentLine line col
- edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r))
+ edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (getLoc lc), r))
-- |Set the true entry 'DeltaPos' from the annotation for a given AST
@@ -371,12 +393,15 @@ setEntryDPI (L (SrcSpanAnn (EpAnn (EpaSpan r) an cs) l) a) dp
where
cs'' = setPriorComments cs (L (EpaDelta dp []) c:cs')
lc = head $ reverse $ (L ca c:cs')
- delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r
+ -- delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r
+ delta = case getLoc lc of
+ EpaSpan rr -> tweakDelta $ ss2delta (ss2pos rr) r
+ EpaDelta dp _ -> tweakDelta dp
line = getDeltaLine delta
col = deltaColumn delta
edp' = if line == 0 then SameLine col
else DifferentLine line col
- edp = edp' `debug` ("setEntryDPI :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r))
+ edp = edp' `debug` ("setEntryDPI :" ++ showGhc (edp', (getLoc lc), r))
-- ---------------------------------------------------------------------
@@ -585,7 +610,7 @@ pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:H
pushTrailingComments w cs lb@(HsValBinds an _)
= (True, HsValBinds an' vb)
where
- (decls, _, _ws1) = runTransform (hsDeclsValBinds lb)
+ decls = hsDeclsLocalBinds lb
(an', decls') = case reverse decls of
[] -> (addCommentsToEpAnn (spanHsLocaLBinds lb) an cs, decls)
(L la d:ds) -> (an, L (addCommentsToEpAnnS la cs) d:ds)
@@ -653,27 +678,30 @@ balanceComments' la1 la2 = do
trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment]
-> [(Int, LEpaComment)]
trailingCommentsDeltas _ [] = []
-trailingCommentsDeltas anc (la@(L l _):las)
- = deltaComment anc la : trailingCommentsDeltas (anchor l) las
+trailingCommentsDeltas rs (la@(L (EpaDelta dp _) _):las)
+ = (deltaLine dp, la): trailingCommentsDeltas rs las
+trailingCommentsDeltas rs (la@(L l _):las)
+ = deltaComment rs la : trailingCommentsDeltas (anchor l) las
where
- deltaComment anc' (L loc c) = (abs(ll - al), L loc c)
+ deltaComment rs' (L loc c) = (abs(ll - al), L loc c)
where
- (al,_) = ss2posEnd anc'
+ (al,_) = ss2posEnd rs'
(ll,_) = ss2pos (anchor loc)
-- AZ:TODO: this is identical to commentsDeltas
priorCommentsDeltas :: RealSrcSpan -> [LEpaComment]
-> [(Int, LEpaComment)]
-priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs)
+priorCommentsDeltas rs cs = go rs (reverse $ sortEpaComments cs)
where
go :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)]
go _ [] = []
- go anc' (la@(L l _):las) = deltaComment anc' la : go (anchor l) las
+ go rs' (la@(L (EpaDelta dp _) _):las) = (deltaLine dp, la) : go rs' las
+ go rs' (la@(L l _):las) = deltaComment rs' la : go (anchor l) las
deltaComment :: RealSrcSpan -> LEpaComment -> (Int, LEpaComment)
- deltaComment anc' (L loc c) = (abs(ll - al), L loc c)
+ deltaComment rs' (L loc c) = (abs(ll - al), L loc c)
where
- (al,_) = ss2pos anc'
+ (al,_) = ss2pos rs'
(ll,_) = ss2pos (anchor loc)
@@ -717,7 +745,7 @@ splitCommentsStart p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts'
cs' = before
ts' = after <> ts
-moveLeadingComments :: (Data t, Data u, Monoid t, Monoid u)
+moveLeadingComments :: (Data t, Data u, Monoid u)
=> LocatedAnS t a -> EpAnnS u -> (LocatedAnS t a, EpAnnS u)
moveLeadingComments (L la a) lb = (L la' a, lb')
`debug` ("moveLeadingComments: (before, after, la', lb'):" ++ showAst (before, after, la', lb'))
@@ -910,8 +938,11 @@ insertAt :: (HasDecls ast)
-> Transform ast
insertAt f t decl = do
oldDecls <- hsDecls t
+ logTr $ "oldDecls:" ++ showAst oldDecls
oldDeclsb <- balanceCommentsList oldDecls
+ logTr $ "oldDeclsb:" ++ showAst oldDeclsb
let oldDecls' = map commentsOrigDeltasDecl oldDeclsb
+ logTr $ "oldDecls':" ++ showAst oldDecls'
replaceDecls t (f decl oldDecls')
-- |Insert a declaration at the beginning or end of the subdecls of the given
@@ -995,7 +1026,7 @@ instance HasDecls ParsedSource where
-- ---------------------------------------------------------------------
instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
- hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsValBinds lb
+ hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = return $ hsDeclsLocalBinds lb
replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) []
= do
@@ -1024,7 +1055,7 @@ instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where
-- ---------------------------------------------------------------------
instance HasDecls (LocatedA (HsExpr GhcPs)) where
- hsDecls (L _ (HsLet _ _ decls _ _ex)) = hsDeclsValBinds decls
+ hsDecls (L _ (HsLet _ _ decls _ _ex)) = return $ hsDeclsLocalBinds decls
hsDecls _ = return []
replaceDecls (L ll (HsLet x tkLet binds tkIn ex)) newDecls
@@ -1066,7 +1097,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
-- idempotent.
-hsDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> TransformT m [LHsDecl GhcPs]
+hsDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs]
hsDeclsPatBindD (L l (ValD _ d)) = hsDeclsPatBind (L l d)
hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
@@ -1074,8 +1105,8 @@ hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
-- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent
-- 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 :: LHsBind GhcPs -> [LHsDecl GhcPs]
+hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb))) = hsDeclsLocalBinds lb
hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x
-- -------------------------------------
@@ -1107,7 +1138,7 @@ replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
-- ---------------------------------------------------------------------
instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
- hsDecls (L _ (LetStmt _ lb)) = hsDeclsValBinds lb
+ hsDecls (L _ (LetStmt _ lb)) = return $ hsDeclsLocalBinds lb
hsDecls (L _ (LastStmt _ e _ _)) = hsDecls e
hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e
hsDecls (L _ (BodyStmt _ e _ _)) = hsDecls e
@@ -1141,7 +1172,7 @@ instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where
-- |Look up the annotated order and sort the decls accordingly
-- TODO:AZ: this should be pure
orderedDecls :: (Monad m)
- => AnnSortKey -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
+ => AnnSortKey [RealSrcSpan] -> [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
orderedDecls sortKey decls = do
case sortKey of
NoAnnSortKey -> do
@@ -1152,18 +1183,38 @@ orderedDecls sortKey decls = do
ordered = map snd $ orderByKey ds keys
return ordered
+-- orderedDeclsBinds :: (Monad m)
+-- => AnnSortKey [DeclTag]
+-- -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
+-- -> TransformT m [LHsDecl GhcPs]
+-- orderedDeclsBinds sortKey binds sigs = do
+-- case sortKey of
+-- NoAnnSortKey -> do
+-- -- return decls
+-- return $ sortBy (\a b ->
+-- compare (realSrcSpan "orderedDecls" $ getLocA a)
+-- (realSrcSpan "orderedDecls" $ getLocA b)) (binds ++ sigs)
+-- AnnSortKey keys -> do
+-- let
+-- go [] _ _ = []
+-- go (ValDTag:ks) (b:bs) ss = b : go ks bs ss
+-- go (SigDTag:ks) bs (s:ss) = s : go ks bs ss
+-- go (_:ks) bs ss = go ks bs ss
+
+-- return (go keys binds sigs)
+
-- ---------------------------------------------------------------------
-hsDeclsValBinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
-hsDeclsValBinds lb = case lb of
- HsValBinds _ (ValBinds sortKey bs sigs) -> do
- let
- bds = map wrapDecl (bagToList bs)
- sds = map wrapSig sigs
- orderedDecls sortKey (bds ++ sds)
- HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"
- HsIPBinds {} -> return []
- EmptyLocalBinds {} -> return []
+-- hsDeclsValBinds :: (Monad m) => HsLocalBinds GhcPs -> TransformT m [LHsDecl GhcPs]
+-- hsDeclsValBinds lb = case lb of
+-- HsValBinds _ (ValBinds sortKey bs sigs) -> do
+-- let
+-- bds = map wrapDecl (bagToList bs)
+-- sds = map wrapSig sigs
+-- orderedDeclsBinds sortKey bds sds
+-- HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"
+-- HsIPBinds {} -> return []
+-- EmptyLocalBinds {} -> return []
data WithWhere = WithWhere
| WithoutWhere
@@ -1186,7 +1237,7 @@ replaceDeclsValbinds w b@(HsValBinds a _) new
an <- oldWhereAnnotation a w (realSrcSpan "replaceDeclsValbinds" oldSpan)
let decs = listToBag $ concatMap decl2Bind new
let sigs = concatMap decl2Sig new
- let sortKey = captureOrder new
+ let sortKey = captureOrderBinds new
return (HsValBinds an (ValBinds sortKey decs sigs))
replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds"
replaceDeclsValbinds w (EmptyLocalBinds _) new
@@ -1197,7 +1248,7 @@ replaceDeclsValbinds w (EmptyLocalBinds _) new
newSigs = concatMap decl2Sig new
let decs = listToBag $ newBinds
let sigs = newSigs
- let sortKey = captureOrder new
+ let sortKey = captureOrderBinds new
return (HsValBinds an (ValBinds sortKey decs sigs))
oldWhereAnnotation :: (Monad m)
@@ -1258,7 +1309,7 @@ modifyValD :: forall m t. (HasTransform m)
modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f =
if (locA ss) == p
then do
- ds <- liftT $ hsDeclsPatBindD pb
+ let ds = hsDeclsPatBindD pb
(ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds
pb' <- liftT $ replaceDeclsPatBindD pb ds'
return (pb',r)
=====================================
utils/check-exact/Types.hs
=====================================
@@ -45,9 +45,16 @@ instance Ord Comment where
-- When we have CPP injected comments with a fake filename, or LINE
-- pragma, the file name changes, so we need to compare the
-- locations only, with out the filename.
- compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2)
- where
- ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
+ -- compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare (ss2pos $ anchor ss1) (ss2pos $ anchor ss2)
+ compare (Comment _ ss1 _ _) (Comment _ ss2 _ _) = compare ss1 ss2
+
+ss2pos :: RealSrcSpan -> Pos
+ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
+
+instance Ord EpaLocation where
+ compare (EpaSpan l1) (EpaSpan l2) = compare (ss2pos l1) (ss2pos l2)
+ compare _ _ = EQ
+
instance Outputable Comment where
ppr x = text (show x)
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -30,6 +30,7 @@ import qualified Orphans as Orphans
import GHC hiding (EpaComment)
import qualified GHC
+import GHC.Data.Bag
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
@@ -47,8 +48,8 @@ import Types
-- |Global switch to enable debug tracing in ghc-exactprint Delta / Print
debugEnabledFlag :: Bool
--- debugEnabledFlag = True
-debugEnabledFlag = False
+debugEnabledFlag = True
+-- debugEnabledFlag = False
-- |Provide a version of trace that comes at the end of the line, so it can
-- easily be commented out when debugging different things.
@@ -128,14 +129,14 @@ undeltaSpan anc kw dp = AddEpAnn kw (EpaSpan sp)
-- ---------------------------------------------------------------------
adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
-adjustDeltaForOffset _colOffset dp@(SameLine _) = dp
+adjustDeltaForOffset _colOffset dp@(SameLine _) = dp
adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c)
= DifferentLine l (c - colOffset)
-- ---------------------------------------------------------------------
-ss2pos :: RealSrcSpan -> Pos
-ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
+-- ss2pos :: RealSrcSpan -> Pos
+-- ss2pos ss = (srcSpanStartLine ss,srcSpanStartCol ss)
ss2posEnd :: RealSrcSpan -> Pos
ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndCol ss)
@@ -242,7 +243,8 @@ normaliseCommentText (x:xs) = x:normaliseCommentText xs
-- |Must compare without span filenames, for CPP injected comments with fake filename
cmpComments :: Comment -> Comment -> Ordering
-cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+-- cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+cmpComments (Comment _ l1 _ _) (Comment _ l2 _ _) = compare l1 l2
-- |Sort, comparing without span filenames, for CPP injected comments with fake filename
sortComments :: [Comment] -> [Comment]
@@ -252,7 +254,8 @@ sortComments cs = sortBy cmpComments cs
sortEpaComments :: [LEpaComment] -> [LEpaComment]
sortEpaComments cs = sortBy cmp cs
where
- cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+ -- cmp (L l1 _) (L l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2)
+ cmp (L l1 _) (L l2 _) = compare l1 l2
-- | Makes a comment which originates from a specific keyword.
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
@@ -268,8 +271,8 @@ isKWComment c = isJust (commentOrigin c)
noKWComments :: [Comment] -> [Comment]
noKWComments = filter (\c -> not (isKWComment c))
-sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a]
-sortAnchorLocated = sortBy (compare `on` (anchor . getLoc))
+-- sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a]
+-- sortAnchorLocated = sortBy (compare `on` (anchor . getLoc))
-- | Calculates the distance from the start of a string to the end of
-- a string.
@@ -429,7 +432,58 @@ hackAnchorToSrcSpan (EpaSpan r) = RealSrcSpan (setRealSrcSpanBufSpan r Strict.No
-- e = - (deltaColumn dp)
hackAnchorToSrcSpan _ = error $ "hackAnchorToSrcSpan"
- -- ---------------------------------------------------------------------
+-- ---------------------------------------------------------------------
+
+orderedDeclsBinds
+ :: AnnSortKey [DeclTag]
+ -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
+ -> [LHsDecl GhcPs]
+orderedDeclsBinds sortKey binds sigs =
+ case sortKey of
+ NoAnnSortKey ->
+ sortBy (\a b -> compare (realSrcSpan "orderedDecls" $ getLocA a)
+ (realSrcSpan "orderedDecls" $ getLocA b)) (binds ++ sigs)
+ AnnSortKey keys ->
+ let
+ go [] _ _ = []
+ go (ValDTag:ks) (b:bs) ss = b : go ks bs ss
+ go (SigDTag:ks) bs (s:ss) = s : go ks bs ss
+ go (_:ks) bs ss = go ks bs ss
+ in
+ go keys binds sigs
+
+hsDeclsLocalBinds :: HsLocalBinds GhcPs -> [LHsDecl GhcPs]
+hsDeclsLocalBinds lb = case lb of
+ HsValBinds _ (ValBinds sortKey bs sigs) ->
+ let
+ bds = map wrapDecl (bagToList bs)
+ sds = map wrapSig sigs
+ in
+ orderedDeclsBinds sortKey bds sds
+ HsValBinds _ (XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid"
+ HsIPBinds {} -> []
+ EmptyLocalBinds {} -> []
+
+hsDeclsValBinds :: (HsValBindsLR GhcPs GhcPs) -> [LHsDecl GhcPs]
+hsDeclsValBinds (ValBinds sortKey bs sigs) =
+ let
+ bds = map wrapDecl (bagToList bs)
+ sds = map wrapSig sigs
+ in
+ orderedDeclsBinds sortKey bds sds
+
+-- ---------------------------------------------------------------------
+
+-- |Convert a 'LSig' into a 'LHsDecl'
+wrapSig :: LSig GhcPs -> LHsDecl GhcPs
+wrapSig (L l s) = L l (SigD NoExtField s)
+
+-- ---------------------------------------------------------------------
+
+-- |Convert a 'LHsBind' into a 'LHsDecl'
+wrapDecl :: LHsBind GhcPs -> LHsDecl GhcPs
+wrapDecl (L l s) = L l (ValD NoExtField s)
+-- ---------------------------------------------------------------------
showAst :: (Data a) => a -> String
showAst ast
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8aada24f70180fe5baaf516df5d88fef77da108
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f8aada24f70180fe5baaf516df5d88fef77da108
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/20221120/e158687c/attachment-0001.html>
More information about the ghc-commits
mailing list