Skip to content

Commit 39f5c3a

Browse files
jaspervdjjaspervdj
authored
Improve Squash step to deal with overlap
1 parent ada1528 commit 39f5c3a

File tree

13 files changed

+292
-246
lines changed

13 files changed

+292
-246
lines changed

‎lib/Language/Haskell/Stylish/Align.hs

+9-9
Original file line numberDiff line numberDiff line change
@@ -8,11 +8,11 @@ module Language.Haskell.Stylish.Align
88

99
--------------------------------------------------------------------------------
1010
import Data.List (nub)
11-
import qualified GHC.Types.SrcLoc as GHC
11+
import qualified GHC.Types.SrcLoc as GHC
1212

1313

1414
--------------------------------------------------------------------------------
15-
import Language.Haskell.Stylish.Editor
15+
import qualified Language.Haskell.Stylish.Editor as Editor
1616
import Language.Haskell.Stylish.Util
1717

1818

@@ -57,13 +57,13 @@ data Alignable a = Alignable
5757
align
5858
:: Maybe Int -- ^ Max columns
5959
-> [Alignable GHC.RealSrcSpan] -- ^ Alignables
60-
-> [Change String] -- ^ Changes performing the alignment
61-
align _ [] = []
60+
-> Editor.Edits -- ^ Changes performing the alignment
61+
align _ [] = mempty
6262
align maxColumns alignment
6363
-- Do not make an changes if we would go past the maximum number of columns
64-
| exceedsColumns (longestLeft + longestRight) = []
65-
| not (fixable alignment) = []
66-
| otherwise = map align' alignment
64+
| exceedsColumns (longestLeft + longestRight) = mempty
65+
| not (fixable alignment) = mempty
66+
| otherwise = foldMap align' alignment
6767
where
6868
exceedsColumns i = case maxColumns of
6969
Nothing -> False
@@ -79,10 +79,10 @@ align maxColumns alignment
7979
| a <- alignment
8080
]
8181

82-
align' a = changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str ->
82+
align' a = Editor.changeLine (GHC.srcSpanStartLine $ aContainer a) $ \str ->
8383
let column = GHC.srcSpanEndCol $ aLeft a
8484
(pre, post) = splitAt column str
85-
in [padRight longestLeft (trimRight pre) ++ trimLeft post]
85+
in [padRight longestLeft (trimRight pre) ++ trimLeft post]
8686

8787
--------------------------------------------------------------------------------
8888
-- | Checks that all the alignables appear on a single line, and that they do

‎lib/Language/Haskell/Stylish/Editor.hs

