module Data.Text.Region (
pt, start, lineStart, regionLength, till, linesSize, regionLines, emptyRegion, line,
regionSize, expandLines, atRegion, ApplyMap(..), updateMap, cutMap, insertMap,
cutRegion, insertRegion,
EditAction(..), cut, paste, overwrite, inverse, applyEdit, apply,
edit, edit_, push, run_, run, runGroup, undo, redo,
module Data.Text.Region.Types
) where
import Prelude hiding (id, (.))
import Prelude.Unicode
import Control.Arrow
import Control.Category
import Control.Lens
import Control.Monad.State
import Data.Text.Region.Types
pt ∷ Int → Int → Point
pt = Point
start ∷ Point
start = pt 0 0
lineStart ∷ Int → Point
lineStart l = pt l 0
regionLength ∷ Lens' Region Size
regionLength = lens fromr tor where
fromr (Region f t) = t .-. f
tor (Region f _) sz = Region f (f .+. sz)
till ∷ Point → Point → Region
l `till` r = Region (min l r) (max l r)
linesSize ∷ Int → Size
linesSize = pt 0
regionLines ∷ Lens' Region Int
regionLines = lens fromr tor where
fromr (Region f t) = succ $ (t ^. pointLine) (f ^. pointLine)
tor (Region f t) l = Region f (set pointLine (f ^. pointLine + l) t)
emptyRegion ∷ Region → Bool
emptyRegion r = r ^. regionFrom ≡ r ^. regionTo
line ∷ Int → Region
line l = lineStart l `till` lineStart (succ l)
regionSize ∷ Point → Size → Region
regionSize pt' sz = pt' `till` (pt' .+. sz)
expandLines ∷ Region → Region
expandLines (Region f t) = lineStart (f ^. pointLine) `till` lineStart (succ $ t ^. pointLine)
atRegion ∷ Editable s ⇒ Region → Lens' (Contents s) (Contents s)
atRegion r = lens fromc toc where
fromc cts = cts ^. splitted (r ^. regionTo) . _1 . splitted (r ^. regionFrom) . _2
toc cts cts' = (cts ^. splitted (r ^. regionFrom) . _1) `concatCts` cts' `concatCts` (cts ^. splitted (r ^. regionTo) . _2)
class ApplyMap a where
applyMap ∷ Map → a → a
instance ApplyMap () where
applyMap _ = id
instance ApplyMap a ⇒ ApplyMap [a] where
applyMap m = map (applyMap m)
instance ApplyMap Map where
applyMap = mappend
instance ApplyMap Region where
applyMap = view ∘ mapIso
instance ApplyMap Point where
applyMap m p = view regionFrom $ applyMap m (p `till` p)
instance ApplyMap (Replace s) where
applyMap m (Replace r w) = Replace (applyMap m r) w
instance ApplyMap (e s) ⇒ ApplyMap (Chain e s) where
applyMap m (Chain rs) = Chain (map (applyMap m) rs)
updateMap ∷ (EditAction e s, ApplyMap a) ⇒ e s → a → a
updateMap = applyMap ∘ actionMap
cutMap ∷ Region → Map
cutMap rgn = Map $ iso (cutRegion rgn) (insertRegion rgn)
insertMap ∷ Region → Map
insertMap = invert ∘ cutMap
cutRegion ∷ Region → Region → Region
cutRegion (Region is ie) (Region s e) = Region
(if is < s then (s .-. ie) .+. is else s)
(if is < e then (e .-. ie) .+. is else e)
insertRegion ∷ Region → Region → Region
insertRegion (Region is ie) (Region s e) = Region
(if is < s then (s .-. is) .+. ie else s)
(if is < e then (e .-. is) .+. ie else e)
class (Editable s, ApplyMap (e s)) ⇒ EditAction e s where
replace ∷ Region → Contents s → e s
actionMap ∷ e s → Map
perform ∷ e s → State (Contents s) (e s)
cut ∷ EditAction e s ⇒ Region → e s
cut r = replace r emptyContents
paste ∷ EditAction e s ⇒ Point → Contents s → e s
paste p = replace (p `till` p)
overwrite ∷ EditAction e s ⇒ Point → Contents s → e s
overwrite p c = replace (p `regionSize` measure c) c
inverse ∷ EditAction e s ⇒ Contents s → e s → e s
inverse cts act = evalState (perform act) cts
applyEdit ∷ EditAction e s ⇒ e s → Contents s → Contents s
applyEdit act = snd ∘ runState (perform act)
apply ∷ EditAction Replace s ⇒ Edit s → Contents s → Contents s
apply = applyEdit
instance Editable s ⇒ EditAction Replace s where
replace = Replace
actionMap (Replace r w) = insertMap ((r ^. regionFrom) `regionSize` measure w) `mappend` cutMap r
perform (Replace r w) = state $ \cts → (Replace ((r ^. regionFrom) `regionSize` measure w) (cts ^. atRegion r), atRegion r .~ w $ cts)
instance EditAction e s ⇒ EditAction (Chain e) s where
replace rgn txt = Chain [replace rgn txt]
actionMap (Chain []) = mempty
actionMap (Chain (r : rs)) = actionMap (applyMap (actionMap r) (Chain rs)) `mappend` actionMap r
perform (Chain rs) = (Chain ∘ reverse) <$> go mempty rs where
go _ [] = return []
go m (c : cs) = (:) <$> perform (applyMap m c) <*> go (actionMap (applyMap m c) `mappend` m) cs
edit ∷ EditAction Replace s ⇒ s → r → EditM s r a → (a, s)
edit txt rs act = second (view $ edited . from contents) $ runState (runEditM act) (editState txt rs)
edit_ ∷ EditAction Replace s ⇒ s → r → EditM s r a → s
edit_ txt rs = snd ∘ edit txt rs
push ∷ ActionIso (Edit s) → EditM s r ()
push e = modify (over (history . undoStack) (e :)) >> modify (set (history . redoStack) [])
run_ ∷ (EditAction Replace s, ApplyMap r) ⇒ Edit s → EditM s r (ActionIso (Edit s))
run_ e = do
cts ← gets (view edited)
let
(undo', cts') = runState (perform e) cts
modify (set edited cts')
modify (over regions (applyMap $ actionMap e))
return $ ActionIso e undo'
run ∷ (EditAction Replace s, ApplyMap r) ⇒ Edit s → EditM s r ()
run e = run_ e >>= push
runGroup ∷ (EditAction Replace s, ApplyMap r) ⇒ [Edit s] → EditM s r ()
runGroup = go mempty where
go _ [] = return ()
go m (e:es) = run e' >> go (applyMap m $ actionMap e') es where
e' = applyMap m e
undo ∷ (EditAction Replace s, ApplyMap r) ⇒ EditM s r ()
undo = do
us@(~(u:_)) ← gets (view $ history . undoStack)
unless (null us) $ do
_ ← run_ (u ^. actionBack)
modify (over (history . undoStack) tail)
modify (over (history . redoStack) (u :))
redo ∷ (EditAction Replace s, ApplyMap r) ⇒ EditM s r ()
redo = do
rs@(~(r:_)) ← gets (view $ history . redoStack)
unless (null rs) $ do
_ ← run_ (r ^. action)
modify (over (history . redoStack) tail)
modify (over (history . undoStack) (r :))