/src/Editing/Basics.hs

http://github.com/Eelis/geordi · Haskell · 261 lines · 187 code · 60 blank · 14 comment · 21 complexity · 924c5d5a94df3a271a7ef7d2b0e19194 MD5 · raw file

  1. {-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, PatternGuards, FlexibleInstances, TypeSynonymInstances, OverlappingInstances, ViewPatterns, FlexibleContexts, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
  2. module 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
  3. import qualified Data.List as List
  4. import qualified Data.Char as Char
  5. import qualified Data.List.NonEmpty as NeList
  6. import Control.Arrow ((&&&))
  7. import Data.List.NonEmpty (NonEmpty((:|)))
  8. import Data.Semigroup (Semigroup(..))
  9. import Data.Monoid (Monoid(..))
  10. import Data.Ord (comparing)
  11. import Util ((.), NeList, neElim, E, nothingAsError, Apply(..), isIdChar, none, MyMonadError(..))
  12. import Prelude.Unicode
  13. import Prelude hiding ((.))
  14. -- Offset
  15. class Offsettable a where offset :: Int a a
  16. instance (Offsettable a, Offsettable b) Offsettable (a, b) where offset i (x, y) = (offset i x, offset i y)
  17. instance Offsettable a Offsettable [a] where offset = fmap . offset
  18. instance Offsettable Int where offset = (+)
  19. instance Offsettable (Pos a) where offset x (Pos p) = Pos (p + x)
  20. instance Offsettable (Range a) where offset x (Range y z) = Range (offset x y) z
  21. instance Offsettable (Anchor a) where offset x (Anchor y z) = Anchor y (offset x z)
  22. instance Offsettable (StickyRange a) where offset = (.) . offset
  23. instance Offsettable (TextEdit a) where
  24. offset i (RangeReplaceEdit r s) = RangeReplaceEdit (offset i r) s
  25. offset i (MoveEdit ba j r) = MoveEdit ba (offset i j) (offset i r)
  26. offset i (InsertEdit a s) = InsertEdit (offset i a) s
  27. -- Positions
  28. newtype Pos a = Pos {pos :: Int}
  29. deriving (Eq, Ord, Enum)
  30. -- 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.
  31. positionIn :: [a] Int Pos a
  32. positionIn _ = Pos
  33. frontPos :: Pos a
  34. frontPos = Pos 0
  35. backPos :: [a] Pos a
  36. backPos l = Pos (length l)
  37. find_occs :: Eq a [a] [a] [Pos a]
  38. find_occs x = map (Pos . fst) . filter (List.isPrefixOf x . snd) . zip [0..] . List.tails
  39. splitAtPos :: Pos a [a] ([a], [a])
  40. splitAtPos = splitAt . pos
  41. instance Show (Pos a) where show = show . pos
  42. -- Ranges
  43. data Range a = Range { start :: Pos a, size :: Int } deriving Eq
  44. rangeFromTo :: Pos a Pos a Range a
  45. rangeFromTo from to = Range from (pos to - pos from)
  46. fullRange :: [a] Range a
  47. fullRange l = rangeFromTo frontPos (backPos l)
  48. end :: Range a Pos a
  49. end Range{..} = offset size start
  50. splitRange :: Range a [a] ([a], [a], [a])
  51. splitRange Range{..} (splitAt (pos start) (x, splitAt size (y, z))) = (x, y, z)
  52. selectRange :: Range a [a] [a]
  53. selectRange Range{..} = take size . drop (pos start)
  54. replaceRange :: Range a [a] [a] [a]
  55. replaceRange r replacement (splitRange r (pre, _, post)) = pre ++ replacement ++ post
  56. contained_in :: Range a Range a Bool
  57. contained_in x y = start y start x end x end y
  58. overlap :: Range a Range a Int
  59. overlap (Range x s) (Range x' s') = max 0 $ min (pos x + s) (pos x' + s') - max (pos x) (pos x')
  60. touch :: Range a Range a Bool
  61. touch x y = end x start y end y start x
  62. -- Sticky positions and ranges
  63. data Side = Before | After deriving (Eq, Ord)
  64. data Anchor a = Anchor { anchor_side :: Side, anchor_pos :: Pos a } deriving Eq
  65. instance Ord (Anchor a) where compare = comparing (anchor_pos &&& anchor_side)
  66. frontAnchor :: Anchor a
  67. frontAnchor = Anchor Before frontPos
  68. type StickyRange a = Side Anchor a
  69. stickyRange :: Anchor a Anchor a StickyRange a
  70. stickyRange x _ Before = x
  71. stickyRange _ x After = x
  72. unanchor_range :: StickyRange a Range a
  73. unanchor_range r | Anchor _ x r Before, Anchor _ y r After = Range x (pos y - pos x)
  74. wideRange, tightRange :: Range a StickyRange a
  75. wideRange r = stickyRange (Anchor Before $ start r) (Anchor After $ end r)
  76. tightRange r = stickyRange (Anchor After $ start r) (Anchor Before $ end r)
  77. two_contiguous :: StickyRange a StickyRange a Maybe (StickyRange a)
  78. two_contiguous x y
  79. | touch (unanchor_range x) (unanchor_range y) = Just $ stickyRange (min (x Before) (y Before)) (max (x After) (y After))
  80. | otherwise = Nothing
  81. findWithRest :: (a Maybe b) [a] Maybe (b, [a])
  82. findWithRest p = work []
  83. where
  84. work _ [] = Nothing
  85. work old (h:t)
  86. | Just b p h = Just (b, old ++ t)
  87. | otherwise = work (h:old) t
  88. contiguous :: NeList (StickyRange a) Maybe (StickyRange a)
  89. contiguous l = case NeList.tail l of
  90. [] Just $ NeList.head l
  91. t findWithRest (two_contiguous $ NeList.head l) t >>= contiguous . uncurry (:|)
  92. merge_contiguous :: NeList (StickyRange a) NeList (StickyRange a)
  93. merge_contiguous l = case neElim l of
  94. (_, []) l
  95. (h, t@(x:xs)) case findWithRest (two_contiguous h) t of
  96. Nothing NeList.cons h (merge_contiguous $ x :| xs)
  97. Just (h', t') merge_contiguous $ h' :| t'
  98. -- Edits
  99. data TextEdit a
  100. = RangeReplaceEdit (Range a) [a]
  101. | InsertEdit (Anchor a) [a]
  102. -- 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.
  103. | MoveEdit Side Int (Range a)
  104. -- 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.
  105. deriving Eq
  106. -- The source ranges for move and replace are implicitly narrow-sticky (i.e. right-sticky begin & left-sticky end).
  107. makeMoveEdit :: MyMonadError String m Anchor a Range a m (TextEdit a)
  108. makeMoveEdit (Anchor ba p) r
  109. | p start r = return $ MoveEdit ba (pos p - pos (start r)) r
  110. | end r p = return $ MoveEdit ba (pos p - pos (start r) - size r) r
  111. | otherwise = throwError "Move destination lies in source range."
  112. instance Apply (TextEdit a) [a] [a] where
  113. apply e s = case e of
  114. RangeReplaceEdit r repl replaceRange r repl s
  115. InsertEdit (Anchor _ p) repl let (x, y) = splitAtPos p s in x ++ repl ++ y
  116. MoveEdit _ p r
  117. | p < 0 let (splitAtPos (offset p (start r)) (x, y), z, w) = splitRange r s in x ++ z ++ y ++ w
  118. | otherwise let (x, y, splitAt p (z, u)) = splitRange r s in x ++ z ++ y ++ u
  119. -- More regular edit representation used during adjustment below.
  120. data Replacement a = Replacement { repl_what :: Range a, repl_length :: Int }
  121. insertion :: Pos a Int Replacement a
  122. insertion p s = Replacement (Range p 0) s
  123. erasure :: Range a Replacement a
  124. erasure = flip Replacement 0
  125. -- Adjustment
  126. adjust_with_insertion :: (Pos a, Int) Anchor a Anchor a
  127. -- How does the insertion at the given place of a given number of things change an Anchor?
  128. adjust_with_insertion (p, s) a@Anchor{..}
  129. | (anchor_side == After p == anchor_pos) p < anchor_pos = offset s a
  130. | otherwise = a
  131. class Adjust a b where adjust :: a b Maybe b
  132. instance Adjust (TextEdit a) (Anchor a) where
  133. adjust (InsertEdit (Anchor _ p) s) a@Anchor{..} = Just $ adjust_with_insertion (p, length s) a
  134. adjust (RangeReplaceEdit r []) a
  135. | a == Anchor After (start r) = Just $ Anchor Before (start r)
  136. | a == Anchor Before (end r) = Just $ Anchor After (start r)
  137. adjust (RangeReplaceEdit r repl) a@Anchor{anchor_pos}
  138. | end r anchor_pos = Just $ offset (length repl - size r) a
  139. | anchor_pos start r = Just a
  140. | otherwise = Nothing
  141. adjust (MoveEdit _ p r) a@Anchor{..}
  142. | start r < anchor_pos, anchor_pos < end r = Just $ offset p a
  143. | p < 0 = adjust_with_insertion (offset p (start r), size r) . adjust (RangeReplaceEdit r []) a
  144. | otherwise = adjust (RangeReplaceEdit r []) (adjust_with_insertion (offset p (end r), size r) a)
  145. instance Adjust (Replacement a) (Replacement a) where
  146. adjust (Replacement r l) re@(Replacement r' l')
  147. | end r start r' = Just $ re{repl_what=offset (l - size r) r'} -- This reflects that we treat (begin r') as left-sticky.
  148. | end r' ≤ start r = Just re -- This reflects that we treat (end r') as left-sticky.
  149. | l == 0, l' == 0 = Just re{repl_what = if start r ≤ start r'
  150. then Range (start r) (max 0 $ pos (end r') - pos (end r))
  151. else Range (start r') (size r' - overlap r r')}
  152. | otherwise = Nothing
  153. instance Adjust (TextEdit a) (Replacement a) where
  154. adjust (RangeReplaceEdit r repl) r' = adjust (Replacement r (length repl)) r'
  155. adjust (InsertEdit (Anchor _ p) s) r = adjust (insertion p (length s)) r
  156. adjust (MoveEdit _ p r) r'
  157. | repl_what r' `contained_in` r = Just $ r'{repl_what = offset p (repl_what r')}
  158. | p < 0 = adjust (erasure r) r' >>= adjust (insertion (offset p (start r)) (size r))
  159. | otherwise = adjust (insertion (offset p (end r)) (size r)) r' >>= adjust (erasure r)
  160. instance Adjust (TextEdit a) (TextEdit a) where
  161. adjust e (InsertEdit a s) = flip InsertEdit s . adjust e a
  162. adjust e (MoveEdit ba p r) = do
  163. r' ← repl_what . adjust e (erasure r)
  164. a adjust e $ Anchor ba $ offset p ((if p < 0 then start else end) r)
  165. makeMoveEdit a r'
  166. adjust e (RangeReplaceEdit r s) = flip RangeReplaceEdit s . repl_what . adjust e (Replacement r (length s))
  167. data Adjuster a = Adjuster
  168. { editAdjuster :: TextEdit a E (Maybe (TextEdit a))
  169. , anchorAdjuster :: Anchor a E (Anchor a) }
  170. instance Semigroup (Adjuster a) where
  171. x <> y = Adjuster
  172. { editAdjuster = (>>= maybe (return Nothing) (editAdjuster y)) . editAdjuster x
  173. , anchorAdjuster = \a anchorAdjuster x a >>= anchorAdjuster y }
  174. instance Monoid (Adjuster a) where
  175. mempty = Adjuster { editAdjuster = return . return, anchorAdjuster = return }
  176. adjuster :: String TextEdit Char Adjuster Char
  177. adjuster s add = Adjuster
  178. { editAdjuster = \e if add == e then return Nothing else case adjust add e of
  179. Just e' → return $ Just e'
  180. _ Left $ "Overlapping edits: " ++ showTextEdit s add ++ " and " ++ showTextEdit s e ++ "."
  181. , anchorAdjuster = nothingAsError msg . adjust add }
  182. where msg = "Could not adjust anchor in original snippet to anchor in well formed snippet."
  183. -- Display
  184. showEditOperand :: String String
  185. showEditOperand " " = "space"
  186. showEditOperand "," = "comma"
  187. showEditOperand ":" = "colon"
  188. showEditOperand ";" = "semicolon"
  189. showEditOperand s
  190. | all Char.isSpace s = "spaces"
  191. | all isIdChar s = s
  192. | none (`elem` " ,;") s, length s < 10 = s
  193. | otherwise = '`' : s ++ "`"
  194. showTextEdit :: String TextEdit Char String
  195. showTextEdit _ (RangeReplaceEdit (Range (Pos 0) 0) r) = "prepend " ++ showEditOperand r
  196. showTextEdit s (RangeReplaceEdit (Range (Pos t) _) r) | t == length s = "append " ++ showEditOperand r
  197. showTextEdit _ (RangeReplaceEdit (Range _ 0) r) = "insert " ++ showEditOperand r
  198. showTextEdit _ (InsertEdit _ r) = "insert " ++ showEditOperand r
  199. showTextEdit s (RangeReplaceEdit r "") = "erase " ++ showEditOperand (selectRange r s)
  200. showTextEdit s (RangeReplaceEdit r s') = "replace " ++ showEditOperand (selectRange r s) ++ " with " ++ showEditOperand s'
  201. showTextEdit s (MoveEdit _ _ r) = "move " ++ showEditOperand (selectRange r s)