module Data.Incremental.Sequence (

    -- * Type

    Seq,
    {-NOTE:
        By re-exporting Seq, we get the definition of DefaultChange for Seq into
        the documentation generated by Haddock.
    -}

    -- * Changes

    insert,
    delete,
    shift,
    changeAt,

    -- * Atomic changes

    AtomicChange (Insert, Delete, Shift, ChangeAt),
    normalizeAtomicChange,

    -- * Transformations

    singleton,
    fromPair,
    cat,
    null,
    length,
    map,
    map',
    concat,
    concatMap,
    gate,
    gate',
    filter,
    filter',
    reverse,
    sort,
    sortBy

) where

{-FIXME:
    Starting with GHC 7.10, we probably do not need to hide Prelude.foldl and
    import Data.Foldable (at least Data.Foldable.foldl' and
    Data.Foldable.toList, because the “Burning Bridges Proposal” has been
    implemented (meaning that certain Prelude functions are now the more general
    versions from Data.Foldable and Data.Traversable).
-}

-- Prelude

import Prelude hiding (
    id,
    (.),
    null,
    length,
    map,
    concat,
    concatMap,
    filter,
    reverse,
    foldl)
import qualified Prelude

-- Control

import Control.Category
import Control.Monad.ST.Lazy
import Control.Monad.Trans.Class
import Control.Monad.Trans.Order

-- Data

import           Data.Monoid
import           Data.Foldable (foldl', asum, toList)
import           Data.Traversable (traverse)
import           Data.FingerTree (FingerTree, Measured (measure))
import qualified Data.FingerTree as FingerTree
import           Data.Sequence (Seq, (><))
import qualified Data.Sequence as Seq
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.STRef.Lazy
import           Data.Order
import           Data.MultiChange (MultiChange)
import qualified Data.MultiChange as MultiChange
import           Data.Incremental
import qualified Data.Incremental.Tuple as Tuple

{-NOTE:
    Naming policy:

      • Data of argument transformations gets additional text, like “elem”.

      • Data related to input of a transformation gets an ordinary identifier,
        and the corresponding data related to output gets the same identifier
        with a prime.

      • Data that refers to the situation after applying a change gets an
        identifier that starts with “new”, and the corresponding data that
        refers to the situation before applying this change gets the
        corresponding identifier that starts with “old”.
-}
{-NOTE:
    State-strictness policy:

      • Reduction of the initial target value causes reduction of the state.

      • In the case of a sequence source, reduction of the part of a target
        change that is generated from an atomic change causes reduction of the
        state that is current just after this atomic change.

      • In the case of a non-sequence source, reduction of a target change
        causes reduction of the state.

      • State data structures are mostly strict, so that reduction of state
        causes evaluation of most of the state.

      • Only in the case of gate, the state data structure is not fully strict.
        Here, the state contains the current source value lazily. Maybe this
        should be changed.

      • In the case of map, state of the element transformation is only reduced
        if the corresponding initial target element or target element change
        (which is embedded in a ChangeAt change) is reduced.
-}

-- * Changes

instance Changeable a => Changeable (Seq a) where

    type DefaultChange (Seq a) = MultiChange (AtomicChange a)

insert :: Int -> Seq a -> DefaultChange (Seq a)
insert ix seq = MultiChange.singleton (Insert ix seq)

delete :: Int -> Int -> DefaultChange (Seq a)
delete ix len = MultiChange.singleton (Delete ix len)

shift :: Int -> Int -> Int -> DefaultChange (Seq a)
shift src len tgt = MultiChange.singleton (Shift src len tgt)

changeAt :: Int -> DefaultChange a -> DefaultChange (Seq a)
changeAt ix change = MultiChange.singleton (ChangeAt ix change)

-- * Atomic changes

data AtomicChange a = Insert !Int !(Seq a)
                    | Delete !Int !Int
                    | Shift !Int !Int !Int
                    | ChangeAt !Int (DefaultChange a)
{-NOTE:
    Insert is strict in the sequence, since it should be strict in the length of
    the sequence, as Delete and Shift are also strict in the length of the
    sequence length. Actually, reducing a sequence to WHNF evaluates everything
    except the elements, which amounts to evaluating its length.

    ChangeAt is not strict in the element change, since MultiChange is also not
    strict in its elements.
-}

{-NOTE:
    Change application for sequences is total. It uses forms of saturation to
    achieve this. All the transformations must work correctly also in the
    saturation cases. At the time of writing, they do.
-}
instance Changeable a => Change (AtomicChange a) where

    type Value (AtomicChange a) = Seq a

    Insert ix seq' $$ seq = applyInsert ix seq' seq

    Delete ix len $$ seq = applyDelete ix len seq

    Shift src len tgt $$ seq = applyShift src len tgt seq

    ChangeAt ix change $$ seq
        | indexInBounds (Seq.length seq) ix
            = front >< (change $$ elem) Seq.<| rear
        | otherwise
            = seq where

        (front, rest) = Seq.splitAt ix seq

        (elem Seq.:< rear) = Seq.viewl rest

applyInsert :: Int -> Seq a -> Seq a -> Seq a
applyInsert ix seq' seq = front >< seq' >< rear where

    (front, rear) = Seq.splitAt ix seq

applyDelete :: Int -> Int -> Seq a -> Seq a
applyDelete ix len seq = front >< rear where

    (front, rest) = Seq.splitAt ix seq

    (_, rear) = Seq.splitAt len rest

applyShift :: Int -> Int -> Int -> Seq a -> Seq a
applyShift src len tgt seq = applyInsert tgt mid (front >< rear) where

    (front, rest) = Seq.splitAt src seq

    (mid, rear) = Seq.splitAt len rest

normalizeAtomicChange :: Int -> AtomicChange a -> AtomicChange a
normalizeAtomicChange totalLen (Insert ix seq) = Insert ix' seq where

    ix' = normalizeIx totalLen ix

normalizeAtomicChange totalLen (Delete ix len) = Delete ix' len' where

    (ix', len') = normalizeIxAndLen totalLen ix len

normalizeAtomicChange totalLen (Shift src len tgt) = Shift src' len' tgt' where

    (src', len') = normalizeIxAndLen totalLen src len

    tgt' = normalizeIx (totalLen - len') tgt

normalizeAtomicChange totalLen (ChangeAt ix change) = ChangeAt ix' change where

    ix' | indexInBounds totalLen ix = ix
        | otherwise                 = totalLen

normalizeIx :: Int -> Int -> Int
normalizeIx totalLen ix = (ix `max` 0) `min` totalLen

normalizeIxAndLen :: Int -> Int -> Int -> (Int, Int)
normalizeIxAndLen totalLen ix len = (ix', len') where

        ix' = normalizeIx totalLen ix

        len' = (len `max` 0) `min` (totalLen - ix')

