text-region 0.1.0.1 → 0.2.0.0

raw patch · 4 files changed

+78/−209 lines, 4 filesdep −containersdep −mtlPVP ok

version bump matches the API change (PVP)

Dependencies removed: containers, mtl

API changes (from Hackage documentation)

Files

• src/Data/Text/Region.hs +41/−110
• src/Data/Text/Region/Types.hs +19/−77
• tests/Test.hs +13/−17
• text-region.cabal +5/−5

@@ -2,10 +2,9 @@ 
 module Data.Text.Region (
 	pt, start, lineStart, regionLength, till, linesSize, regionLines, emptyRegion, line,
-	regionSize, expandLines, atRegion, ApplyMap(..), updateMap, cutMap, insertMap,
+	regionSize, expandLines, atRegion, overlaps, applyMap, cutMap, insertMap,
 	cutRegion, insertRegion,
-	EditAction(..), cut, paste, overwrite, inverse, applyEdit, apply,
-	edit, edit_, push, run_, run, runGroup, undo, redo,
+	EditAction(..), cut, paste, overwrite, apply, update,
 
 	module Data.Text.Region.Types
 	) where
@@ -13,10 +12,8 @@ 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
 
@@ -74,33 +71,15 @@ 	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)
+-- | Does regions overlaps
+overlaps ∷ Region → Region → Bool
+overlaps l r
+	| r ^. regionFrom ≥ l ^. regionTo = False
+	| r ^. regionTo ≤ l ^. regionFrom = False
+	| otherwise = True
 
--- | Update 'Region' after some action
-updateMap ∷ (EditAction e s, ApplyMap a) ⇒ e s → a → a
-updateMap = applyMap ∘ actionMap
+applyMap ∷ Map → Region → Region
+applyMap = view ∘ mapIso
 
 -- | Cut 'Region' mapping
 cutMap ∷ Region → Map
@@ -116,19 +95,25 @@ 	(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
+-- | Update second region position as if it was data inserted at first region (region sets insertion point and data size)
+-- Region tries not to extend if data inserted at region bound except when region is empty
+-- This allows define replace as cut and insert in special case when we replace region itself
 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)
+insertRegion (Region is ie) (Region s e)
+	| (s ≡ e) ∧ (is ≡ s) = Region is ie
+	| otherwise = 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
+class Editable 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)
+	-- | Perform action, modifying 'Contents'
+	perform ∷ e s → Contents s → Contents s
+	-- | Get action undo
+	inversed ∷ e s → Contents s → e s
 
 -- | Cuts region
 cut ∷ EditAction e s ⇒ Region → e s
@@ -142,80 +127,26 @@ 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)
+-- | 'perform' for 'Edit'
+apply ∷ Editable s ⇒ Edit s → Contents s → Contents s
+apply = perform
 
--- | 'applyEdit' for 'Edit'
-apply ∷ EditAction Replace s ⇒ Edit s → Contents s → Contents s
-apply = applyEdit
+-- | Update regions
+update ∷ Editable s ⇒ Edit s → Region → Region
+update = applyMap ∘ actionMap
 
 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 ∷ 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 :))
+	actionMap (Replace r w) = insertMap (r & regionLength .~ measure w) `mappend` cutMap r
+	perform (Replace r w) cts = cts & atRegion r .~ w
+	inversed (Replace r w) cts = Replace (r & regionLength .~ measure w) (cts ^. atRegion r)
 
-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 :))
+instance Editable s ⇒ EditAction Edit s where
+	replace rgn txt = Edit [replace rgn txt]
+	actionMap = foldr go mempty ∘ view replaces where
+		go r m = actionMap (over replaceRegion (applyMap m) r) `mappend` m
+	perform = snd ∘ foldr go (mempty, id) ∘ view replaces where
+		go r (m, fn) = (actionMap r' `mappend` m, perform r' ∘ fn) where
+			r' = over replaceRegion (applyMap m) r
+	inversed e@(Edit rs) cts = Edit [Replace (applyMap m r) (cts ^. atRegion r) | Replace r _ ← rs] where
+		m = actionMap e

