ghc-exactprint 1.9.0.0 → 1.10.0.0
raw patch · 7 files changed
+369/−454 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Language.Haskell.GHC.ExactPrint.Types: NormalLayout :: Rigidity
- Language.Haskell.GHC.ExactPrint.Types: RigidLayout :: Rigidity
- Language.Haskell.GHC.ExactPrint.Types: data Rigidity
- Language.Haskell.GHC.ExactPrint.Types: instance GHC.Classes.Eq Language.Haskell.GHC.ExactPrint.Types.Rigidity
- Language.Haskell.GHC.ExactPrint.Types: instance GHC.Classes.Ord Language.Haskell.GHC.ExactPrint.Types.Rigidity
- Language.Haskell.GHC.ExactPrint.Types: instance GHC.Internal.Show.Show Language.Haskell.GHC.ExactPrint.Types.Rigidity
- Language.Haskell.GHC.ExactPrint.ExactPrint: epOptions :: (forall ast. Data ast => Located ast -> a -> m a) -> (String -> m a) -> (String -> m a) -> Rigidity -> Bool -> EPOptions m a
+ Language.Haskell.GHC.ExactPrint.ExactPrint: epOptions :: (String -> m a) -> (String -> m a) -> EPOptions m a
- Language.Haskell.GHC.ExactPrint.Transform: balanceComments :: forall (m :: Type -> Type). Monad m => LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs, LHsDecl GhcPs)
+ Language.Haskell.GHC.ExactPrint.Transform: balanceComments :: LHsDecl GhcPs -> LHsDecl GhcPs -> (LHsDecl GhcPs, LHsDecl GhcPs)
- Language.Haskell.GHC.ExactPrint.Transform: balanceCommentsList :: forall (m :: Type -> Type). Monad m => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs]
+ Language.Haskell.GHC.ExactPrint.Transform: balanceCommentsList :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]
- Language.Haskell.GHC.ExactPrint.Transform: balanceCommentsListA :: forall (m :: Type -> Type) a. Monad m => [LocatedA a] -> TransformT m [LocatedA a]
+ Language.Haskell.GHC.ExactPrint.Transform: balanceCommentsListA :: [LocatedA a] -> [LocatedA a]
- Language.Haskell.GHC.ExactPrint.Transform: hsDecls :: forall (m :: Type -> Type). (HasDecls t, Monad m) => t -> TransformT m [LHsDecl GhcPs]
+ Language.Haskell.GHC.ExactPrint.Transform: hsDecls :: HasDecls t => t -> [LHsDecl GhcPs]
- Language.Haskell.GHC.ExactPrint.Transform: insertAfter :: HasDecls (LocatedA ast) => LocatedA old -> LocatedA ast -> LHsDecl GhcPs -> Transform (LocatedA ast)
+ Language.Haskell.GHC.ExactPrint.Transform: insertAfter :: HasDecls (LocatedA ast) => LocatedA old -> LocatedA ast -> LHsDecl GhcPs -> LocatedA ast
- Language.Haskell.GHC.ExactPrint.Transform: insertAt :: HasDecls ast => (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]) -> ast -> LHsDecl GhcPs -> Transform ast
+ Language.Haskell.GHC.ExactPrint.Transform: insertAt :: HasDecls ast => (LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]) -> ast -> LHsDecl GhcPs -> ast
- Language.Haskell.GHC.ExactPrint.Transform: insertAtEnd :: HasDecls ast => ast -> LHsDecl GhcPs -> Transform ast
+ Language.Haskell.GHC.ExactPrint.Transform: insertAtEnd :: HasDecls ast => ast -> LHsDecl GhcPs -> ast
- Language.Haskell.GHC.ExactPrint.Transform: insertAtStart :: HasDecls ast => ast -> LHsDecl GhcPs -> Transform ast
+ Language.Haskell.GHC.ExactPrint.Transform: insertAtStart :: HasDecls ast => ast -> LHsDecl GhcPs -> ast
- Language.Haskell.GHC.ExactPrint.Transform: insertBefore :: HasDecls (LocatedA ast) => LocatedA old -> LocatedA ast -> LHsDecl GhcPs -> Transform (LocatedA ast)
+ Language.Haskell.GHC.ExactPrint.Transform: insertBefore :: HasDecls (LocatedA ast) => LocatedA old -> LocatedA ast -> LHsDecl GhcPs -> LocatedA ast
- Language.Haskell.GHC.ExactPrint.Transform: modifyValD :: HasTransform m => SrcSpan -> Decl -> (PMatch -> [Decl] -> m ([Decl], Maybe t)) -> m (Decl, Maybe t)
+ Language.Haskell.GHC.ExactPrint.Transform: modifyValD :: SrcSpan -> Decl -> (PMatch -> [Decl] -> ([Decl], Maybe t)) -> (Decl, Maybe t)
- Language.Haskell.GHC.ExactPrint.Transform: replaceDecls :: forall (m :: Type -> Type). (HasDecls t, Monad m) => t -> [LHsDecl GhcPs] -> TransformT m t
+ Language.Haskell.GHC.ExactPrint.Transform: replaceDecls :: HasDecls t => t -> [LHsDecl GhcPs] -> t
- Language.Haskell.GHC.ExactPrint.Transform: replaceDeclsPatBind :: forall (m :: Type -> Type). Monad m => LHsBind GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsBind GhcPs)
+ Language.Haskell.GHC.ExactPrint.Transform: replaceDeclsPatBind :: LHsBind GhcPs -> [LHsDecl GhcPs] -> LHsBind GhcPs
- Language.Haskell.GHC.ExactPrint.Transform: replaceDeclsPatBindD :: forall (m :: Type -> Type). Monad m => LHsDecl GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsDecl GhcPs)
+ Language.Haskell.GHC.ExactPrint.Transform: replaceDeclsPatBindD :: LHsDecl GhcPs -> [LHsDecl GhcPs] -> LHsDecl GhcPs
- Language.Haskell.GHC.ExactPrint.Transform: replaceDeclsValbinds :: forall (m :: Type -> Type). Monad m => WithWhere -> HsLocalBinds GhcPs -> [LHsDecl GhcPs] -> TransformT m (HsLocalBinds GhcPs)
+ Language.Haskell.GHC.ExactPrint.Transform: replaceDeclsValbinds :: WithWhere -> HsLocalBinds GhcPs -> [LHsDecl GhcPs] -> HsLocalBinds GhcPs
- Language.Haskell.GHC.ExactPrint.Transform: transferEntryDP :: forall (m :: Type -> Type) t1 t2 a b. (Monad m, Typeable t1, Typeable t2) => LocatedAn t1 a -> LocatedAn t2 b -> TransformT m (LocatedAn t2 b)
+ Language.Haskell.GHC.ExactPrint.Transform: transferEntryDP :: (Typeable t1, Typeable t2) => LocatedAn t1 a -> LocatedAn t2 b -> LocatedAn t2 b
- Language.Haskell.GHC.ExactPrint.Transform: transferEntryDP' :: forall (m :: Type -> Type). Monad m => LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs)
+ Language.Haskell.GHC.ExactPrint.Transform: transferEntryDP' :: LHsDecl GhcPs -> LHsDecl GhcPs -> LHsDecl GhcPs
Files
- ChangeLog +3/−0
- ghc-exactprint.cabal +1/−1
- src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +12/−26
- src/Language/Haskell/GHC/ExactPrint/Transform.hs +223/−268
- src/Language/Haskell/GHC/ExactPrint/Types.hs +0/−4
- tests/Test/Common.hs +1/−2
- tests/Test/Transform.hs +129/−153
ChangeLog view
@@ -1,3 +1,6 @@+2024-05-21 v1.10.0.0+ * Make the Language.Haskell.GHC.ExactPrint.Transform API pure+ * Remove EPOoptions fields that had no effect 2024-05-16 v1.9.0.0 * Support GHC 9.10.1 2022-12-19 v1.8.0.0
ghc-exactprint.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: ghc-exactprint-version: 1.9.0.0+version: 1.10.0.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 9.2.1, this library provides a means to round trip any code that can
src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs view
@@ -26,7 +26,7 @@ , makeDeltaAst -- * Configuration- , EPOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint, epUpdateAnchors)+ , EPOptions(epTokenPrint, epWhitespacePrint) , stringOptions , epOptions , deltaOptions@@ -79,8 +79,7 @@ exactPrint :: ExactPrint ast => ast -> String exactPrint ast = snd $ runIdentity (runEP stringOptions (markAnnotated ast)) --- | The additional option to specify the rigidity and printing--- configuration.+-- | The additional option to specify the printing configuration. exactPrintWithOptions :: (ExactPrint ast, Monoid b, Monad m) => EPOptions m b -> ast@@ -88,9 +87,8 @@ exactPrintWithOptions r ast = runEP r (markAnnotated ast) --- | Transform concrete annotations into relative annotations which--- are more useful when transforming an AST. This corresponds to the--- earlier 'relativiseApiAnns'.+-- | Transform concrete annotations into relative annotations.+-- This should be unnecessary from GHC 9.10 makeDeltaAst :: ExactPrint ast => ast -> ast makeDeltaAst ast = fst $ runIdentity (runEP deltaOptions (markAnnotated ast)) @@ -131,39 +129,27 @@ -- | The R part of RWS. The environment. Updated via 'local' as we -- enter a new AST element, having a different anchor point. data EPOptions m a = EPOptions- {- epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a- , epTokenPrint :: String -> m a+ { epTokenPrint :: String -> m a , epWhitespacePrint :: String -> m a- , epRigidity :: Rigidity- , epUpdateAnchors :: Bool } -- | Helper to create a 'EPOptions'-epOptions ::- (forall ast . Data ast => GHC.Located ast -> a -> m a)- -> (String -> m a)- -> (String -> m a)- -> Rigidity- -> Bool- -> EPOptions m a-epOptions astPrint tokenPrint wsPrint rigidity delta = EPOptions- {- epAstPrint = astPrint- , epWhitespacePrint = wsPrint+epOptions :: (String -> m a)+ -> (String -> m a)+ -> EPOptions m a+epOptions tokenPrint wsPrint = EPOptions+ { epWhitespacePrint = wsPrint , epTokenPrint = tokenPrint- , epRigidity = rigidity- , epUpdateAnchors = delta } -- | Options which can be used to print as a normal String. stringOptions :: EPOptions Identity String-stringOptions = epOptions (\_ b -> return b) return return NormalLayout False+stringOptions = epOptions return return -- | Options which can be used to simply update the AST to be in delta -- form, without generating output deltaOptions :: EPOptions Identity ()-deltaOptions = epOptions (\_ _ -> return ()) (\_ -> return ()) (\_ -> return ()) NormalLayout True+deltaOptions = epOptions (\_ -> return ()) (\_ -> return ()) data EPWriter a = EPWriter { output :: !a }
src/Language/Haskell/GHC/ExactPrint/Transform.hs view
@@ -157,6 +157,7 @@ -- |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 @@ -- |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 @@ -- |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 @@ -- | 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 @@ -- 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 @@ 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' m0:ms') ->+ (L (addCommentsToEpAnn lm' (EpaComments middle )) m0:ms')+ _ -> error "balanceCommentsFB"+ matches'' = balanceCommentsListA matches'+ (m,ms) = case reverse matches'' of+ (L lm' m0:ms') ->+ (L (addCommentsToEpAnn lm' (EpaCommentsBalanced [] after)) m0,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@@ -468,7 +455,7 @@ (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f) move = map snd move' stay = map snd stay'- (l'', grhss', binds', logInfo)+ (l'', grhss', binds', _logInfo) = case reverse grhss of [] -> (l, [], binds, (EpaComments [], noSrcSpanA)) (L lg (GRHS ag grs rhs):gs) ->@@ -491,26 +478,24 @@ 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 @@ -- 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,15 +677,12 @@ -- --------------------------------------------------------------------- -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+ (la',grhss', _logInfo) = case reverse grhss of [] -> (la,grhss,[]) (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))]) where@@ -770,24 +744,21 @@ -- | 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 @@ -- |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 @@ -- 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 @@ -- 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 l0 m' = balanceSameLineComments m+ in (l0, 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 @@ -- 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 @@ -- 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))+ = 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 :: (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'+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 :: (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+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 @@ -- 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- put r- match' <- lift $ liftT $ replaceDecls match ds'+ let+ ds = hsDecls match+ (ds',r0) = f match ds+ put r0+ let match' = replaceDecls match ds' return match' else return match @@ -1208,6 +1163,6 @@ => ([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'
src/Language/Haskell/GHC/ExactPrint/Types.hs view
@@ -21,10 +21,6 @@ -- --------------------------------------------------------------------- -data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show)---- ---------------------------------------------------------------------- -- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted -- from an @AnnKeywordId@ because the annotation must be interleaved into the -- stream and does not have a well-defined position
tests/Test/Common.hs view
@@ -112,9 +112,8 @@ -- 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
tests/Test/Transform.hs view
@@ -95,9 +95,8 @@ 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 @@ 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 @@ 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 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]+ 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) - (lp',_,w) <- runTransformT doAddLocal- debugM $ "addLocaLDecl1:" ++ intercalate "\n" w+ let lp' = doAddLocal return lp' -- ---------------------------------------------------------------------@@ -332,20 +329,19 @@ 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 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)+ doAddLocal = replaceDecls (anchorEof lp) [parent',d2']+ where+ lp = top+ (de1:d2:_) = hsDecls lp+ (de1'',d2') = balanceComments de1 d2 - replaceDecls (anchorEof lp) [parent',d2']+ (parent',_) = modifyValD (getLocA de1) de1'' $ \_m (d:ds) ->+ let+ newDecl' = setEntryDP newDecl (DifferentLine 1 0)+ in (((d:ds) ++ [newDecl']),Nothing) - (lp',_,_w) <- runTransformT doAddLocal- debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+ lp' = doAddLocal return lp' -- ---------------------------------------------------------------------@@ -376,19 +371,18 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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]+ 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',_,_w) <- runTransformT doRmDecl- debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+ 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 @@ 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 @@ 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)+ doRmDecl = replaceDecls lp [de1']+ where+ [de1] = hsDecls lp - replaceDecls lp [de1']+ (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',_,_w) <- runTransformT doRmDecl- debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+ lp' = doRmDecl return lp' -- ---------------------------------------------------------------------@@ -557,50 +542,42 @@ 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-- replaceDecls lp [s1,de1,d3']+ doRmDecl = replaceDecls lp [s1,de1,d3']+ where+ tlDecs = hsDecls lp+ [s1,de1,d2,d3] = balanceCommentsList tlDecs+ d3' = transferEntryDP' d2 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 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))) - let (lp',_,_w) = runTransform doRmDecl- debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n"+ 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 @@ 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 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',_,_w) = runTransform doChange+ let lp' = doChange return lp' -- ---------------------------------------------------------------------