Types.hs

{-# LANGUAGE TemplateHaskell, RankNTypes, TypeSynonymInstances, FlexibleInstances, OverloadedStrings, GeneralizedNewtypeDeriving, FlexibleContexts #-}

module Data.Text.Region.Types (
	Point(..), pointLine, pointColumn, pointRegion, Size, (.-.), (.+.),
	Region(..), regionFrom, regionTo,
	Map(..),
	Contents, emptyContents,
	concatCts, splitCts, splitted,
	Editable(..), contents, by, measure,
	Replace(..), replaceRegion, replaceWith, Edit(..), replaces,
	Regioned(..),

	module Data.Group
	) where

import Prelude hiding (id, (.))
import Prelude.Unicode

import Control.Category
import Control.Lens hiding ((.=))
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Group
import Data.List
import Data.Semigroup (Semigroup(..))
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

-- | 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]

instance FromJSON Point where
	parseJSON = withObject "point" $ \v → Point <$> v .: "line" <*> v .: "column"

instance Semigroup Point where
	Point l c <> Point bl bc
		| l ≡ 0 = Point bl (c + bc)
		| otherwise = Point (l + bl) c

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 '.-.'
--
-- prop> (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
-- This works if we don't use overlapped regions
newtype Map = Map { mapIso :: Iso' Region Region }

instance Semigroup Map where
	Map l <> Map r = Map (r . l)

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

-- | Edit is several replace actions, applied simultaneously, must not overlap
newtype Edit s = Edit {
	_replaces ∷ [Replace s] }
		deriving (Eq, Show, Semigroup, Monoid)

makeLenses ''Edit

instance (Editable s, ToJSON s) ⇒ ToJSON (Edit s) where
	toJSON = toJSON ∘ _replaces

instance (Editable s, FromJSON s) ⇒ FromJSON (Edit s) where
	parseJSON = fmap Edit ∘ parseJSON

class Regioned a where
	regions ∷ Traversal' a Region

instance Regioned Point where
	regions = pointRegion

instance Regioned Region where
	regions = id

instance Regioned (Replace s) where
	regions = replaceRegion

instance Regioned (Edit s) where
	regions = replaces . each . replaceRegion