/src/Editing/Basics.hs

  1{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, PatternGuards, FlexibleInstances, TypeSynonymInstances, OverlappingInstances, ViewPatterns, FlexibleContexts, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
  2
  3module Editing.Basics (Pos(Pos, pos), positionIn, Anchor(..), Side(..), StickyRange, Range(..), TextEdit(..), tightRange, unanchor_range, selectRange, Offsettable(..), showEditOperand, showTextEdit, find_occs, wideRange, stickyRange, end, contained_in, merge_contiguous, makeMoveEdit, replaceRange, Adjuster(..), adjuster, rangeFromTo, frontPos, frontAnchor, fullRange) where
  4
  5import qualified Data.List as List
  6import qualified Data.Char as Char
  7import qualified Data.List.NonEmpty as NeList
  8import Control.Arrow ((&&&))
  9import Data.List.NonEmpty (NonEmpty((:|)))
 10import Data.Semigroup (Semigroup(..))
 11import Data.Monoid (Monoid(..))
 12import Data.Ord (comparing)
 13import Util ((.), NeList, neElim, E, nothingAsError, Apply(..), isIdChar, none, MyMonadError(..))
 14
 15import Prelude.Unicode
 16import Prelude hiding ((.))
 17
 18-- Offset
 19
 20class Offsettable a where offset :: Int → a → a
 21
 22instance (Offsettable a, Offsettable b) ⇒ Offsettable (a, b) where offset i (x, y) = (offset i x, offset i y)
 23instance Offsettable a ⇒ Offsettable [a] where offset = fmap . offset
 24instance Offsettable Int where offset = (+)
 25instance Offsettable (Pos a) where offset x (Pos p) = Pos (p + x)
 26instance Offsettable (Range a) where offset x (Range y z) = Range (offset x y) z
 27instance Offsettable (Anchor a) where offset x (Anchor y z) = Anchor y (offset x z)
 28instance Offsettable (StickyRange a) where offset = (.) . offset
 29instance Offsettable (TextEdit a) where
 30  offset i (RangeReplaceEdit r s) = RangeReplaceEdit (offset i r) s
 31  offset i (MoveEdit ba j r) = MoveEdit ba (offset i j) (offset i r)
 32  offset i (InsertEdit a s) = InsertEdit (offset i a) s
 33
 34-- Positions
 35
 36newtype Pos a = Pos {pos :: Int}
 37  deriving (Eq, Ord, Enum)
 38    -- The 'a' phantom parameter denotes the element type for the position. This prevents accidental mix-ups of different kinds of positions. The Pos constructor should be used as little as possible.
 39
 40positionIn :: [a] → Int → Pos a
 41positionIn _ = Pos
 42
 43frontPos :: Pos a
 44frontPos = Pos 0
 45
 46backPos :: [a] → Pos a
 47backPos l = Pos (length l)
 48
 49find_occs :: Eq a ⇒ [a] → [a] → [Pos a]
 50find_occs x = map (Pos . fst) . filter (List.isPrefixOf x . snd) . zip [0..] . List.tails
 51
 52splitAtPos :: Pos a → [a] → ([a], [a])
 53splitAtPos = splitAt . pos
 54
 55instance Show (Pos a) where show = show . pos
 56
 57-- Ranges
 58
 59data Range a = Range { start :: Pos a, size :: Int } deriving Eq
 60
 61rangeFromTo :: Pos a → Pos a → Range a
 62rangeFromTo from to = Range from (pos to - pos from)
 63
 64fullRange :: [a] → Range a
 65fullRange l = rangeFromTo frontPos (backPos l)
 66
 67end :: Range a → Pos a
 68end Range{..} = offset size start
 69
 70splitRange :: Range a → [a] → ([a], [a], [a])
 71splitRange Range{..} (splitAt (pos start) → (x, splitAt size → (y, z))) = (x, y, z)
 72
 73selectRange :: Range a → [a] → [a]
 74selectRange Range{..} = take size . drop (pos start)
 75
 76replaceRange :: Range a → [a] → [a] → [a]
 77replaceRange r replacement (splitRange r → (pre, _, post)) = pre ++ replacement ++ post
 78
 79contained_in :: Range a → Range a → Bool
 80contained_in x y = start y ≤ start x ∧ end x ≤ end y
 81
 82overlap :: Range a → Range a → Int
 83overlap (Range x s) (Range x' s') = max 0 $ min (pos x + s) (pos x' + s') - max (pos x) (pos x')
 84
 85touch :: Range a → Range a → Bool
 86touch x y = end x ≥ start y ∧ end y ≥ start x
 87
 88-- Sticky positions and ranges
 89
 90data Side = Before | After deriving (Eq, Ord)
 91
 92data Anchor a = Anchor { anchor_side :: Side, anchor_pos :: Pos a } deriving Eq
 93
 94instance Ord (Anchor a) where compare = comparing (anchor_pos &&& anchor_side)
 95
 96frontAnchor :: Anchor a
 97frontAnchor = Anchor Before frontPos
 98
 99type StickyRange a = Side → Anchor a
100
101stickyRange :: Anchor a → Anchor a → StickyRange a
102stickyRange x _ Before = x
103stickyRange _ x After = x
104
105unanchor_range :: StickyRange a → Range a
106unanchor_range r | Anchor _ x ← r Before, Anchor _ y ← r After = Range x (pos y - pos x)
107
108wideRange, tightRange :: Range a → StickyRange a
109wideRange r = stickyRange (Anchor Before $ start r) (Anchor After $ end r)
110tightRange r = stickyRange (Anchor After $ start r) (Anchor Before $ end r)
111
112two_contiguous :: StickyRange a → StickyRange a → Maybe (StickyRange a)
113two_contiguous x y
114  | touch (unanchor_range x) (unanchor_range y) = Just $ stickyRange (min (x Before) (y Before)) (max (x After) (y After))
115  | otherwise = Nothing
116
117findWithRest :: (a → Maybe b) → [a] → Maybe (b, [a])
118findWithRest p = work []
119  where
120    work _ [] = Nothing
121    work old (h:t)
122      | Just b ← p h = Just (b, old ++ t)
123      | otherwise = work (h:old) t
124
125contiguous :: NeList (StickyRange a) → Maybe (StickyRange a)
126contiguous l = case NeList.tail l of
127  [] → Just $ NeList.head l
128  t → findWithRest (two_contiguous $ NeList.head l) t >>= contiguous . uncurry (:|)
129
130merge_contiguous :: NeList (StickyRange a) → NeList (StickyRange a)
131merge_contiguous l = case neElim l of
132  (_, []) → l
133  (h, t@(x:xs)) → case findWithRest (two_contiguous h) t of
134    Nothing → NeList.cons h (merge_contiguous $ x :| xs)
135    Just (h', t') → merge_contiguous $ h' :| t'
136
137-- Edits
138
139data TextEdit a
140  = RangeReplaceEdit (Range a) [a]
141  | InsertEdit (Anchor a) [a]
142    -- We don't just use a RangeReplaceEdit with empty range for insertions, because it is not expressive enough. For instance, given "xy", insertions at the positions "after x" and "before y" would both designate position 1, but a prior "add z after x" edit should increment the latter position but not the former. The Anchor's Side expresses this difference.
143  | MoveEdit Side Int (Range a)
144    -- MoveEdit's Int is an offset. If it is a nonnegative number n, the insert position is n characters beyond the end of the source range. If it is a negative number -n, the insert position is n characters before the start of the source range. We use this instead of a normal Anchor because it ensures that silly "move into self"-edits are not representable. This constructor must not be used by anyone but the makeMoveEdit smart constructor, which detects such edits.
145  deriving Eq
146    -- The source ranges for move and replace are implicitly narrow-sticky (i.e. right-sticky begin & left-sticky end).
147
148makeMoveEdit :: MyMonadError String m ⇒ Anchor a → Range a → m (TextEdit a)
149makeMoveEdit (Anchor ba p) r
150  | p ≤ start r = return $ MoveEdit ba (pos p - pos (start r)) r
151  | end r ≤ p = return $ MoveEdit ba (pos p - pos (start r) - size r) r
152  | otherwise = throwError "Move destination lies in source range."
153
154instance Apply (TextEdit a) [a] [a] where
155  apply e s = case e of
156    RangeReplaceEdit r repl → replaceRange r repl s
157    InsertEdit (Anchor _ p) repl → let (x, y) = splitAtPos p s in x ++ repl ++ y
158    MoveEdit _ p r
159      | p < 0 → let (splitAtPos (offset p (start r)) → (x, y), z, w) = splitRange r s in x ++ z ++ y ++ w
160      | otherwise → let (x, y, splitAt p → (z, u)) = splitRange r s in x ++ z ++ y ++ u
161
162-- More regular edit representation used during adjustment below.
163
164data Replacement a = Replacement { repl_what :: Range a, repl_length :: Int }
165
166insertion :: Pos a → Int → Replacement a
167insertion p s = Replacement (Range p 0) s
168
169erasure :: Range a → Replacement a
170erasure = flip Replacement 0
171
172-- Adjustment
173
174adjust_with_insertion :: (Pos a, Int) → Anchor a → Anchor a
175  -- How does the insertion at the given place of a given number of things change an Anchor?
176adjust_with_insertion (p, s) a@Anchor{..}
177  | (anchor_side == After ∧ p == anchor_pos) ∨ p < anchor_pos = offset s a
178  | otherwise = a
179
180class Adjust a b where adjust :: a → b → Maybe b
181
182instance Adjust (TextEdit a) (Anchor a) where
183  adjust (InsertEdit (Anchor _ p) s) a@Anchor{..} = Just $ adjust_with_insertion (p, length s) a
184  adjust (RangeReplaceEdit r []) a
185    | a == Anchor After (start r) = Just $ Anchor Before (start r)
186    | a == Anchor Before (end r) = Just $ Anchor After (start r)
187  adjust (RangeReplaceEdit r repl) a@Anchor{anchor_pos}
188    | end r ≤ anchor_pos = Just $ offset (length repl - size r) a
189    | anchor_pos ≤ start r = Just a
190    | otherwise = Nothing
191  adjust (MoveEdit _ p r) a@Anchor{..}
192    | start r < anchor_pos, anchor_pos < end r = Just $ offset p a
193    | p < 0 = adjust_with_insertion (offset p (start r), size r) . adjust (RangeReplaceEdit r []) a
194    | otherwise = adjust (RangeReplaceEdit r []) (adjust_with_insertion (offset p (end r), size r) a)
195
196instance Adjust (Replacement a) (Replacement a) where
197  adjust (Replacement r l) re@(Replacement r' l')
198    | end r ≤ start r' = Just $ re{repl_what=offset (l - size r) r'} -- This reflects that we treat (begin r') as left-sticky.
199    | end r' ≤ start r = Just re -- This reflects that we treat (end r') as left-sticky.
200    | l == 0, l' == 0 = Just re{repl_what = if start r ≤ start r'
201        then Range (start r) (max 0 $ pos (end r') - pos (end r))
202        else Range (start r') (size r' - overlap r r')}
203    | otherwise = Nothing
204
205instance Adjust (TextEdit a) (Replacement a) where
206  adjust (RangeReplaceEdit r repl) r' = adjust (Replacement r (length repl)) r'
207  adjust (InsertEdit (Anchor _ p) s) r = adjust (insertion p (length s)) r
208  adjust (MoveEdit _ p r) r'
209    | repl_what r' `contained_in` r = Just $ r'{repl_what = offset p (repl_what r')}
210    | p < 0 = adjust (erasure r) r' >>= adjust (insertion (offset p (start r)) (size r))
211    | otherwise = adjust (insertion (offset p (end r)) (size r)) r' >>= adjust (erasure r)
212
213instance Adjust (TextEdit a) (TextEdit a) where
214  adjust e (InsertEdit a s) = flip InsertEdit s . adjust e a
215  adjust e (MoveEdit ba p r) = do
216    r' ← repl_what . adjust e (erasure r)
217    a ← adjust e $ Anchor ba $ offset p ((if p < 0 then start else end) r)
218    makeMoveEdit a r'
219  adjust e (RangeReplaceEdit r s) = flip RangeReplaceEdit s . repl_what . adjust e (Replacement r (length s))
220
221data Adjuster a = Adjuster
222  { editAdjuster :: TextEdit a → E (Maybe (TextEdit a))
223  , anchorAdjuster :: Anchor a → E (Anchor a) }
224
225instance Semigroup (Adjuster a) where
226  x <> y = Adjuster
227    { editAdjuster = (>>= maybe (return Nothing) (editAdjuster y)) . editAdjuster x
228    , anchorAdjuster = \a → anchorAdjuster x a >>= anchorAdjuster y }
229
230instance Monoid (Adjuster a) where
231  mempty = Adjuster { editAdjuster = return . return, anchorAdjuster = return }
232
233adjuster :: String → TextEdit Char → Adjuster Char
234adjuster s add = Adjuster
235  { editAdjuster = \e → if add == e then return Nothing else case adjust add e of
236      Just e' → return $ Just e'
237      _ → Left $ "Overlapping edits: " ++ showTextEdit s add ++ " and " ++ showTextEdit s e ++ "."
238  , anchorAdjuster = nothingAsError msg . adjust add }
239  where msg = "Could not adjust anchor in original snippet to anchor in well formed snippet."
240
241-- Display
242
243showEditOperand :: String → String
244showEditOperand " " = "space"
245showEditOperand "," = "comma"
246showEditOperand ":" = "colon"
247showEditOperand ";" = "semicolon"
248showEditOperand s
249  | all Char.isSpace s = "spaces"
250  | all isIdChar s = s
251  | none (`elem` " ,;") s, length s < 10 = s
252  | otherwise = '`' : s ++ "`"
253
254showTextEdit :: String → TextEdit Char → String
255showTextEdit _ (RangeReplaceEdit (Range (Pos 0) 0) r) = "prepend " ++ showEditOperand r
256showTextEdit s (RangeReplaceEdit (Range (Pos t) _) r) | t == length s = "append " ++ showEditOperand r
257showTextEdit _ (RangeReplaceEdit (Range _ 0) r) = "insert " ++ showEditOperand r
258showTextEdit _ (InsertEdit _ r) = "insert " ++ showEditOperand r
259showTextEdit s (RangeReplaceEdit r "") = "erase " ++ showEditOperand (selectRange r s)
260showTextEdit s (RangeReplaceEdit r s') = "replace " ++ showEditOperand (selectRange r s) ++ " with " ++ showEditOperand s'
261showTextEdit s (MoveEdit _ _ r) = "move " ++ showEditOperand (selectRange r s)