module Data.Mark (
Point(..), (.-.), (.+.), Size, linesSize, stringSize,
Region(..), regionLines, emptyRegion,
line,
region, regionSize, at,
Map(..), apply, back,
cut, insert,
cutRegion, insertRegion,
Contents, Edit(..),
EditM(..), editRegion, mapRegion, runEdit, edit, editEval,
Prefix(..), prefix, Suffix(..), suffix, concatCts, splitCts,
Editable(..), measure,
erase, write, replace,
Replace(..), eraser, writer, replacer, run
) where
import Prelude hiding (splitAt, length, lines, unlines)
import Control.Arrow ((&&&))
import Control.Applicative
import Control.Lens (view)
import Control.Lens.Iso
import Control.Monad.State
import Data.Aeson
import qualified Data.List as List (splitAt, length, break, intercalate)
import Data.Text (Text)
import qualified Data.Text as T (splitAt, length, split, intercalate)
import Data.Monoid
import HsDev.Util ((.::))
data Point = Point {
pointLine :: Int,
pointColumn :: Int }
deriving (Eq, Ord, Read, Show)
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"
(.-.) :: 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)
type Size = Point
instance Monoid Size where
mempty = Point 0 0
l `mappend` r = r .+. l
linesSize :: Int -> Point
linesSize n = Point n 0
stringSize :: Int -> Point
stringSize n = Point 0 n
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"
regionLines :: Region -> Int
regionLines r = succ $ pointLine (regionTo r) pointLine (regionFrom r)
emptyRegion :: Region -> Bool
emptyRegion r = regionTo r == regionFrom r
line :: Int -> Region
line l = region (Point l 0) (Point (succ l) 0)
region :: Point -> Point -> Region
region f t = Region (min f t) (max f t)
regionSize :: Point -> Size -> Region
regionSize pt sz = region pt (sz .+. pt)
at :: Editable a => Contents a -> Region -> Contents a
at cts r =
onHead (snd . splitAt (pointColumn $ regionFrom r)) .
onLast (fst . splitAt (pointColumn $ regionTo r)) .
take (regionLines r) .
drop (pointLine (regionFrom r)) $
cts
where
onHead :: (a -> a) -> [a] -> [a]
onHead _ [] = []
onHead f (x:xs) = f x : xs
onLast :: (a -> a) -> [a] -> [a]
onLast _ [] = []
onLast f l@(last -> x) = init l ++ [f x]
newtype Map = Map { mapIso :: Iso' Region Region }
instance Monoid Map where
mempty = Map $ iso id id
(Map l) `mappend` (Map r) = Map (r . l)
apply :: Map -> Region -> Region
apply = view . mapIso
back :: Map -> Map
back (Map f) = Map (from f)
cut :: Region -> Map
cut rgn = Map $ iso (cutRegion rgn) (insertRegion rgn)
insert :: Region -> Map
insert = back . cut
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)
type Contents a = [a]
data Edit a = Edit {
editCts :: Contents a -> Contents a,
editMap :: Map }
instance Monoid (Edit a) where
mempty = Edit id mempty
(Edit fl ml) `mappend` (Edit fr mr) = Edit (fr . fl) (ml `mappend` mr)
newtype EditM s a = EditM { runEditM :: State (Edit s) a }
deriving (Functor, Applicative, Monad, MonadState (Edit s))
editRegion :: Region -> (Region -> Edit a) -> EditM a ()
editRegion rgn edit' = do
rgn' <- mapRegion rgn
modify (`mappend` (edit' rgn'))
mapRegion :: Region -> EditM a Region
mapRegion rgn = gets (($ rgn) . apply . editMap)
runEdit :: Editable s => EditM s a -> (a, Edit s)
runEdit act = runState (runEditM act) mempty
edit :: Editable s => s -> EditM s a -> s
edit cts = snd . editEval cts
editEval :: Editable s => s -> EditM s a -> (a, s)
editEval cts act = (v, unlines . editCts st . lines $ cts) where
(v, st) = runEdit act
data Prefix a = Prefix {
prefixLines :: [a],
prefixLine :: a }
deriving (Eq, Ord, Read, Show)
instance Functor Prefix where
fmap f (Prefix ls l) = Prefix (fmap f ls) (f l)
prefix :: Contents a -> Prefix a
prefix cts = Prefix (init cts) (last cts)
data Suffix a = Suffix {
suffixLine :: a,
suffixLines :: [a] }
deriving (Eq, Ord, Read, Show)
instance Functor Suffix where
fmap f (Suffix l ls) = Suffix (f l) (fmap f ls)
suffix :: Contents a -> Suffix a
suffix cts = Suffix (head cts) (tail cts)
concatCts :: Monoid a => Prefix a -> Suffix a -> Contents a
concatCts (Prefix ps p) (Suffix s ss) = ps ++ [p `mappend` s] ++ ss
splitCts :: Editable a => Point -> Contents a -> (Prefix a, Suffix a)
splitCts (Point l c) cts = (Prefix (take l cts) p, Suffix s (drop (succ l) cts)) where
(p, s) = splitAt c (cts !! l)
class Monoid a => Editable a where
splitAt :: Int -> a -> (a, a)
length :: a -> Int
lines :: a -> [a]
unlines :: [a] -> a
instance Editable String where
splitAt = List.splitAt
length = List.length
lines s = case List.break (== '\n') s of
(pre, "") -> [pre]
(pre, _:post) -> pre : lines post
unlines = List.intercalate "\n"
instance Editable Text where
splitAt = T.splitAt
length = T.length
lines = T.split (== '\n')
unlines = T.intercalate "\n"
measure :: Editable s => Contents s -> Size
measure [] = error "Invalid argument"
measure cts = Point (pred $ List.length cts) (length $ last cts)
erase :: Editable s => Region -> EditM s ()
erase rgn = editRegion rgn (\r -> Edit (erase' r) (cut r)) where
erase' :: Editable a => Region -> Contents a -> Contents a
erase' rgn' cts = fst (splitCts (regionFrom rgn') cts) `concatCts` snd (splitCts (regionTo rgn') cts)
write :: Editable s => Point -> Contents s -> EditM s ()
write _ ([]) = error "Invalid argument"
write pt cts = editRegion (pt `regionSize` measure cts) (\r -> Edit (write' r) (insert r)) where
write' rgn' origin = prefix (before' `concatCts` suffix cts) `concatCts` after' where
(before', after') = splitCts (regionFrom rgn') origin
replace :: Editable s => Region -> Contents s -> EditM s ()
replace rgn cts = erase rgn >> write (regionFrom rgn) cts
data Replace s = Replace {
replaceRegion :: Region,
replaceWith :: Contents s }
deriving (Eq, Read, Show)
instance (Editable s, ToJSON s) => ToJSON (Replace s) where
toJSON (Replace e c) = object ["region" .= e, "contents" .= unlines c]
instance (Editable s, FromJSON s) => FromJSON (Replace s) where
parseJSON = withObject "edit" $ \v -> Replace <$> v .:: "region" <*> (lines <$> v .:: "contents")
eraser :: Monoid s => Region -> Replace s
eraser rgn = Replace rgn [mempty]
writer :: Editable s => Point -> s -> Replace s
writer pt cts = Replace (region pt pt) $ lines cts
replacer :: Editable s => Region -> s -> Replace s
replacer rgn cts = Replace rgn (lines cts)
run :: Editable s => [Replace s] -> EditM s ()
run = mapM_ (uncurry replace . (replaceRegion &&& replaceWith))