diff options
Diffstat (limited to 'utils/check-exact/Transform.hs')
| -rw-r--r-- | utils/check-exact/Transform.hs | 485 |
1 files changed, 307 insertions, 178 deletions
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index 45f3612a76..a2faefe81e 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -46,8 +46,8 @@ module Transform , WithWhere(..) -- ** New gen functions - , noAnnSrcSpanDP - , noAnnSrcSpanDP0 + , noAnnSrcSpanDP, noAnnSrcSpanDPI + , noAnnSrcSpanDP0, noAnnSrcSpanDP0I , noAnnSrcSpanDP1 , noAnnSrcSpanDPn , d0, d1, dn @@ -68,8 +68,8 @@ module Transform , anchorEof -- ** Managing lists, pure functions - , captureOrder - , captureLineSpacing + , captureOrder, captureOrderBinds + , captureLineSpacing, captureLineSpacingI , captureMatchLineSpacing , captureTypeSigSpacing @@ -79,7 +79,7 @@ module Transform -- * Pure functions , setEntryDP , getEntryDP - , transferEntryDP + , transferEntryDP, transferEntryDPI , transferEntryDP' , wrapSig, wrapDecl , decl2Sig, decl2Bind @@ -95,6 +95,7 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Data.Bag import GHC.Data.FastString +import qualified GHC.Data.Strict as Strict import Data.Data import Data.List ( sortBy ) @@ -177,9 +178,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 @@ -190,8 +210,17 @@ captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ))))) ms' = captureLineSpacing ms captureMatchLineSpacing d = d -captureLineSpacing :: Default t +captureLineSpacingI :: Default t => [LocatedAn t e] -> [LocatedAn t e] +captureLineSpacingI [] = [] +captureLineSpacingI [d] = [d] +captureLineSpacingI (de1:d2:ds) = de1:captureLineSpacingI (d2':ds) + where + (l1,_) = ss2pos $ rs $ getLocI de1 + (l2,_) = ss2pos $ rs $ getLocI d2 + d2' = setEntryDPI d2 (deltaPos (l2-l1) 0) + +captureLineSpacing :: [LocatedA e] -> [LocatedA e] captureLineSpacing [] = [] captureLineSpacing [d] = [d] captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds) @@ -210,30 +239,31 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H -- AnnDColon, and to the start of the ty AddEpAnn kw dca = dc rd = case last ns of - L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll - L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? + L (EpAnnS anc' _ _) _ -> anchor anc' -- TODO MovedAnchor? dc' = case dca of - EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) - EpaDelta _ _ -> AddEpAnn kw dca + EpaSpan (RealSrcSpan r _) -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) + _ -> AddEpAnn kw dca -- --------------------------------- ty' :: LHsSigType GhcPs ty' = case ty of - (L (SrcSpanAnn EpAnnNotUsed ll) b) - -> let - op = case dca of - 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) + -- (L (EpAnnS (Anchor r op) a c) b) + -- -> let + -- op' = case op of + -- MovedAnchor _ -> op + -- _ -> case dca of + -- EpaSpan dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r) + -- EpaDelta _ _ -> MovedAnchor (SameLine 1) + -- in (L (EpAnnS (Anchor r op') a c) b) + (L (EpAnnS anc0 a c) b) -> let - op' = case op of - MovedAnchor _ -> op + anc' = case anc0 of + EpaDelta _ _ -> anc0 _ -> case dca of - EpaSpan dcr _ -> MovedAnchor (ss2delta (ss2posEnd dcr) r) - EpaDelta _ _ -> MovedAnchor (SameLine 1) - in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b) + EpaSpan _ -> error "todo" + EpaDelta _ _ -> EpaDelta (SameLine 1) [] + in (L (EpAnnS anc' a c) b) captureTypeSigSpacing s = s @@ -255,15 +285,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) -- --------------------------------------------------------------------- @@ -282,18 +312,59 @@ 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 => LocatedAn t a -> DeltaPos -> LocatedAn t a -setEntryDP (L (SrcSpanAnn EpAnnNotUsed l) a) dp +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 + = L (EpAnnS (EpaDelta d' []) an cs') a + where + (d',cs') = case cs of + EpaComments (h:t) -> + let + (dp0,c') = go h + in + (dp0, EpaComments (c':t)) + EpaCommentsBalanced (h:t) ts -> + let + (dp0,c') = go h + in + (dp0, EpaCommentsBalanced (c':t) ts) + _ -> (dp, cs) + go (L (EpaDelta ma c0) c) = (d, L (EpaDelta ma c0) c) + go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c) +setEntryDP (L (EpAnnS (EpaSpan (RealSrcSpan r _)) an cs) a) dp + = case sortEpaComments (priorComments cs) of + [] -> L (EpAnnS (EpaDelta dp []) an cs) a + (L ca c:cs') -> + L (EpAnnS (EpaDelta edp []) an cs'') a + 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 = case getLoc lc of + EpaSpan (RealSrcSpan rr _) -> tweakDelta $ ss2delta (ss2pos rr) r + _ -> DifferentLine 1 0 + line = getDeltaLine delta + col = deltaColumn delta + edp' = if line == 0 then SameLine col + else DifferentLine line col + edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (getLoc lc), r)) + + +-- |Set the true entry 'DeltaPos' from the annotation for a given AST +-- element. This is the 'DeltaPos' ignoring any comments. +setEntryDPI :: Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a +setEntryDPI (L (SrcSpanAnn EpAnnNotUsed l) a) dp = L (SrcSpanAnn - (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) def emptyComments) + (EpAnn (EpaDelta dp []) def emptyComments) l) a -setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp +setEntryDPI (L (SrcSpanAnn (EpAnn _ an (EpaComments [])) l) a) dp = L (SrcSpanAnn - (EpAnn (Anchor r (MovedAnchor dp)) an (EpaComments [])) + (EpAnn (EpaDelta dp []) an (EpaComments [])) l) a -setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor d)) an cs) l) a) dp +setEntryDPI (L (SrcSpanAnn (EpAnn (EpaDelta d _) an cs) l) a) dp = L (SrcSpanAnn - (EpAnn (Anchor r (MovedAnchor d')) an cs') + (EpAnn (EpaDelta d' []) an cs') l) a where (d',cs') = case cs of @@ -308,65 +379,72 @@ setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r (MovedAnchor d)) an cs) l) a) dp in (dp0, EpaCommentsBalanced (c':t) ts) _ -> (dp, cs) - go (L (Anchor rr (MovedAnchor ma)) c) = (d, L (Anchor rr (MovedAnchor ma)) c) - go (L (Anchor rr _) c) = (d, L (Anchor rr (MovedAnchor dp)) c) -setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp + go (L (EpaDelta ma c0) c) = (d, L (EpaDelta ma c0) c) + go (L (EpaSpan _) c) = (d, L (EpaDelta dp []) c) +setEntryDPI (L (SrcSpanAnn (EpAnn (EpaSpan (RealSrcSpan r _)) an cs) l) a) dp = case sortEpaComments (priorComments cs) of [] -> L (SrcSpanAnn - (EpAnn (Anchor r (MovedAnchor dp)) an cs) + (EpAnn (EpaDelta dp []) an cs) l) a (L ca c:cs') -> L (SrcSpanAnn - (EpAnn (Anchor r (MovedAnchor edp)) an cs'') + (EpAnn (EpaDelta edp []) an cs'') l) a where - cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs') - lc = last $ (L ca c:cs') - delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r + cs'' = setPriorComments cs (L (EpaDelta dp []) c:cs') + lc = head $ reverse $ (L ca c:cs') + -- delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r + delta = case getLoc lc of + EpaSpan (RealSrcSpan rr _) -> tweakDelta $ ss2delta (ss2pos rr) r + EpaSpan _ -> tweakDelta (SameLine 0) + 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` ("setEntryDPI :" ++ showGhc (edp', (getLoc lc), r)) -- --------------------------------------------------------------------- getEntryDP :: LocatedAn t a -> DeltaPos -getEntryDP (L (SrcSpanAnn (EpAnn (Anchor _ (MovedAnchor dp)) _ _) _) _) = dp +getEntryDP (L (SrcSpanAnn (EpAnn (EpaDelta dp []) _ _) _) _) = dp 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 (RealSrcSpan r _)) = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] +addEpaLocationDelta _off _anc loc = loc -- 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 (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp' where - r = case la of - (SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l - (SrcSpanAnn (EpAnn (Anchor r' _) _ _) _) -> r' - dp' = adjustDeltaForOffset off (ss2deltaEnd anc r) + -- r = case la of + -- (EpAnnS (Anchor r' _) _ _) -> r' + -- dp' = adjustDeltaForOffset off (ss2deltaEnd anc r) + dp' = case la of + (EpAnnS (EpaSpan (RealSrcSpan r' _)) _ _) -> adjustDeltaForOffset off (ss2deltaEnd anc r') + (EpAnnS (EpaSpan _) _ _) -> adjustDeltaForOffset off (SameLine 0) + (EpAnnS (EpaDelta dp _) _ _) -> adjustDeltaForOffset off dp +setEntryDPFromAnchor _off _ (L la a) = L la a -- --------------------------------------------------------------------- -- |Take the annEntryDelta associated with the first item and associate it with the second. -- Also transfer any comments occuring before it. -transferEntryDP :: (Monad m, Monoid t2, Typeable t1, Typeable t2) +transferEntryDPI :: (Monad m, Monoid t2, Typeable t1, Typeable t2) => LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b) -transferEntryDP (L (SrcSpanAnn EpAnnNotUsed l1) _) (L (SrcSpanAnn EpAnnNotUsed _) b) = do +transferEntryDPI (L (SrcSpanAnn EpAnnNotUsed l1) _) (L (SrcSpanAnn EpAnnNotUsed _) b) = do logTr $ "transferEntryDP': EpAnnNotUsed,EpAnnNotUsed" return (L (SrcSpanAnn EpAnnNotUsed l1) b) -transferEntryDP (L (SrcSpanAnn (EpAnn anc _an cs) _l1) _) (L (SrcSpanAnn EpAnnNotUsed l2) b) = do +transferEntryDPI (L (SrcSpanAnn (EpAnn anc _an cs) _l1) _) (L (SrcSpanAnn EpAnnNotUsed l2) b) = do logTr $ "transferEntryDP': EpAnn,EpAnnNotUsed" return (L (SrcSpanAnn (EpAnn anc mempty cs) l2) b) -transferEntryDP (L (SrcSpanAnn (EpAnn anc1 an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do +transferEntryDPI (L (SrcSpanAnn (EpAnn anc1 an1 cs1) _l1) _) (L (SrcSpanAnn (EpAnn _anc2 an2 cs2) l2) b) = do logTr $ "transferEntryDP': EpAnn,EpAnn" -- Problem: if the original had preceding comments, blindly -- transferring the location is not correct @@ -376,13 +454,27 @@ transferEntryDP (L (SrcSpanAnn (EpAnn anc1 an1 cs1) _l1) _) (L (SrcSpanAnn (EpAn (L anc _:_) -> do logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc return (L (SrcSpanAnn (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) l2) b) -transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do +transferEntryDPI (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do logTr $ "transferEntryDP': EpAnnNotUsed,EpAnn" return (L (SrcSpanAnn (EpAnn anc2' an2 cs2) l2) b) where anc2' = case anc2 of - Anchor _a op -> Anchor (realSrcSpan l2) op + -- Anchor _a op -> Anchor (realSrcSpan "transferEntryDP" l2) op + EpaDelta _dp _cs -> anc2 + EpaSpan _ -> EpaSpan (RealSrcSpan (realSrcSpan "transferEntryDP" l2) Strict.Nothing) +transferEntryDP :: (Monad m, Typeable an) + => LocatedAnS an a -> LocatedAnS an b -> TransformT m (LocatedAnS an b) +transferEntryDP (L (EpAnnS anc1 an1 cs1) _) (L (EpAnnS _anc2 an2 cs2) b) = do + logTr $ "transferEntryDP': EpAnn,EpAnn" + -- Problem: if the original had preceding comments, blindly + -- transferring the location is not correct + case priorComments cs1 of + [] -> return (L (EpAnnS anc1 (combine an1 an2) cs2) b) + -- TODO: what happens if the receiving side already has comments? + (L anc _:_) -> do + logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc + return (L (EpAnnS anc1 (combine an1 an2) (cs1 <> cs2)) b) -- |If a and b are the same type return first arg, else return second combine :: (Typeable a, Typeable b) => a -> b -> b @@ -401,7 +493,7 @@ pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs pushDeclDP (ValD x (FunBind a b (MG c (L d ms )))) dp = ValD x (FunBind a b (MG c (L d' ms'))) where - L d' _ = setEntryDP (L d ms) dp + L d' _ = setEntryDPI (L d ms) dp ms' :: [LMatch GhcPs (LHsExpr GhcPs)] ms' = case ms of [] -> [] @@ -449,24 +541,33 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do -- + move the interior ones to the first match, -- + move the trailing ones to the last match. let - split = splitCommentsEnd (realSrcSpan $ locA lf) (epAnnComments $ ann lf) - split2 = splitCommentsStart (realSrcSpan $ locA lf) (EpaComments (sortEpaComments $ priorComments split)) - - before = sortEpaComments $ priorComments split2 - middle = sortEpaComments $ getFollowingComments split2 - after = sortEpaComments $ getFollowingComments split - - lf' = setCommentsSrcAnn lf (EpaComments before) + (before,middle,after) = case s_entry lf of + EpaSpan (RealSrcSpan ss _) -> + let + split = splitCommentsEnd ss (s_comments lf) + split2 = splitCommentsStart ss (EpaComments (sortEpaComments $ priorComments split)) + + before = sortEpaComments $ priorComments split2 + middle = sortEpaComments $ getFollowingComments split2 + after = sortEpaComments $ getFollowingComments split + in (before,middle,after) + _ -> (priorComments $ s_comments lf, + [], + getFollowingComments $ s_comments lf) + + lf' = setCommentsEpAnnS lf (EpaComments before) logTr $ "balanceCommentsFB (before, after): " ++ showAst (before, after) - let matches' = case matches of + -- let matches' = case matches of + let matches' :: [LocatedA (Match GhcPs (LHsExpr GhcPs))] + matches' = case matches of (L lm' m':ms') -> - (L (addCommentsToSrcAnn lm' (EpaComments middle )) m':ms') - _ -> error "balanceCommentsFB" + (L (addCommentsToEpAnnS lm' (EpaComments middle )) m':ms') + _ -> error "balanceCommentsFB3" matches'' <- balanceCommentsList' matches' let (m,ms) = case reverse matches'' of (L lm' m':ms') -> - (L (addCommentsToSrcAnn lm' (EpaCommentsBalanced [] after)) m',ms') - _ -> error "balanceCommentsFB" + (L (addCommentsToEpAnnS lm' (EpaCommentsBalanced [] after)) m',ms') + _ -> error "balanceCommentsFB4" (m',second') <- balanceComments' m second m'' <- balanceCommentsMatch m' let (m''',lf'') = case ms of @@ -485,28 +586,28 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds'))) where simpleBreak (r,_) = r /= 0 - (SrcSpanAnn an1 _loc1) = l - anc1 = addCommentOrigDeltas $ epAnnComments an1 + an1 = l + anc1 = addCommentOrigDeltas $ s_comments an1 cs1f = getFollowingComments anc1 (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f) move = map snd move' stay = map snd stay' (l'', grhss', binds', logInfo) = case reverse grhss of - [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) + [] -> (l, [], binds, (EpaComments [], noSrcSpanA)) (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs) - -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) + -> (l, reverse (L lg g:gs), binds, (EpaComments [], noSrcSpanA)) (L lg (GRHS ag grs rhs):gs) -> let anc1' = setFollowingComments anc1 stay - an1' = setCommentsSrcAnn l anc1' + an1' = setCommentsEpAnnS l anc1' -- --------------------------------- (moved,bindsm) = pushTrailingComments WithWhere (EpaCommentsBalanced [] move) binds -- --------------------------------- (EpAnn anc an lgc) = ag - lgc' = splitCommentsEnd (realSrcSpan $ locA lg) $ addCommentOrigDeltas lgc + lgc' = splitCommentsEnd (realSrcSpan "balanceCommentsMatch" $ locA lg) $ addCommentOrigDeltas lgc ag' = if moved then EpAnn anc an lgc' else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) @@ -520,10 +621,10 @@ 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 (addCommentsToSrcAnn la cs) d:ds) + (L la d:ds) -> (an, L (addCommentsToEpAnnS la cs) d:ds) (vb,_ws2) = case runTransform (replaceDeclsValbinds w lb (reverse decls')) of ((HsValBinds _ vb'), _, ws2') -> (vb', ws2') _ -> (ValBinds NoAnnSortKey emptyBag [], []) @@ -546,7 +647,7 @@ balanceCommentsList' (a:b:ls) = do -- Many of these should in fact be following comments for the previous anchor balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b) balanceComments' la1 la2 = do - logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) + -- logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) logTr $ "balanceComments': (anc1)=" ++ showAst (anc1) logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s) logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move) @@ -554,10 +655,14 @@ balanceComments' la1 la2 = do return (la1', la2') where simpleBreak n (r,_) = r > n - L (SrcSpanAnn an1 loc1) f = la1 - L (SrcSpanAnn an2 loc2) s = la2 - anc1 = addCommentOrigDeltas $ epAnnComments an1 - anc2 = addCommentOrigDeltas $ epAnnComments an2 + -- L (SrcSpanAnn an1 loc1) f = la1 + L an1 f = la1 + -- L (SrcSpanAnn an2 loc2) s = la2 + L an2 s = la2 + -- anc1 = addCommentOrigDeltas $ s_comments an1 + -- anc2 = addCommentOrigDeltas $ s_comments an2 + anc1 = s_comments an1 + anc2 = s_comments an2 cs1s = splitCommentsEnd (anchorFromLocatedA la1) anc1 cs1p = priorCommentsDeltas (anchorFromLocatedA la1) (priorComments cs1s) @@ -577,8 +682,8 @@ balanceComments' la1 la2 = do move = sortEpaComments $ map snd (cs1move ++ move'' ++ move') stay = sortEpaComments $ map snd (cs1stay ++ stay') - an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move) - an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f)) + an1' = setCommentsEpAnnS (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move) + an2' = setCommentsEpAnnS (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f)) la1' = L an1' f la2' = L an2' s @@ -586,27 +691,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) + = (getDeltaLine 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) @@ -617,14 +725,16 @@ priorCommentsDeltas anc cs = go anc (reverse $ sortEpaComments cs) splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments splitCommentsEnd p (EpaComments cs) = cs' where - cmp (L (Anchor l _) _) = ss2pos l > ss2posEnd p + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True (before, after) = break cmp cs cs' = case after of [] -> EpaComments cs _ -> EpaCommentsBalanced before after splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' where - cmp (L (Anchor l _) _) = ss2pos l > ss2posEnd p + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True (before, after) = break cmp cs cs' = before ts' = after <> ts @@ -634,33 +744,34 @@ splitCommentsEnd p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments splitCommentsStart p (EpaComments cs) = cs' where - cmp (L (Anchor l _) _) = ss2pos l > ss2pos p + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True (before, after) = break cmp cs cs' = case after of [] -> EpaComments cs _ -> EpaCommentsBalanced before after splitCommentsStart p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' where - cmp (L (Anchor l _) _) = ss2pos l > ss2pos p + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True (before, after) = break cmp cs cs' = before ts' = after <> ts -moveLeadingComments :: (Data t, Data u, Monoid t, Monoid u) - => LocatedAn t a -> SrcAnn u -> (LocatedAn t a, SrcAnn u) -moveLeadingComments from@(L (SrcSpanAnn EpAnnNotUsed _) _) to = (from, to) +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')) where - split = splitCommentsEnd (realSrcSpan $ locA la) (epAnnComments $ ann la) + split = splitCommentsEnd (realSrcSpan "moveLeadingComments" $ locA la) (s_comments la) before = sortEpaComments $ priorComments split after = sortEpaComments $ getFollowingComments split -- TODO: need to set an entry delta on lb' to zero, and move the -- original spacing to the first comment. - la' = setCommentsSrcAnn la (EpaComments after) - lb' = addCommentsToSrcAnn lb (EpaCommentsBalanced before []) + la' = setCommentsEpAnnS la (EpaComments after) + lb' = addCommentsToEpAnnS lb (EpaCommentsBalanced before []) -- | A GHC comment includes the span of the preceding (non-comment) -- token. Takes an original list of comments, and converts the @@ -679,33 +790,25 @@ addCommentOrigDeltasAnn :: (EpAnn a) -> (EpAnn a) addCommentOrigDeltasAnn EpAnnNotUsed = EpAnnNotUsed addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) +addCommentOrigDeltasEpAnnS :: (EpAnnS a) -> (EpAnnS a) +addCommentOrigDeltasEpAnnS (EpAnnS e a cs) = EpAnnS e a (addCommentOrigDeltas cs) + -- TODO: this is replicating functionality in ExactPrint. Sort out the -- import loop` anchorFromLocatedA :: LocatedA a -> RealSrcSpan -anchorFromLocatedA (L (SrcSpanAnn an loc) _) - = case an of - EpAnnNotUsed -> realSrcSpan loc - (EpAnn anc _ _) -> anchor anc +anchorFromLocatedA (L (EpAnnS anc _ _) _) = anchor anc -- | A GHC comment includes the span of the preceding token. Take an -- original comment, and convert the 'Anchor to have a have a -- `MovedAnchor` operation based on the original location, only if it -- does not already have one. commentOrigDelta :: LEpaComment -> LEpaComment -commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp)) - = (L (GHC.Anchor la op) (GHC.EpaComment t pp)) - `debug` ("commentOrigDelta: (la, pp, r,c, op)=" ++ showAst (la, pp, r,c, op)) +commentOrigDelta (L (EpaSpan (RealSrcSpan la _)) (GHC.EpaComment t pp)) + = (L op (GHC.EpaComment t pp)) where - (r,c) = ss2posEnd pp - - op' = if r == 0 - then MovedAnchor (ss2delta (r,c+1) la) - -- then MovedAnchor (ss2delta (r,c+0) la) - -- else MovedAnchor (ss2delta (r,c) la) - else MovedAnchor (tweakDelta $ ss2delta (r,c) la) - op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0) - then MovedAnchor (DifferentLine 1 0) - else op' + op = EpaDelta (origDelta la pp) [] +commentOrigDelta (L anc (GHC.EpaComment t pp)) + = (L anc (GHC.EpaComment t pp)) -- --------------------------------------------------------------------- @@ -722,8 +825,8 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do (L lg g@(GRHS EpAnnNotUsed _gs _rhs):grs) -> (la,reverse $ (L lg g):grs,[]) (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))]) where - (SrcSpanAnn an1 _loc1) = la - anc1 = addCommentOrigDeltas $ epAnnComments an1 + an1 = la + anc1 = addCommentOrigDeltas $ s_comments an1 (EpAnn anc an _) = ga :: EpAnn GrhsAnn (csp,csf) = case anc1 of EpaComments cs -> ([],cs) @@ -738,8 +841,7 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do gac' = setFollowingComments gac (sortEpaComments $ gfc ++ move) ga' = (EpAnn anc an gac') - an1' = setCommentsSrcAnn la cs1 - la'' = an1' + la'' = setCommentsEpAnnS la cs1 -- --------------------------------------------------------------------- @@ -751,26 +853,34 @@ anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l -- --------------------------------------------------------------------- commentsOrigDeltasDecl :: LHsDecl GhcPs -> LHsDecl GhcPs -commentsOrigDeltasDecl (L (SrcSpanAnn an l) d) = L (SrcSpanAnn an' l) d - where - an' = addCommentOrigDeltasAnn an +commentsOrigDeltasDecl (L an d) = L (addCommentOrigDeltasEpAnnS an) d -- --------------------------------------------------------------------- -- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the -- given @DeltaPos@. -noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann) -noAnnSrcSpanDP l dp - = SrcSpanAnn (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments) l +noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> (EpAnnS ann) +noAnnSrcSpanDP _ dp + = EpAnnS (EpaDelta dp []) mempty emptyComments + +-- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the +-- given @DeltaPos@. +noAnnSrcSpanDPI :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDPI l dp + = SrcSpanAnn (EpAnn (EpaDelta dp []) mempty emptyComments) l + +noAnnSrcSpanDP0I :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDP0I l = noAnnSrcSpanDPI l (SameLine 0) -noAnnSrcSpanDP0 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDP0 :: (Monoid ann) => SrcSpan -> (EpAnnS ann) +-- noAnnSrcSpanDP0 :: SrcSpan -> SrcSpanAnnA noAnnSrcSpanDP0 l = noAnnSrcSpanDP l (SameLine 0) noAnnSrcSpanDP1 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) -noAnnSrcSpanDP1 l = noAnnSrcSpanDP l (SameLine 1) +noAnnSrcSpanDP1 l = noAnnSrcSpanDPI l (SameLine 1) noAnnSrcSpanDPn :: (Monoid ann) => SrcSpan -> Int -> SrcSpanAnn' (EpAnn ann) -noAnnSrcSpanDPn l s = noAnnSrcSpanDP l (SameLine s) +noAnnSrcSpanDPn l s = noAnnSrcSpanDPI l (SameLine s) d0 :: EpaLocation d0 = EpaDelta (SameLine 0) [] @@ -781,20 +891,18 @@ d1 = EpaDelta (SameLine 1) [] dn :: Int -> EpaLocation dn n = EpaDelta (SameLine n) [] -m0 :: AnchorOperation -m0 = MovedAnchor $ SameLine 0 +m0 :: DeltaPos +m0 = SameLine 0 -m1 :: AnchorOperation -m1 = MovedAnchor $ SameLine 1 +m1 :: DeltaPos +m1 = SameLine 1 -mn :: Int -> AnchorOperation -mn n = MovedAnchor $ SameLine n +mn :: Int -> DeltaPos +mn n = SameLine n addComma :: SrcSpanAnnA -> SrcSpanAnnA -addComma (SrcSpanAnn EpAnnNotUsed l) - = (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem [AddCommaAnn d0]) emptyComments) l) -addComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) - = (SrcSpanAnn (EpAnn anc (AnnListItem (AddCommaAnn d0:as)) cs) l) +addComma (EpAnnS anc (AnnListItem as) cs) + = (EpAnnS anc (AnnListItem (AddCommaAnn d0:as)) cs) -- --------------------------------------------------------------------- @@ -809,8 +917,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 @@ -894,7 +1005,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 @@ -923,19 +1034,20 @@ 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 = do logTr "replaceDecls HsLet" - let lastAnc = realSrcSpan $ spanHsLocaLBinds binds + let lastAnc = realSrcSpan "replaceDecls" $ spanHsLocaLBinds binds -- TODO: may be an intervening comment, take account for lastAnc let (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of (L (TokenLoc l) ls, L (TokenLoc i) is) -> let off = case l of - (EpaSpan r _) -> LayoutStartCol $ snd $ ss2pos r + (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r + (EpaSpan _) -> LayoutStartCol 0 -- Arbitrary (EpaDelta (SameLine _) _) -> LayoutStartCol 0 (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex @@ -965,7 +1077,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 @@ -973,8 +1085,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 -- ------------------------------------- @@ -1006,7 +1118,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 @@ -1040,29 +1152,49 @@ 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 -- return decls - return $ sortBy (\a b -> compare (realSrcSpan $ getLocA a) (realSrcSpan $ getLocA b)) decls + return $ sortBy (\a b -> compare (realSrcSpan "orderedDecls" $ getLocA a) (realSrcSpan "orderedDecls" $ getLocA b)) decls AnnSortKey keys -> do let ds = map (\s -> (rs $ getLocA s,s)) decls 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 @@ -1082,10 +1214,10 @@ replaceDeclsValbinds w b@(HsValBinds a _) new = do logTr "replaceDeclsValbinds" let oldSpan = spanHsLocaLBinds b - an <- oldWhereAnnotation a w (realSrcSpan oldSpan) + 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 @@ -1096,20 +1228,18 @@ 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) => EpAnn AnnList -> WithWhere -> RealSrcSpan -> TransformT m (EpAnn AnnList) oldWhereAnnotation EpAnnNotUsed ww _oldSpan = do - newSpan <- uniqueSrcSpanT let w = case ww of WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] WithoutWhere -> [] - let anc2' = Anchor (rs newSpan) (MovedAnchor (SameLine 1)) + let anc2' = EpaDelta (SameLine 1) [] (anc, anc2) <- do - newSpan' <- uniqueSrcSpanT - return ( Anchor (rs newSpan') (MovedAnchor (DifferentLine 1 2)) + return (EpaDelta (DifferentLine 1 2) [] , anc2') let an = EpAnn anc (AnnList (Just anc2) Nothing Nothing w []) @@ -1132,9 +1262,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList) newWhereAnnotation ww = do - newSpan <- uniqueSrcSpanT - let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)) - let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)) + let anc = EpaDelta (DifferentLine 1 2) [] + let anc2 = EpaDelta (DifferentLine 1 4) [] let w = case ww of WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] WithoutWhere -> [] @@ -1160,7 +1289,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) |