changeLength :: AtomicChange a -> Int -> Int
changeLength (Insert _ seq) totalLength = totalLength + Seq.length seq
changeLength (Delete _ len) totalLength = totalLength - len
changeLength (Shift _ _ _)  totalLength = totalLength
changeLength (ChangeAt _ _) totalLength = totalLength
-- NOTE: The given change must be normal.

indexInBounds :: Int -> Int -> Bool
indexInBounds len ix = ix >= 0 && ix < len

-- * Transformations

-- ** Singleton construction

singleton :: Changeable a => a ->> Seq a
singleton = simpleTrans Seq.singleton (changeAt 0)

-- ** Two-element sequence construction

fromPair :: Changeable a => (a, a) ->> Seq a
fromPair = MultiChange.map $ simpleTrans fun prop where

    fun ~(val1, val2) = Seq.fromList [val1, val2]

    prop (Tuple.First change)  = ChangeAt 0 change
    prop (Tuple.Second change) = ChangeAt 1 change

-- ** Concatenation of two sequences

cat :: Changeable a => (Seq a, Seq a) ->> Seq a
cat = concat . fromPair

-- ** Length queries

null :: Changeable a => Seq a ->> Bool
null = fromFunction (== 0) . length

length :: Changeable a => Seq a ->> Int
length = MultiChange.composeMap $ stateTrans' init prop where

    init seq = (len, len) where

        len = Seq.length seq

    prop change state = (ReplaceBy len', len') where

        normChange = normalizeAtomicChange state change

        len' = changeLength normChange state

-- ** Mapping