@@ -1,17 +1,13 @@ {-# LANGUAGE TemplateHaskell, RankNTypes, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts #-}
 
 module Data.Text.Region.Types (
-	Point(..), pointLine, pointColumn, Size, (.-.), (.+.),
+	Point(..), pointLine, pointColumn, pointRegion, 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(..),
+	Replace(..), replaceRegion, replaceWith, Edit(..), replaces,
 
 	module Data.Group
 	) where
@@ -21,7 +17,6 @@ 
 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
@@ -37,6 +32,10 @@ 
 makeLenses ''Point
 
+-- | As empty region
+pointRegion ∷ Iso' Point Region
+pointRegion = iso (\p → Region p p) _regionFrom
+
 instance ToJSON Point where
 	toJSON (Point l c) = object ["line" .= l, "column" .= c]
 
@@ -66,7 +65,9 @@ 	| bl ≡ l = Point 0 (max 0 (c - bc))
 	| otherwise = Point 0 0
 
--- | Opposite to ".-.", @(pt .-. base) .+. base = pt@
+-- | Opposite to '.-.'
+--
+-- prop> (pt .-. base) .+. base = pt
 (.+.) ∷ Point → Point → Point
 (Point l c) .+. (Point bl bc)
 	| l ≡ 0 = Point bl (c + bc)
@@ -94,6 +95,7 @@ -- 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
+-- This works if we don't use overlapped regions
 newtype Map = Map { mapIso :: Iso' Region Region }
 
 instance Monoid Map where
@@ -179,75 +181,15 @@ 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 ]
+-- | Edit is several replace actions, applied simultaneously, must not overlap
+newtype Edit s = Edit {
+	_replaces ∷ [Replace s] }
+		deriving (Eq, Show, Monoid)
 
-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"
+makeLenses ''Edit
 
--- | Make edit state for contents
-editState ∷ Editable s ⇒ s → r → EditState s r
-editState x = EditState emptyStack (x ^. contents)
+instance (Editable s, ToJSON s) ⇒ ToJSON (Edit s) where
+	toJSON = toJSON ∘ _replaces
 
-newtype EditM s r a = EditM { runEditM ∷ State (EditState s r) a } deriving (Applicative, Functor, Monad, MonadState (EditState s r))
+instance (Editable s, FromJSON s) ⇒ FromJSON (Edit s) where
+	parseJSON = fmap Edit ∘ parseJSON

@@ -5,7 +5,6 @@ import Prelude.Unicode
 
 import Control.Lens
-import Control.Monad.State
 import Data.Text.Region
 import Test.Hspec
 
@@ -29,20 +28,17 @@ 	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 perform undo" $
+			let
+				act' = mconcat [cut bar, replace quux (by nums), paste start (by xxx)]
+				undo' = inversed act' (by text)
+			in
+			(apply undo' ∘ apply act') (by text) ≡ by text
 		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
+			let
+				go 0 _ txt = txt
+				go n c txt = go (n - 1) (over pointRegion (update act') c) (apply act' txt) where
+					act' = mconcat [cut first, paste c (txt ^. atRegion first)]
+					first = pt 0 0 `till` pt 0 1
+			in
+			go (length text) (pt 0 (length text)) (by text) ≡ by (reverse text)

@@ -1,5 +1,5 @@ name:                text-region
-version:             0.1.0.1
+version:             0.2.0.0
 synopsis:            Marking text regions
 description: Provides functions to update text region positions according to text edit actions
 homepage:            https://github.com/mvoidex/text-region
@@ -28,10 +28,10 @@     base-unicode-symbols >= 0.2,
     aeson >= 0.9,
     bytestring >= 0.10,
-    containers >= 0.5,
+    -- containers >= 0.5,
     groups >= 0.4.0,
     lens >= 4.12,
-    mtl >= 2.2,
+    -- mtl >= 2.2,
     text >= 1.2.1
 
 test-suite test
@@ -46,7 +46,7 @@     base-unicode-symbols >= 0.2,
     text-region,
     hspec,
-    containers >= 0.5,
+    -- containers >= 0.5,
     lens >= 4.12,
-    mtl >= 2.2,
+    -- mtl >= 2.2,
     text >= 1.2.1