diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ Copyright © 2007–2009 Brandenburgische Technische Universität Cottbus +Copyright © 2011 Wolfgang Jeltsch All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted diff --git a/grapefruit-frp.cabal b/grapefruit-frp.cabal --- a/grapefruit-frp.cabal +++ b/grapefruit-frp.cabal @@ -1,15 +1,15 @@ Name: grapefruit-frp -Version: 0.0.0.0 -Cabal-Version: >= 1.2.3 +Version: 0.1.0.0 +Cabal-Version: >= 1.6 Build-Type: Simple License: BSD3 License-File: LICENSE -Copyright: © 2007–2009 Brandenburgische Technische Universität Cottbus +Copyright: © 2007–2009 Brandenburgische Technische Universität Cottbus; © 2011 Wolfgang Jeltsch Author: Wolfgang Jeltsch -Maintainer: jeltsch@informatik.tu-cottbus.de +Maintainer: wolfgang@cs.ioc.ee Stability: provisional -Homepage: http://haskell.org/haskellwiki/Grapefruit -Package-URL: http://hackage.haskell.org/packages/archive/grapefruit-frp/0.0.0.0/grapefruit-frp-0.0.0.0.tar.gz +Homepage: http://grapefruit-project.org/ +Package-URL: http://hackage.haskell.org/packages/archive/grapefruit-frp/0.1.0.0/grapefruit-frp-0.1.0.0.tar.gz Synopsis: Functional Reactive Programming core Description: Grapefruit is a library for Functional Reactive Programming (FRP) with a focus on user interfaces. FRP makes it possible to implement reactive and interactive systems @@ -18,40 +18,53 @@ . This package contains general support for Functional Reactive Programming. Category: FRP, Reactivity -Tested-With: GHC == 6.8.3 - GHC == 6.10.1 +Tested-With: GHC == 7.0.4 +Source-Repository head + type: darcs + location: http://darcs.grapefruit-project.org/main + +Source-Repository this + type: darcs + location: http://darcs.grapefruit-project.org/main + tag: grapefruit-0.1.0.0 + Library Build-Depends: arrows >= 0.2 && < 0.5, - base >= 3.0 && < 4.1, - containers >= 0.1 && < 0.3, - TypeCompose >= 0.3 && < 0.7 + base >= 3.0 && < 4.4, + containers >= 0.1 && < 0.5, + fingertree >= 0.0 && < 0.1, + semigroups >= 0.8 && < 0.9, + TypeCompose >= 0.3 && < 0.9 Extensions: Arrows - CPP EmptyDataDecls + FlexibleContexts + FlexibleInstances GADTs GeneralizedNewtypeDeriving - -- ImpredicativeTypes + ImpredicativeTypes KindSignatures + MultiParamTypeClasses Rank2Types - ScopedTypeVariables + TypeFamilies TypeOperators - GHC-Options: -fglasgow-exts -O0 - -- Switching off optimizations is needed because otherwise GHC 6.10.1 loops. - -- Replacing (fmap polyUnOSF funSignal) and (fmap polyUnSSF funSignal) in the - -- Signal.switch implementation by (undefined) makes GHC work even with -O. Exposed-Modules: FRP.Grapefruit.Circuit FRP.Grapefruit.Setup FRP.Grapefruit.Signal FRP.Grapefruit.Signal.Continuous FRP.Grapefruit.Signal.Discrete + FRP.Grapefruit.Signal.Incremental + FRP.Grapefruit.Signal.Incremental.Sequence + FRP.Grapefruit.Signal.Incremental.Set FRP.Grapefruit.Signal.Segmented - Other-Modules: Internal.Capsule - Internal.Circuit - Internal.CSeg + Other-Modules: Internal.Circuit Internal.Signal + Internal.Signal.Continuous.Segment Internal.Signal.Discrete + Internal.Signal.Discrete.Capsule + Internal.Signal.Discrete.ListenerSet + Internal.Signal.Discrete.Vista + Internal.Signal.Incremental.Sequence.AtomicDiff + Internal.Signal.Incremental.Sequence.Selection Internal.Signal.Segmented - Internal.ListenerSet - Internal.Vista HS-Source-Dirs: src diff --git a/src/FRP/Grapefruit/Setup.hs b/src/FRP/Grapefruit/Setup.hs --- a/src/FRP/Grapefruit/Setup.hs +++ b/src/FRP/Grapefruit/Setup.hs @@ -3,6 +3,7 @@ Setup, setup, + fromIO, run ) where @@ -28,6 +29,10 @@ -- |Converts an I/O action into a setup. setup :: IO (IO ()) -> Setup setup = Setup . App . O + + -- |Forms an initialization-only setup from an I/O action. + fromIO :: IO () -> Setup + fromIO = setup . (>> return (return ())) -- |Converts a setup into an I/O action. run :: Setup -> IO (IO ()) diff --git a/src/FRP/Grapefruit/Signal.hs b/src/FRP/Grapefruit/Signal.hs --- a/src/FRP/Grapefruit/Signal.hs +++ b/src/FRP/Grapefruit/Signal.hs @@ -14,11 +14,18 @@ -} module FRP.Grapefruit.Signal ( + {-FIXME: + Unfortunately, it seems that we have to export polySwitch and PolySignalFun here and use + them in the Switching example, since we might not be able to construct the argument signals + for switch (which must have impredicative types). This was not the case before GHC 7. + -} + -- * Signals Signal, -- * Switching switch, + polySwitch, -- * Signal functions SignalFun (OSF, SSF), @@ -26,6 +33,7 @@ unSSF, sfApp, (:->), + PolySignalFun (PolySignalFun), -- * Signal shapes Of, diff --git a/src/FRP/Grapefruit/Signal/Continuous.hs b/src/FRP/Grapefruit/Signal/Continuous.hs --- a/src/FRP/Grapefruit/Signal/Continuous.hs +++ b/src/FRP/Grapefruit/Signal/Continuous.hs @@ -18,24 +18,20 @@ -- Control import Control.Applicative as Applicative -#if __GLASGOW_HASKELL__ >= 610 import Control.Arrow as Arrow -#else - import Control.Arrow as Arrow hiding (pure) -#endif import Control.Compose as Compose -- Data import Data.Unique as Unique -- Internal - import Internal.Capsule as Capsule - import Internal.CSeg as CSeg hiding (producer) - import qualified Internal.CSeg as CSeg import Internal.Signal as Signal - import Internal.Signal.Discrete (DSignal) + import Internal.Signal.Continuous.Segment as CSeg hiding (producer) + import qualified Internal.Signal.Continuous.Segment as CSeg + import Internal.Signal.Discrete.Capsule as Capsule + import Internal.Signal.Discrete as DSignal (DSignal) import qualified Internal.Signal.Discrete as DSignal - import Internal.Signal.Segmented as SSignal + import Internal.Signal.Segmented as SSignal hiding (producer) -- Internal import Internal.Circuit as Circuit @@ -75,50 +71,35 @@ instance Signal CSignal where - osfSwitch signal@(SSignal init _) = CSignal (initCap init) segs' where + osfSwitch signal@(SSignal init _) = CSignal ((initCap . unPolyOSF) init) segs' where segs' = osfSwitch (segsSignal signal) ssfSwitch (SSignal init upd) (CSignal initCap segs) = ssfSwitch sampler segs where - sampler = polySSignal (fixInitCapForInit init initCap) - (polyTimeIDApp (fixInitCapForUpd <$> upd) <#> segs) + sampler = SSignal (fixInitCapForInit init initCap) + (DSignal.timeIDApp (fixInitCapForUpd <$> upd) <#> segs) initCap :: CSignal era val -> Capsule val initCap (CSignal initCap _) = initCap - segsSignal :: SSignal era (forall era'. CSignal era' val) - -> SSignal era (forall era'. SSignal era' (CSeg val)) - segsSignal = fmap polySegs - - polySegs :: (forall era'. CSignal era' val) -> (forall era'. SSignal era' (CSeg val)) - polySegs signal = segs signal + segsSignal :: SSignal era (PolyOSF CSignal val) + -> SSignal era (PolyOSF SSignal (CSeg val)) + segsSignal = fmap (\polyOSF -> PolyOSF (segs (unPolyOSF polyOSF))) segs :: CSignal era' val -> SSignal era' (CSeg val) segs (CSignal _ segs) = segs - polySSignal :: (forall era'. SSignal era' (CSeg val) -> SignalFun era' shape) - -> DSignal era (forall era'. SSignal era' (CSeg val) -> SignalFun era' shape) - -> SSignal era (forall era'. SSignal era' (CSeg val) -> SignalFun era' shape) - polySSignal init upd = SSignal init upd - - fixInitCapForInit :: (forall era'. CSignal era' val -> signalFun era' shape) - -> Capsule val - -> (forall era'. SSignal era' (CSeg val) -> signalFun era' shape) - fixInitCapForInit fun initCap segs = fun (CSignal initCap segs) + fixInitCapForInit :: PolySSF CSignal val shape -> Capsule val -> PolySSF SSignal (CSeg val) shape + fixInitCapForInit fun initCap = PolySSF (\segs -> unPolySSF fun (CSignal initCap segs)) - fixInitCapForUpd :: (forall era'. CSignal era' val -> signalFun era' shape) + fixInitCapForUpd :: PolySSF CSignal val shape -> Unique -> CSeg val - -> (forall era'. SSignal era' (CSeg val) -> signalFun era' shape) - fixInitCapForUpd fun timeID initSeg segs = fun (CSignal (currentValCapsule timeID initSeg) segs) + -> PolySSF SSignal (CSeg val) shape + fixInitCapForUpd fun timeID initSeg = result where - polyTimeIDApp :: DSignal era (Unique -> - CSeg val -> - forall era'. SSignal era' (CSeg val) -> SignalFun era' shape) - -> DSignal era (CSeg val -> - forall era'. SSignal era' (CSeg val) -> SignalFun era' shape) - polyTimeIDApp signal = DSignal.timeIDApp signal + result = PolySSF (\segs -> unPolySSF fun (CSignal (currentValCapsule timeID initSeg) segs)) instance Samplee CSignal where diff --git a/src/FRP/Grapefruit/Signal/Incremental.hs b/src/FRP/Grapefruit/Signal/Incremental.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Signal/Incremental.hs @@ -0,0 +1,161 @@ +module FRP.Grapefruit.Signal.Incremental ( + + -- * Incremental signal type + ISignal, + Incremental (patch, type ValidationState, validationInit, validationStep), + Diff (Replacement), + + -- * Monolithic values + Monolithic (Monolithic), + + -- * Construction + construct, + + -- * Queries + withInit, + updates, + + -- * Conversion + toSSignal, + monolithicFromSSignal, + monolithicToSSignal, + + -- * Composition + const, + map, + combine, + + -- * Connectors + consumer + +) where + + -- Prelude + import Prelude hiding (const, map) + + -- Data + import Data.Semigroup as Semigroup + + -- Internal + import Internal.Signal.Segmented as SSignal (SSignal (SSignal), scan) + + -- FRP.Grapefruit + import FRP.Grapefruit.Setup as Setup + import FRP.Grapefruit.Circuit as Circuit + import FRP.Grapefruit.Signal as Signal + import FRP.Grapefruit.Signal.Discrete as DSignal hiding (map, consumer) + import qualified FRP.Grapefruit.Signal.Discrete as DSignal + + {- + Since an ISignal may be derived from an SSignal, it can indirectly depend on a CSignal. So + access to the initial value must be forbidden for the same reason it is forbidden for + SSignals. + -} + + -- #> should also work for ISignals. + + -- * Incremental signal type + data ISignal era val = ISignal val (DSignal era (Diff val)) + + class (Semigroup (Diff val)) => Incremental val where + + data Diff val :: * + + patch :: val -> Diff val -> val + + type ValidationState val :: * + + validationInit :: val -> ValidationState val + + validationStep :: Diff val -> ValidationState val -> Maybe (ValidationState val) + + -- * Monolithic values + newtype Monolithic val = Monolithic val + + instance Semigroup (Diff (Monolithic val)) where + + _ <> monolithic2 = monolithic2 + + instance Incremental (Monolithic val) where + + data Diff (Monolithic val) = Replacement val + + patch _ (Replacement val) = Monolithic val + + type ValidationState (Monolithic val) = () + + validationInit _ = () + + validationStep _ _ = Just () + + -- * Construction + construct :: (Incremental val) => val -> DSignal era (Diff val) -> ISignal era val + construct init diffs = ISignal init (DSignal.stateful (validationInit init) + (fmap diffToTrans diffs)) where + + diffToTrans diff state = case validationStep diff state of + Nothing -> error $ "grapefruit-frp: " ++ + "incremental signal validation failure" + Just state' -> (diff,state') + + -- * Queries + withInit :: (Signal signal) => ISignal era val -> (val -> signal era val') -> signal era val' + withInit (ISignal init _) cont = cont init + + updates :: ISignal era val -> DSignal era (Diff val) + updates (ISignal _ upd) = upd + + -- * Conversion + toSSignal :: (Incremental val) => ISignal era val -> SSignal era val + toSSignal (ISignal init upd) = SSignal.scan init patch upd + + monolithicFromSSignal :: SSignal era val -> ISignal era (Monolithic val) + monolithicFromSSignal (SSignal init upd) = ISignal (Monolithic init) (fmap Replacement upd) + + monolithicToSSignal :: ISignal era (Monolithic val) -> SSignal era val + monolithicToSSignal = fmap (\(Monolithic val) -> val) . toSSignal + + -- * Composition + -- analogous to pure + const :: (Incremental val) => val -> ISignal era val + const val = ISignal val DSignal.empty + + -- analogous to fmap + map :: (Incremental val, Incremental val') + => (val -> (val',state)) + -> (Diff val -> state -> (Diff val',state)) + -> (ISignal era val -> ISignal era val') + map start step (ISignal init upd) = ISignal init' upd' where + + (init',initState) = start init + + upd' = DSignal.stateful initState (fmap step upd) + + -- analogous to liftA2 + combine :: (Incremental val1, Incremental val2, Incremental val') + => (val1 -> val2 -> (val',state)) + -> (Diff val1 -> state -> (Diff val',state)) + -> (Diff val2 -> state -> (Diff val',state)) + -> (ISignal era val1 -> ISignal era val2 -> ISignal era val') + combine start step1 step2 (ISignal init1 upd1) (ISignal init2 upd2) = ISignal init' upd' where + + (init',initState) = start init1 init2 + + upd' = DSignal.stateful initState (unionWith transCombine + (fmap step1 upd1) + (fmap step2 upd2)) + transCombine trans1 trans2 state = let + + (diff1',state') = trans1 state + + (diff2',state'') = trans2 state' + + in (diff1' <> diff2',state'') + + -- * Connectors + consumer :: (val -> IO ()) -> (Diff val -> IO ()) -> Consumer ISignal val + consumer initHdlr updHdlr = Consumer $ + proc (ISignal init upd) -> do + putSetup -< Setup.fromIO $ + initHdlr init + consume (DSignal.consumer updHdlr) -< upd diff --git a/src/FRP/Grapefruit/Signal/Incremental/Sequence.hs b/src/FRP/Grapefruit/Signal/Incremental/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Signal/Incremental/Sequence.hs @@ -0,0 +1,295 @@ +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 + 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 + + Diff atomicDiffs1 <> Diff atomicDiffs2 = Diff (atomicDiffs1 `mappend` atomicDiffs2) + + instance Monoid (Diff (Seq el)) where + + mempty = Diff Seq.empty + + mappend = (<>) + + 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" diff --git a/src/FRP/Grapefruit/Signal/Incremental/Set.hs b/src/FRP/Grapefruit/Signal/Incremental/Set.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Signal/Incremental/Set.hs @@ -0,0 +1,275 @@ +module FRP.Grapefruit.Signal.Incremental.Set ( + + -- * Diffs + Diff (Diff), + insertion, + deletion, + elementInsertion, + elementDeletion, + + -- * Construction + empty, + singleton, + + -- * Conversion + -- fromSeqs, + -- fromAscSeqs, + -- fromDistinctAscSeqs, + toSeqs, + toAscSeqs, + + -- * Combination + union, + difference, + intersection, + + -- * Queries + null, + size, + member, + staticMember, + notMember, + staticNotMember, + -- isSubsetOf, + -- also staticIsSubsetOf? + -- isProperSubsetOf, + -- also staticIsProperSubsetOf? + + -- * Filtering + -- filter, + -- staticFilter, + -- partition, + -- staticPartition, + -- split, + -- staticSplit, + -- splitMember, + -- staticSplitMember, + + -- * Mapping + -- map, + -- staticMap, + -- mapMonotonic, + -- staticMapMonotonic + +) where + + -- Prelude + import Prelude hiding (null, filter, map) + + -- Control + import Control.Applicative as Applicative ((<$>), (<*>)) + + -- Data + import Data.Semigroup as Semigroup + import Data.Monoid as Monoid + import qualified Data.List as List + import Data.Set as Set (Set) + import qualified Data.Set as Set + import Data.Sequence as Seq (Seq) + import qualified Data.Sequence as Seq + import Data.Map as Map (Map) + import qualified Data.Map as Map + + -- FRP.Grapefruit + import FRP.Grapefruit.Signal.Segmented as SSignal + import FRP.Grapefruit.Signal.Incremental as ISignal hiding (combine, map) + import qualified FRP.Grapefruit.Signal.Incremental as ISignal + import qualified FRP.Grapefruit.Signal.Incremental.Sequence as SeqISignal + + {-FIXME: + There are several occurences of set union, difference and intersection which involve a set + which is being changed, for example, in patch and combinationDiff. This results in time + linear in the changed set which is very bad. Maybe, we should replace those occurences with + alternative implementations of union, difference and intersection which work by iterating + through the elements of the diff sets. + -} + + -- * Diffs + instance (Ord el) => Incremental (Set el) where + + data Diff (Set el) = Diff (Map el Bool) + + patch set diff = (set `Set.difference` revDiffMap False) `Set.union` revDiffMap True where + + revDiffMap = reverseDiffMap diff + + type ValidationState (Set el) = () + + validationInit _ = () + + validationStep _ _ = Just () + + instance (Ord el) => Semigroup (Diff (Set el)) where + + Diff diffMap1 <> Diff diffMap2 = Diff (diffMap2 `Map.union` diffMap1) + {- + Mind the order of Map.union arguments. Map.union is left-biased and the insertions and + deletions of the second diff must win. + -} + + instance (Ord el) => Monoid (Diff (Set el)) where + + mempty = Diff Map.empty + + mappend = (<>) + + insertion :: (Ord el) => Set el -> Diff (Set el) + insertion = containednessChange True + + deletion :: (Ord el) => Set el -> Diff (Set el) + deletion = containednessChange False + + containednessChange :: (Ord el) => Bool -> Set el -> Diff (Set el) + containednessChange containedness set = Diff $ + Map.fromList [(el,containedness) | el <- Set.toList set] + + elementInsertion :: el -> Diff (Set el) + elementInsertion el = Diff $ Map.singleton el True + + elementDeletion :: el -> Diff (Set el) + elementDeletion el = Diff $ Map.singleton el False + + -- Applying diffSet only to the diff and memoizing the result improves efficiency. + reverseDiffMap :: (Ord el) => Diff (Set el) -> (Bool -> Set el) + reverseDiffMap (Diff diffMap) = \containedness -> if containedness then insertionSet + else deletionSet where + + (insertionMap,deletionMap) = Map.partition id diffMap + + insertionSet = Map.keysSet insertionMap + + deletionSet = Map.keysSet deletionMap + + -- * Construction + empty :: (Ord el) => ISignal era (Set el) + empty = ISignal.const Set.empty + + singleton :: (Ord el) => SSignal era el -> ISignal era (Set el) + singleton = ISignal.map start step . ISignal.monolithicFromSSignal where + + start (Monolithic init) = (Set.singleton init,init) + + step (Replacement el') el = (Diff (Map.fromList [(el,False),(el',True)]),el') + + -- * Conversion + -- fromSeqs :: (Ord el) => ISignal era (Seq el) -> ISignal era (Set el) + + -- fromAscSeqs + + -- fromDistinctAscSeqs + + toSeqs :: (Ord el) => ISignal era (Set el) -> ISignal era (Seq el) + toSeqs = toAscSeqs + + toAscSeqs :: (Ord el) => ISignal era (Set el) -> ISignal era (Seq el) + toAscSeqs = ISignal.map start step where + + start init = ((Seq.fromList . Set.toAscList) init,init) + + step = toAscSeqsStep + + toAscSeqsStep :: (Ord el) => Diff (Set el) -> Set el -> (Diff (Seq el),Set el) + toAscSeqsStep (Diff diffMap) set = (mconcat seqDiffs,last sets) where + + (seqDiffs,nextSets) = unzip $ zipWith atomicStep (Map.toList diffMap) sets + + sets = set : nextSets + + atomicStep (el,False) set = case Set.splitMember el set of + (_,False,_) -> (mempty,set) + (ltSet,True,_) -> (,) (SeqISignal.elementDeletion $ + Set.size ltSet) + (Set.delete el set) + atomicStep (el,True) set = case Set.splitMember el set of + (ltSet,False,_) -> (,) (SeqISignal.elementInsertion + (Set.size ltSet) + el) + (Set.insert el set) + (_,True,_) -> (mempty,set) + + -- * Combination + union :: (Ord el) => ISignal era (Set el) -> ISignal era (Set el) -> ISignal era (Set el) + union = combine True True True Set.union + + difference :: (Ord el) => ISignal era (Set el) -> ISignal era (Set el) -> ISignal era (Set el) + difference = combine False True False Set.difference + + intersection :: (Ord el) => ISignal era (Set el) -> ISignal era (Set el) -> ISignal era (Set el) + intersection = combine False False False Set.intersection + + {-| + Pointwise combination of two incremental set signals. + + Let us assume a function @modify :: Bool -> Set el -> Set el@ where @modify False@ is the + identity function and @modify True@ is the complement function. This function is not + implementable since the complement of a finite set is usually infinite. However, we use this + function for defining the behavior of @combine@. + + Now choose @mod1@, @mod2@, @mod'@ and @setComb@ such that the following holds: + @ + setComb set1 set2 = modify mod' (modify mod1 set1 `Set.intersection` modify mod2 set2) + @ + Then @combine mod1 mod2 mod' setComb@ is the pointwise application of @setComb@. + -} + combine :: (Ord el) + => Bool + -> Bool + -> Bool + -> (Set el -> Set el -> Set el) + -> (ISignal era (Set el) -> ISignal era (Set el) -> ISignal era (Set el)) + combine mod1 mod2 mod' setComb = ISignal.combine start step1 step2 where + + start init1 init2 = (setComb init1 init2,(init1,init2)) + + step1 diff1 (set1,set2) = (,) (combinationDiff mod1 mod2 mod' diff1 set1 set2) + (patch set1 diff1,set2) + + step2 diff2 (set1,set2) = (,) (combinationDiff mod2 mod1 mod' diff2 set2 set1) + (set1,patch set2 diff2) + + combinationDiff :: (Ord el) + => Bool -> Bool -> Bool -> Diff (Set el) -> Set el -> Set el -> Diff (Set el) + combinationDiff diffMod otherMod mod' diff diffSet otherSet = Diff diffMap' where + + diffMap' = Map.unions [consMap containedness (revDiffMap' containedness) | + containedness <- [False,True]] + + revDiffMap' = flip reduce otherSet . reverseDiffMap diff . (/= diffMod) . (/= mod') + + reduce = if otherMod then Set.difference else Set.intersection + + consMap val = Map.fromAscList . List.map (flip (,) val) . Set.toAscList + + -- * Queries + null :: (Ord el) => ISignal era (Set el) -> SSignal era Bool + null = fmap (== 0) . size + + size :: (Ord el) => ISignal era (Set el) -> SSignal era Int + size = fmap Set.size . ISignal.toSSignal + + member :: (Ord el) => SSignal era el -> ISignal era (Set el) -> SSignal era Bool + member els sets = Set.member <$> els <*> ISignal.toSSignal sets + + staticMember :: (Ord el) => el -> ISignal era (Set el) -> SSignal era Bool + staticMember el = monolithicToSSignal . ISignal.map start step where + + start init = let + + contained = Set.member el init + + in (Monolithic contained,contained) + + step (Diff diffMap) contained = let + + contained' = case Map.lookup el diffMap of + Nothing -> contained + Just containedness -> containedness + + in (Replacement contained',contained') + + notMember :: (Ord el) => SSignal era el -> ISignal era (Set el) -> SSignal era Bool + notMember = (fmap not .) . member + + staticNotMember :: (Ord el) => el -> ISignal era (Set el) -> SSignal era Bool + staticNotMember = (fmap not .) . staticMember + diff --git a/src/FRP/Grapefruit/Signal/Segmented.hs b/src/FRP/Grapefruit/Signal/Segmented.hs --- a/src/FRP/Grapefruit/Signal/Segmented.hs +++ b/src/FRP/Grapefruit/Signal/Segmented.hs @@ -8,18 +8,20 @@ -- * Segmented signal type SSignal, - -- * Introduction + -- * Construction + construct, fromInitAndUpdate, - -- * Accessors + -- * Queries withInit, - update, + updates, -- * Stateful signals scan, -- * Connectors - consumer + consumer, + producer ) where diff --git a/src/Internal/CSeg.hs b/src/Internal/CSeg.hs deleted file mode 100644 --- a/src/Internal/CSeg.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# OPTIONS_GHC -fno-cse #-} -module Internal.CSeg ( - - CSeg, - currentValCapsule, - producer - -) where - - -- Control - import Control.Applicative as Applicative - import Control.Arrow as Arrow - import Control.Compose as Compose - import Control.Concurrent.MVar as MVar - - -- Data - import Data.Unique as Unique - - -- System - import System.IO.Unsafe as UnsafeIO - - -- Internal - import Internal.Capsule as Capsule - import Internal.Circuit as Circuit - - -- FRP.Grapefruit - import FRP.Grapefruit.Circuit as Circuit - - newtype CSeg val = CSeg (((->) Unique :. Capsule) val) deriving (Functor, Applicative) - - currentValCapsule :: Unique -> CSeg val -> Capsule val - currentValCapsule currentTimeID (CSeg capsuleGen) = unO capsuleGen currentTimeID - - producer :: IO val -> Circuit era () (CSeg val) - producer readVal = proc _ -> do - maybeValVar <- act -< newMVar Nothing - addECFinalizer <- getECFinalizerAdd -< () - returnA -< CSeg $ - O (unsafeCurrentValCapsule readVal maybeValVar addECFinalizer) - - {-# NOINLINE unsafeCurrentValCapsule #-} - unsafeCurrentValCapsule :: IO val - -> MVar (Maybe val) - -> (IO () -> IO ()) - -> Unique - -> Capsule val - unsafeCurrentValCapsule readVal maybeValVar addECFinalizer timeID = unsafePerformIO $ - seq timeID $ - getCurrentValCapsule where - - getCurrentValCapsule = do - maybeVal <- readMVar maybeValVar - case maybeVal of - Nothing -> do - val <- readVal - putMVar maybeValVar (Just val) - addECFinalizer resetMaybeValVar - return (Applicative.pure val) - justVal@(Just val) -> do - putMVar maybeValVar justVal - return (Applicative.pure val) - - resetMaybeValVar = do - readMVar maybeValVar - putMVar maybeValVar Nothing diff --git a/src/Internal/Capsule.hs b/src/Internal/Capsule.hs deleted file mode 100644 --- a/src/Internal/Capsule.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Internal.Capsule ( - - Capsule (Capsule) - -) where - - -- Control - import Control.Applicative as Applicative - - -- Don’t use newtype since this would defeat the purpose of Capsule. - data Capsule val = Capsule val - - instance Functor Capsule where - - fmap fun (Capsule val) = Capsule (fun val) - - instance Applicative Capsule where - - pure = Capsule - - Capsule fun <*> Capsule arg = Capsule (fun arg) diff --git a/src/Internal/Circuit.hs b/src/Internal/Circuit.hs --- a/src/Internal/Circuit.hs +++ b/src/Internal/Circuit.hs @@ -9,9 +9,7 @@ ) where -- Control -#if __GLASGOW_HASKELL__ >= 610 import Control.Category as Category -#endif import Control.Arrow as Arrow import Control.Arrow.Operations as ArrowOperations import Control.Arrow.Transformer as ArrowTransformer @@ -48,9 +46,7 @@ -} newtype Circuit era i o = Circuit (CircuitArrow i o) deriving ( -#if __GLASGOW_HASKELL__ >= 610 Category, -#endif Arrow, ArrowLoop, ArrowApply diff --git a/src/Internal/ListenerSet.hs b/src/Internal/ListenerSet.hs deleted file mode 100644 --- a/src/Internal/ListenerSet.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Internal.ListenerSet ( - - ListenerSet, - empty, - add, - notify - -) where - - -- Data - import Data.Map (Map) - import qualified Data.Map as Map - import Data.IORef as IORef - - newtype ListenerSet = ListenerSet (Map Int (IO ())) - - empty :: ListenerSet - empty = ListenerSet Map.empty - - add :: IORef ListenerSet -> IO () -> IO (IO ()) - add setRef listener = do - ListenerSet currentMap <- readIORef setRef - let - - newKey | Map.null currentMap = minBound - | otherwise = succ (fst (Map.findMax currentMap)) - - writeIORef setRef - (ListenerSet $ Map.insert newKey listener currentMap) - return $ modifyIORef setRef - (\(ListenerSet map) -> ListenerSet $ - Map.delete newKey map) - - notify :: ListenerSet -> IO () - notify (ListenerSet map) = sequence_ (Map.elems map) diff --git a/src/Internal/Signal.hs b/src/Internal/Signal.hs --- a/src/Internal/Signal.hs +++ b/src/Internal/Signal.hs @@ -5,6 +5,7 @@ -- * Switching switch, + polySwitch, -- * Signal functions SignalFun (OSF, SSF), @@ -12,6 +13,13 @@ unSSF, sfApp, (:->), + PolySignalFun (PolySignalFun), + PolyOSF (PolyOSF), + PolySSF (PolySSF), + polyOSF, + polySSF, + unPolyOSF, + unPolySSF, -- * Signal shapes Of, @@ -48,20 +56,14 @@ infixl 4 #> infixl 4 <# - {-FIXME: - This module as well as others have quite a lot of code for working around problems with - impredicativity and higher-rank polymorphism. I hope that these problems go away with FPH, - so at some day the code should be simplified accordingly. - -} - -- * Signals -- |The class of all signal types. class Signal signal where - osfSwitch :: SSignal era (forall era'. signal era' val) -> + osfSwitch :: SSignal era (PolyOSF signal val) -> signal era val - ssfSwitch :: SSignal era (forall era'. signal era' val -> SignalFun era' shape) -> + ssfSwitch :: SSignal era (PolySSF signal val shape) -> (signal era val -> SignalFun era shape) -- * Switching @@ -88,24 +90,14 @@ corresponds to the usage of rank 2 polymorphism in the type of 'runST'. -} switch :: SSignal era (forall era'. SignalFun era' shape) -> SignalFun era shape - switch = internalSwitch - - -- Level of indirection so that explicit global foralls don’t get into the API docs. - internalSwitch :: forall era shape. - SSignal era (forall era'. SignalFun era' shape) -> SignalFun era shape - internalSwitch funSignal@(SSignal init _) = case init :: SignalFun () shape of - OSF _ -> OSF $ - osfSwitch (fmap polyUnOSF funSignal) - - SSF _ -> SSF $ - ssfSwitch (fmap polyUnSSF funSignal) + switch = polySwitch . fmap PolySignalFun - polyUnOSF :: (forall era. SignalFun era (signal `Of` val)) -> forall era. signal era val - polyUnOSF osf = unOSF osf + polySwitch :: SSignal era (PolySignalFun shape) -> SignalFun era shape + polySwitch funSignal@(SSignal (PolySignalFun init) _) = fun' where - polyUnSSF :: (forall era. SignalFun era (signal `Of` val :-> shape)) - -> forall era. (signal era val -> SignalFun era shape) - polyUnSSF ssf = unSSF ssf + fun' = case init of + OSF _ -> OSF $ osfSwitch (fmap polyOSF funSignal) + SSF _ -> SSF $ ssfSwitch (fmap polySSF funSignal) -- * Signal functions -- FIXME: Hyperlink to :-> and document the data constructors seperately as soon as this works. @@ -172,6 +164,24 @@ to signal functions of shape @/resultShape/@. -} data argShape :-> resultShape + + newtype PolySignalFun shape = PolySignalFun (forall era. SignalFun era shape) + + newtype PolyOSF signal val = PolyOSF (forall era. signal era val) + + newtype PolySSF signal val shape = PolySSF (forall era. signal era val -> SignalFun era shape) + + polyOSF :: PolySignalFun (signal `Of` val) -> PolyOSF signal val + polyOSF (PolySignalFun signalFun) = PolyOSF (unOSF signalFun) + + polySSF :: PolySignalFun (signal `Of` val :-> shape) -> PolySSF signal val shape + polySSF (PolySignalFun signalFun) = PolySSF (unSSF signalFun) + + unPolyOSF :: PolyOSF signal val -> signal era val + unPolyOSF (PolyOSF signal) = signal + + unPolySSF :: PolySSF signal val shape -> signal era val -> SignalFun era shape + unPolySSF (PolySSF fun) = fun -- * Signal shapes -- FIXME: Make :-> a hyperlink when this works. diff --git a/src/Internal/Signal/Continuous/Segment.hs b/src/Internal/Signal/Continuous/Segment.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Continuous/Segment.hs @@ -0,0 +1,65 @@ +{-# OPTIONS_GHC -fno-cse #-} +module Internal.Signal.Continuous.Segment ( + + CSeg, + currentValCapsule, + producer + +) where + + -- Control + import Control.Applicative as Applicative + import Control.Arrow as Arrow + import Control.Compose as Compose + import Control.Concurrent.MVar as MVar + + -- Data + import Data.Unique as Unique + + -- System + import System.IO.Unsafe as UnsafeIO + + -- Internal + import Internal.Signal.Discrete.Capsule as Capsule + import Internal.Circuit as Circuit + + -- FRP.Grapefruit + import FRP.Grapefruit.Circuit as Circuit + + newtype CSeg val = CSeg (((->) Unique :. Capsule) val) deriving (Functor, Applicative) + + currentValCapsule :: Unique -> CSeg val -> Capsule val + currentValCapsule currentTimeID (CSeg capsuleGen) = unO capsuleGen currentTimeID + + producer :: IO val -> Circuit era () (CSeg val) + producer readVal = proc _ -> do + maybeValVar <- act -< newMVar Nothing + addECFinalizer <- getECFinalizerAdd -< () + returnA -< CSeg $ + O (unsafeCurrentValCapsule readVal maybeValVar addECFinalizer) + + {-# NOINLINE unsafeCurrentValCapsule #-} + unsafeCurrentValCapsule :: IO val + -> MVar (Maybe val) + -> (IO () -> IO ()) + -> Unique + -> Capsule val + unsafeCurrentValCapsule readVal maybeValVar addECFinalizer timeID = unsafePerformIO $ + seq timeID $ + getCurrentValCapsule where + + getCurrentValCapsule = do + maybeVal <- takeMVar maybeValVar + case maybeVal of + Nothing -> do + val <- readVal + putMVar maybeValVar (Just val) + addECFinalizer resetMaybeValVar + return (Applicative.pure val) + justVal@(Just val) -> do + putMVar maybeValVar justVal + return (Applicative.pure val) + + resetMaybeValVar = do + takeMVar maybeValVar + putMVar maybeValVar Nothing diff --git a/src/Internal/Signal/Discrete.hs b/src/Internal/Signal/Discrete.hs --- a/src/Internal/Signal/Discrete.hs +++ b/src/Internal/Signal/Discrete.hs @@ -57,11 +57,11 @@ import Data.Map as Map (Map) -- for documentation only -- Internal - import Internal.Capsule as Capsule - import Internal.Vista (Vista) - import qualified Internal.Vista as Vista - import Internal.Signal as Signal - import {-# SOURCE #-} Internal.Signal.Segmented as SSignal + import Internal.Signal as Signal + import Internal.Signal.Discrete.Capsule as Capsule + import Internal.Signal.Discrete.Vista as Vista (Vista) + import qualified Internal.Signal.Discrete.Vista as Vista + import {-# SOURCE #-} Internal.Signal.Segmented as SSignal -- FRP.Grapefruit import FRP.Grapefruit.Setup as Setup @@ -107,17 +107,15 @@ osfSwitch (SSignal init upd) = DSignal vista' where - vista' = Vista.baseSwitch (vista init) (vista (fmap polyVista upd)) + vista' = Vista.baseSwitch ((vista . unPolyOSF) init) (vista (fmap (vista . unPolyOSF) upd)) ssfSwitch (SSignal init upd) arg = signalFun' where - signalFun' = switch (SSignal.fromInitAndUpdate reducedInit reducedUpd) - - reducedInit = init (DSignal (vista arg)) + signalFun' = polySwitch (SSignal.fromInitAndUpdate reducedInit reducedUpd) - reducedUpd = DSignal (polyReducedFunUpdate (vista vistaFunUpd) (vista arg)) + reducedInit = appToVista init (vista arg) - vistaFunUpd = vistaFunSignal upd + reducedUpd = DSignal (Vista.reducedFunUpdate (vista (fmap appToVista upd)) (vista arg)) instance Sampler DSignal where @@ -125,20 +123,11 @@ samplerMap = fmap - polyReducedFunUpdate :: Vista (Vista val -> forall era'. SignalFun era' shape) - -> Vista val - -> Vista (forall era'. SignalFun era' shape) - polyReducedFunUpdate funUpdVista argVista = Vista.reducedFunUpdate funUpdVista argVista - - vistaFunSignal :: DSignal era (forall era'. DSignal era' val -> SignalFun era' shape) - -> DSignal era (Vista val -> forall era'. SignalFun era' shape) - vistaFunSignal = fmap (\dSignalFun vista -> dSignalFun (DSignal vista)) - vista :: DSignal era val -> Vista val - vista (DSignal val) = val + vista (DSignal vista) = vista - polyVista :: (forall era. DSignal era val) -> Vista val - polyVista dSignal = vista dSignal + appToVista :: PolySSF DSignal val shape -> Vista val -> PolySignalFun shape + appToVista fun vista = PolySignalFun (unPolySSF fun (DSignal vista)) -- * Empty signal -- |A signal with no occurrences. @@ -340,9 +329,7 @@ occurence with the occuring value as its argument. -} consumer :: (val -> IO ()) -> Consumer DSignal val - consumer handler = Consumer $ arr dSignalVista >>> Vista.consumer handler where - - dSignalVista (DSignal vista) = vista + consumer handler = Consumer (arr vista >>> Vista.consumer handler) {-| Converts an event handler registration into a discrete signal producer. diff --git a/src/Internal/Signal/Discrete/Capsule.hs b/src/Internal/Signal/Discrete/Capsule.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Discrete/Capsule.hs @@ -0,0 +1,21 @@ +module Internal.Signal.Discrete.Capsule ( + + Capsule (Capsule) + +) where + + -- Control + import Control.Applicative as Applicative + + -- Don’t use newtype since this would defeat the purpose of Capsule. + data Capsule val = Capsule val + + instance Functor Capsule where + + fmap fun (Capsule val) = Capsule (fun val) + + instance Applicative Capsule where + + pure = Capsule + + Capsule fun <*> Capsule arg = Capsule (fun arg) diff --git a/src/Internal/Signal/Discrete/ListenerSet.hs b/src/Internal/Signal/Discrete/ListenerSet.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Discrete/ListenerSet.hs @@ -0,0 +1,35 @@ +module Internal.Signal.Discrete.ListenerSet ( + + ListenerSet, + empty, + add, + notify + +) where + + -- Data + import Data.Map (Map) + import qualified Data.Map as Map + import Data.IORef as IORef + + newtype ListenerSet = ListenerSet (Map Int (IO ())) + + empty :: ListenerSet + empty = ListenerSet Map.empty + + add :: IORef ListenerSet -> IO () -> IO (IO ()) + add setRef listener = do + ListenerSet currentMap <- readIORef setRef + let + + newKey | Map.null currentMap = minBound + | otherwise = succ (fst (Map.findMax currentMap)) + + writeIORef setRef + (ListenerSet $ Map.insert newKey listener currentMap) + return $ modifyIORef setRef + (\(ListenerSet map) -> ListenerSet $ + Map.delete newKey map) + + notify :: ListenerSet -> IO () + notify (ListenerSet map) = sequence_ (Map.elems map) diff --git a/src/Internal/Signal/Discrete/Vista.hs b/src/Internal/Signal/Discrete/Vista.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Discrete/Vista.hs @@ -0,0 +1,285 @@ +module Internal.Signal.Discrete.Vista ( + + Vista, + empty, + transUnion, + stateful, + mapMaybe, + baseSwitch, + reducedFunUpdate, + timeIDApp, + crackCapsules, + consumer, + producer + +) where + + -- Prelude + import Prelude hiding (filter) + + -- Control + import Control.Arrow as Arrow + import Control.Monad as Monad + import Control.Concurrent.Chan as Chan + + -- Data + import Data.Function as Function + import Data.Maybe as Maybe hiding (mapMaybe) + import Data.Map (Map) + import qualified Data.Map as Map + import Data.IORef as IORef + import Data.Unique as Unique + + -- System + import System.IO.Unsafe as UnsafeIO + + -- Internal + import Internal.Signal.Discrete.ListenerSet as ListenerSet (ListenerSet) + import qualified Internal.Signal.Discrete.ListenerSet as ListenerSet + import Internal.Signal.Discrete.Capsule as Capsule + import Internal.Circuit as Circuit + + -- FRP.Grapefruit + import FRP.Grapefruit.Setup as Setup + import FRP.Grapefruit.Circuit as Circuit + + {- FIXME: + + This implementation is a bit inefficient because there is a complete re-registration after + every event the sink listens to. We can make it more efficient by including two additional + fields into Variant describing the difference between the old and the new set of discrete + sources: one set covering the added sources and one covering the removed sources. + + -} + + newtype Vista val = Vista (VistaMap val) + + type VistaMap val = Map DSource (Variant val) + + data DSource = DSource Unique (IORef ListenerSet) + + instance Eq DSource where + + DSource id1 _ == DSource id2 _ = id1 == id2 + + instance Ord DSource where + + compare (DSource id1 _) (DSource id2 _) = compare id1 id2 + + data Variant val = Variant Unique (Maybe val) (Vista val) + + empty :: Vista val + empty = Vista Map.empty + + mapTransUnion :: (Ord key) + => (val1 -> val') + -> (val2 -> val') + -> (val1 -> val2 -> val') + -> (Map key val1 -> Map key val2 -> Map key val') + mapTransUnion conv1 conv2 comb map1 map2 = map' where + + map' = convMap1 `Map.union` convMap2 `Map.union` intersectionMap + + convMap1 = Map.map conv1 (map1 `Map.difference` intersectionMap) + + convMap2 = Map.map conv2 (map2 `Map.difference` intersectionMap) + + intersectionMap = Map.intersectionWith comb map1 map2 + + {- + Maybe it’s better if unionWith isn’t implemented on top of transUnion. Consider the case + that we merge many signals whose discrete source sets don’t overlap. transUnion applies id + linearily many times to the values while a directly implemented unionWith wouldn’t do so. + -} + transUnion :: (val1 -> val') + -> (val2 -> val') + -> (val1 -> val2 -> val') + -> (Vista val1 -> Vista val2 -> Vista val') + transUnion conv1 conv2 comb vista1@(Vista map1) vista2@(Vista map2) = Vista map' where + + map' = mapTransUnion variantConv1 + variantConv2 + variantComb + map1 + map2 + + variantConv1 (Variant timeID1 maybeVal1 nextVista1) = Variant timeID1 + (fmap conv1 maybeVal1) + (this nextVista1 vista2) + + variantConv2 (Variant timeID2 maybeVal2 nextVista2) = Variant timeID2 + (fmap conv2 maybeVal2) + (this vista1 nextVista2) + + variantComb (Variant timeID1 maybeVal1 nextVista1) + (Variant timeID2 maybeVal2 nextVista2) = Variant timeID1 + (maybeComb maybeVal1 + maybeVal2) + (this nextVista1 nextVista2) + + maybeComb Nothing Nothing = Nothing + maybeComb Nothing (Just val2) = Just (conv2 val2) + maybeComb (Just val1) Nothing = Just (conv1 val1) + maybeComb (Just val1) (Just val2) = Just (comb val1 val2) + + this = transUnion conv1 conv2 comb + + stateful :: state -> Vista (state -> (val',state)) -> Vista val' + stateful initState (Vista transMap) = Vista $ Map.map variantConv transMap where + + variantConv (Variant timeID Nothing nextVista) = Variant timeID + Nothing + (stateful initState nextVista) + variantConv (Variant timeID (Just trans) nextVista) = let + + (val',nextState) = trans initState + + in Variant timeID + (Just val') + (stateful nextState + nextVista) + + mapMaybe :: (val -> Maybe val') -> (Vista val -> Vista val') + mapMaybe fun (Vista map) = Vista (Map.map variantConv map) where + + variantConv (Variant timeID maybeVal nextVista) = Variant timeID + (maybeVal >>= fun) + (mapMaybe fun nextVista) + + baseSwitch :: Vista val -> Vista (Vista val) -> Vista val + baseSwitch valVista@(Vista valMap) switchVista@(Vista switchMap) = Vista map' where + + map' = mapTransUnion valConv + switchConv + comb + valMap + switchMap + + valConv (Variant valTimeID + maybeVal + nextValVista) = Variant valTimeID + maybeVal + (baseSwitch nextValVista switchVista) + + switchConv (Variant switchTimeID + Nothing + nextSwitchVista) = Variant switchTimeID + Nothing + (baseSwitch valVista nextSwitchVista) + switchConv (Variant switchTimeID + (Just nextValVista) + nextSwitchVista) = Variant switchTimeID + Nothing + (baseSwitch nextValVista nextSwitchVista) + + comb (Variant valTimeID + maybeVal + nextValVista) + (Variant switchTimeID + Nothing + nextSwitchVista) = Variant valTimeID + maybeVal + (baseSwitch nextValVista nextSwitchVista) + comb (Variant valTimeID + maybeVal + _) + (Variant _ + (Just nextValVista) + nextSwitchVista) = Variant valTimeID + maybeVal + (baseSwitch nextValVista nextSwitchVista) + + reducedFunUpdate :: Vista (Vista val -> fun) -> Vista val -> Vista fun + reducedFunUpdate funUpdVista@(Vista funUpdMap) + argVista@(Vista argMap) = Vista $ reducedMap funUpdMap argMap where + + reducedMap = mapTransUnion funUpdConv argConv comb + + funUpdConv (Variant funTimeID + maybeFunUpd + nextFunUpdVista) = Variant funTimeID + (fmap ($ argVista) maybeFunUpd) + (reducedFunUpdate nextFunUpdVista argVista) + + argConv (Variant argTimeID + maybeArg + nextArgVista) = Variant argTimeID + Nothing + (reducedFunUpdate funUpdVista nextArgVista) + + comb (Variant funTimeID + maybeFunUpd + nextFunUpdVista) + (Variant argTimeID + _ + nextArgVista) = Variant funTimeID + (fmap ($ nextArgVista) maybeFunUpd) + (reducedFunUpdate nextFunUpdVista + nextArgVista) + + timeIDApp :: Vista (Unique -> val) -> Vista val + timeIDApp (Vista map) = Vista $ Map.map variantConv map where + + variantConv (Variant timeID maybeFun nextVista) = Variant timeID + (fmap ($ timeID) maybeFun) + (timeIDApp nextVista) + + -- Reducing the resulting Variant means reducing the capsule. + crackCapsules :: Vista (Capsule val) -> Vista val + crackCapsules (Vista map) = Vista $ Map.map variantConv map where + + variantConv (Variant timeID + Nothing + nextVista) = Variant timeID + Nothing + (crackCapsules nextVista) + variantConv (Variant timeID + (Just (Capsule val)) + nextVista) = Variant timeID + (Just val) + (crackCapsules nextVista) + + consumer :: (val -> IO ()) -> Circuit era (Vista val) () + consumer handler = proc vista -> putSetup -< setup $ + do + unregRef <- newIORef undefined + setDSourceSet handler unregRef vista + return $ join (readIORef unregRef) + + setDSourceSet :: (val -> IO ()) -> IORef (IO ()) -> Vista val -> IO () + setDSourceSet handler unregRef (Vista map) = do + unreg <- mapM (uncurry sourceReg) + (Map.assocs map) + writeIORef unregRef (sequence_ unreg) where + + sourceReg (DSource _ listenersRef) variant = ListenerSet.add listenersRef (handle variant) + + handle (Variant _ maybeVal nextVista) = do + when (isJust maybeVal) + (handler (fromJust maybeVal)) + join (readIORef unregRef) + setDSourceSet handler unregRef nextVista + + producer :: ((val -> IO ()) -> Setup) -> Circuit era () (Vista val) + producer register = proc _ -> do + sourceID <- act -< newUnique + listenersRef <- act -< newIORef ListenerSet.empty + timeIDs <- act -< fix (unsafeInterleaveIO . liftM2 (:) newUnique) + chan <- act -< newChan + vals <- act -< getChanContents chan + ecFinalization <- getECFinalization -< () + putSetup -< register $ \val -> do + writeChan chan val + listeners <- readIORef listenersRef + ListenerSet.notify listeners + ecFinalization + returnA -< sourceVista (DSource sourceID listenersRef) timeIDs vals + + sourceVista :: DSource -> [Unique] -> [val] -> Vista val + sourceVista source timeIDs vals = Vista $ + Map.singleton source (sourceVariant source timeIDs vals) + + sourceVariant :: DSource -> [Unique] -> [val] -> Variant val + sourceVariant source (timeID : nextTimeIDs) (val : nextVals) = variant where + + variant = Variant timeID (Just val) (sourceVista source nextTimeIDs nextVals) diff --git a/src/Internal/Signal/Incremental/Sequence/AtomicDiff.hs b/src/Internal/Signal/Incremental/Sequence/AtomicDiff.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Incremental/Sequence/AtomicDiff.hs @@ -0,0 +1,75 @@ +module Internal.Signal.Incremental.Sequence.AtomicDiff ( + + AtomicDiff (Insertion, Deletion, Shift, Update), + atomicPatch, + lengthDelta, + relocate, + reverse + +) where + + -- Prelude + import Prelude hiding (length, reverse) + + -- Data + import Data.Sequence as Seq (Seq) + import qualified Data.Sequence as Seq + + data AtomicDiff el = Insertion Int (Seq el) + | Deletion Int Int + | Shift Int Int Int + | Update Int (Seq el) + + instance Functor AtomicDiff where + + fmap fun (Insertion idx els) = Insertion idx (fmap fun els) + fmap _ (Deletion idx cnt) = Deletion idx cnt + fmap _ (Shift from cnt to) = Shift from cnt to + fmap fun (Update idx els) = Update idx (fmap fun els) + + atomicPatch :: (Seq el -> stuff) + -> (Int -> stuff -> (stuff,stuff)) + -> (stuff -> stuff -> stuff) + -> (stuff -> AtomicDiff el -> stuff) + atomicPatch fromSeq splitAt (><) = actualPatch where + + actualPatch stuff (Insertion idx els) = insert idx (fromSeq els) stuff + actualPatch stuff (Deletion idx cnt) = take idx stuff >< drop (idx + cnt) stuff + actualPatch stuff (Shift from cnt to) = let + + (front,middleAndBack) = splitAt from stuff + + (middle,back) = splitAt cnt middleAndBack + + in insert to middle (front >< back) + actualPatch stuff (Update idx els) = flip actualPatch (Insertion idx els) $ + flip actualPatch (Deletion idx (Seq.length els)) $ + stuff + + insert idx middle stuff = let + + (front,back) = splitAt idx stuff + + in front >< (middle >< back) + + take = (fst .) . splitAt + + drop = (snd .) . splitAt + + lengthDelta :: AtomicDiff el -> Int + lengthDelta (Insertion _ els) = Seq.length els + lengthDelta (Deletion _ cnt) = negate cnt + lengthDelta (Shift _ _ _) = 0 + lengthDelta (Update _ _) = 0 + + relocate :: Int -> AtomicDiff el -> AtomicDiff el + relocate offset (Insertion idx els) = Insertion (idx + offset) els + relocate offset (Deletion idx cnt) = Deletion (idx + offset) cnt + relocate offset (Shift from cnt to) = Shift (from + offset) cnt (to + offset) + relocate offset (Update idx els) = Update (idx + offset) els + + reverse :: Int -> AtomicDiff el -> AtomicDiff el + reverse len (Insertion idx els) = Insertion (len - idx) (Seq.reverse els) + reverse len (Deletion idx cnt) = Deletion (len - idx - cnt) cnt + reverse len (Shift from cnt to) = Shift (len - from - cnt) cnt (len - to - cnt) + reverse len (Update idx els) = Update (len - idx - Seq.length els) (Seq.reverse els) diff --git a/src/Internal/Signal/Incremental/Sequence/Selection.hs b/src/Internal/Signal/Incremental/Sequence/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Incremental/Sequence/Selection.hs @@ -0,0 +1,96 @@ +module Internal.Signal.Incremental.Sequence.Selection ( + + SeqSel, + fromSeq, + splitAt, + selectionIndex, + selectionInterval, + atomicPatch + +) where + + -- Prelude + import Prelude hiding (splitAt) + + -- Data + import Data.Monoid as Monoid + import Data.Foldable as Foldable + import Data.FingerTree as FingerTree + import Data.Sequence as Seq (Seq) + + -- Internal + import Internal.Signal.Incremental.Sequence.AtomicDiff as AtomicDiff + hiding (atomicPatch) + import qualified Internal.Signal.Incremental.Sequence.AtomicDiff as AtomicDiff + + -- * Pairs of original length and filtered length + newtype Lengths = Lengths (Sum Int,Sum Int) deriving (Monoid) + + lengths :: Int -> Int -> Lengths + lengths origLen selLen = Lengths (Sum origLen,Sum selLen) + + originalLength :: Lengths -> Int + originalLength (Lengths (Sum origLen,_)) = origLen + + selectionLength :: Lengths -> Int + selectionLength (Lengths (_,Sum selLen)) = selLen + + -- * Blocks of multiple bad elements and one good element + newtype Block = Block Int + + instance Measured Lengths Block where + + measure (Block badCnt) = lengths (succ badCnt) 1 + + -- * Sequence selections + data SeqSel = SeqSel (FingerTree Lengths Block) Int + + instance Monoid SeqSel where + + mempty = SeqSel FingerTree.empty 0 + + SeqSel blocks1 end1 `mappend` seqSel2 = SeqSel (blocks1 >< others) end' where + + SeqSel others end' = adjustFront end1 seqSel2 + + fromSeq :: (el -> Bool) -> Seq el -> SeqSel + fromSeq prd = fromList . toList where + + fromList list = case break prd list of + (bads,[]) -> SeqSel FingerTree.empty (length bads) + (bads,ok : list') -> cons (length bads) (fromList list') + + cons :: Int -> SeqSel -> SeqSel + cons badCnt (SeqSel blocks end) = SeqSel (Block badCnt <| blocks) end + + adjustFront :: Int -> SeqSel -> SeqSel + adjustFront delta (SeqSel blocks end) = case viewl blocks of + EmptyL -> SeqSel empty (end + delta) + block :< blocks -> SeqSel (adjBlock block <| blocks) + end + where + + adjBlock (Block badCnt) = Block (badCnt + delta) + + splitAt :: Int -> SeqSel -> (SeqSel,SeqSel) + splitAt idx (SeqSel blocks end) = (SeqSel blocks1 end1,seqSel2) where + + (blocks1,others) = FingerTree.split ((<= idx) . originalLength) blocks + + end1 = idx - originalLength (measure blocks1) + + seqSel2 = adjustFront (negate end1) (SeqSel others end) + + selectionIndex :: SeqSel -> Int -> Int + selectionIndex (SeqSel blocks _) idx = selectionLength $ + measure $ + FingerTree.takeUntil ((<= idx) . originalLength) blocks + + selectionInterval :: SeqSel -> Int -> Int -> (Int,Int) + selectionInterval seqSel idx cnt = (selIdx,selectionIndex seqSel (idx + cnt) - selIdx) where + + selIdx = selectionIndex seqSel idx + + atomicPatch :: (el -> Bool) -> SeqSel -> AtomicDiff el -> SeqSel + atomicPatch prd = AtomicDiff.atomicPatch (fromSeq prd) splitAt mappend + diff --git a/src/Internal/Signal/Segmented.hs b/src/Internal/Signal/Segmented.hs --- a/src/Internal/Signal/Segmented.hs +++ b/src/Internal/Signal/Segmented.hs @@ -3,12 +3,13 @@ -- * Segmented signal type SSignal (SSignal), - -- * Introduction + -- * Construction + construct, fromInitAndUpdate, - -- * Accessors + -- * Queries withInit, - update, + updates, -- * Stateful signals scan, @@ -17,7 +18,8 @@ crackCapsules, -- * Connectors - consumer + consumer, + producer ) where @@ -29,9 +31,9 @@ import Control.Arrow as Arrow -- Internal - import Internal.Capsule as Capsule import Internal.Signal as Signal - import Internal.Signal.Discrete (DSignal) + import Internal.Signal.Discrete.Capsule as Capsule + import Internal.Signal.Discrete as DSignal (DSignal) import qualified Internal.Signal.Discrete as DSignal -- FRP.Grapefruit @@ -99,7 +101,7 @@ instance Signal SSignal where - osfSwitch signal@(SSignal init upd) = case init of + osfSwitch signal@(SSignal init upd) = case unPolyOSF init of SSignal init' _ -> SSignal init' upd' where @@ -107,33 +109,21 @@ ssfSwitch signal arg@(SSignal _ argUpd) = ssfSwitch (fixInit <$> signal <#> arg) argUpd - initUpdate :: DSignal era (forall era'. SSignal era' val) -> DSignal era val - initUpdate upd = DSignal.crackCapsules (fmap polyInitCapsule upd) - - polyInitCapsule :: (forall era'. SSignal era' val) -> Capsule val - polyInitCapsule signal = initCapsule signal + initUpdate :: DSignal era (PolyOSF SSignal val) -> DSignal era val + initUpdate = DSignal.crackCapsules . fmap (initCapsule . unPolyOSF) initCapsule :: SSignal era' val -> Capsule val initCapsule (SSignal init _) = Applicative.pure init - updateSignal :: SSignal era (forall era'. SSignal era' val) - -> SSignal era (forall era'. DSignal era' val) - updateSignal signal = crackCapsules (fmap polyUpdateCapsule signal) - - polyUpdateCapsule :: (forall era'. SSignal era' val) - -> Capsule (forall era'. DSignal era' val) - polyUpdateCapsule signal = signal `seq` polyCapsule (polyUpdate signal) - - polyCapsule :: (forall era'. DSignal era' val) -> Capsule (forall era'. DSignal era' val) - polyCapsule signal = Capsule signal + updateSignal :: SSignal era (PolyOSF SSignal val) + -> SSignal era (PolyOSF DSignal val) + updateSignal signal = crackCapsules (fmap updateCapsule signal) - polyUpdate :: (forall era'. SSignal era' val) -> (forall era'. DSignal era' val) - polyUpdate signal = update signal + updateCapsule :: PolyOSF SSignal val -> Capsule (PolyOSF DSignal val) + updateCapsule signal = unPolyOSF signal `seq` Capsule (PolyOSF (updates (unPolyOSF signal))) - fixInit :: (forall era'. SSignal era' val -> signalFun era' shape) - -> val - -> (forall era'. DSignal era' val -> signalFun era' shape) - fixInit fun init upd = fun (SSignal init upd) + fixInit :: PolySSF SSignal val shape -> val -> PolySSF DSignal val shape + fixInit fun init = PolySSF (unPolySSF fun . SSignal init) instance Sampler SSignal where @@ -159,19 +149,24 @@ upd' = samplerUpd <#> signal - -- * Introduction + -- * Construction {-| Constructs a segmented signal from an initial value and a series of updates. - A signal @fromInitAndUpdate /init/ /upd/@ has initially the value @/init/@. At each - occurence in @/upd/@, it has an update point and changes its value to the value occuring - in @/upd/@. If the segmented signal is interpreted as a kind of discrete signal, - @fromInitAndUpdate@ just adds an initial occurence of @/init/@ to the signal @/upd/@. + A signal @construct /init/ /upd/@ has initially the value @/init/@. At each occurence in + @/upd/@, it has an update point and changes its value to the value occuring in @/upd/@. If + the segmented signal is interpreted as a kind of discrete signal, @fromInitAndUpdate@ just + adds an initial occurence of @/init/@ to the signal @/upd/@. -} + construct :: val -> DSignal era val -> SSignal era val + construct val upd = SSignal val upd + + {-# DEPRECATED fromInitAndUpdate "fromInitAndUpdate is replaced by construct." #-} + -- |Same as 'construct'. fromInitAndUpdate :: val -> DSignal era val -> SSignal era val fromInitAndUpdate val upd = SSignal val upd - -- * Accessors + -- * Queries -- FIXME: Is it safe to support arbitrary signal types here? {-| Applies the second argument to the initial value of the first argument. @@ -191,8 +186,8 @@ If the segmented signal is interpreted as a discrete signal with an additional occurence at the start then @update@ just drops this occurence. -} - update :: SSignal era val -> DSignal era val - update (SSignal _ upd) = upd + updates :: SSignal era val -> DSignal era val + updates (SSignal _ upd) = upd -- * Stateful signals {-| @@ -223,6 +218,24 @@ consumer :: (val -> IO ()) -> Consumer SSignal val consumer handler = Consumer $ proc (SSignal init upd) -> do - putSetup -< setup $ - handler init >> return (return ()) + putSetup -< Setup.fromIO $ handler init consume (DSignal.consumer handler) -< upd + + -- FIXME: Simplify the other consumer and producer docs by documenting function arguments. + {-| + Converts a value read action and a change event handler registration into a segmented signal + producer. + -} + producer :: IO val + -- ^an action reading the current value of the signal + -> (IO () -> Setup) + -- ^ an action which registers a given event handler so that it is called everytime + -- the value of the signal has changed + -> Producer SSignal val + producer readVal changeReg = Producer $ + proc _ -> do + init <- act -< readVal + upd <- produce (DSignal.producer updReg) -< () + returnA -< SSignal init upd where + + updReg handler = changeReg (readVal >>= handler) diff --git a/src/Internal/Vista.hs b/src/Internal/Vista.hs deleted file mode 100644 --- a/src/Internal/Vista.hs +++ /dev/null @@ -1,285 +0,0 @@ -module Internal.Vista ( - - Vista, - empty, - transUnion, - stateful, - mapMaybe, - baseSwitch, - reducedFunUpdate, - timeIDApp, - crackCapsules, - consumer, - producer - -) where - - -- Prelude - import Prelude hiding (filter) - - -- Control - import Control.Arrow as Arrow - import Control.Monad as Monad - import Control.Concurrent.Chan as Chan - - -- Data - import Data.Function as Function - import Data.Maybe as Maybe hiding (mapMaybe) - import Data.Map (Map) - import qualified Data.Map as Map - import Data.IORef as IORef - import Data.Unique as Unique - - -- System - import System.IO.Unsafe as UnsafeIO - - -- Internal - import Internal.ListenerSet (ListenerSet) - import qualified Internal.ListenerSet as ListenerSet - import Internal.Capsule as Capsule - import Internal.Circuit as Circuit - - -- FRP.Grapefruit - import FRP.Grapefruit.Setup as Setup - import FRP.Grapefruit.Circuit as Circuit - - {- FIXME: - - This implementation is a bit inefficient because there is a complete re-registration after - every event the sink listens to. We can make it more efficient by including two additional - fields into Variant describing the difference between the old and the new set of discrete - sources: one set covering the added sources and one covering the removed sources. - - -} - - newtype Vista val = Vista (VistaMap val) - - type VistaMap val = Map DSource (Variant val) - - data DSource = DSource Unique (IORef ListenerSet) - - instance Eq DSource where - - DSource id1 _ == DSource id2 _ = id1 == id2 - - instance Ord DSource where - - compare (DSource id1 _) (DSource id2 _) = compare id1 id2 - - data Variant val = Variant Unique (Maybe val) (Vista val) - - empty :: Vista val - empty = Vista Map.empty - - mapTransUnion :: (Ord key) - => (val1 -> val') - -> (val2 -> val') - -> (val1 -> val2 -> val') - -> (Map key val1 -> Map key val2 -> Map key val') - mapTransUnion conv1 conv2 comb map1 map2 = map' where - - map' = convMap1 `Map.union` convMap2 `Map.union` intersectionMap - - convMap1 = Map.map conv1 (map1 `Map.difference` intersectionMap) - - convMap2 = Map.map conv2 (map2 `Map.difference` intersectionMap) - - intersectionMap = Map.intersectionWith comb map1 map2 - - {- - Maybe it’s better if unionWith isn’t implemented on top of transUnion. Consider the case - that we merge many signals whose discrete source sets don’t overlap. transUnion applies id - linearily many times to the values while a directly implemented unionWith wouldn’t do so. - -} - transUnion :: (val1 -> val') - -> (val2 -> val') - -> (val1 -> val2 -> val') - -> (Vista val1 -> Vista val2 -> Vista val') - transUnion conv1 conv2 comb vista1@(Vista map1) vista2@(Vista map2) = Vista map' where - - map' = mapTransUnion variantConv1 - variantConv2 - variantComb - map1 - map2 - - variantConv1 (Variant timeID1 maybeVal1 nextVista1) = Variant timeID1 - (fmap conv1 maybeVal1) - (this nextVista1 vista2) - - variantConv2 (Variant timeID2 maybeVal2 nextVista2) = Variant timeID2 - (fmap conv2 maybeVal2) - (this vista1 nextVista2) - - variantComb (Variant timeID1 maybeVal1 nextVista1) - (Variant timeID2 maybeVal2 nextVista2) = Variant timeID1 - (maybeComb maybeVal1 - maybeVal2) - (this nextVista1 nextVista2) - - maybeComb Nothing Nothing = Nothing - maybeComb Nothing (Just val2) = Just (conv2 val2) - maybeComb (Just val1) Nothing = Just (conv1 val1) - maybeComb (Just val1) (Just val2) = Just (comb val1 val2) - - this = transUnion conv1 conv2 comb - - stateful :: state -> Vista (state -> (val',state)) -> Vista val' - stateful initState (Vista transMap) = Vista $ Map.map variantConv transMap where - - variantConv (Variant timeID Nothing nextVista) = Variant timeID - Nothing - (stateful initState nextVista) - variantConv (Variant timeID (Just trans) nextVista) = let - - (val',nextState) = trans initState - - in Variant timeID - (Just val') - (stateful nextState - nextVista) - - mapMaybe :: (val -> Maybe val') -> (Vista val -> Vista val') - mapMaybe fun (Vista map) = Vista (Map.map variantConv map) where - - variantConv (Variant timeID maybeVal nextVista) = Variant timeID - (maybeVal >>= fun) - (mapMaybe fun nextVista) - - baseSwitch :: Vista val -> Vista (Vista val) -> Vista val - baseSwitch valVista@(Vista valMap) switchVista@(Vista switchMap) = Vista map' where - - map' = mapTransUnion valConv - switchConv - comb - valMap - switchMap - - valConv (Variant valTimeID - maybeVal - nextValVista) = Variant valTimeID - maybeVal - (baseSwitch nextValVista switchVista) - - switchConv (Variant switchTimeID - Nothing - nextSwitchVista) = Variant switchTimeID - Nothing - (baseSwitch valVista nextSwitchVista) - switchConv (Variant switchTimeID - (Just nextValVista) - nextSwitchVista) = Variant switchTimeID - Nothing - (baseSwitch nextValVista nextSwitchVista) - - comb (Variant valTimeID - maybeVal - nextValVista) - (Variant switchTimeID - Nothing - nextSwitchVista) = Variant valTimeID - maybeVal - (baseSwitch nextValVista nextSwitchVista) - comb (Variant valTimeID - maybeVal - _) - (Variant _ - (Just nextValVista) - nextSwitchVista) = Variant valTimeID - maybeVal - (baseSwitch nextValVista nextSwitchVista) - - reducedFunUpdate :: Vista (Vista val -> fun) -> Vista val -> Vista fun - reducedFunUpdate funUpdVista@(Vista funUpdMap) - argVista@(Vista argMap) = Vista $ reducedMap funUpdMap argMap where - - reducedMap = mapTransUnion funUpdConv argConv comb - - funUpdConv (Variant funTimeID - maybeFunUpd - nextFunUpdVista) = Variant funTimeID - (fmap ($ argVista) maybeFunUpd) - (reducedFunUpdate nextFunUpdVista argVista) - - argConv (Variant argTimeID - maybeArg - nextArgVista) = Variant argTimeID - Nothing - (reducedFunUpdate funUpdVista nextArgVista) - - comb (Variant funTimeID - maybeFunUpd - nextFunUpdVista) - (Variant argTimeID - _ - nextArgVista) = Variant funTimeID - (fmap ($ nextArgVista) maybeFunUpd) - (reducedFunUpdate nextFunUpdVista - nextArgVista) - - timeIDApp :: Vista (Unique -> val) -> Vista val - timeIDApp (Vista map) = Vista $ Map.map variantConv map where - - variantConv (Variant timeID maybeFun nextVista) = Variant timeID - (fmap ($ timeID) maybeFun) - (timeIDApp nextVista) - - -- Reducing the resulting Variant means reducing the capsule. - crackCapsules :: Vista (Capsule val) -> Vista val - crackCapsules (Vista map) = Vista $ Map.map variantConv map where - - variantConv (Variant timeID - Nothing - nextVista) = Variant timeID - Nothing - (crackCapsules nextVista) - variantConv (Variant timeID - (Just (Capsule val)) - nextVista) = Variant timeID - (Just val) - (crackCapsules nextVista) - - consumer :: (val -> IO ()) -> Circuit era (Vista val) () - consumer handler = proc vista -> putSetup -< setup $ - do - unregRef <- newIORef undefined - setDSourceSet handler unregRef vista - return $ join (readIORef unregRef) - - setDSourceSet :: (val -> IO ()) -> IORef (IO ()) -> Vista val -> IO () - setDSourceSet handler unregRef (Vista map) = do - unreg <- mapM (uncurry sourceReg) - (Map.assocs map) - writeIORef unregRef (sequence_ unreg) where - - sourceReg (DSource _ listenersRef) variant = ListenerSet.add listenersRef (handle variant) - - handle (Variant _ maybeVal nextVista) = do - when (isJust maybeVal) - (handler (fromJust maybeVal)) - join (readIORef unregRef) - setDSourceSet handler unregRef nextVista - - producer :: ((val -> IO ()) -> Setup) -> Circuit era () (Vista val) - producer register = proc _ -> do - sourceID <- act -< newUnique - listenersRef <- act -< newIORef ListenerSet.empty - timeIDs <- act -< fix (unsafeInterleaveIO . liftM2 (:) newUnique) - chan <- act -< newChan - vals <- act -< getChanContents chan - ecFinalization <- getECFinalization -< () - putSetup -< register $ \val -> do - writeChan chan val - listeners <- readIORef listenersRef - ListenerSet.notify listeners - ecFinalization - returnA -< sourceVista (DSource sourceID listenersRef) timeIDs vals - - sourceVista :: DSource -> [Unique] -> [val] -> Vista val - sourceVista source timeIDs vals = Vista $ - Map.singleton source (sourceVariant source timeIDs vals) - - sourceVariant :: DSource -> [Unique] -> [val] -> Variant val - sourceVariant source (timeID : nextTimeIDs) (val : nextVals) = variant where - - variant = Variant timeID (Just val) (sourceVista source nextTimeIDs nextVals)