map :: (Changeable a, Changeable b) => (a ->> b) -> Seq a ->> Seq b
map trans = MultiChange.bind $ stTrans (\ seq -> do
    let elemProc = toSTProc trans
    let seqInit seq = do
            procOutputs <- traverse elemProc seq
            return (fmap fst procOutputs, fmap snd procOutputs)
    (seq', initElemProps) <- seqInit seq
    elemPropsRef <- newSTRef initElemProps
    let propCore (Insert ix seq) = do
            (seq', elemProps) <- seqInit seq
            modifySTRef elemPropsRef (applyInsert ix elemProps)
            return (insert ix seq')
        propCore (Delete ix len) = do
            modifySTRef elemPropsRef (applyDelete ix len)
            return (delete ix len)
        propCore (Shift src len tgt) = do
            modifySTRef elemPropsRef (applyShift src len tgt)
            return (shift src len tgt)
        propCore (ChangeAt ix change) = do
            elemProps <- readSTRef elemPropsRef
            if indexInBounds (Seq.length elemProps) ix
                then do
                    let elemProp = Seq.index elemProps ix
                    change' <- elemProp change
                    return (changeAt ix change')
                else return mempty
    let prop change = do
            change' <- propCore change
            newElemProps <- readSTRef elemPropsRef
            return (newElemProps `Prelude.seq` change')
    return (initElemProps `Prelude.seq` seq', prop))

map' :: (Changeable a, DefaultChange a ~ PrimitiveChange a,
         Changeable b, DefaultChange b ~ PrimitiveChange b) =>
        (a -> b) -> Seq a ->> Seq b
map' fun = MultiChange.map $ simpleTrans (fmap fun) prop where

    prop (Insert ix seq)      = Insert ix (fmap fun seq)
    prop (Delete ix len)      = Delete ix len
    prop (Shift src len tgt)  = Shift src len tgt
    prop (ChangeAt ix change) = ChangeAt ix (fmap fun change)

-- ** Concatenation of multiple sequences

seqConcat :: Seq (Seq a) -> Seq a
seqConcat = asum

newtype ConcatStateElement = ConcatStateElement Int

data ConcatStateMeasure = ConcatStateMeasure {
                              sourceLength :: !Int,
                              targetLength :: !Int
                          }

instance Monoid ConcatStateMeasure where

    mempty = ConcatStateMeasure 0 0

    mappend (ConcatStateMeasure srcLen1 tgtLen1)
            (ConcatStateMeasure srcLen2 tgtLen2) = measure' where

        measure' = ConcatStateMeasure (srcLen1 + srcLen2) (tgtLen1 + tgtLen2)

instance Measured ConcatStateMeasure ConcatStateElement where

    measure (ConcatStateElement elemLen) = ConcatStateMeasure 1 elemLen

type ConcatState = FingerTree ConcatStateMeasure ConcatStateElement

seqToConcatState :: Seq (Seq a) -> ConcatState
seqToConcatState = FingerTree.fromList .
                   toList              .
                   fmap (ConcatStateElement . Seq.length)

data ChangeAndLength a = ChangeAndLength (DefaultChange (Seq a)) !Int

concat :: Changeable a => Seq (Seq a) ->> Seq a
concat = MultiChange.bind $ stateTrans' init prop where

    init seq = (seqConcat seq, seqToConcatState seq)

    prop (Insert ix seq) state = (change', state') where

        (ix', front, rear) = splitAndTranslate ix state

        change' = insert ix' (seqConcat seq)

        state' = front <> seqToConcatState seq <> rear

    prop (Delete ix len) state = (change', state') where

        (ix', front, rest) = splitAndTranslate ix state

        (len', _, rear) = splitAndTranslate len rest

        change' = delete ix' len'

        state' = front <> rear

    prop (Shift src len tgt) state = (change', state') where

        (src', front, rest) = splitAndTranslate src state

        (len', mid, rear) = splitAndTranslate len rest

        (tgt', front', rear') = splitAndTranslate tgt (front <> rear)

        change' = shift src' len' tgt'

        state' = front' <> mid <> rear'

    prop (ChangeAt ix change) state
        | indexInBounds len ix = (change', state')
        | otherwise            = (mempty, state) where

        len = sourceLength (measure state)

        (ix', front, rest) = splitAndTranslate ix state

        (ConcatStateElement elemLen FingerTree.:< rear) = FingerTree.viewl rest

        ChangeAndLength change' elemLen' = foldl' next init change where

            init = ChangeAndLength mempty elemLen

            next (ChangeAndLength curChange curElemLen) atomic = result where

                result = ChangeAndLength curChange' curElemLen'

                normAtomic = normalizeAtomicChange curElemLen atomic

                shiftedNormAtomic = case normAtomic of
                    Insert elemIx seq
                        -> insert (ix' + elemIx) seq
                    Delete elemIx curElemLen
                        -> delete (ix' + elemIx) curElemLen
                    Shift elemSrc curElemLen elemTgt
                        -> shift (ix' + elemSrc) curElemLen (ix' + elemTgt)
                    ChangeAt elemIx change
                        -> if indexInBounds curElemLen elemIx
                               then changeAt (ix' + elemIx) change
                               else mempty

                curChange' = shiftedNormAtomic `mappend` curChange

                curElemLen' = changeLength normAtomic curElemLen

        state' = front <> (ConcatStateElement elemLen' FingerTree.<| rear)

    splitAndTranslate :: Int -> ConcatState -> (Int, ConcatState, ConcatState)
    splitAndTranslate ix state = (ix', front, rear) where

        (front, rear) = FingerTree.split ((> ix) . sourceLength) state

        ix' = targetLength (measure front)

-- ** Monadic bind

concatMap :: (Changeable a, Changeable b) => (a ->> Seq b) -> Seq a ->> Seq b
concatMap trans = concat . map trans

-- ** Gates

gate :: Changeable a => (a ->> Bool) -> a ->> Seq a
gate prd = stTrans (\ val -> do
    valRef <- newSTRef val
    (accepted, prop) <- toSTProc prd val
    acceptedRef <- newSTRef accepted
    let prop' change = do
            oldVal <- readSTRef valRef
            let newVal = change $$ oldVal
            writeSTRef valRef newVal
            acceptedChange <- prop change
            oldAccepted <- readSTRef acceptedRef
            let newAccepted = acceptedChange $$ oldAccepted
            writeSTRef acceptedRef newAccepted
            return $ case (oldAccepted, newAccepted) of
                (False, False) -> mempty
                (False, True)  -> insert 0 (Seq.singleton newVal)
                (True,  False) -> delete 0 1
                (True,  True)  -> changeAt 0 change
    return (emptyOrSingleton accepted val, prop'))
{-FIXME:
    Consider factoring out at least the update of values and accepted flags.
-}
{-FIXME:
    Here we seem to use the apostrophe to distinguish between argument
    transformation and result transformation, which does not seem to be coherent
    with the rest of this module.
-}

gate' :: (Changeable a, DefaultChange a ~ PrimitiveChange a) =>
         (a -> Bool) -> a ->> Seq a
gate' prd = stateTrans' init prop where

    init val = (emptyOrSingleton accepted val, accepted) where

        accepted = prd val

    prop Keep            oldAccepted = (mempty,  oldAccepted)
    prop (ReplaceBy val) oldAccepted = (change', newAccepted) where

        change' = case (oldAccepted, newAccepted) of
                      (False, False) -> mempty
                      (False, True)  -> insert 0 (Seq.singleton val)
                      (True,  False) -> delete 0 1
                      (True,  True)  -> changeAt 0 (ReplaceBy val)

        newAccepted = prd val

emptyOrSingleton :: Bool -> a -> Seq a
emptyOrSingleton accepted val | accepted  = Seq.singleton val
                              | otherwise = Seq.empty

-- ** Filtering

filter :: Changeable a => (a ->> Bool) -> Seq a ->> Seq a
filter = concatMap . gate

filter' :: (Changeable a, DefaultChange a ~ PrimitiveChange a) =>
           (a -> Bool) -> Seq a ->> Seq a
filter' = concatMap . gate'

-- FIXME: Maybe add partition and partition'.

-- ** Reversal

reverse :: Changeable a => Seq a ->> Seq a
reverse = MultiChange.map $ stateTrans' init prop where

    init seq = (Seq.reverse seq, Seq.length seq)

    prop change state = propNorm (normalizeAtomicChange state change) state

    propNorm change state = (propCore change state, changeLength change state)

    propCore (Insert ix seq) state = change' where

        change' = Insert (state - ix) (Seq.reverse seq)

    propCore (Delete ix len) state = change' where

        change' = Delete (state - (ix + len)) len

    propCore (Shift src len tgt) state = change' where

        change' = Shift (state - (src + len)) len (state - len - tgt)

    propCore (ChangeAt ix elemChange) state = change' where

        change' = ChangeAt (state - ix - 1) elemChange

-- ** Sorting

data Tagged o val = Tagged !val !(Element o) deriving (Eq, Ord)

sort :: (Ord a, Changeable a) => Seq a ->> Seq a
sort = MultiChange.bind $ orderSTTrans (\ seq -> do
    let seq' = Seq.sort seq
    initTaggedSeq <- traverse (\ elem -> fmap (Tagged elem) newMaximum) seq
    let initTaggedSet = Set.fromList (toList initTaggedSeq)
    taggedSeqRef <- lift $ newSTRef initTaggedSeq
    taggedSetRef <- lift $ newSTRef initTaggedSet
    let performInsert ix elem = do
            taggedSeq <- lift $ readSTRef taggedSeqRef
            let (front, rest) = Seq.splitAt ix taggedSeq
            tag <- case Seq.viewl rest of
                       Seq.EmptyL                    -> newMaximum
                       Tagged _ neighborTag Seq.:< _ -> newBefore neighborTag
            lift $ writeSTRef taggedSeqRef
                              (front >< Tagged elem tag Seq.<| rest)
            oldTaggedSet <- lift $ readSTRef taggedSetRef
            let newTaggedSet = Set.insert (Tagged elem tag) oldTaggedSet
            lift $ writeSTRef taggedSetRef newTaggedSet
            return (Set.findIndex (Tagged elem tag) newTaggedSet)
    let performDelete ix = do
            taggedSeq <- lift $ readSTRef taggedSeqRef
            let (front, rest) = Seq.splitAt ix taggedSeq
            let Tagged elem tag Seq.:< rear = Seq.viewl rest
            lift $ writeSTRef taggedSeqRef (front >< rear)
            taggedSet <- lift $ readSTRef taggedSetRef
            lift $ writeSTRef taggedSetRef
                              (Set.delete (Tagged elem tag) taggedSet)
            return (Set.findIndex (Tagged elem tag) taggedSet)
    let elemInsert ix elem = do
            ix' <- performInsert ix elem
            return (Insert ix' (Seq.singleton elem))
    let elemDelete ix = do
            ix' <- performDelete ix
            return (Delete ix' 1)
    let elemShift src tgt = do
            taggedSeq <- lift $ readSTRef taggedSeqRef
            let Tagged elem _ = Seq.index taggedSeq src
            src' <- performDelete src
            tgt' <- performInsert tgt elem
            return (Shift src' 1 tgt')
    let propCore (Insert ix seq) = do
            changes' <- traverse (elemInsert ix) (Prelude.reverse (toList seq))
            return (MultiChange.fromList changes')
        propCore (Delete ix len) = do
            changes' <- traverse elemDelete (replicate len ix)
            return (MultiChange.fromList changes')
        propCore (Shift src len tgt) = (case compare src tgt of
            LT -> genShifts (Prelude.reverse [0 .. len - 1])
            GT -> genShifts [0 .. len - 1]
            EQ -> return mempty) where

            genShifts offsets = do
                changes' <- traverse genShift offsets
                return (MultiChange.fromList changes')

            genShift offset = elemShift (src + offset) (tgt + offset)

        propCore (ChangeAt ix change) = do
            taggedSeq <- lift $ readSTRef taggedSeqRef
            if indexInBounds (Seq.length taggedSeq) ix
                then do
                    let Tagged oldElem _ = Seq.index taggedSeq ix
                    let newElem = change $$ oldElem
                    src' <- performDelete ix
                    tgt' <- performInsert ix newElem
                    return (shift src' 1 tgt' `mappend` changeAt src' change)
                else return mempty
    let prop change = do
            oldTaggedSeq <- lift $ readSTRef taggedSeqRef
            change' <- propCore $
                       normalizeAtomicChange (Seq.length oldTaggedSeq) change
            newTaggedSeq <- lift $ readSTRef taggedSeqRef
            newTaggedSet <- lift $ readSTRef taggedSetRef
            return $ newTaggedSeq `Prelude.seq`
                     newTaggedSet `Prelude.seq`
                     change'
    return (initTaggedSet `Prelude.seq` seq', prop))

orderSTTrans :: (forall o s . TransProc (OrderT o (ST s)) p q) -> Trans p q
orderSTTrans transProc = trans (\ cont -> runST (evalOrderT (cont transProc)))

sortBy :: Changeable a => (a -> a -> Ordering) -> Seq a ->> Seq a
sortBy compare = map fromOrderValue . sort . map (toOrderValue compare)
{-FIXME:
    In the future, we maybe should have a sortBy that takes a compare
    transformation instead of a compare function.
-}

data OrderValue a = OrderValue (a -> a -> Ordering) a

instance Eq (OrderValue a) where

    orderVal1 == orderVal2 = compare orderVal1 orderVal2 == EQ

instance Ord (OrderValue a) where

    compare (OrderValue compare val1) (OrderValue _ val2) = compare val1 val2

newtype OrderChange p = OrderChange p deriving Monoid

instance Change p => Change (OrderChange p) where

    type Value (OrderChange p) = OrderValue (Value p)

    OrderChange change $$ OrderValue compare val = OrderValue compare $
                                                   change $$ val

instance Changeable a => Changeable (OrderValue a) where

    type DefaultChange (OrderValue a) = OrderChange (DefaultChange a)

toOrderValue :: Changeable a => (a -> a -> Ordering) -> a ->> OrderValue a
toOrderValue compare = simpleTrans (OrderValue compare) OrderChange

fromOrderValue :: Changeable a => OrderValue a ->> a
fromOrderValue = simpleTrans (\ (OrderValue _ val) -> val)
                             (\ (OrderChange change) -> change)