grapefruit-frp 0.0.0.0 → 0.1.0.0
raw patch · 23 files changed
+1479/−561 lines, 23 filesdep +fingertreedep +semigroupsdep ~TypeComposedep ~basedep ~containers
Dependencies added: fingertree, semigroups
Dependency ranges changed: TypeCompose, base, containers
Files
- LICENSE +1/−0
- grapefruit-frp.cabal +36/−23
- src/FRP/Grapefruit/Setup.hs +5/−0
- src/FRP/Grapefruit/Signal.hs +8/−0
- src/FRP/Grapefruit/Signal/Continuous.hs +17/−36
- src/FRP/Grapefruit/Signal/Incremental.hs +161/−0
- src/FRP/Grapefruit/Signal/Incremental/Sequence.hs +295/−0
- src/FRP/Grapefruit/Signal/Incremental/Set.hs +275/−0
- src/FRP/Grapefruit/Signal/Segmented.hs +6/−4
- src/Internal/CSeg.hs +0/−65
- src/Internal/Capsule.hs +0/−21
- src/Internal/Circuit.hs +0/−4
- src/Internal/ListenerSet.hs +0/−35
- src/Internal/Signal.hs +34/−24
- src/Internal/Signal/Continuous/Segment.hs +65/−0
- src/Internal/Signal/Discrete.hs +13/−26
- src/Internal/Signal/Discrete/Capsule.hs +21/−0
- src/Internal/Signal/Discrete/ListenerSet.hs +35/−0
- src/Internal/Signal/Discrete/Vista.hs +285/−0
- src/Internal/Signal/Incremental/Sequence/AtomicDiff.hs +75/−0
- src/Internal/Signal/Incremental/Sequence/Selection.hs +96/−0
- src/Internal/Signal/Segmented.hs +51/−38
- src/Internal/Vista.hs +0/−285
LICENSE view
@@ -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
grapefruit-frp.cabal view
@@ -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
src/FRP/Grapefruit/Setup.hs view
@@ -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 ())
src/FRP/Grapefruit/Signal.hs view
@@ -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,
src/FRP/Grapefruit/Signal/Continuous.hs view
@@ -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
+ src/FRP/Grapefruit/Signal/Incremental.hs view
@@ -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
+ src/FRP/Grapefruit/Signal/Incremental/Sequence.hs view
@@ -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"
+ src/FRP/Grapefruit/Signal/Incremental/Set.hs view
@@ -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+
src/FRP/Grapefruit/Signal/Segmented.hs view
@@ -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
− src/Internal/CSeg.hs
@@ -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
− src/Internal/Capsule.hs
@@ -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)
src/Internal/Circuit.hs view
@@ -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
− src/Internal/ListenerSet.hs
@@ -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)
src/Internal/Signal.hs view
@@ -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.
+ src/Internal/Signal/Continuous/Segment.hs view
@@ -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
src/Internal/Signal/Discrete.hs view
@@ -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.
+ src/Internal/Signal/Discrete/Capsule.hs view
@@ -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)
+ src/Internal/Signal/Discrete/ListenerSet.hs view
@@ -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)
+ src/Internal/Signal/Discrete/Vista.hs view
@@ -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)
+ src/Internal/Signal/Incremental/Sequence/AtomicDiff.hs view
@@ -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)
+ src/Internal/Signal/Incremental/Sequence/Selection.hs view
@@ -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+
src/Internal/Signal/Segmented.hs view
@@ -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)
− src/Internal/Vista.hs
@@ -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)