text-region (empty) → 0.1.0.0

raw patch · 5 files changed

+570/−0 lines, 5 filesdep +aesondep +basedep +base-unicode-symbolssetup-changed

Dependencies added: aeson, base, base-unicode-symbols, bytestring, containers, groups, hspec, lens, mtl, text, text-region

Files

Setup.hs +2/−0
src/Data/Text/Region.hs +221/−0
src/Data/Text/Region/Types.hs +253/−0
tests/Test.hs +48/−0
text-region.cabal +46/−0

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/Data/Text/Region.hs view

@@ -0,0 +1,221 @@+{-# LANGUAGE RankNTypes, TupleSections, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
+
+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
+
+-- | Make 'Point' from line and column
+pt ∷ Int → Int → Point
+pt = Point
+
+-- | 'Point' at the beginning
+start ∷ Point
+start = pt 0 0
+
+-- | 'Point' at the beginning of line
+lineStart ∷ Int → Point
+lineStart l = pt l 0
+
+-- | Regions length
+regionLength ∷ Lens' Region Size
+regionLength = lens fromr tor where
+	fromr (Region f t) = t .-. f
+	tor (Region f _) sz = Region f (f .+. sz)
+
+-- | Region from one 'Point' to another
+till ∷ Point → Point → Region
+l `till` r = Region (min l r) (max l r)
+
+-- | Distance of @n@ lines
+linesSize ∷ Int → Size
+linesSize = pt 0
+
+-- 'Region' height in lines, any 'Region' at least of line height 1
+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)
+
+-- | Is 'Region' empty
+emptyRegion ∷ Region → Bool
+emptyRegion r = r ^. regionFrom ≡ r ^. regionTo
+
+-- | n'th line region, starts at the beginning of line and ends on the next line
+line ∷ Int → Region
+line l = lineStart l `till` lineStart (succ l)
+
+-- | Make 'Region' by start position and 'Size'
+regionSize ∷ Point → Size → Region
+regionSize pt' sz = pt' `till` (pt' .+. sz)
+
+-- | Expand 'Region' to contain full lines
+expandLines ∷ Region → Region
+expandLines (Region f t) = lineStart (f ^. pointLine) `till` lineStart (succ $ t ^. pointLine)
+
+-- | Get contents at 'Region'
+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)
+
+-- | Update 'Region' after some action
+updateMap ∷ (EditAction e s, ApplyMap a) ⇒ e s → a → a
+updateMap = applyMap ∘ actionMap
+
+-- | Cut 'Region' mapping
+cutMap ∷ Region → Map
+cutMap rgn = Map $ iso (cutRegion rgn) (insertRegion rgn)
+
+-- | Opposite to 'cutMap'
+insertMap ∷ Region → Map
+insertMap = invert ∘ cutMap
+
+-- | Update second 'Region' position as if it was data cutted at first 'Region'
+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)
+
+-- | Update second region position as if it was data inserted at first region
+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
+	-- | Make replace action over 'Region' and 'Contents'
+	replace ∷ Region → Contents s → e s
+	-- | Make 'Map' from action
+	actionMap ∷ e s → Map
+	-- | Perform action, modifying 'Contents' and returning inverse (undo) action
+	perform ∷ e s → State (Contents s) (e s)
+
+-- | Cuts region
+cut ∷ EditAction e s ⇒ Region → e s
+cut r = replace r emptyContents
+
+-- | Pastes 'Contents' at some 'Point'
+paste ∷ EditAction e s ⇒ Point → Contents s → e s
+paste p = replace (p `till` p)
+
+-- | Overwrites 'Contents' at some 'Point'
+overwrite ∷ EditAction e s ⇒ Point → Contents s → e s
+overwrite p c = replace (p `regionSize` measure c) c
+
+-- | Get undo-action
+inverse ∷ EditAction e s ⇒ Contents s → e s → e s
+inverse cts act = evalState (perform act) cts
+
+-- | Apply action to 'Contents'
+applyEdit ∷ EditAction e s ⇒ e s → Contents s → Contents s
+applyEdit act = snd ∘ runState (perform act)
+
+-- | 'applyEdit' for 'Edit'
+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
+
+-- | Run edit monad and return result with updated contents
+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)
+
+-- | Run edit monad and return updated contents
+edit_ ∷ EditAction Replace s ⇒ s → r → EditM s r a → s
+edit_ txt rs = snd ∘ edit txt rs
+
+-- | Push action into history, also drops redo stack
+push ∷ EditAction Replace s ⇒ ActionIso (Edit s) → EditM s r ()
+push e = modify (over (history . undoStack) (e :)) >> modify (set (history . redoStack) [])
+
+-- | Run edit action and returns corresponding redo-undo action
+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 edit action with updating undo/redo stack
+run ∷ (EditAction Replace s, ApplyMap r) ⇒ Edit s → EditM s r ()
+run e = run_ e >>= push
+
+-- | Run edit actions, updating undo/redo stack for each of them, but act like they was applied simultaneously
+-- For example, cutting 1-st and then 3-rd letter:
+-- @run (cut first) >> run (cut third) -- 1234 -> 234 -> 23@
+-- @runGroup [cut first, cut third] -- 1234 -> 234 -> 24@
+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 last action
+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 :))

