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
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)
type Size = Point
(.-.) ∷ 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
(.+.) ∷ Point → Point → Point
(Point l c) .+. (Point bl bc)
| l ≡ 0 = Point bl (c + bc)
| otherwise = Point (l + bl) c
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"
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)
type Contents a = [a]
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)
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)
splitted ∷ Editable a ⇒ Point → Iso' (Contents a) (Contents a, Contents a)
splitted p = iso (splitCts p) (uncurry concatCts)
class Monoid a ⇒ Editable a where
splitContents ∷ Int → a → (a, a)
contentsLength ∷ a → Int
splitLines ∷ a → [a]
joinLines ∷ [a] → a
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"
measure ∷ Editable s ⇒ Contents s → Size
measure [] = error "Invalid input"
measure cts = Point (pred $ length cts) (contentsLength $ last cts)
data Replace s = Replace {
_replaceRegion ∷ Region,
_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
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
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"
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 [] []
data EditState s r = EditState {
_history ∷ ActionStack (Edit s),
_edited ∷ Contents s,
_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"
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))