{-# 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))