/src/Editing/Basics.hs
http://github.com/Eelis/geordi · Haskell · 261 lines · 187 code · 60 blank · 14 comment · 21 complexity · 924c5d5a94df3a271a7ef7d2b0e19194 MD5 · raw file
- {-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, PatternGuards, FlexibleInstances, TypeSynonymInstances, OverlappingInstances, ViewPatterns, FlexibleContexts, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-}
- 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
- import qualified Data.List as List
- import qualified Data.Char as Char
- import qualified Data.List.NonEmpty as NeList
- import Control.Arrow ((&&&))
- import Data.List.NonEmpty (NonEmpty((:|)))
- import Data.Semigroup (Semigroup(..))
- import Data.Monoid (Monoid(..))
- import Data.Ord (comparing)
- import Util ((.), NeList, neElim, E, nothingAsError, Apply(..), isIdChar, none, MyMonadError(..))
- import Prelude.Unicode
- import Prelude hiding ((.))
- -- Offset
- class Offsettable a where offset :: Int → a → a
- instance (Offsettable a, Offsettable b) ⇒ Offsettable (a, b) where offset i (x, y) = (offset i x, offset i y)
- instance Offsettable a ⇒ Offsettable [a] where offset = fmap . offset
- instance Offsettable Int where offset = (+)
- instance Offsettable (Pos a) where offset x (Pos p) = Pos (p + x)
- instance Offsettable (Range a) where offset x (Range y z) = Range (offset x y) z
- instance Offsettable (Anchor a) where offset x (Anchor y z) = Anchor y (offset x z)
- instance Offsettable (StickyRange a) where offset = (.) . offset
- instance Offsettable (TextEdit a) where
- offset i (RangeReplaceEdit r s) = RangeReplaceEdit (offset i r) s
- offset i (MoveEdit ba j r) = MoveEdit ba (offset i j) (offset i r)
- offset i (InsertEdit a s) = InsertEdit (offset i a) s
- -- Positions
- newtype Pos a = Pos {pos :: Int}
- deriving (Eq, Ord, Enum)
- -- 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.
- positionIn :: [a] → Int → Pos a
- positionIn _ = Pos
- frontPos :: Pos a
- frontPos = Pos 0
- backPos :: [a] → Pos a
- backPos l = Pos (length l)
- find_occs :: Eq a ⇒ [a] → [a] → [Pos a]
- find_occs x = map (Pos . fst) . filter (List.isPrefixOf x . snd) . zip [0..] . List.tails
- splitAtPos :: Pos a → [a] → ([a], [a])
- splitAtPos = splitAt . pos
- instance Show (Pos a) where show = show . pos
- -- Ranges
- data Range a = Range { start :: Pos a, size :: Int } deriving Eq
- rangeFromTo :: Pos a → Pos a → Range a
- rangeFromTo from to = Range from (pos to - pos from)
- fullRange :: [a] → Range a
- fullRange l = rangeFromTo frontPos (backPos l)
- end :: Range a → Pos a
- end Range{..} = offset size start
- splitRange :: Range a → [a] → ([a], [a], [a])
- splitRange Range{..} (splitAt (pos start) → (x, splitAt size → (y, z))) = (x, y, z)
- selectRange :: Range a → [a] → [a]
- selectRange Range{..} = take size . drop (pos start)
- replaceRange :: Range a → [a] → [a] → [a]
- replaceRange r replacement (splitRange r → (pre, _, post)) = pre ++ replacement ++ post
- contained_in :: Range a → Range a → Bool
- contained_in x y = start y ≤ start x ∧ end x ≤ end y
- overlap :: Range a → Range a → Int
- overlap (Range x s) (Range x' s') = max 0 $ min (pos x + s) (pos x' + s') - max (pos x) (pos x')
- touch :: Range a → Range a → Bool
- touch x y = end x ≥ start y ∧ end y ≥ start x
- -- Sticky positions and ranges
- data Side = Before | After deriving (Eq, Ord)
- data Anchor a = Anchor { anchor_side :: Side, anchor_pos :: Pos a } deriving Eq
- instance Ord (Anchor a) where compare = comparing (anchor_pos &&& anchor_side)
- frontAnchor :: Anchor a
- frontAnchor = Anchor Before frontPos
- type StickyRange a = Side → Anchor a
- stickyRange :: Anchor a → Anchor a → StickyRange a
- stickyRange x _ Before = x
- stickyRange _ x After = x
- unanchor_range :: StickyRange a → Range a
- unanchor_range r | Anchor _ x ← r Before, Anchor _ y ← r After = Range x (pos y - pos x)
- wideRange, tightRange :: Range a → StickyRange a
- wideRange r = stickyRange (Anchor Before $ start r) (Anchor After $ end r)
- tightRange r = stickyRange (Anchor After $ start r) (Anchor Before $ end r)
- two_contiguous :: StickyRange a → StickyRange a → Maybe (StickyRange a)
- two_contiguous x y
- | touch (unanchor_range x) (unanchor_range y) = Just $ stickyRange (min (x Before) (y Before)) (max (x After) (y After))
- | otherwise = Nothing
- findWithRest :: (a → Maybe b) → [a] → Maybe (b, [a])
- findWithRest p = work []
- where
- work _ [] = Nothing
- work old (h:t)
- | Just b ← p h = Just (b, old ++ t)
- | otherwise = work (h:old) t
- contiguous :: NeList (StickyRange a) → Maybe (StickyRange a)
- contiguous l = case NeList.tail l of
- [] → Just $ NeList.head l
- t → findWithRest (two_contiguous $ NeList.head l) t >>= contiguous . uncurry (:|)
- merge_contiguous :: NeList (StickyRange a) → NeList (StickyRange a)
- merge_contiguous l = case neElim l of
- (_, []) → l
- (h, t@(x:xs)) → case findWithRest (two_contiguous h) t of
- Nothing → NeList.cons h (merge_contiguous $ x :| xs)
- Just (h', t') → merge_contiguous $ h' :| t'
- -- Edits
- data TextEdit a
- = RangeReplaceEdit (Range a) [a]
- | InsertEdit (Anchor a) [a]
- -- 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.
- | MoveEdit Side Int (Range a)
- -- 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.
- deriving Eq
- -- The source ranges for move and replace are implicitly narrow-sticky (i.e. right-sticky begin & left-sticky end).
- makeMoveEdit :: MyMonadError String m ⇒ Anchor a → Range a → m (TextEdit a)
- makeMoveEdit (Anchor ba p) r
- | p ≤ start r = return $ MoveEdit ba (pos p - pos (start r)) r
- | end r ≤ p = return $ MoveEdit ba (pos p - pos (start r) - size r) r
- | otherwise = throwError "Move destination lies in source range."
- instance Apply (TextEdit a) [a] [a] where
- apply e s = case e of
- RangeReplaceEdit r repl → replaceRange r repl s
- InsertEdit (Anchor _ p) repl → let (x, y) = splitAtPos p s in x ++ repl ++ y
- MoveEdit _ p r
- | p < 0 → let (splitAtPos (offset p (start r)) → (x, y), z, w) = splitRange r s in x ++ z ++ y ++ w
- | otherwise → let (x, y, splitAt p → (z, u)) = splitRange r s in x ++ z ++ y ++ u
- -- More regular edit representation used during adjustment below.
- data Replacement a = Replacement { repl_what :: Range a, repl_length :: Int }
- insertion :: Pos a → Int → Replacement a
- insertion p s = Replacement (Range p 0) s
- erasure :: Range a → Replacement a
- erasure = flip Replacement 0
- -- Adjustment
- adjust_with_insertion :: (Pos a, Int) → Anchor a → Anchor a
- -- How does the insertion at the given place of a given number of things change an Anchor?
- adjust_with_insertion (p, s) a@Anchor{..}
- | (anchor_side == After ∧ p == anchor_pos) ∨ p < anchor_pos = offset s a
- | otherwise = a
- class Adjust a b where adjust :: a → b → Maybe b
- instance Adjust (TextEdit a) (Anchor a) where
- adjust (InsertEdit (Anchor _ p) s) a@Anchor{..} = Just $ adjust_with_insertion (p, length s) a
- adjust (RangeReplaceEdit r []) a
- | a == Anchor After (start r) = Just $ Anchor Before (start r)
- | a == Anchor Before (end r) = Just $ Anchor After (start r)
- adjust (RangeReplaceEdit r repl) a@Anchor{anchor_pos}
- | end r ≤ anchor_pos = Just $ offset (length repl - size r) a
- | anchor_pos ≤ start r = Just a
- | otherwise = Nothing
- adjust (MoveEdit _ p r) a@Anchor{..}
- | start r < anchor_pos, anchor_pos < end r = Just $ offset p a
- | p < 0 = adjust_with_insertion (offset p (start r), size r) . adjust (RangeReplaceEdit r []) a
- | otherwise = adjust (RangeReplaceEdit r []) (adjust_with_insertion (offset p (end r), size r) a)
- instance Adjust (Replacement a) (Replacement a) where
- adjust (Replacement r l) re@(Replacement r' l')
- | end r ≤ start r' = Just $ re{repl_what=offset (l - size r) r'} -- This reflects that we treat (begin r') as left-sticky.
- | end r' ≤ start r = Just re -- This reflects that we treat (end r') as left-sticky.
- | l == 0, l' == 0 = Just re{repl_what = if start r ≤ start r'
- then Range (start r) (max 0 $ pos (end r') - pos (end r))
- else Range (start r') (size r' - overlap r r')}
- | otherwise = Nothing
- instance Adjust (TextEdit a) (Replacement a) where
- adjust (RangeReplaceEdit r repl) r' = adjust (Replacement r (length repl)) r'
- adjust (InsertEdit (Anchor _ p) s) r = adjust (insertion p (length s)) r
- adjust (MoveEdit _ p r) r'
- | repl_what r' `contained_in` r = Just $ r'{repl_what = offset p (repl_what r')}
- | p < 0 = adjust (erasure r) r' >>= adjust (insertion (offset p (start r)) (size r))
- | otherwise = adjust (insertion (offset p (end r)) (size r)) r' >>= adjust (erasure r)
- instance Adjust (TextEdit a) (TextEdit a) where
- adjust e (InsertEdit a s) = flip InsertEdit s . adjust e a
- adjust e (MoveEdit ba p r) = do
- r' ← repl_what . adjust e (erasure r)
- a ← adjust e $ Anchor ba $ offset p ((if p < 0 then start else end) r)
- makeMoveEdit a r'
- adjust e (RangeReplaceEdit r s) = flip RangeReplaceEdit s . repl_what . adjust e (Replacement r (length s))
- data Adjuster a = Adjuster
- { editAdjuster :: TextEdit a → E (Maybe (TextEdit a))
- , anchorAdjuster :: Anchor a → E (Anchor a) }
- instance Semigroup (Adjuster a) where
- x <> y = Adjuster
- { editAdjuster = (>>= maybe (return Nothing) (editAdjuster y)) . editAdjuster x
- , anchorAdjuster = \a → anchorAdjuster x a >>= anchorAdjuster y }
- instance Monoid (Adjuster a) where
- mempty = Adjuster { editAdjuster = return . return, anchorAdjuster = return }
- adjuster :: String → TextEdit Char → Adjuster Char
- adjuster s add = Adjuster
- { editAdjuster = \e → if add == e then return Nothing else case adjust add e of
- Just e' → return $ Just e'
- _ → Left $ "Overlapping edits: " ++ showTextEdit s add ++ " and " ++ showTextEdit s e ++ "."
- , anchorAdjuster = nothingAsError msg . adjust add }
- where msg = "Could not adjust anchor in original snippet to anchor in well formed snippet."
- -- Display
- showEditOperand :: String → String
- showEditOperand " " = "space"
- showEditOperand "," = "comma"
- showEditOperand ":" = "colon"
- showEditOperand ";" = "semicolon"
- showEditOperand s
- | all Char.isSpace s = "spaces"
- | all isIdChar s = s
- | none (`elem` " ,;") s, length s < 10 = s
- | otherwise = '`' : s ++ "`"
- showTextEdit :: String → TextEdit Char → String
- showTextEdit _ (RangeReplaceEdit (Range (Pos 0) 0) r) = "prepend " ++ showEditOperand r
- showTextEdit s (RangeReplaceEdit (Range (Pos t) _) r) | t == length s = "append " ++ showEditOperand r
- showTextEdit _ (RangeReplaceEdit (Range _ 0) r) = "insert " ++ showEditOperand r
- showTextEdit _ (InsertEdit _ r) = "insert " ++ showEditOperand r
- showTextEdit s (RangeReplaceEdit r "") = "erase " ++ showEditOperand (selectRange r s)
- showTextEdit s (RangeReplaceEdit r s') = "replace " ++ showEditOperand (selectRange r s) ++ " with " ++ showEditOperand s'
- showTextEdit s (MoveEdit _ _ r) = "move " ++ showEditOperand (selectRange r s)