grapefruit-frp-0.1.0.6: src/FRP/Grapefruit/Signal/Incremental/Sequence.hs
{-# LANGUAGE NoImpredicativeTypes #-}
module FRP.Grapefruit.Signal.Incremental.Sequence (
-- * Diffs
Diff (Diff),
AtomicDiff (Insertion, Deletion, Shift, Update),
insertion,
deletion,
shift,
update,
elementInsertion,
elementDeletion,
elementShift,
elementUpdate,
-- * Construction
empty,
singleton,
(<|),
(|>),
-- * Combination
(><),
-- * Queries
null,
length,
-- * Transformations
map,
staticMap,
filter,
staticFilter,
reverse
) where
-- Prelude
import Prelude hiding (filter, foldl, foldr, length, map, null, reverse, sum)
import qualified Prelude
-- Data
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
-- Internal
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
-- FRP.Grapefruit
import FRP.Grapefruit.Signal.Segmented as SSignal
import FRP.Grapefruit.Signal.Incremental as ISignal hiding (map)
import qualified FRP.Grapefruit.Signal.Incremental as ISignal
-- * Diffs
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')
-- * Construction
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
-- * Combination
(><) :: 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)
-- * Queries
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')
-- equals :: ISignal era (Seq el) -> ISignal era (Seq el) -> SSignal era Bool
-- compare :: ISignal era (Seq el) -> ISignal era (Seq el) -> SSignal era Ordering
-- * Indexing
-- index :: ISignal era (Seq el) -> SSignal era Int -> SSignal era el
-- take :: SSignal era Int -> ISignal era (Seq el) -> ISignal era (Seq el)
-- drop :: SSignal era Int -> ISignal era (Seq el) -> ISignal era (Seq el)
-- splitAt :: SSignal era Int
-- -> ISignal era (Seq el)
-- -> (ISignal era (Seq el),ISignal era (Seq el))
-- * Transformations
-- not in Data.Sequence (but fmap is)
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,())
-- not in Data.Sequence
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)
-- not in Data.Sequence
sort :: (Ord el) => ISignal era (Seq el) -> ISignal era (Seq el)
sort = staticSortBy compare
-- not in Data.Sequence
sortBy :: SSignal era (el -> el -> Ordering) -> ISignal era (Seq el) -> ISignal era (Seq el)
sortBy = error "ISignal.sortBy not yet implemented"
-- not in Data.Sequence
staticSortBy :: (el -> el -> Ordering) -> ISignal era (Seq el) -> ISignal era (Seq el)
staticSortBy = error "ISignal.staticSortBy not yet implemented"