+142-64
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# language LambdaCase #-}
1+
{-# LANGUAGE LambdaCase #-}
22

33
--------------------------------------------------------------------------------
44
-- | This module provides you with a line-based editor. It's main feature is
@@ -11,103 +11,181 @@
1111
module Language.Haskell.Stylish.Editor
1212
( module Language.Haskell.Stylish.Block
1313

14-
, Change
15-
, applyChanges
14+
, Edits
15+
, apply
1616

17-
, change
17+
, replace
18+
, replaceRealSrcSpan
1819
, changeLine
19-
, delete
20-
, deleteLine
21-
, insert
20+
, changeLines
21+
, insertLines
2222
) where
2323

2424

2525
--------------------------------------------------------------------------------
26-
import Data.List (intercalate, sortOn)
26+
import qualified Data.Map as M
27+
import Data.Maybe (fromMaybe)
28+
import qualified GHC.Types.SrcLoc as GHC
2729

2830

2931
--------------------------------------------------------------------------------
3032
import Language.Haskell.Stylish.Block
3133

3234

3335
--------------------------------------------------------------------------------
34-
-- | Changes the lines indicated by the 'Block' into the given 'Lines'
35-
data Change a = Change
36-
{ changeBlock :: Block a
37-
, changeLines :: [a] -> [a]
38-
}
36+
data Change
37+
-- | Insert some lines.
38+
= CInsert [String]
39+
-- | Replace the block of N lines by the given lines.
40+
| CBlock Int ([String] -> [String])
41+
-- | Replace (startCol, endCol) by the given string on this line.
42+
| CLine Int Int String
3943

4044

4145
--------------------------------------------------------------------------------
42-
moveChange :: Int -> Change a -> Change a
43-
moveChange offset (Change block ls) = Change (moveBlock offset block) ls
46+
-- | Due to the function in CBlock we cannot write a lawful Ord instance, but
47+
-- this lets us merge-sort changes.
48+
beforeChange :: Change -> Change -> Bool
49+
beforeChange (CInsert _) _ = True
50+
beforeChange _ (CInsert _) = False
51+
beforeChange (CBlock _ _) _ = True
52+
beforeChange _ (CBlock _ _) = False
53+
beforeChange (CLine x _ _) (CLine y _ _) = x <= y
4454

4555

4656
--------------------------------------------------------------------------------
47-
applyChanges :: [Change a] -> [a] -> [a]
48-
applyChanges changes0
49-
| overlapping blocks = error $
50-
"Language.Haskell.Stylish.Editor.applyChanges: " ++
51-
"refusing to make overlapping changes on lines " ++
52-
intercalate ", " (map printBlock blocks)
53-
| otherwise = go 1 changes1
57+
prettyChange :: Int -> Change -> String
58+
prettyChange l (CInsert ls) =
59+
show l ++ " insert " ++ show (length ls) ++ " lines"
60+
prettyChange l (CBlock n _) = show l ++ "-" ++ show (l + n) ++ " replace lines"
61+
prettyChange l (CLine start end x) =
62+
show l ++ ":" ++ show start ++ "-" ++ show end ++ " replace by " ++ show x
63+
64+
65+
--------------------------------------------------------------------------------
66+
-- | Merge in order
67+
mergeChanges :: [Change] -> [Change] -> [Change]
68+
mergeChanges = go
5469
where
55-
changes1 = sortOn (blockStart . changeBlock) changes0
56-
blocks = map changeBlock changes1
70+
go [] ys = ys
71+
go xs [] = xs
72+
go (x : xs) (y : ys) =
73+
if x `beforeChange` y then x : go xs (y : ys) else y : go (x : xs) ys
74+
75+
76+
--------------------------------------------------------------------------------
77+
-- Stores sorted spans to change per line.
78+
newtype Edits = Edits {unEdits :: M.Map Int [Change]}
79+
80+
81+
--------------------------------------------------------------------------------
82+
instance Show Edits where
83+
show edits = unlines $ do
84+
(line, changes) <- M.toAscList $ unEdits edits
85+
prettyChange line <$> changes
5786

58-
printBlock b = show (blockStart b) ++ "-" ++ show (blockEnd b)
5987

60-
go _ [] ls = ls
61-
go n (ch : chs) ls =
62-
-- Divide the remaining lines into:
63-
--
64-
-- > pre
65-
-- > old (lines that are affected by the change)
66-
-- > post
67-
--
68-
-- And generate:
69-
--
70-
-- > pre
71-
-- > new
72-
-- > (recurse)
73-
--
74-
let block = changeBlock ch
75-
(pre, ls') = splitAt (blockStart block - n) ls
76-
(old, post) = splitAt (blockLength block) ls'
77-
new = changeLines ch old
78-
extraLines = length new - blockLength block
79-
chs' = map (moveChange extraLines) chs
80-
n' = blockStart block + blockLength block + extraLines
81-
in pre ++ new ++ go n' chs' post
88+
--------------------------------------------------------------------------------
89+
instance Semigroup Edits where
90+
Edits l <> Edits r = Edits $ M.unionWith mergeChanges l r
8291

8392

8493
--------------------------------------------------------------------------------
85-
-- | Change a block of lines for some other lines
86-
change :: Block a -> ([a] -> [a]) -> Change a
87-
change = Change
94+
instance Monoid Edits where
95+
mempty = Edits mempty
8896

8997

9098
--------------------------------------------------------------------------------
91-
-- | Change a single line for some other lines
92-
changeLine :: Int -> (a -> [a]) -> Change a
93-
changeLine start f = change (Block start start) $ \case
94-
[] -> []
95-
(x : _) -> f x
99+
replaceRealSrcSpan :: GHC.RealSrcSpan -> String -> Edits
100+
replaceRealSrcSpan rss repl
101+
| GHC.srcSpanStartLine rss /= GHC.srcSpanEndLine rss = mempty
102+
| otherwise = replace
103+
(GHC.srcSpanStartLine rss)
104+
(GHC.srcSpanStartCol rss)
105+
(GHC.srcSpanEndCol rss)
106+
repl
96107

97108

98109
--------------------------------------------------------------------------------
99-
-- | Delete a block of lines
100-
delete :: Block a -> Change a
101-
delete block = Change block $ const []
110+
replace :: Int -> Int -> Int -> String -> Edits
111+
replace line startCol endCol repl
112+
| startCol > endCol = mempty
113+
| otherwise =
114+
Edits $ M.singleton line [CLine startCol endCol repl]
102115

103116

104117
--------------------------------------------------------------------------------
105-
-- | Delete a single line
106-
deleteLine :: Int -> Change a
107-
deleteLine start = delete (Block start start)
118+
changeLine :: Int -> (String -> [String]) -> Edits
119+
changeLine start f = changeLines (Block start start) $ \ls -> case ls of
120+
l : _ -> f l
121+
_ -> f ""
108122

109123

110124
--------------------------------------------------------------------------------
111-
-- | Insert something /before/ the given lines
112-
insert :: Int -> [a] -> Change a
113-
insert start = Change (Block start (start - 1)) . const
125+
changeLines :: Block String -> ([String] -> [String]) -> Edits
126+
changeLines (Block start end) f =
127+
Edits $ M.singleton start [CBlock (end - start + 1) f]
128+
129+
130+
--------------------------------------------------------------------------------
131+
insertLines :: Int -> [String] -> Edits
132+
insertLines line ls = Edits $ M.singleton line [CInsert ls]
133+
134+
135+
--------------------------------------------------------------------------------
136+
data Conflict = Conflict Int Change Int Change
137+
138+
139+
--------------------------------------------------------------------------------
140+
prettyConflict :: Conflict -> String
141+
prettyConflict (Conflict l1 c1 l2 c2) = unlines
142+
[ "Conflict between edits:"
143+
, "- " ++ prettyChange l1 c1
144+
, "- " ++ prettyChange l2 c2
145+
]
146+
147+
148+
--------------------------------------------------------------------------------
149+
conflicts :: Edits -> [Conflict]
150+
conflicts (Edits edits) = M.toAscList edits >>= uncurry checkChanges
151+
where
152+
checkChanges _ [] = []
153+
checkChanges i (CInsert _ : cs) = checkChanges i cs
154+
checkChanges i (c1@(CBlock _ _) : c2 : _) = [Conflict i c1 i c2]
155+
checkChanges i [c1@(CBlock n _)] = do
156+
i' <- [i + 1 .. i + n - 1]
157+
case M.lookup i' edits of
158+
Just (c2 : _) -> [Conflict i c1 i' c2]
159+
_ -> []
160+
checkChanges i (c1@(CLine xstart xend _) : c2@(CLine ystart _ _) : cs)
161+
| xstart == ystart = [Conflict i c1 i c2]
162+
| xend > ystart = [Conflict i c1 i c2]
163+
| otherwise = checkChanges i (c2 : cs)
164+
checkChanges _ (CLine _ _ _ : _) = []
165+
166+
167+
--------------------------------------------------------------------------------
168+
apply :: Edits -> [String] -> [String]
169+
apply (Edits edits) = case conflicts (Edits edits) of
170+
c : _ -> error $ "Language.Haskell.Stylish.Editor: " ++ prettyConflict c
171+
_ -> go 1 (editsFor 1)
172+
where
173+
editsFor i = fromMaybe [] $ M.lookup i edits
174+
175+
go _ _ [] = []
176+
go i [] (l : ls) = l : go (i + 1) (editsFor $ i + 1) ls
177+
go i (CInsert ls' : cs) ls = ls' ++ go i cs ls
178+
go i (CBlock n f : _cs) ls =
179+
let (domain, ls') = splitAt n ls in
180+
f domain ++ go (i + n) (editsFor $ i + n) ls'
181+
go i (CLine xstart xend x : cs) (l : ls) =
182+
let l' = take (xstart - 1) l ++ x ++ drop (xend - 1) l in
183+
go i (adjust xstart xend x <$> cs) (l' : ls)
184+
185+
adjust _ _ _ (CInsert xs) = CInsert xs
186+
adjust _ _ _ (CBlock n f) = CBlock n f
187+
adjust xstart xend x (CLine ystart yend y)
188+
| ystart >= xend =
189+
let offset = length x - (xend - xstart) in
190+
CLine (ystart + offset) (yend + offset) y
191+
| otherwise = CLine ystart yend y

‎lib/Language/Haskell/Stylish/Step/Data.hs

+7-9
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,8 @@ import Prelude hiding (init)
2828

2929

3030
--------------------------------------------------------------------------------
31-
import Language.Haskell.Stylish.Editor
3231
import Language.Haskell.Stylish.Comments
32+
import qualified Language.Haskell.Stylish.Editor as Editor
3333
import Language.Haskell.Stylish.GHC
3434
import Language.Haskell.Stylish.Module
3535
import Language.Haskell.Stylish.Ordering
@@ -87,10 +87,10 @@ defaultConfig = Config
8787
}
8888

8989
step :: Config -> Step
90-
step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls
90+
step cfg = makeStep "Data" \ls m -> Editor.apply (changes m) ls
9191
where
92-
changes :: Module -> [ChangeLine]
93-
changes m = formatDataDecl cfg <$> dataDecls m
92+
changes :: Module -> Editor.Edits
93+
changes = foldMap (formatDataDecl cfg) . dataDecls
9494

9595
dataDecls :: Module -> [DataDecl]
9696
dataDecls m = do
@@ -108,8 +108,6 @@ step cfg = makeStep "Data" \ls m -> applyChanges (changes m) ls
108108
}
109109
_ -> []
110110

111-
type ChangeLine = Change String
112-
113111
data DataDecl = MkDataDecl
114112
{ dataComments :: [GHC.LEpaComment]
115113
, dataLoc :: GHC.RealSrcSpan
@@ -120,11 +118,11 @@ data DataDecl = MkDataDecl
120118
}
121119

122120

123-
formatDataDecl :: Config -> DataDecl -> ChangeLine
121+
formatDataDecl :: Config -> DataDecl -> Editor.Edits
124122
formatDataDecl cfg@Config{..} decl@MkDataDecl {..} =
125-
change originalDeclBlock (const printedDecl)
123+
Editor.changeLines originalDeclBlock (const printedDecl)
126124
where
127-
originalDeclBlock = Block
125+
originalDeclBlock = Editor.Block
128126
(GHC.srcSpanStartLine dataLoc)
129127
(GHC.srcSpanEndLine dataLoc)
130128

0 commit comments

Comments
 (0)