diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs index ae4202a7..11496570 100644 --- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs @@ -157,6 +157,7 @@ logDataWithAnnsTr str ast = do -- |If we need to add new elements to the AST, they need their own -- 'SrcSpan' for this. +-- This should no longer be needed, we use an @EpaDelta@ location instead. uniqueSrcSpanT :: (Monad m) => TransformT m SrcSpan uniqueSrcSpanT = do col <- get @@ -329,18 +330,15 @@ setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP -- |Take the annEntryDelta associated with the first item and associate it with the second. -- Also transfer any comments occurring before it. -transferEntryDP :: (Monad m, Typeable t1, Typeable t2) - => LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b) -transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn _anc2 an2 cs2) b) = do - logTr $ "transferEntryDP': EpAnn,EpAnn" +transferEntryDP :: (Typeable t1, Typeable t2) + => LocatedAn t1 a -> LocatedAn t2 b -> (LocatedAn t2 b) +transferEntryDP (L (EpAnn anc1 an1 cs1) _) (L (EpAnn _anc2 an2 cs2) b) = -- Problem: if the original had preceding comments, blindly -- transferring the location is not correct case priorComments cs1 of - [] -> return (L (EpAnn anc1 (combine an1 an2) cs2) b) + [] -> (L (EpAnn 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 (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) b) + (L _ _:_) -> (L (EpAnn anc1 (combine an1 an2) (cs1 <> cs2)) b) -- |If a and b are the same type return first arg, else return second @@ -350,10 +348,11 @@ combine x y = fromMaybe y (cast x) -- |Take the annEntryDelta associated with the first item and associate it with the second. -- Also transfer any comments occurring before it. -- TODO: call transferEntryDP, and use pushDeclDP -transferEntryDP' :: (Monad m) => LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs) -transferEntryDP' la lb = do - (L l2 b) <- transferEntryDP la lb - return (L l2 (pushDeclDP b (SameLine 0))) +transferEntryDP' :: LHsDecl GhcPs -> LHsDecl GhcPs -> (LHsDecl GhcPs) +transferEntryDP' la lb = + let + (L l2 b) = transferEntryDP la lb + in (L l2 (pushDeclDP b (SameLine 0))) pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs @@ -372,16 +371,16 @@ pushDeclDP d _dp = d -- | If we compile in haddock mode we get DocDecls, which we strip out -- while exact printing. Make sure we do not balance any comments on -- to them be stripping them out here already. -balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] +balanceCommentsList :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] balanceCommentsList decls = balanceCommentsList' (filter notDocDecl decls) -balanceCommentsList' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] -balanceCommentsList' [] = return [] -balanceCommentsList' [x] = return [x] -balanceCommentsList' (a:b:ls) = do - (a',b') <- balanceComments a b - r <- balanceCommentsList' (b':ls) - return (a':r) +balanceCommentsList' :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] +balanceCommentsList' [] = [] +balanceCommentsList' [x] = [x] +balanceCommentsList' (a:b:ls) = (a':r) + where + (a',b') = balanceComments a b + r = balanceCommentsList' (b':ls) -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. @@ -389,28 +388,27 @@ balanceCommentsList' (a:b:ls) = do -- from the second one to the 'annFollowingComments' of the first if they belong -- to it instead. This is typically required before deleting or duplicating -- either of the AST elements. -balanceComments :: (Monad m) - => LHsDecl GhcPs -> LHsDecl GhcPs - -> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs) -balanceComments first second = do +balanceComments :: LHsDecl GhcPs -> LHsDecl GhcPs + -> (LHsDecl GhcPs, LHsDecl GhcPs) +balanceComments first second = case first of - (L l (ValD x fb@(FunBind{}))) -> do - (L l' fb',second') <- balanceCommentsFB (L l fb) second - return (L l' (ValD x fb'), second') + (L l (ValD x fb@(FunBind{}))) -> + let + (L l' fb',second') = balanceCommentsFB (L l fb) second + in (L l' (ValD x fb'), second') _ -> balanceCommentsA first second -- |Once 'balanceCommentsA has been called to move trailing comments to a -- 'FunBind', these need to be pushed down from the top level to the last -- 'Match' if that 'Match' needs to be manipulated. -balanceCommentsFB :: (Monad m) - => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) -balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do - debugM $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) +balanceCommentsFB :: LHsBind GhcPs -> LocatedA b -> (LHsBind GhcPs, LocatedA b) +balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second + = balanceCommentsA (packFunBind bind) second' -- There are comments on lf. We need to -- + Keep the prior ones here -- + move the interior ones to the first match, -- + move the trailing ones to the last match. - let + where (before,middle,after) = case entry lf of EpaSpan (RealSrcSpan ss _) -> let @@ -426,40 +424,29 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do getFollowingComments $ comments lf) lf' = setCommentsEpAnn lf (EpaComments before) - debugM $ "balanceCommentsFB (before, after): " ++ showAst (before, after) - debugM $ "balanceCommentsFB lf': " ++ showAst lf' - -- let matches' = case matches of - let matches' :: [LocatedA (Match GhcPs (LHsExpr GhcPs))] - matches' = case matches of - (L lm' m':ms') -> - (L (addCommentsToEpAnn lm' (EpaComments middle )) m':ms') - _ -> error "balanceCommentsFB" - matches'' <- balanceCommentsListA matches' - let (m,ms) = case reverse matches'' of - (L lm' m':ms') -> - (L (addCommentsToEpAnn lm' (EpaCommentsBalanced [] after)) m',ms') - -- (L (addCommentsToEpAnnS lm' (EpaCommentsBalanced [] after)) m',ms') - _ -> error "balanceCommentsFB4" - debugM $ "balanceCommentsFB: (m,ms):" ++ showAst (m,ms) - (m',second') <- balanceCommentsA m second - m'' <- balanceCommentsMatch m' - let (m''',lf'') = case ms of - [] -> moveLeadingComments m'' lf' - _ -> (m'',lf') - debugM $ "balanceCommentsFB: (lf'', m'''):" ++ showAst (lf'',m''') - debugM $ "balanceCommentsFB done" - let bind = L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms))))) - debugM $ "balanceCommentsFB returning:" ++ showAst bind - balanceCommentsA (packFunBind bind) second' + matches' :: [LocatedA (Match GhcPs (LHsExpr GhcPs))] + matches' = case matches of + (L lm' m':ms') -> + (L (addCommentsToEpAnn lm' (EpaComments middle )) m':ms') + _ -> error "balanceCommentsFB" + matches'' = balanceCommentsListA matches' + (m,ms) = case reverse matches'' of + (L lm' m':ms') -> + (L (addCommentsToEpAnn lm' (EpaCommentsBalanced [] after)) m',ms') + _ -> error "balanceCommentsFB4" + (m',second') = balanceCommentsA m second + m'' = balanceCommentsMatch m' + (m''',lf'') = case ms of + [] -> moveLeadingComments m'' lf' + _ -> (m'',lf') + bind = L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms))))) balanceCommentsFB f s = balanceCommentsA f s -- | Move comments on the same line as the end of the match into the -- GRHS, prior to the binds -balanceCommentsMatch :: (Monad m) - => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) -balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do - logTr $ "balanceCommentsMatch: (logInfo)=" ++ showAst (logInfo) - return (L l'' (Match am mctxt pats (GRHSs xg grhss' binds'))) +balanceCommentsMatch :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) +balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) + = (L l'' (Match am mctxt pats (GRHSs xg grhss' binds'))) where simpleBreak (r,_) = r /= 0 an1 = l @@ -491,26 +478,24 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do pushTrailingComments :: WithWhere -> EpAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs) pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b) pushTrailingComments _ _cs (HsIPBinds _ _) = error "TODO: pushTrailingComments:HsIPBinds" -pushTrailingComments w cs lb@(HsValBinds an _) - = (True, HsValBinds an' vb) +pushTrailingComments w cs lb@(HsValBinds an _) = (True, HsValBinds an' vb) where decls = hsDeclsLocalBinds lb (an', decls') = case reverse decls of [] -> (addCommentsToEpAnn an cs, decls) (L la d:ds) -> (an, L (addCommentsToEpAnn la cs) d:ds) - (vb,_ws2) = case runTransform (replaceDeclsValbinds w lb (reverse decls')) of - ((HsValBinds _ vb'), _, ws2') -> (vb', ws2') - _ -> (ValBinds NoAnnSortKey emptyBag [], []) + vb = case replaceDeclsValbinds w lb (reverse decls') of + (HsValBinds _ vb') -> vb' + _ -> ValBinds NoAnnSortKey emptyBag [] -balanceCommentsListA :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a] -balanceCommentsListA [] = return [] -balanceCommentsListA [x] = return [x] -balanceCommentsListA (a:b:ls) = do - logTr $ "balanceCommentsListA entered" - (a',b') <- balanceCommentsA a b - r <- balanceCommentsListA (b':ls) - return (a':r) +balanceCommentsListA :: [LocatedA a] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a @@ -518,16 +503,8 @@ balanceCommentsListA (a:b:ls) = do -- with a passed-in decision function. -- The initial situation is that all comments for a given anchor appear as prior comments -- Many of these should in fact be following comments for the previous anchor -balanceCommentsA :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b) -balanceCommentsA la1 la2 = do - debugM $ "balanceCommentsA: anchors=" ++ showAst (an1, an2) - -- debugM $ "balanceCommentsA: (anc1)=" ++ showAst (anc1) - -- debugM $ "balanceCommentsA: (anc2)=" ++ showAst (anc2) - debugM $ "balanceCommentsA: (cs1f)=" ++ showAst (cs1f) - debugM $ "balanceCommentsA: (cs2p, cs2f)=" ++ showAst (cs2p, cs2f) - debugM $ "balanceCommentsA: (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move) - debugM $ "balanceCommentsA: (an1',an2')=" ++ showAst (an1',an2') - return (la1', la2') +balanceCommentsA :: LocatedA a -> LocatedA b -> (LocatedA a, LocatedA b) +balanceCommentsA la1 la2 = (la1', la2') where simpleBreak n (r,_) = r > n L an1 f = la1 @@ -700,12 +677,9 @@ fullSpanFromLocatedA (L (EpAnn anc (AnnListItem tas) _) _) = rr -- --------------------------------------------------------------------- -balanceSameLineComments :: (Monad m) - => LMatch GhcPs (LHsExpr GhcPs) -> TransformT m (LMatch GhcPs (LHsExpr GhcPs)) -balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do - logTr $ "balanceSameLineComments: (la)=" ++ showGhc (ss2range $ locA la) - logTr $ "balanceSameLineComments: [logInfo]=" ++ showAst logInfo - return (L la' (Match anm mctxt pats (GRHSs x grhss' lb))) +balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) +balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) + = (L la' (Match anm mctxt pats (GRHSs x grhss' lb))) where simpleBreak n (r,_) = r > n (la',grhss', logInfo) = case reverse grhss of @@ -770,24 +744,21 @@ addComma (EpAnn anc (AnnListItem as) cs) -- | Insert a declaration into an AST element having sub-declarations -- (@HasDecls@) according to the given location function. insertAt :: (HasDecls ast) - => (LHsDecl GhcPs - -> [LHsDecl GhcPs] - -> [LHsDecl GhcPs]) - -> ast - -> LHsDecl GhcPs - -> Transform ast -insertAt f t decl = do - oldDecls <- hsDecls t - oldDeclsb <- balanceCommentsList oldDecls - let oldDecls' = oldDeclsb - replaceDecls t (f decl oldDecls') + => (LHsDecl GhcPs + -> [LHsDecl GhcPs] + -> [LHsDecl GhcPs]) + -> ast + -> LHsDecl GhcPs + -> ast +insertAt f t decl = replaceDecls t (f decl oldDecls') + where + oldDecls = hsDecls t + oldDeclsb = balanceCommentsList oldDecls + oldDecls' = oldDeclsb -- |Insert a declaration at the beginning or end of the subdecls of the given -- AST item -insertAtStart, insertAtEnd :: (HasDecls ast) - => ast - -> LHsDecl GhcPs - -> Transform ast +insertAtStart, insertAtEnd :: HasDecls ast => ast -> LHsDecl GhcPs -> ast insertAtEnd = insertAt (\x xs -> xs ++ [x]) @@ -802,11 +773,11 @@ insertAtStart = insertAt insertFirst -- |Insert a declaration at a specific location in the subdecls of the given -- AST item -insertAfter, insertBefore :: (HasDecls (LocatedA ast)) +insertAfter, insertBefore :: HasDecls (LocatedA ast) => LocatedA old -> LocatedA ast -> LHsDecl GhcPs - -> Transform (LocatedA ast) + -> LocatedA ast insertAfter (getLocA -> k) = insertAt findAfter where findAfter x xs = @@ -833,10 +804,10 @@ class (Data t) => HasDecls t where -- given syntax phrase. They are always returned in the wrapped 'HsDecl' -- form, even if orginating in local decls. This is safe, as annotations -- never attach to the wrapper, only to the wrapped item. - hsDecls :: (Monad m) => t -> TransformT m [LHsDecl GhcPs] + hsDecls :: t -> [LHsDecl GhcPs] -- | Replace the directly enclosed decl list by the given - -- decl list. Runs in the 'Transform' monad to be able to update list order + -- decl list. As parto of replacing it will update list order -- annotations, and rebalance comments and other layout changes as needed. -- -- For example, a call on replaceDecls for a wrapped 'FunBind' having no @@ -854,96 +825,86 @@ class (Data t) => HasDecls t where -- where -- nn = 2 -- @ - replaceDecls :: (Monad m) => t -> [LHsDecl GhcPs] -> TransformT m t + replaceDecls :: t -> [LHsDecl GhcPs] -> t -- --------------------------------------------------------------------- instance HasDecls ParsedSource where - hsDecls (L _ (HsModule (XModulePs _ _lo _ _) _mn _exps _imps decls)) = return decls + hsDecls (L _ (HsModule (XModulePs _ _lo _ _) _mn _exps _imps decls)) = decls replaceDecls (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps _decls)) decls - = do - logTr "replaceDecls LHsModule" - return (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps decls)) + = (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps decls)) -- --------------------------------------------------------------------- instance HasDecls (LocatedA (HsDecl GhcPs)) where - hsDecls (L _ (TyClD _ c@ClassDecl{})) = return $ hsDeclsClassDecl c - hsDecls decl = do - error $ "hsDecls:decl=" ++ showAst decl - replaceDecls (L l (TyClD e dec@ClassDecl{})) decls = do - let decl' = replaceDeclsClassDecl dec decls - return (L l (TyClD e decl')) - replaceDecls decl _decls = do - error $ "replaceDecls:decl=" ++ showAst decl + hsDecls (L _ (TyClD _ c@ClassDecl{})) = hsDeclsClassDecl c + hsDecls decl = error $ "hsDecls:decl=" ++ showAst decl + replaceDecls (L l (TyClD e dec@ClassDecl{})) decls = + let + decl' = replaceDeclsClassDecl dec decls + in (L l (TyClD e decl')) + replaceDecls decl _decls + = error $ "replaceDecls:decl=" ++ showAst decl -- --------------------------------------------------------------------- instance HasDecls (LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))) where - hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = return $ hsDeclsLocalBinds lb + hsDecls (L _ (Match _ _ _ (GRHSs _ _ lb))) = hsDeclsLocalBinds lb replaceDecls (L l (Match xm c p (GRHSs xr rhs binds))) [] - = do - logTr "replaceDecls LMatch empty decls" - binds'' <- replaceDeclsValbinds WithoutWhere binds [] - return (L l (Match xm c p (GRHSs xr rhs binds''))) + = let + binds'' = replaceDeclsValbinds WithoutWhere binds [] + in (L l (Match xm c p (GRHSs xr rhs binds''))) replaceDecls m@(L l (Match xm c p (GRHSs xr rhs binds))) newBinds - = do - logTr "replaceDecls LMatch nonempty decls" + = let -- Need to throw in a fresh where clause if the binds were empty, -- in the annotations. - (l', rhs') <- case binds of - EmptyLocalBinds{} -> do - logTr $ "replaceDecls LMatch empty binds" - - logDataWithAnnsTr "Match.replaceDecls:balancing comments:m" m - L l' m' <- balanceSameLineComments m - logDataWithAnnsTr "Match.replaceDecls:(m1')" (L l' m') - return (l', grhssGRHSs $ m_grhss m') - _ -> return (l, rhs) - binds'' <- replaceDeclsValbinds WithWhere binds newBinds - logDataWithAnnsTr "Match.replaceDecls:binds'" binds'' - return (L l' (Match xm c p (GRHSs xr rhs' binds''))) + (l', rhs') = case binds of + EmptyLocalBinds{} -> + let + L l' m' = balanceSameLineComments m + in (l', grhssGRHSs $ m_grhss m') + _ -> (l, rhs) + binds'' = replaceDeclsValbinds WithWhere binds newBinds + in (L l' (Match xm c p (GRHSs xr rhs' binds''))) -- --------------------------------------------------------------------- instance HasDecls (LocatedA (HsExpr GhcPs)) where - hsDecls (L _ (HsLet _ decls _ex)) = return $ hsDeclsLocalBinds decls - hsDecls _ = return [] + hsDecls (L _ (HsLet _ decls _ex)) = hsDeclsLocalBinds decls + hsDecls _ = [] replaceDecls (L ll (HsLet (tkLet, tkIn) binds ex)) newDecls - = do - logTr "replaceDecls HsLet" - let lastAnc = realSrcSpan $ spanHsLocaLBinds binds + = let + lastAnc = realSrcSpan $ spanHsLocaLBinds binds -- TODO: may be an intervening comment, take account for lastAnc - let (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of - (EpTok l, EpTok i) -> - let - off = case l of - (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r - (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0 - (EpaDelta (SameLine _) _) -> LayoutStartCol 0 - (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c - ex'' = setEntryDPFromAnchor off i ex - newDecls'' = case newDecls of - [] -> newDecls - (d:ds) -> setEntryDPDecl d (SameLine 0) : ds - in ( EpTok l - , EpTok (addEpaLocationDelta off lastAnc i) - , ex'' - , newDecls'') - (_,_) -> (tkLet, tkIn, ex, newDecls) - binds' <- replaceDeclsValbinds WithoutWhere binds newDecls' - return (L ll (HsLet (tkLet', tkIn') binds' ex')) + (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of + (EpTok l, EpTok i) -> + let + off = case l of + (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r + (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0 + (EpaDelta (SameLine _) _) -> LayoutStartCol 0 + (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c + ex'' = setEntryDPFromAnchor off i ex + newDecls'' = case newDecls of + [] -> newDecls + (d:ds) -> setEntryDPDecl d (SameLine 0) : ds + in ( EpTok l + , EpTok (addEpaLocationDelta off lastAnc i) + , ex'' + , newDecls'') + (_,_) -> (tkLet, tkIn, ex, newDecls) + binds' = replaceDeclsValbinds WithoutWhere binds newDecls' + in (L ll (HsLet (tkLet', tkIn') binds' ex')) -- TODO: does this make sense? Especially as no hsDecls for HsPar replaceDecls (L l (HsPar x e)) newDecls - = do - logTr "replaceDecls HsPar" - e' <- replaceDecls e newDecls - return (L l (HsPar x e')) + = let + e' = replaceDecls e newDecls + in (L l (HsPar x e')) replaceDecls old _new = error $ "replaceDecls (LHsExpr GhcPs) undefined for:" ++ showGhc old -- --------------------------------------------------------------------- @@ -970,53 +931,51 @@ hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x -- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is -- idempotent. -replaceDeclsPatBindD :: (Monad m) => LHsDecl GhcPs -> [LHsDecl GhcPs] - -> TransformT m (LHsDecl GhcPs) -replaceDeclsPatBindD (L l (ValD x d)) newDecls = do - (L _ d') <- replaceDeclsPatBind (L l d) newDecls - return (L l (ValD x d')) +replaceDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs] -> (LHsDecl GhcPs) +replaceDeclsPatBindD (L l (ValD x d)) newDecls = + let + (L _ d') = replaceDeclsPatBind (L l d) newDecls + in (L l (ValD x d')) replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x -- | Replace the immediate declarations for a 'PatBind'. This -- cannot be a member of 'HasDecls' because a 'FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent. -replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs] - -> TransformT m (LHsBind GhcPs) +replaceDeclsPatBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -> (LHsBind GhcPs) replaceDeclsPatBind (L l (PatBind x a p (GRHSs xr rhss binds))) newDecls - = do - logTr "replaceDecls PatBind" - binds'' <- replaceDeclsValbinds WithWhere binds newDecls - return (L l (PatBind x a p (GRHSs xr rhss binds''))) + = (L l (PatBind x a p (GRHSs xr rhss binds''))) + where + binds'' = replaceDeclsValbinds WithWhere binds newDecls replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x -- --------------------------------------------------------------------- instance HasDecls (LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))) where - hsDecls (L _ (LetStmt _ lb)) = return $ hsDeclsLocalBinds lb + hsDecls (L _ (LetStmt _ lb)) = hsDeclsLocalBinds lb hsDecls (L _ (LastStmt _ e _ _)) = hsDecls e hsDecls (L _ (BindStmt _ _pat e)) = hsDecls e hsDecls (L _ (BodyStmt _ e _ _)) = hsDecls e - hsDecls _ = return [] + hsDecls _ = [] replaceDecls (L l (LetStmt x lb)) newDecls - = do - lb'' <- replaceDeclsValbinds WithWhere lb newDecls - return (L l (LetStmt x lb'')) + = let + lb'' = replaceDeclsValbinds WithWhere lb newDecls + in (L l (LetStmt x lb'')) replaceDecls (L l (LastStmt x e d se)) newDecls - = do - e' <- replaceDecls e newDecls - return (L l (LastStmt x e' d se)) + = let + e' = replaceDecls e newDecls + in (L l (LastStmt x e' d se)) replaceDecls (L l (BindStmt x pat e)) newDecls - = do - e' <- replaceDecls e newDecls - return (L l (BindStmt x pat e')) + = let + e' = replaceDecls e newDecls + in (L l (BindStmt x pat e')) replaceDecls (L l (BodyStmt x e a b)) newDecls - = do - e' <- replaceDecls e newDecls - return (L l (BodyStmt x e' a b)) - replaceDecls x _newDecls = return x + = let + e' = replaceDecls e newDecls + in (L l (BodyStmt x e' a b)) + replaceDecls x _newDecls = x -- ===================================================================== -- end of HasDecls instances @@ -1098,61 +1057,57 @@ data WithWhere = WithWhere -- care, as this does not manage the declaration order, the -- ordering should be done by the calling function from the 'HsLocalBinds' -- context in the AST. -replaceDeclsValbinds :: (Monad m) - => WithWhere +replaceDeclsValbinds :: WithWhere -> HsLocalBinds GhcPs -> [LHsDecl GhcPs] - -> TransformT m (HsLocalBinds GhcPs) -replaceDeclsValbinds _ _ [] = do - return (EmptyLocalBinds NoExtField) + -> HsLocalBinds GhcPs +replaceDeclsValbinds _ _ [] = EmptyLocalBinds NoExtField replaceDeclsValbinds w b@(HsValBinds a _) new - = do - logTr "replaceDeclsValbinds" - let oldSpan = spanHsLocaLBinds b - an <- oldWhereAnnotation a w (realSrcSpan oldSpan) - let decs = listToBag $ concatMap decl2Bind new - let sigs = concatMap decl2Sig new - let sortKey = captureOrderBinds new - return (HsValBinds an (ValBinds sortKey decs sigs)) + = let + oldSpan = spanHsLocaLBinds b + an = oldWhereAnnotation a w (realSrcSpan oldSpan) + decs = listToBag $ concatMap decl2Bind new + sigs = concatMap decl2Sig new + sortKey = captureOrderBinds new + in (HsValBinds an (ValBinds sortKey decs sigs)) replaceDeclsValbinds _ (HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" replaceDeclsValbinds w (EmptyLocalBinds _) new - = do - logTr "replaceDecls HsLocalBinds" - an <- newWhereAnnotation w - let newBinds = concatMap decl2Bind new - newSigs = concatMap decl2Sig new - let decs = listToBag $ newBinds - let sigs = newSigs - let sortKey = captureOrderBinds new - return (HsValBinds an (ValBinds sortKey decs sigs)) - -oldWhereAnnotation :: (Monad m) - => EpAnn AnnList -> WithWhere -> RealSrcSpan -> TransformT m (EpAnn AnnList) -oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do - -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, change the AnnList anchor to have the correct DP too - let (AnnList ancl o c _r t) = an - let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] - WithoutWhere -> [] - (anc', ancl') <- do - case ww of - WithWhere -> return (anc, ancl) - WithoutWhere -> return (anc, ancl) - let an' = EpAnn anc' - (AnnList ancl' o c w t) - cs - return an' - -newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList) -newWhereAnnotation ww = do - let anc = EpaDelta (DifferentLine 1 3) [] - let anc2 = EpaDelta (DifferentLine 1 5) [] - let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] - WithoutWhere -> [] - let an = EpAnn anc - (AnnList (Just anc2) Nothing Nothing w []) - emptyComments - return an + = let + an = newWhereAnnotation w + newBinds = concatMap decl2Bind new + newSigs = concatMap decl2Sig new + decs = listToBag $ newBinds + sigs = newSigs + sortKey = captureOrderBinds new + in (HsValBinds an (ValBinds sortKey decs sigs)) + +oldWhereAnnotation :: EpAnn AnnList -> WithWhere -> RealSrcSpan -> (EpAnn AnnList) +oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = an' + -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, + -- change the AnnList anchor to have the correct DP too + where + (AnnList ancl o c _r t) = an + w = case ww of + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] + WithoutWhere -> [] + (anc', ancl') = + case ww of + WithWhere -> (anc, ancl) + WithoutWhere -> (anc, ancl) + an' = EpAnn anc' + (AnnList ancl' o c w t) + cs + +newWhereAnnotation :: WithWhere -> (EpAnn AnnList) +newWhereAnnotation ww = an + where + anc = EpaDelta (DifferentLine 1 3) [] + anc2 = EpaDelta (DifferentLine 1 5) [] + w = case ww of + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0) [])] + WithoutWhere -> [] + an = EpAnn anc + (AnnList (Just anc2) Nothing Nothing w []) + emptyComments -- --------------------------------------------------------------------- @@ -1163,32 +1118,32 @@ type PMatch = LMatch GhcPs (LHsExpr GhcPs) -- declarations are extracted and returned after modification. For a -- 'FunBind' the supplied 'SrcSpan' is used to identify the specific -- 'Match' to be transformed, for when there are multiple of them. -modifyValD :: forall m t. (HasTransform m) - => SrcSpan +modifyValD :: forall t. + SrcSpan -> Decl - -> (PMatch -> [Decl] -> m ([Decl], Maybe t)) - -> m (Decl,Maybe t) + -> (PMatch -> [Decl] -> ([Decl], Maybe t)) + -> (Decl,Maybe t) modifyValD p pb@(L ss (ValD _ (PatBind {} ))) f = if (locA ss) == p - then do - let ds = hsDeclsPatBindD pb - (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds - pb' <- liftT $ replaceDeclsPatBindD pb ds' - return (pb',r) - else return (pb,Nothing) -modifyValD p decl f = do - (decl',r) <- runStateT (everywhereM (mkM doModLocal) (unpackFunDecl decl)) Nothing - return (packFunDecl decl',r) + then + let + ds = hsDeclsPatBindD pb + (ds',r) = f (error "modifyValD.PatBind should not touch Match") ds + pb' = replaceDeclsPatBindD pb ds' + in (pb',r) + else (pb,Nothing) +modifyValD p decl f = (packFunDecl decl', r) where - doModLocal :: PMatch -> StateT (Maybe t) m PMatch + (decl',r) = runState (everywhereM (mkM doModLocal) (unpackFunDecl decl)) Nothing + doModLocal :: PMatch -> State (Maybe t) PMatch doModLocal (match@(L ss _) :: PMatch) = do if (locA ss) == p then do - ds <- lift $ liftT $ hsDecls match - `debug` ("modifyValD: match=" ++ showAst match) - (ds',r) <- lift $ f match ds + let + ds = hsDecls match + (ds',r) = f match ds put r - match' <- lift $ liftT $ replaceDecls match ds' + let match' = replaceDecls match ds' return match' else return match @@ -1208,6 +1163,6 @@ modifyDeclsT :: (HasDecls t,HasTransform m) => ([LHsDecl GhcPs] -> m [LHsDecl GhcPs]) -> t -> m t modifyDeclsT action t = do - decls <- liftT $ hsDecls t + let decls = hsDecls t decls' <- action decls - liftT $ replaceDecls t decls' + return $ replaceDecls t decls' diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs index 3cab5cfb..1ef3e5c5 100644 --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -112,9 +112,8 @@ changeBalanceComments _libdir top = do -- let (GHC.L l p) = makeDeltaAst top let (GHC.L l p) = top let decls0 = GHC.hsmodDecls p - (decls,_,w) = runTransform (balanceCommentsList decls0) + decls = balanceCommentsList decls0 let p2 = p { GHC.hsmodDecls = decls} - debugM $ "changeBalanceComments:\n" ++ unlines w return (GHC.L l p2) changeMakeDelta :: Changer diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs index 18fd8559..173fd29d 100644 --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -95,9 +95,8 @@ mkTestMod libdir suffix dir f fp = changeWhereIn3a :: Changer changeWhereIn3a _libdir (L l p) = do let decls0 = hsmodDecls p - (decls,_,w) = runTransform (balanceCommentsList decls0) + decls = balanceCommentsList decls0 (_de0:_:de1:_d2:_) = decls - debugM $ unlines w debugM $ "changeWhereIn3a:de1:" ++ showAst de1 let p2 = p { hsmodDecls = decls} return (L l p2) @@ -107,13 +106,12 @@ changeWhereIn3a _libdir (L l p) = do changeWhereIn3b :: Changer changeWhereIn3b _libdir (L l p) = do let decls0 = hsmodDecls p - (decls,_,w) = runTransform (balanceCommentsList decls0) + decls = balanceCommentsList decls0 (de0:tdecls@(_:de1:d2:_)) = decls de0' = setEntryDP de0 (DifferentLine 2 0) de1' = setEntryDP de1 (DifferentLine 2 0) d2' = setEntryDP d2 (DifferentLine 2 0) decls' = d2':de1':de0':tdecls - debugM $ unlines w debugM $ "changeWhereIn3b:de1':" ++ showAst de1' let p2 = p { hsmodDecls = decls'} return (L l p2) @@ -192,7 +190,7 @@ changeAddDecl libdir top = do let (p',_,_w) = runTransform doAddDecl doAddDecl = everywhereM (mkM replaceTopLevelDecls) top replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource - replaceTopLevelDecls m = insertAtStart m decl' + replaceTopLevelDecls m = return $ insertAtStart m decl' return p' -- --------------------------------------------------------------------- @@ -314,16 +312,15 @@ addLocaLDecl1 :: Changer addLocaLDecl1 libdir top = do Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let decl' = setEntryDP (L ld decl) (DifferentLine 1 5) - doAddLocal = do - let lp = top - (de1:d2:d3:_) <- hsDecls lp - (de1'',d2') <- balanceComments de1 d2 - (de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do - return ((wrapDecl decl' : d),Nothing) - replaceDecls lp [de1', d2', d3] - - (lp',_,w) <- runTransformT doAddLocal - debugM $ "addLocaLDecl1:" ++ intercalate "\n" w + doAddLocal :: ParsedSource + doAddLocal = replaceDecls lp [de1', d2', d3] + where + lp = top + (de1:d2:d3:_) = hsDecls lp + (de1'',d2') = balanceComments de1 d2 + (de1',_) = modifyValD (getLocA de1'') de1'' $ \_m d -> ((wrapDecl decl' : d),Nothing) + + let lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -332,20 +329,19 @@ addLocaLDecl2 :: Changer addLocaLDecl2 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = do - -- (de1:d2:_) <- hsDecls (makeDeltaAst lp) - (de1:d2:_) <- hsDecls lp - (de1'',d2') <- balanceComments de1 d2 + doAddLocal = replaceDecls lp [parent',d2'] + where + (de1:d2:_) = hsDecls lp + (de1'',d2') = balanceComments de1 d2 - (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do - newDecl' <- transferEntryDP' d (makeDeltaAst newDecl) - let d' = setEntryDP d (DifferentLine 1 0) - return ((newDecl':d':ds),Nothing) + (parent',_) = modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> + let + newDecl' = transferEntryDP' d (makeDeltaAst newDecl) + d' = setEntryDP d (DifferentLine 1 0) + in ((newDecl':d':ds),Nothing) - replaceDecls lp [parent',d2'] - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -354,19 +350,18 @@ addLocaLDecl3 :: Changer addLocaLDecl3 libdir top = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let - doAddLocal = do - let lp = top - (de1:d2:_) <- hsDecls lp - (de1'',d2') <- balanceComments de1 d2 - - (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do - let newDecl' = setEntryDP newDecl (DifferentLine 1 0) - return (((d:ds) ++ [newDecl']),Nothing) - - replaceDecls (anchorEof lp) [parent',d2'] - - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + doAddLocal = replaceDecls (anchorEof lp) [parent',d2'] + where + lp = top + (de1:d2:_) = hsDecls lp + (de1'',d2') = balanceComments de1 d2 + + (parent',_) = modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> + let + newDecl' = setEntryDP newDecl (DifferentLine 1 0) + in (((d:ds) ++ [newDecl']),Nothing) + + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -376,19 +371,18 @@ addLocaLDecl4 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right newSig <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") let - doAddLocal = do - (parent:ds) <- hsDecls (makeDeltaAst lp) + doAddLocal = replaceDecls (anchorEof lp) (parent':ds) + where + (parent:ds) = hsDecls (makeDeltaAst lp) - let newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 0) - let newSig' = setEntryDP (makeDeltaAst newSig) (DifferentLine 1 5) + newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 0) + newSig' = setEntryDP (makeDeltaAst newSig) (DifferentLine 1 5) - (parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do - return ((decls++[newSig',newDecl']),Nothing) + (parent',_) = modifyValD (getLocA parent) parent $ \_m decls -> + ((decls++[newSig',newDecl']),Nothing) - replaceDecls (anchorEof lp) (parent':ds) - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -396,19 +390,19 @@ addLocaLDecl4 libdir lp = do addLocaLDecl5 :: Changer addLocaLDecl5 _libdir lp = do let - doAddLocal = do - decls <- hsDecls lp - [s1,de1,d2,d3] <- balanceCommentsList decls + doAddLocal = replaceDecls lp [s1,de1',d3'] + where + decls = hsDecls lp + [s1,de1,d2,d3] = balanceCommentsList decls - let d3' = setEntryDP d3 (DifferentLine 2 0) + d3' = setEntryDP d3 (DifferentLine 2 0) - (de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do - let d2' = setEntryDP d2 (DifferentLine 1 0) - return ([d2'],Nothing) - replaceDecls lp [s1,de1',d3'] + (de1',_) = modifyValD (getLocA de1) de1 $ \_m _decls -> + let + d2' = setEntryDP d2 (DifferentLine 1 0) + in ([d2'],Nothing) - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- @@ -418,36 +412,35 @@ addLocaLDecl6 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") let newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 5) - doAddLocal = do - decls0 <- hsDecls lp - [de1'',d2] <- balanceCommentsList decls0 + doAddLocal = replaceDecls lp [de1', d2] + where + decls0 = hsDecls lp + [de1'',d2] = balanceCommentsList decls0 - let de1 = captureMatchLineSpacing de1'' - let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1 - let [ma1,_ma2] = ms + de1 = captureMatchLineSpacing de1'' + L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1 + [ma1,_ma2] = ms - (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do - return ((newDecl' : decls),Nothing) - replaceDecls lp [de1', d2] + (de1',_) = modifyValD (getLocA ma1) de1 $ \_m decls -> + ((newDecl' : decls),Nothing) - (lp',_,_w) <- runTransformT doAddLocal - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doAddLocal return lp' -- --------------------------------------------------------------------- rmDecl1 :: Changer rmDecl1 _libdir lp = do - let doRmDecl = do - tlDecs0 <- hsDecls lp - tlDecs <- balanceCommentsList tlDecs0 - let (de1:_s1:_d2:d3:ds) = tlDecs - let d3' = setEntryDP d3 (DifferentLine 2 0) + let + doRmDecl = replaceDecls lp (de1:d3':ds) + where + tlDecs0 = hsDecls lp + tlDecs = balanceCommentsList tlDecs0 + (de1:_s1:_d2:d3:ds) = tlDecs + d3' = setEntryDP d3 (DifferentLine 2 0) - replaceDecls lp (de1:d3':ds) - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doRmDecl return lp' -- --------------------------------------------------------------------- @@ -459,9 +452,9 @@ rmDecl2 _libdir lp = do let go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs) go e@(GHC.L _ (GHC.HsLet{})) = do - decs0 <- hsDecls e - decs <- balanceCommentsList $ captureLineSpacing decs0 - e' <- replaceDecls e (init decs) + let decs0 = hsDecls e + let decs = balanceCommentsList $ captureLineSpacing decs0 + let e' = replaceDecls e (init decs) return e' go x = return x @@ -475,37 +468,31 @@ rmDecl2 _libdir lp = do rmDecl3 :: Changer rmDecl3 _libdir lp = do let - doRmDecl = do - -- [de1,d2] <- hsDecls (makeDeltaAst lp) - [de1,d2] <- hsDecls lp - - (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do - let sd1' = setEntryDP sd1 (DifferentLine 2 0) - return ([],Just sd1') - - replaceDecls lp [de1',sd1,d2] - - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + doRmDecl = replaceDecls lp [de1',sd1,d2] + where + [de1,d2] = hsDecls lp + (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1] -> + let + sd1' = setEntryDP sd1 (DifferentLine 2 0) + in ([],Just sd1') + + lp' = doRmDecl return lp' + -- --------------------------------------------------------------------- rmDecl4 :: Changer rmDecl4 _libdir lp = do let - doRmDecl = do - [de1] <- hsDecls lp - - (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do - sd2' <- transferEntryDP' sd1 sd2 - - let sd1' = setEntryDP sd1 (DifferentLine 2 0) - return ([sd2'],Just sd1') - - replaceDecls (anchorEof lp) [de1',sd1] - - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + doRmDecl = replaceDecls (anchorEof lp) [de1',sd1] + where + [de1] = hsDecls lp + (de1',Just sd1) = modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> + let + sd2' = transferEntryDP' sd1 sd2 + sd1' = setEntryDP sd1 (DifferentLine 2 0) + in ([sd2'],Just sd1') + lp' = doRmDecl return lp' -- --------------------------------------------------------------------- @@ -520,8 +507,8 @@ rmDecl5 _libdir lp = do let decs = hsDeclsLocalBinds lb let hdecs : _ = decs let dec = last decs - _ <- transferEntryDP hdecs dec - lb' <- replaceDeclsValbinds WithoutWhere lb [dec] + -- _ <- transferEntryDP hdecs dec + let lb' = replaceDeclsValbinds WithoutWhere lb [dec] return (HsLet (tkLet, tkIn) lb' expr) go x = return x @@ -536,20 +523,18 @@ rmDecl5 _libdir lp = do rmDecl6 :: Changer rmDecl6 _libdir lp = do let - doRmDecl = do - [de1] <- hsDecls lp - - (de1',_) <- modifyValD (getLocA de1) de1 $ \_m subDecs -> do - let subDecs' = captureLineSpacing subDecs - let (ss1:_sd1:sd2:sds) = subDecs' - sd2' <- transferEntryDP' ss1 sd2 - - return (sd2':sds,Nothing) - - replaceDecls lp [de1'] - - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + doRmDecl = replaceDecls lp [de1'] + where + [de1] = hsDecls lp + + (de1',_) = modifyValD (getLocA de1) de1 $ \_m subDecs -> + let + subDecs' = captureLineSpacing subDecs + (ss1:_sd1:sd2:sds) = subDecs' + sd2' = transferEntryDP' ss1 sd2 + in (sd2':sds,Nothing) + + lp' = doRmDecl return lp' -- --------------------------------------------------------------------- @@ -557,50 +542,42 @@ rmDecl6 _libdir lp = do rmDecl7 :: Changer rmDecl7 _libdir lp = do let - doRmDecl = do - -- tlDecs <- hsDecls (makeDeltaAst lp) - tlDecs <- hsDecls lp - [s1,de1,d2,d3] <- balanceCommentsList tlDecs - - d3' <- transferEntryDP' d2 d3 + doRmDecl = replaceDecls lp [s1,de1,d3'] + where + tlDecs = hsDecls lp + [s1,de1,d2,d3] = balanceCommentsList tlDecs + d3' = transferEntryDP' d2 d3 - replaceDecls lp [s1,de1,d3'] - - (lp',_,_w) <- runTransformT doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + lp' = doRmDecl return lp' + -- --------------------------------------------------------------------- rmTypeSig1 :: Changer rmTypeSig1 _libdir lp = do - let doRmDecl = do - tlDecs <- hsDecls lp - let (s0:de1:d2) = tlDecs - s1 = captureTypeSigSpacing s0 - (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1 - L ln n2' <- transferEntryDP n1 n2 - let s1' = (L l (SigD x1 (TypeSig x2 [L (noTrailingN ln) n2'] typ))) - replaceDecls lp (s1':de1:d2) - - let (lp',_,_w) = runTransform doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + let doRmDecl = replaceDecls lp (s1':de1:d2) + where + tlDecs = hsDecls lp + (s0:de1:d2) = tlDecs + s1 = captureTypeSigSpacing s0 + (L l (SigD x1 (TypeSig x2 [n1,n2] typ))) = s1 + L ln n2' = transferEntryDP n1 n2 + s1' = (L l (SigD x1 (TypeSig x2 [L (noTrailingN ln) n2'] typ))) + + lp' = doRmDecl return lp' -- --------------------------------------------------------------------- rmTypeSig2 :: Changer rmTypeSig2 _libdir lp = do - let doRmDecl = do - -- tlDecs <- hsDecls (makeDeltaAst lp) - tlDecs <- hsDecls lp - let [de1] = tlDecs - - (de1',_) <- modifyValD (getLocA de1) de1 $ \_m [_s,d] -> do - return ([d],Nothing) - replaceDecls lp [de1'] + let doRmDecl = replaceDecls lp [de1'] + where + tlDecs = hsDecls lp + [de1] = tlDecs + (de1',_) = modifyValD (getLocA de1) de1 $ \_m [_s,d] -> ([d],Nothing) - let (lp',_,_w) = runTransform doRmDecl - debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" + let lp' = doRmDecl return lp' -- --------------------------------------------------------------------- @@ -664,15 +641,14 @@ addHiding2 _libdir top = do cloneDecl1 :: Changer cloneDecl1 _libdir lp = do - let doChange = do - tlDecs <- hsDecls (makeDeltaAst lp) - let (d1':d2:ds) = tlDecs - -- d2' <- fst <$> cloneT d2 - let d2' = d2 - let d2'' = setEntryDP d2' (DifferentLine 2 0) - replaceDecls lp (d1':d2:d2'':ds) - - let (lp',_,_w) = runTransform doChange + let doChange = replaceDecls lp (d1':d2:d2'':ds) + where + tlDecs = hsDecls (makeDeltaAst lp) + (d1':d2:ds) = tlDecs + d2' = d2 + d2'' = setEntryDP d2' (DifferentLine 2 0) + + let lp' = doChange return lp' -- ---------------------------------------------------------------------