module FRP.Grapefruit.Signal.Incremental.Sequence (
Diff (Diff),
AtomicDiff (Insertion, Deletion, Shift, Update),
insertion,
deletion,
shift,
update,
elementInsertion,
elementDeletion,
elementShift,
elementUpdate,
empty,
singleton,
(<|),
(|>),
(><),
null,
length,
map,
staticMap,
filter,
staticFilter,
reverse
) where
import Prelude hiding (filter, foldl, foldr, length, map, null, reverse, sum)
import qualified Prelude
import Data.Semigroup as Semigroup
import Data.Monoid as Monoid
import Data.Foldable as Foldable (foldl, toList, sum)
import Data.Sequence as Seq (Seq)
import qualified Data.Sequence as Seq
import Internal.Signal.Incremental.Sequence.AtomicDiff as AtomicDiff
hiding (atomicPatch,
reverse)
import qualified Internal.Signal.Incremental.Sequence.AtomicDiff as AtomicDiff
import Internal.Signal.Incremental.Sequence.Selection as SeqSel
hiding (atomicPatch)
import qualified Internal.Signal.Incremental.Sequence.Selection as SeqSel
import FRP.Grapefruit.Signal.Segmented as SSignal
import FRP.Grapefruit.Signal.Incremental as ISignal hiding (map)
import qualified FRP.Grapefruit.Signal.Incremental as ISignal
instance Incremental (Seq el) where
data Diff (Seq el) = Diff (Seq (AtomicDiff el))
patch seq (Diff atomicDiffs) = foldl atomicPatch seq atomicDiffs
type ValidationState (Seq el) = Int
validationInit initSeq = Seq.length initSeq
validationStep (Diff atomicDiffs) len = foldl consComp (Just len) atomicDiffs where
consComp maybeLen atomicDiff = maybeLen >>= atomicValidationStep atomicDiff
atomicValidationStep :: AtomicDiff el -> Int -> Maybe Int
atomicValidationStep atomicDiff len | isOk = Just (len + lengthDelta atomicDiff)
| otherwise = Nothing where
isOk = case atomicDiff of
Insertion idx els -> idx >= 0 && idx <= len
Deletion idx cnt -> intervalIsOk idx cnt
Shift from cnt to -> intervalIsOk from cnt && intervalIsOk to cnt
Update idx els -> intervalIsOk idx (Seq.length els)
intervalIsOk idx cnt = idx >= 0 && cnt >= 0 && idx + cnt <= len
instance Semigroup (Diff (Seq el)) where
(<>) = mappend
instance Monoid (Diff (Seq el)) where
mempty = Diff Seq.empty
Diff atomicDiffs1 `mappend` Diff atomicDiffs2 = Diff (atomicDiffs1 `mappend` atomicDiffs2)
insertion :: Int -> Seq el -> Diff (Seq el)
insertion idx els = fromAtomicDiff (Insertion idx els)
deletion :: Int -> Int -> Diff (Seq el)
deletion idx cnt = fromAtomicDiff (Deletion idx cnt)
shift :: Int -> Int -> Int -> Diff (Seq el)
shift from cnt to = fromAtomicDiff (Shift from cnt to)
update :: Int -> Seq el -> Diff (Seq el)
update idx els = fromAtomicDiff (Update idx els)
fromAtomicDiff :: AtomicDiff el -> Diff (Seq el)
fromAtomicDiff = Diff . Seq.singleton
elementInsertion :: Int -> el -> Diff (Seq el)
elementInsertion idx el = insertion idx (Seq.singleton el)
elementDeletion :: Int -> Diff (Seq el)
elementDeletion idx = deletion idx 1
elementShift :: Int -> Int -> Diff (Seq el)
elementShift from to = shift from 1 to
elementUpdate :: Int -> el -> Diff (Seq el)
elementUpdate idx el = update idx (Seq.singleton el)
atomicPatch :: Seq el -> AtomicDiff el -> Seq el
atomicPatch = AtomicDiff.atomicPatch id Seq.splitAt mappend
diffLengthDelta :: Diff (Seq el) -> Int
diffLengthDelta (Diff atomicDiffs) = sum (fmap lengthDelta atomicDiffs)
fromAtomicStep :: (AtomicDiff el -> state -> (AtomicDiff el',state))
-> (Diff (Seq el) -> state -> (Diff (Seq el'),state))
fromAtomicStep atomicStep (Diff atomicDiffs) state = (Diff atomicDiffs',state') where
(atomicDiffs',state') = foldl consComp nilComp atomicDiffs
nilComp = (Seq.empty,state)
consComp (atomicDiffs',state) atomicDiff = let
(atomicDiff',state') = atomicStep atomicDiff
state
in (atomicDiffs' Seq.|> atomicDiff',state')
empty :: ISignal era (Seq a)
empty = ISignal.const Seq.empty
singleton :: SSignal era el -> ISignal era (Seq el)
singleton = ISignal.map start step . ISignal.monolithicFromSSignal where
start (Monolithic init) = (Seq.singleton init,())
step (Replacement el) _ = (Diff (Seq.singleton (Update 0 (Seq.singleton el))),())
(<|) :: SSignal era el -> ISignal era (Seq el) -> ISignal era (Seq el)
heads <| tails = singleton heads >< tails
(|>) :: ISignal era (Seq el) -> SSignal era el -> ISignal era (Seq el)
inits |> lasts = inits >< singleton lasts
(><) :: ISignal era (Seq el) -> ISignal era (Seq el) -> ISignal era (Seq el)
(><) = ISignal.combine start (fromAtomicStep atomicStep1) (fromAtomicStep atomicStep2) where
start init1 init2 = (init1 `mappend` init2,Seq.length init1)
atomicStep1 atomicDiff1 len1 = (atomicDiff1,len1 + lengthDelta atomicDiff1)
atomicStep2 atomicDiff2 len1 = (AtomicDiff.relocate len1 atomicDiff2,len1)
null :: ISignal era (Seq el)-> SSignal era Bool
null = fmap (== 0) . length
length :: ISignal era (Seq el) -> SSignal era Int
length = ISignal.monolithicToSSignal . ISignal.map start step where
start init = let
lenInit = Seq.length init
in (Monolithic lenInit,lenInit)
step diff len = let
len' = len + diffLengthDelta diff
in (Replacement len',len')
map :: SSignal era (el -> el') -> ISignal era (Seq el) -> ISignal era (Seq el')
map = ISignal.combine start funStep (fromAtomicStep atomicSeqStep) . monolithicFromSSignal where
start (Monolithic initFun) initSeq = (fmap initFun initSeq,(initFun,initSeq))
funStep (Replacement fun) (_,seq) = (,) (Diff (Seq.singleton (Update 0 (fmap fun seq))))
(fun,seq)
atomicSeqStep atomicSeqDiff (fun,seq) = (,) (fmap fun atomicSeqDiff)
(fun,atomicPatch seq atomicSeqDiff)
staticMap :: (el -> el') -> ISignal era (Seq el) -> ISignal era (Seq el')
staticMap fun = ISignal.map start (fromAtomicStep atomicStep) where
start init = (fmap fun init,())
atomicStep atomicDiff _ = (fmap fun atomicDiff,())
filter :: SSignal era (el -> Bool) -> ISignal era (Seq el) -> ISignal era (Seq el)
filter = ISignal.combine start prdStep seqStep . ISignal.monolithicFromSSignal where
start (Monolithic initPrd) initSeq = (,) (filterSeq initPrd initSeq)
(initPrd,initSeq,SeqSel.fromSeq initPrd initSeq)
prdStep (Replacement prd) (_,seq,_) = (,) (Diff $
Seq.fromList [Deletion 0 (Seq.length seq),
Insertion 0 (filterSeq prd seq)])
(prd,seq,SeqSel.fromSeq prd seq)
seqStep seqDiff (prd,seq,seqSel) = let
(seqDiff',seqSel') = selectionStep prd
seqDiff
seqSel
in (seqDiff',(prd,patch seq seqDiff,seqSel'))
staticFilter :: (el -> Bool) -> ISignal era (Seq el) -> ISignal era (Seq el)
staticFilter prd = ISignal.map start (selectionStep prd) where
start initSeq = (filterSeq prd initSeq,SeqSel.fromSeq prd initSeq)
filterSeq :: (el -> Bool) -> Seq el -> Seq el
filterSeq prd = Seq.fromList . Prelude.filter prd . toList
selectionStep :: (el -> Bool) -> Diff (Seq el) -> SeqSel -> (Diff (Seq el),SeqSel)
selectionStep prd = fromAtomicStep (unsafeAtomicSelectionStep prd) . breakUpdates where
breakUpdates (Diff atomicDiffs) = Diff (atomicDiffs >>= breakUpdate)
breakUpdate (Update idx els) = Seq.fromList $
[Deletion idx (Seq.length els),Insertion idx els]
breakUpdate atomicDiff = Seq.singleton atomicDiff
unsafeAtomicSelectionStep :: (el -> Bool) -> AtomicDiff el -> SeqSel -> (AtomicDiff el,SeqSel)
unsafeAtomicSelectionStep prd atomicDiff seqSel = (atomicDiff',seqSel') where
atomicDiff' = case atomicDiff of
Insertion idx els -> Insertion (selectionIndex seqSel idx)
(filterSeq prd els)
Deletion idx cnt -> uncurry Deletion (selectionInterval seqSel idx cnt)
Shift from cnt to -> uncurry Shift (selectionInterval seqSel from cnt) $
selectionIndex seqSel' to
Update idx els -> error "grapefruit-frp: internal error"
seqSel' = SeqSel.atomicPatch prd seqSel atomicDiff
reverse :: ISignal era (Seq el) -> ISignal era (Seq el)
reverse = ISignal.map start (fromAtomicStep atomicStep) where
start init = (Seq.reverse init,Seq.length init)
atomicStep atomicDiff len = (AtomicDiff.reverse len atomicDiff,len + lengthDelta atomicDiff)
sort :: (Ord el) => ISignal era (Seq el) -> ISignal era (Seq el)
sort = staticSortBy compare
sortBy :: SSignal era (el -> el -> Ordering) -> ISignal era (Seq el) -> ISignal era (Seq el)
sortBy = error "ISignal.sortBy not yet implemented"
staticSortBy :: (el -> el -> Ordering) -> ISignal era (Seq el) -> ISignal era (Seq el)
staticSortBy = error "ISignal.staticSortBy not yet implemented"