1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
{-# LANGUAGE LambdaCase #-}
--------------------------------------------------------------------------------
-- | This module provides you with a line-based editor. It's main feature is
-- that you can specify multiple changes at the same time, e.g.:
--
-- > [deleteLine 3, changeLine 4 ["Foo"]]
--
-- when this is evaluated, we take into account that 4th line will become the
-- 3rd line before it needs changing.
module Language.Haskell.Stylish.Editor
( module Language.Haskell.Stylish.Block
, Edits
, apply
, replace
, replaceRealSrcSpan
, changeLine
, changeLines
, insertLines
) where
--------------------------------------------------------------------------------
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import qualified GHC.Types.SrcLoc as GHC
--------------------------------------------------------------------------------
import Language.Haskell.Stylish.Block
--------------------------------------------------------------------------------
data Change
-- | Insert some lines.
= CInsert [String]
-- | Replace the block of N lines by the given lines.
| CBlock Int ([String] -> [String])
-- | Replace (startCol, endCol) by the given string on this line.
| CLine Int Int String
--------------------------------------------------------------------------------
-- | Due to the function in CBlock we cannot write a lawful Ord instance, but
-- this lets us merge-sort changes.
beforeChange :: Change -> Change -> Bool
beforeChange (CInsert _) _ = True
beforeChange _ (CInsert _) = False
beforeChange (CBlock _ _) _ = True
beforeChange _ (CBlock _ _) = False
beforeChange (CLine x _ _) (CLine y _ _) = x <= y
--------------------------------------------------------------------------------
prettyChange :: Int -> Change -> String
prettyChange l (CInsert ls) =
show l ++ " insert " ++ show (length ls) ++ " lines"
prettyChange l (CBlock n _) = show l ++ "-" ++ show (l + n) ++ " replace lines"
prettyChange l (CLine start end x) =
show l ++ ":" ++ show start ++ "-" ++ show end ++ " replace by " ++ show x
--------------------------------------------------------------------------------
-- | Merge in order
mergeChanges :: [Change] -> [Change] -> [Change]
mergeChanges = go
where
go [] ys = ys
go xs [] = xs
go (x : xs) (y : ys) =
if x `beforeChange` y then x : go xs (y : ys) else y : go (x : xs) ys
--------------------------------------------------------------------------------
-- Stores sorted spans to change per line.
newtype Edits = Edits {unEdits :: M.Map Int [Change]}
--------------------------------------------------------------------------------
instance Show Edits where
show edits = unlines $ do
(line, changes) <- M.toAscList $ unEdits edits
prettyChange line <$> changes
--------------------------------------------------------------------------------
instance Semigroup Edits where
Edits l <> Edits r = Edits $ M.unionWith mergeChanges l r
--------------------------------------------------------------------------------
instance Monoid Edits where
mempty = Edits mempty
--------------------------------------------------------------------------------
replaceRealSrcSpan :: GHC.RealSrcSpan -> String -> Edits
replaceRealSrcSpan rss repl
| GHC.srcSpanStartLine rss /= GHC.srcSpanEndLine rss = mempty
| otherwise = replace
(GHC.srcSpanStartLine rss)
(GHC.srcSpanStartCol rss)
(GHC.srcSpanEndCol rss)
repl
--------------------------------------------------------------------------------
replace :: Int -> Int -> Int -> String -> Edits
replace line startCol endCol repl
| startCol > endCol = mempty
| otherwise =
Edits $ M.singleton line [CLine startCol endCol repl]
--------------------------------------------------------------------------------
changeLine :: Int -> (String -> [String]) -> Edits
changeLine start f = changeLines (Block start start) $ \ls -> case ls of
l : _ -> f l
_ -> f ""
--------------------------------------------------------------------------------
changeLines :: Block String -> ([String] -> [String]) -> Edits
changeLines (Block start end) f =
Edits $ M.singleton start [CBlock (end - start + 1) f]
--------------------------------------------------------------------------------
insertLines :: Int -> [String] -> Edits
insertLines line ls = Edits $ M.singleton line [CInsert ls]
--------------------------------------------------------------------------------
data Conflict = Conflict Int Change Int Change
--------------------------------------------------------------------------------
prettyConflict :: Conflict -> String
prettyConflict (Conflict l1 c1 l2 c2) = unlines
[ "Conflict between edits:"
, "- " ++ prettyChange l1 c1
, "- " ++ prettyChange l2 c2
]
--------------------------------------------------------------------------------
conflicts :: Edits -> [Conflict]
conflicts (Edits edits) = M.toAscList edits >>= uncurry checkChanges
where
checkChanges _ [] = []
checkChanges i (CInsert _ : cs) = checkChanges i cs
checkChanges i (c1@(CBlock _ _) : c2 : _) = [Conflict i c1 i c2]
checkChanges i [c1@(CBlock n _)] = do
i' <- [i + 1 .. i + n - 1]
case M.lookup i' edits of
Just (c2 : _) -> [Conflict i c1 i' c2]
_ -> []
checkChanges i (c1@(CLine xstart xend _) : c2@(CLine ystart _ _) : cs)
| xstart == ystart = [Conflict i c1 i c2]
| xend > ystart = [Conflict i c1 i c2]
| otherwise = checkChanges i (c2 : cs)
checkChanges _ (CLine _ _ _ : _) = []
--------------------------------------------------------------------------------
apply :: Edits -> [String] -> [String]
apply (Edits edits) = case conflicts (Edits edits) of
c : _ -> error $ "Language.Haskell.Stylish.Editor: " ++ prettyConflict c
_ -> go 1 (editsFor 1)
where
editsFor i = fromMaybe [] $ M.lookup i edits
go _ _ [] = []
go i [] (l : ls) = l : go (i + 1) (editsFor $ i + 1) ls
go i (CInsert ls' : cs) ls = ls' ++ go i cs ls
go i (CBlock n f : _cs) ls =
let (domain, ls') = splitAt n ls in
f domain ++ go (i + n) (editsFor $ i + n) ls'
go i (CLine xstart xend x : cs) (l : ls) =
let l' = take (xstart - 1) l ++ x ++ drop (xend - 1) l in
go i (adjust xstart xend x <$> cs) (l' : ls)
adjust _ _ _ (CInsert xs) = CInsert xs
adjust _ _ _ (CBlock n f) = CBlock n f
adjust xstart xend x (CLine ystart yend y)
| ystart >= xend =
let offset = length x - (xend - xstart) in
CLine (ystart + offset) (yend + offset) y
| otherwise = CLine ystart yend y
|