+ src/Data/Text/Region/Types.hs view

@@ -0,0 +1,253 @@+{-# LANGUAGE TemplateHaskell, RankNTypes, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts #-}
+
+module Data.Text.Region.Types (
+	Point(..), pointLine, pointColumn, Size, (.-.), (.+.),
+	Region(..), regionFrom, regionTo,
+	Map(..),
+	Contents, emptyContents,
+	concatCts, splitCts, splitted,
+	Editable(..), contents, by, measure,
+	Replace(..), replaceRegion, replaceWith, Chain(..), chain, Edit,
+	ActionIso(..), action, actionBack,
+	ActionStack(..), undoStack, redoStack, emptyStack,
+	EditState(..), editState, history, edited, regions,
+	EditM(..),
+
+	module Data.Group
+	) where
+
+import Prelude hiding (id, (.))
+import Prelude.Unicode
+
+import Control.Category
+import Control.Lens hiding ((.=))
+import Control.Monad.State
+import Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as L
+import Data.Group
+import Data.List
+import Data.Text (Text)
+import qualified Data.Text as T
+
+-- | Point at text: zero-based line and column
+data Point = Point {
+	_pointLine ∷ Int,
+	_pointColumn ∷ Int }
+		deriving (Eq, Ord, Read, Show)
+
+makeLenses ''Point
+
+instance ToJSON Point where
+	toJSON (Point l c) = object ["line" .= l, "column" .= c]
+
+instance FromJSON Point where
+	parseJSON = withObject "point" $ \v → Point <$> v .: "line" <*> v .: "column"
+
+instance Monoid Point where
+	mempty = Point 0 0
+	Point l c `mappend` Point bl bc
+		| l ≡ 0 = Point bl (c + bc)
+		| otherwise = Point (l + bl) c
+
+instance Group Point where
+	invert (Point l c) = Point (negate l) (negate c)
+
+-- | Distance between 'Point's is measured in lines and columns.
+-- And it is defined, that distance between point at l:c and point (l + 1):0 is one line no matter c is
+-- because we need to go to new line to reach destination point
+-- Columns are taken into account only if points are on the same line
+type Size = Point
+
+-- | @pt .-. base@ is distance from @base@ to @pt@
+-- Distance can't be less then zero lines and columns
+(.-.) ∷ Point → Point → Point
+Point l c .-. Point bl bc
+	| bl < l = Point (l - bl) c
+	| bl ≡ l = Point 0 (max 0 (c - bc))
+	| otherwise = Point 0 0
+
+-- | Opposite to ".-.", @(pt .-. base) .+. base = pt@
+(.+.) ∷ Point → Point → Point
+(Point l c) .+. (Point bl bc)
+	| l ≡ 0 = Point bl (c + bc)
+	| otherwise = Point (l + bl) c
+
+-- | Region from 'Point' to another
+data Region = Region {
+	_regionFrom ∷ Point,
+	_regionTo ∷ Point }
+		deriving (Eq, Ord, Read, Show)
+
+makeLenses ''Region
+
+instance ToJSON Region where
+	toJSON (Region f t) = object ["from" .= f, "to" .= t]
+
+instance FromJSON Region where
+	parseJSON = withObject "region" $ \v -> Region <$> v .: "from" <*> v .: "to"
+
+-- | Main idea is that there are only two basic actions, that changes regions: inserting and cutting
+-- When something is cutted out or inserted in, 'Region' positions must be updated
+-- All editings can be represented as many cuts and inserts, so we can combine them to get function
+-- which maps source regions to regions on updated data
+-- Because insert is dual to cut (and therefore composes something like iso), we can also get function to map regions back
+-- Combining this functions while edit, we get function, that maps regions from source data to edited one
+-- To get back function, we must also combine opposite actions, or we can represent actions as 'Iso'
+-- Same idea goes for modifying contents, represent each action as isomorphism and combine them together
+newtype Map = Map { mapIso :: Iso' Region Region }
+
+instance Monoid Map where
+	mempty = Map $ iso id id
+	Map l `mappend` Map r = Map (r . l)
+
+instance Group Map where
+	invert (Map f) = Map (from f)
+
+-- | Contents is list of lines, list must have at least one (maybe empty) line
+type Contents a = [a]
+
+-- | Empty contents are contents with one empty line
+emptyContents ∷ Monoid a ⇒ Contents a
+emptyContents = [mempty]
+
+checkCts ∷ Contents a → Contents a
+checkCts [] = error "Contents can't be empty"
+checkCts cs = cs
+
+concatCts ∷ Monoid a ⇒ Contents a → Contents a → Contents a
+concatCts ls rs = init (checkCts ls) ++ [last (checkCts ls) `mappend` head (checkCts rs)] ++ tail (checkCts rs)
+
+-- | Split 'Contents' at some 'Point'
+splitCts ∷ Editable a ⇒ Point → Contents a → (Contents a, Contents a)
+splitCts (Point l c) cts = (take l cts ++ [p], s : drop (succ l) cts) where
+	(p, s) = splitContents c (cts !! l)
+
+-- | Get splitted 'Contents' at some 'Point'
+splitted ∷ Editable a ⇒ Point → Iso' (Contents a) (Contents a, Contents a)
+splitted p = iso (splitCts p) (uncurry concatCts)
+
+-- | Something editable, string types implements this
+class Monoid a ⇒ Editable a where
+	-- | Split editable at some position
+	splitContents ∷ Int → a → (a, a)
+	contentsLength ∷ a → Int
+	splitLines ∷ a → [a]
+	joinLines ∷ [a] → a
+
+-- | Get 'Contents' for some 'Editable', splitting lines
+contents ∷ (Editable a, Editable b) ⇒ Iso a b (Contents a) (Contents b)
+contents = iso splitLines joinLines
+
+by ∷ Editable a ⇒ a → Contents a
+by = splitLines
+
+instance Editable String where
+	splitContents = splitAt
+	contentsLength = length
+	splitLines s = case break (≡ '\n') s of
+		(pre', "") → [pre']
+		(pre', _:post') → pre' : splitLines post'
+	joinLines = intercalate "\n"
+
+instance Editable Text where
+	splitContents = T.splitAt
+	contentsLength = T.length
+	splitLines = T.split (≡ '\n')
+	joinLines = T.intercalate "\n"
+
+-- | Contents 'Size'
+measure ∷ Editable s ⇒ Contents s → Size
+measure [] = error "Invalid input"
+measure cts = Point (pred $ length cts) (contentsLength $ last cts)
+
+-- | Serializable edit action
+data Replace s = Replace {
+	-- | 'Region' to replace
+	_replaceRegion ∷ Region,
+	-- | 'Contents' to replace with
+	_replaceWith ∷ Contents s }
+		deriving (Eq)
+
+makeLenses ''Replace
+
+instance (Editable s, ToJSON s) ⇒ ToJSON (Replace s) where
+	toJSON (Replace e c) = object ["region" .= e, "contents" .= view (from contents) c]
+
+instance (Editable s, FromJSON s) ⇒ FromJSON (Replace s) where
+	parseJSON = withObject "edit" $ \v → Replace <$> v .: "region" <*> (view contents <$> v .: "contents")
+
+instance (Editable s, ToJSON s) ⇒ Show (Replace s) where
+	show = L.unpack ∘ encode
+
+-- | Chain of edit actions
+newtype Chain e s = Chain {
+	_chain ∷ [e s] } deriving (Eq, Show, Monoid)
+
+makeLenses ''Chain
+
+instance ToJSON (e s) ⇒ ToJSON (Chain e s) where
+	toJSON = toJSON ∘ _chain
+
+instance FromJSON (e s) ⇒ FromJSON (Chain e s) where
+	parseJSON = fmap Chain ∘ parseJSON
+
+type Edit s = Chain Replace s
+
+-- | Some action with its inverse
+data ActionIso e = ActionIso {
+	_action ∷ e,
+	_actionBack ∷ e }
+
+makeLenses ''ActionIso
+
+instance Monoid e ⇒ Monoid (ActionIso e) where
+	mempty = ActionIso mempty mempty
+	ActionIso l l' `mappend` ActionIso r r' = ActionIso (l `mappend` r) (r' `mappend` l')
+
+instance Monoid e ⇒ Group (ActionIso e) where
+	invert (ActionIso f b) = ActionIso b f
+
+instance ToJSON e ⇒ ToJSON (ActionIso e) where
+	toJSON (ActionIso f b) = object ["fore" .= f, "back" .= b]
+
+instance FromJSON e ⇒ FromJSON (ActionIso e) where
+	parseJSON = withObject "action-iso" $ \v → ActionIso <$> v .: "fore" <*> v .: "back"
+
+-- | Stack of undo/redo actions
+data ActionStack e = ActionStack {
+	_undoStack ∷ [ActionIso e],
+	_redoStack ∷ [ActionIso e] }
+
+makeLenses ''ActionStack
+
+instance ToJSON e ⇒ ToJSON (ActionStack e) where
+	toJSON (ActionStack u r) = object ["undo" .= u, "redo" .= r]
+
+instance FromJSON e ⇒ FromJSON (ActionStack e) where
+	parseJSON = withObject "action-stack" $ \v → ActionStack <$> v .: "undo" <*> v .: "redo"
+
+emptyStack ∷ ActionStack e
+emptyStack = ActionStack [] []
+
+-- | Edit state
+data EditState s r = EditState {
+	-- | Edit history is stack of edit actions
+	_history ∷ ActionStack (Edit s),
+	-- | Currently edited data
+	_edited ∷ Contents s,
+	-- | Some region-based state, that will be updated on each edit
+	_regions ∷ r }
+
+makeLenses ''EditState
+
+instance (Editable s, ToJSON s, ToJSON r) ⇒ ToJSON (EditState s r) where
+	toJSON (EditState h e rs) = object ["history" .= h, "contents" .= view (from contents) e, "regions" .= rs ]
+
+instance (Editable s, FromJSON s, FromJSON r) ⇒ FromJSON (EditState s r) where
+	parseJSON = withObject "edit-state" $ \v → EditState <$> v .: "history" <*> fmap (view contents) (v .: "contents") <*> v .: "regions"
+
+-- | Make edit state for contents
+editState ∷ Editable s ⇒ s → r → EditState s r
+editState x = EditState emptyStack (x ^. contents)
+
+newtype EditM s r a = EditM { runEditM ∷ State (EditState s r) a } deriving (Applicative, Functor, Monad, MonadState (EditState s r))

+ tests/Test.hs view

@@ -0,0 +1,48 @@+module Main (
+	main
+	) where
+
+import Prelude.Unicode
+
+import Control.Lens
+import Control.Monad.State
+import Data.Text.Region
+import Test.Hspec
+
+text ∷ String
+text = "foo bar baz quux"
+
+bar ∷ Region
+bar = pt 0 3 `till` pt 0 7
+
+quux ∷ Region
+quux = pt 0 11 `till` pt 0 16
+
+nums ∷ String
+nums = " 123456"
+
+xxx ∷ String
+xxx = "xxx "
+
+main ∷ IO ()
+main = hspec $ do
+	describe "regions are updated" $ do
+		it "should delete correctly" $
+			apply (cut quux `mappend` cut bar) (by text) ≡ by "foo baz"
+	describe "editor monad" $ do
+		it "should perform undo/redo" $
+			(≡ text) $ edit_ text () $ do
+				runGroup [
+					cut bar,
+					replace quux (by nums),
+					paste start (by xxx)]
+				undo >> redo >> undo >> undo >> undo
+		it "should reverse text" $
+			(≡ reverse text) $ edit_ text (pt 0 (length text)) $ replicateM_ (length text) $ do
+				-- cut first letter and insert at caret
+				let
+					l = pt 0 0 `till` pt 0 1
+				c ← gets (view regions)
+				cts ← gets (view edited)
+				run $ paste c (view (atRegion l) cts)
+				run $ cut l

+ text-region.cabal view

@@ -0,0 +1,46 @@+name:                text-region
+version:             0.1.0.0
+synopsis:            Provides functions to update text region positions according to text edit actions
+homepage:            https://github.com/mvoidex/text-region
+license:             BSD3
+author:              Alexandr `Voidex` Ruchkin
+maintainer:          voidex@live.com
+category:            Text
+build-type:          Simple
+cabal-version:       >=1.10
+
+library
+  hs-source-dirs: src
+  default-language: Haskell2010
+  ghc-options: -threaded -Wall -fno-warn-tabs
+  default-extensions: UnicodeSyntax
+  exposed-modules:     
+    Data.Text.Region
+    Data.Text.Region.Types
+  build-depends:
+    base >= 4.8 && < 4.9,
+    base-unicode-symbols >= 0.2,
+    aeson >= 0.9,
+    bytestring >= 0.10,
+    containers >= 0.5,
+    groups >= 0.4.0,
+    lens >= 4.12,
+    mtl >= 2.2,
+    text >= 1.2.1
+
+test-suite test
+  type: exitcode-stdio-1.0
+  main-is: Test.hs
+  hs-source-dirs: tests
+  ghc-options: -threaded -Wall -fno-warn-tabs
+  default-language: Haskell2010
+  default-extensions: UnicodeSyntax
+  build-depends:
+    base >= 4.8 && < 4.9,
+    base-unicode-symbols >= 0.2,
+    text-region,
+    hspec,
+    containers >= 0.5,
+    lens >= 4.12,
+    mtl >= 2.2,
+    text >= 1.2.1