diff --git a/SimpleH.cabal b/SimpleH.cabal --- a/SimpleH.cabal +++ b/SimpleH.cabal @@ -1,6 +1,6 @@ name: SimpleH -version: 0.9 +version: 0.9.1 synopsis: A light, clean and powerful Haskell utility library description: SimpleH is a Prelude complement that defines a few very useful abstractions, such as Monad transformers, Lenses, parser combinators, reactive abstractions and a few others. license: BSD3 @@ -17,6 +17,7 @@ build-depends: base ==4.6.*, containers ==0.5.*, clock ==0.3.* hs-source-dirs: src extensions: TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts, FunctionalDependencies + ghc-options: -W source-repository head type: git location: git://github.com/lih/SimpleH.git diff --git a/src/SimpleH/Applicative.hs b/src/SimpleH/Applicative.hs --- a/src/SimpleH/Applicative.hs +++ b/src/SimpleH/Applicative.hs @@ -33,6 +33,11 @@ join ~(w,~(w',a)) = (w+w',a) instance Applicative [] instance Monad [] where join = fold + +instance (Unit f,Unit g) => Unit (FProd f g) where pure a = FProd (pure a,pure a) +instance (Applicative f,Applicative g) => Applicative (FProd f g) where + FProd ~(ff,fg) <*> FProd ~(xf,xg) = FProd (ff<*>xf,fg<*>xg) + instance Applicative Tree instance Monad Tree where join (Node (Node a subs) subs') = Node a (subs + map join subs') @@ -79,14 +84,14 @@ deriving instance Unit f => Unit (Backwards f) deriving instance Functor f => Functor (Backwards f) instance Applicative f => Applicative (Backwards f) where - Backwards fs <*> Backwards xs = Backwards (xs<**>fs) + Backwards fs <*> Backwards xs = Backwards (fs<**>xs) ap = (<*>) infixl 2 <*,*> -infixl 3 <**> +infixl 2 <**> (*>) = liftA2 (flip const) (<*) = liftA2 const -(<**>) = liftA2 (&) +f <**> x = liftA2 (&) x f sequence_ = foldr (*>) (pure ()) traverse_ :: (Applicative f,Foldable t) => (a -> f b) -> t a -> f () traverse_ f = sequence_ . map f diff --git a/src/SimpleH/Core.hs b/src/SimpleH/Core.hs --- a/src/SimpleH/Core.hs +++ b/src/SimpleH/Core.hs @@ -25,7 +25,8 @@ comparing,tailSafe,headDef, - inOrder,insertOrd,invertOrd, + Orderable(..), + insertOrd,invertOrd, -- * The rest is imported from the Prelude module Prelude @@ -118,6 +119,8 @@ one = zero:one (a:as) * (b:bs) = a+b:as*bs _ * _ = zero +instance (Ring a,Ring b) => Ring (a:*:b) where + one = (one,one) ; ~(a,b) * ~(c,d) = (a*c,b*d) class Unit f where pure :: a -> f a @@ -160,7 +163,7 @@ {-| A monoid on category endomorphisms under composition -} newtype Endo k a = Endo { runEndo :: k a a } -instance Category k => Semigroup (Endo k a) where Endo f+Endo g = Endo (f . g) +instance Category k => Semigroup (Endo k a) where Endo f+Endo g = Endo (g . f) instance Category k => Monoid (Endo k a) where zero = Endo id {-| A monoid on Maybes, where the sum is the leftmost non-Nothing value. -} @@ -174,8 +177,12 @@ {-| The Max monoid, where @(+) =~ max@ -} newtype Max a = Max { getMax :: a } + deriving (Eq,Ord,Bounded,Show) instance Ord a => Semigroup (Max a) where Max a+Max b = Max (max a b) instance (Ord a,Bounded a) => Monoid (Max a) where zero = Max minBound +instance (Ord a,Bounded a) => Ring (Max a) where + one = Max maxBound + Max a * Max b = Max (min a b) {-| The dual of a monoid is the same as the original, with arguments reversed -} newtype Dual m = Dual { getDual :: m } @@ -188,17 +195,27 @@ -- |An ordered list. The semigroup instance merges two lists so that -- the result remains in ascending order. newtype OrdList a = OrdList { getOrdList :: [a] } -instance Ord a => Semigroup (OrdList a) where + deriving (Eq,Ord,Show) +instance Orderable a => Semigroup (OrdList a) where OrdList a + OrdList b = OrdList (a ++ b) - where (x:xt) ++ (y:yt) = m : insertOrd m' xt ++ yt - where (m,m') = inOrder x y + where (x:xt) ++ (y:yt) = a : c : cs + where (a,_,z) = inOrder x y + ~(c:cs) = if z then xt ++ (y:yt) else (x:xt) ++ yt a ++ b = a + b -deriving instance Ord a => Monoid (OrdList a) +deriving instance Orderable a => Monoid (OrdList a) deriving instance Unit OrdList +class Ord t => Orderable t where + inOrder :: t -> t -> (t,t,Bool) +instance Ord t => Orderable (Max t) where + inOrder (Max a) (Max b) = (Max x,Max y,z) + where ~(x,y) | z = (a,b) + | otherwise = (b,a) + z = a<=b insertOrd e [] = [e] -insertOrd e (x:xs) = a:insertOrd b xs - where (a,b) = inOrder e x +insertOrd e (x:xs) = a:y:ys + where (a,_,z) = inOrder e x + ~(y:ys) = if z then x:xs else insertOrd e xs newtype Interleave a = Interleave { interleave :: [a] } instance Semigroup (Interleave a) where @@ -230,9 +247,5 @@ unit = pure () when p m = if p then m else unit unless p m = if p then unit else m - -inOrder a b = (min,max) - where ~(min,max) | a<=b = (a,b) - | otherwise = (b,a) invertOrd GT = LT ; invertOrd LT = GT ; invertOrd EQ = EQ diff --git a/src/SimpleH/Foldable.hs b/src/SimpleH/Foldable.hs --- a/src/SimpleH/Foldable.hs +++ b/src/SimpleH/Foldable.hs @@ -42,7 +42,7 @@ split = foldMap ((,zero)<|>(zero,)) partitionEithers :: (Foldable t,Unit t,Monoid (t a),Monoid (t b)) => t (a:+:b) -> (t a,t b) -partitionEithers = split . map (Left . pure<|>Right . pure) +partitionEithers = split . map (pure|||pure) partition p = split . map (\a -> (if p a then Left else Right) (pure a)) filter p = fst . partition p select = filter @@ -50,9 +50,9 @@ compose = runEndo . foldMap Endo -foldl :: Foldable t => (a -> b -> a) -> a -> t b -> a -foldl f e t = (runEndo . getDual) (foldMap (\b -> Dual (Endo (\a -> f a b))) t) e -foldr f e t = runEndo (foldMap (\b -> Endo (f b)) t) e +foldr :: Foldable t => (b -> a -> a) -> a -> t b -> a +foldr f e t = (runEndo . getDual) (foldMap (\b -> Dual (Endo (f b))) t) e +foldl' f e t = runEndo (foldMap (\b -> Endo (\a -> a`seq`f a b)) t) e find :: Foldable t => (a -> Bool) -> t a -> Maybe a find p = foldMap (filter p . Id) diff --git a/src/SimpleH/Functor.hs b/src/SimpleH/Functor.hs --- a/src/SimpleH/Functor.hs +++ b/src/SimpleH/Functor.hs @@ -3,7 +3,7 @@ module SimpleH.Functor( Functor(..),Cofunctor(..),Bifunctor(..), - Id(..),Const(..),Flip(..),Compose(..), + Id(..),Const(..),Flip(..),Compose(..),FProd(..),Sum(..), (<$>),(|||),(<$),(<&>),void,left,right, promap,map2,map3 @@ -62,11 +62,11 @@ map f = FProd . (map f <#> map f) . getFProd newtype Sum f g a = Sum { getSum :: f a:+:g a } instance (Functor f,Functor g) => Functor (Sum f g) where - map f = Sum . ((Left<$>map f) <|> (Right<$>map f)) . getSum + map f = Sum . (map f ||| map f) . getSum instance Functor (Either b) where map f = Left <|> Right . f instance Functor Maybe where map _ Nothing = Nothing; map f (Just a) = Just (f a) -instance Functor ((,) b) where map f (b,a) = (b,f a) +instance Functor ((,) b) where map f ~(b,a) = (b,f a) instance Functor ((->) a) where map = (.) deriving instance Functor Interleave deriving instance Functor OrdList diff --git a/src/SimpleH/Lens.hs b/src/SimpleH/Lens.hs --- a/src/SimpleH/Lens.hs +++ b/src/SimpleH/Lens.hs @@ -25,7 +25,7 @@ iso,from,lens,getter,prism, -- * Extracting values - (^.),(^..),(^?),(%~),(%-),at,at',warp,set, + (^.),(^..),(^?),(%~),(%-),(%%~),(%%-),at,at',warp,set, (-.),(.-), -- * Basic lenses @@ -100,12 +100,16 @@ prism f g = \k a -> (pure <|> map (g a) . k) (f a) -- |Retrieve a value from a structure using a 'Lens' (or 'Iso') -infixl 8 ^.,^..,^?,%~ +infixl 8 ^.,^..,^?,%~,%-,%%~,%%- (^.) = flip at (^..) = flip at' -- | (%~) = warp +(%%~) :: Iso s t a b -> (b -> a) -> (t -> s) +(%%~) i = warp (from i) (%-) = set +(%%-) :: Iso s t a b -> a -> (t -> s) +(%%-) i = set (from i) (^?) :: (Unit f,Monoid (f b)) => a -> Traversal' a b -> f b x^?l = getConst $ l (Const . pure) x @@ -140,6 +144,8 @@ _each k (a,a') = (,)<$>k a<*>k a' instance Compound a b (a,a,a) (b,b,b) where _each k (a,a',a'') = (,,)<$>k a<*>k a'<*>k a'' +instance Compound a b (a:+:a) (b:+:b) where + _each k = map Left . k <|> map Right . k _list :: [a] :<->: (():+:(a:*:[a])) _list = iso (\l -> case l of [] -> Left () @@ -179,7 +185,7 @@ instance Isomorphic a b (Void,a) (Void,b) where _iso = iso (vd,) snd _Id = _iso :: Iso' a (Id a) -_OrdList = _iso :: Iso' [a] (OrdList a) +_OrdList = _iso :: Iso (OrdList a) (OrdList b) [a] [b] _Dual = _iso :: Iso' a (Dual a) _Const = _iso :: Iso' a (Const a b) _Max = _iso :: Iso' a (Max a) diff --git a/src/SimpleH/Monad.hs b/src/SimpleH/Monad.hs --- a/src/SimpleH/Monad.hs +++ b/src/SimpleH/Monad.hs @@ -16,6 +16,7 @@ -- *** The State Monad MonadState(..), + IOLens,_ioref,_mvar, StateT,State, _stateT,eval,exec,_state, (=~),(=-),gets,saving, @@ -56,6 +57,8 @@ import SimpleH.Lens import qualified Control.Exception as Ex import qualified Control.Monad.Fix as Fix +import Data.IORef +import Control.Concurrent instance (Traversable g,Monad f,Monad g) => Monad (Compose f g) where join = Compose .map join.join.map sequence.getCompose.map getCompose @@ -96,7 +99,7 @@ foldlM = folding (_Kleisli._Endo._Dual) foldrM = folding (_Kleisli._Endo) -while e = fix (\w -> e >>= maybe (return()) (const w)) +while e = fix (\w -> e >>= maybe unit (const w)) until e = fix (\w -> e >>= maybe w return) infixr 2 >>,=<< @@ -105,7 +108,7 @@ (=<<) = flip (>>=) f <=< g = \a -> g a >>= f (>=>) = flip (<=<) -a <*= f = a >>= \a -> f a >> return a +a <*= f = a >>= (>>)<$>f<*>return return = pure newtype RWST r w s m a = RWST { runRWST :: (r,s) -> m (a,s,w) } @@ -134,7 +137,7 @@ deriving instance Ring (m (a,s,w)) => Ring (RWST r w s m a) instance (Monad m,Monoid w) => MonadState s (RWST r w s m) where get = RWST (\ ~(_,s) -> pure (s,s,zero) ) - put s = RWST (\ ~(_,_) -> pure ((),s,zero) ) + put s = RWST (\ _ -> pure ((),s,zero) ) modify f = RWST (\ ~(_,s) -> pure ((),f s,zero) ) instance (Monad m,Monoid w) => MonadReader r (RWST r w s m) where ask = RWST (\ ~(r,s) -> pure (r,s,zero) ) @@ -165,6 +168,16 @@ put = modify . const modify :: (s -> s) -> m () modify f = get >>= put . f +instance MonadState (IO ()) IO where + get = return unit + put a = a + modify f = put (f unit) +type IOLens a = Lens' (IO ()) (IO a) +_ioref :: IORef a -> IOLens a +_ioref r = lens (const (readIORef r)) (\x a -> x >> a >>= writeIORef r) +_mvar :: MVar a -> IOLens a +_mvar r = lens (const (readMVar r)) (\x a -> x >> a >>= putMVar r) + get_ = lift get ; put_ = lift . put ; modify_ = lift . modify newtype StateT s m a = StateT (RWST Void Void s m a) diff --git a/src/SimpleH/Reactive.hs b/src/SimpleH/Reactive.hs --- a/src/SimpleH/Reactive.hs +++ b/src/SimpleH/Reactive.hs @@ -4,16 +4,16 @@ module SimpleH.Reactive.TimeVal, -- * Reactive Events - Event,_event, + Event,_event,Reactive(..), -- ** Contructing events - atTimes, + atTimes,mkEvent, withTime,times, mapFutures, -- ** Combining events - (//),(<|*>), - + (//),(<|*>),(<*|>), + -- ** Filtering events groupE,mask, @@ -32,34 +32,47 @@ import SimpleH.Reactive.Time -- |An event (a list of time-value pairs of increasing times) -newtype Event t a = Event { getEvent :: Compose [] (Future t) a } +newtype Event t a = Event { getEvent :: Compose OrdList (Future t) a } deriving (Unit,Functor,Foldable,Traversable) +data Reactive t a = Reactive a (Event t a) +instance Ord t => Unit (Reactive t) where + pure a = Reactive a zero +instance Functor (Reactive t) where + map f (Reactive a e) = Reactive (f a) (map f e) +instance Ord t => Applicative (Reactive t) where + Reactive f fs <*> Reactive x xs = Reactive (f x) (cons f fs<*>cons x xs) + where cons a = _event %%~ tail . ((minBound,a)^._future :) + instance (Ord t,Show t,Show a) => Show (Event t a) where show = show . at' _event instance Ord t => Semigroup (Event t a) where - (+) = warp2 (from _event._OrdList) (+) + (+) = warp2 (from _Event) (+) instance Ord t => Monoid (Event t a) where zero = []^._event -instance (Bounded t,Ord t) => Applicative (Event t) where - fe@(at' _event -> f:_) <*> xe@(at' _event -> x:_) = mapAccum_ fun (e^.._event) (f,x) ^. _event - where fun mod = at' _state $ modify ((const +++ const) (sequenceEither mod)) - >> uncurry (<*>)<$>get - e = (Left<$>mapFutures (x>>) fe) + (Right<$>mapFutures (f>>) xe) +instance Ord t => Applicative (Event t) where + fe@(at' _event -> f:_) <*> xe@(at' _event -> x:_) = + (traverse (at _state) e)^.._state & \st -> + br ((f^._time)+(x^._time)) (snd (st (f^._value,x^._value))) + where e = map (\f (_,x) -> ((f,x),f x)) fe + + map (\x (f,_) -> ((f,x),f x)) xe + br t (at' _event -> e) = (map (_time %- t) b + a)^._event + where (b,a) = span (\f -> f^._time _ = zero -instance (Bounded t,Ord t) => Monad (Event t) where - join = map (at' _event) >>> at' _event >>> map (sequence >>> map join >>> group >>> map last) +instance Ord t => Monad (Event t) where + join = map (at' _event) >>> at' _event >>> map (sequence >>> map join) >>> merge >>> at _event where merge [] = [] + merge [t] = t merge ([]:t) = merge t - merge ((x:xs):t) = x:merge (insertOrd xs t) -pureEither :: (forall a. a -> f a) -> Either a b -> Either (f a) (f b) -pureEither f = f ||| f -sequenceEither f = pureEither ((f^._time,)>>>at _future) (f^._value) + merge ((x:xs):ys:t) = x:merge (sum xs ys : t) + where sum = warp2 _OrdList (+) -type EventRep t a = Compose [] (Future t) a +type EventRep t a = OrdList (Future t a) _Event :: Iso (Event t a) (Event t' b) (EventRep t a) (EventRep t' b) -_Event = iso Event getEvent +_Event = _Compose.iso Event getEvent _event :: Iso (Event t a) (Event t' b) [Future t a] [Future t' b] -_event = _Compose._Event -atTimes ts = map (at _future . (,()) . pure . pure) ts^._event +_event = _OrdList._Event +atTimes ts = (ts <&> \t -> (pure t,())^._future)^._event +mkEvent as = (as <&> at _future . (_1 %~ pure))^._event {-| The \'splice\' operator. Occurs when @a@ occurs. @@ -68,7 +81,7 @@ (//) :: Ord t => Event t a -> Event t b -> Event t (a, Event t b) bs // es = mapAccum_ fun (bs^.._event) (es^.._event) ^. _event where fun b es = (ys,b & _value %~ (,xs^._event)) - where (xs,ys) = span ((==GT) . cmpFut b) es + where (xs,ys) = span (flip ltFut b) es infixl 1 // {-| @@ -76,17 +89,22 @@ > at t: a <|*> (bi,b) = a <*> (minBound,bi):b -} -(<|*>) :: Ord t => Event t (a -> b) -> (a,Event t a) -> Event t b -fs <|*> (a,as) = (traverse tr (fs // as) ^.. _state <&> snd) a - where tr (f,as) = traverse_ put as >> map f get -infixl 2 <|*> +(<*|>) :: Ord t => Event t (a -> b) -> Reactive t a -> Event t b +fs <*|> Reactive a as = (traverse tr (fs // as) ^.. _state <&> snd) a + where tr (f,as) = traverse_ put as >> f<$>get +infixl 2 <*|> +(<|*>) :: Ord t => Reactive t (a -> b) -> Event t a -> Event t b +f <|*> a = (&)<$>a<*|>f +infixr 1 <|*> -- |Group the occurences of an event by equality. Occurs when the first occurence of a group occurs. -groupE = from _event %~ groupE . (+repeat (Future (maxBound,undefined))) - where groupE fs = (f & _value %- xs) : (groupE ys & _head._time %~ (sum (at _time<$>xs)+)) +groupE = _event %%~ groupE . (+repeat (Future (maxBound,undefined))) + where groupE fs = (f & _value %- xs):(z & _time %~ (sum (at _time<$>xs)+)):zs where (xs,ys) = span ((==f^._value) . at _value) fs ; f = head fs + ~(z:zs) = groupE ys + sum = foldl' (+) zero -mapFutures f = from _event %~ map f +mapFutures f = _event %%~ map f withTime = mapFutures (\(Future f) -> Future (_1%~timeVal <$> listen f)) times = map2 fst withTime @@ -95,16 +113,20 @@ -- |Sinks an action event into the Real World. Each action is executed sink l = for_ (withTime l) $ \(Since t,v) -> waitTill t >> v event m = at _event<$>event' zero - where event' t = do - Future ~(t',a) <- futureIO (timeVal t `seq` m) - fs <- unsafeInterleaveIO $ event' t' - return (Future (t',a):fs) + where event' t = unsafeInterleaveIO $ do + f <- futureIO (timeVal t `seq` m) + fs <- event' (f^._time) + return (f:fs) -- |A Future value (a value with a timestamp) newtype Future t a = Future (Time t,a) deriving (Show,Functor,Unit,Applicative,Traversable,Foldable,Monad,Semigroup,Monoid) instance Ord t => Eq (Future t a) where f == f' = compare f f'==EQ instance Ord t => Ord (Future t a) where compare = cmpFut +instance Ord t => Orderable (Future t a) where + inOrder (Future (t,a)) (Future (t',b)) = (Future (tx,x),Future (ty,y),z) + where (tx,ty,z) = inOrder t t' + ~(x,y) = if z then (a,b) else (b,a) _future :: Iso (Future t a) (Future t' b) (Time t,a) (Time t',b) _future = iso Future (\(Future ~(t,a)) -> (t,a)) _time :: Lens (Time t) (Time t') (Future t a) (Future t' a) @@ -113,6 +135,7 @@ _value = from _future._2 cmpFut :: Ord t => Future t a -> Future t b -> Ordering cmpFut a b = compare (a^._time) (b^._time) +ltFut a b = cmpFut a b == LT futureIO :: IO a -> IO (Future Seconds a) futureIO m = do val <- newEmptyMVar diff --git a/src/SimpleH/Reactive/Time.hs b/src/SimpleH/Reactive/Time.hs --- a/src/SimpleH/Reactive/Time.hs +++ b/src/SimpleH/Reactive/Time.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TupleSections, RecursiveDo #-} +{-# LANGUAGE TupleSections, RecursiveDo, RankNTypes #-} module SimpleH.Reactive.Time ( -- * Unambiguous times Time, @@ -6,7 +6,7 @@ -- * Time utilities Seconds, - timeIO,waitTill,currentTime, + timeIO,waitTill,currentTime ) where import SimpleH @@ -15,53 +15,79 @@ import System.IO.Unsafe import Data.IORef import System.Clock -import Control.Exception (AsyncException(..)) -type MinMax t = (t,t) +type Bounds t = (t,t) type PartCmp t = t -> IO t -- |A repeatable action that converges to a single point type Improve a = IO a -- |An action that creates a new value upon each call type New a = IO a -- |A type wrappers for timestamps that can be compared unambiguously -newtype Time t = Time (New (Improve (PartCmp (MinMax (TimeVal t))))) +newtype Time t = Time (New (Improve (PartCmp (Bounds (TimeVal t))))) +_Time = iso Time (\(Time t) -> t) instance (Eq t,Show t) => Show (Time t) where show = show . timeVal instance Ord t => Eq (Time t) where a == b = compare a b == EQ instance Ord t => Ord (Time t) where compare (Time ta) (Time tb) = at _thunk $ - (mergeTimesBy ta tb >=> until) $ \a b -> do - let cmpV a b = a (minBound,maxBound) >>= \a -> cmp a <$> b a - (+)<$>cmpV a b<*>map invertOrd<$>cmpV b a + (mergeTimesBy ta tb >=> until) $ \_ a b -> do + let cmpV cmp a b = a (minBound,maxBound) >>= \a -> cmp a <$> b a + (+)<$>cmpV cmp a b<*>cmpV (flip cmp) b a where cmp (a,a') (b,b') | a' Semigroup (Time t) where - Time ta + Time tb = Time $ mergeTimesBy ta tb $ \fa fb -> return $ \h -> - max2<$>maxV h fa fb<*>maxV h fb fa - where max2 (xa,ya) (xb,yb) = (max xa xb,max ya yb) - maxV h fa fb = fa h >>= \a -> max2 a<$>fb a + Time ta + Time tb = mergeFun (warp2 (mapIso2 _Max _Max) (+)) + stopMax (Time ta) (Time tb) + where stopMax action (a,a') (b,b') | a'b' = _ioref action =- pure ta + | otherwise = unit +-- |The Time monoid where @zero == minBound@ instance Ord t => Monoid (Time t) where zero = minBound +-- |The Time ring where @(*) == min@ and @one == maxBound@ +instance Ord t => Ring (Time t) where + one = maxBound + Time ta * Time tb = mergeFun (warp2 (mapIso2 _Max _Max) (*)) + stopMin (Time ta) (Time tb) + where stopMin action (a,a') (b,b') | a'b' = _ioref action =- pure tb + | otherwise = unit +instance Ord t => Orderable (Time t) where + inOrder a b = (a*b,if z then b else a,z) + where z = a<=b + instance Bounded (Time t) where minBound = Time (pure (pure (pure (pure (minBound,minBound))))) maxBound = Time (pure (pure (pure (pure (maxBound,maxBound))))) instance Unit Time where pure t = Time (pure (pure (pure (pure (pure t,pure t))))) + type Seconds = Double -mergeTimesBy tta ttb f = newChan >>= \res -> do - union <- newChan - ta <- unsafeInterleaveIO tta ; tb <- unsafeInterleaveIO ttb - let consume f ta = forkIO $ tillPoint ta $ writeChan union . f - unknown = const (pure (minBound,maxBound)) - consume Left ta ; consume Right tb - forkIO $ (\f -> f unknown unknown) $ fix $ \m a b -> do - writeChan res =<< f a b - end <- (&&)<$>isPoint a<*>isPoint b - unless end $ (flip m b <|> m a) =<< readChan union - return (readChan res) + +mergeFun f c (Time ta) (Time tb) = + Time $ mergeTimesBy ta tb $ \action fa fb -> return $ \h -> do + let cmb f c fa fb = fa h >>= \a -> fb a >>= \b -> f a b <$ c action a b + f<$>cmb f c fa fb<*>cmb (flip f) (map flip c) fb fa + +mergeTimesBy tta ttb f = join $ readIORef action + where action = unsafePerformIO (newIORef chan) + chan = newChan >>= \res -> do + union <- newChan + ta <- unsafeInterleaveIO tta ; tb <- unsafeInterleaveIO ttb + let consume f ta = forkIO $ tillPoint ta $ writeChan union . f + unknown = const (pure (minBound,maxBound)) + consume Left ta ; consume Right tb + forkIO $ (\f -> f unknown unknown) $ fix $ \m a b -> do + r <- f action a b ; writeChan res r + end <- (&&)<$>isPoint a<*>isPoint b + if end then writeIORef action (return (pure r)) + else (flip m b <|> m a) =<< readChan union + + return (readChan res) isPoint f = f (minBound,maxBound) <&> uncurry (==) tillPoint m f = fix (\p -> m >>= \x -> f x >> isPoint x >>= flip unless p) @@ -70,41 +96,41 @@ t >>= flip tillPoint (writeIORef r <=< (&) (minBound,maxBound)) fst <$> readIORef r -timeIO io = do +timeIO io = mdo sem <- newEmptyMVar - defined <- newIORef False - value <- newIORef undefined + action <- newIORef chan + lookup <- newIORef forkVal + notify <- newIORef (\c t t' -> writeVal c (pure (pure t,t'))) + + let chan = map readChan $ newChan <*= \ch -> do + forkIO $ readMVar sem >>= writeVal ch . pureFun + writeChan ch $ \(_,b) -> join ( + readIORef lookup<**>pure ch<**>currentTime<**>pure b) + forkVal ch t b = do + forkAt b $ join ( + readIORef notify<**>pure ch<**>currentTime<**>pure Never) + return (Since t,Never) + writeVal ch m = writeChan ch =<< (const.pure<$>m) + pureFun t = pure (pure t,pure t) + forkIO $ mdo - io >> writeIORef value (Since t) - writeIORef defined True + io + _ioref action =- pure (pure t^.._Time) + _ioref lookup =- pure (\_ _ _ -> pure (pure t,pure t)) + _ioref notify =- pure (const (const (const unit))) t <- currentTime - putMVar sem () + putMVar sem t - return $ Time $ map readChan $ newChan <*= \c -> do - let valWrite m = writeChan c =<< (const.pure<$>m) - pureFun t = (t,t) - pureVal = pureFun<$>readIORef value - - def <- readIORef defined - if def then valWrite pureVal - else do - forkIO $ readMVar sem >> valWrite pureVal - writeChan c $ \(_,b) -> do - c <- currentTime - let forkVal = forkAt b (currentTime >>= \t -> - readIORef defined >>= \def -> - unless def (valWrite (pure (Since t,Never)))) - >> pure (Since c,Never) - readIORef defined >>= bool pureVal forkVal --- print_ a = a <*= print + return $ Time $ join (readIORef action) +-- print_ s a = putStrLn (s+": "+show a) >> pure a waitTill t = do now <- t `seq` currentTime when (t>now) $ threadDelay (floor $ (t-now)*1000000) -forkAt (Since t) io = () <$ forkIO (putStrLn ("Waiting till "+show t) >> waitTill t >> io) +forkAt (Since t) io = () <$ forkIO (waitTill t >> io) forkAt Always io = () <$ forkIO io -forkAt Never io = return () +forkAt Never _ = return () seconds t = fromIntegral (sec t) + fromIntegral (nsec t)/1000000000 :: Seconds currentTime = seconds<$>getTime Realtime diff --git a/src/SimpleH/Reactive/TimeVal.hs b/src/SimpleH/Reactive/TimeVal.hs --- a/src/SimpleH/Reactive/TimeVal.hs +++ b/src/SimpleH/Reactive/TimeVal.hs @@ -17,6 +17,13 @@ join (Since b) = b join Always = Always join Never = Never +instance Foldable TimeVal where + fold (Since t) = t + fold _ = zero +instance Traversable TimeVal where + sequence (Since t) = Since<$>t + sequence Always = pure Always + sequence Never = pure Never instance Bounded (TimeVal t) where minBound = Always ; maxBound = Never