SimpleH 0.9 → 0.9.1

raw patch · 10 files changed

+204/−110 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• SimpleH.cabal +2/−1
• src/SimpleH/Applicative.hs +8/−3
• src/SimpleH/Core.hs +25/−12
• src/SimpleH/Foldable.hs +4/−4
• src/SimpleH/Functor.hs +3/−3
• src/SimpleH/Lens.hs +9/−3
• src/SimpleH/Monad.hs +16/−3
• src/SimpleH/Reactive.hs +56/−33
• src/SimpleH/Reactive/Time.hs +74/−48
• src/SimpleH/Reactive/TimeVal.hs +7/−0

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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)

@@ -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<t) (uniq e)+                  uniq = map last . group   _ <*> _ = 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

@@ -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'<b = Just LT | b'<a = Just GT                             | a==a' && b==b' = Just EQ                             | otherwise = Nothing+-- |The Time semigroup where @ta + tb == max ta tb@ instance Ord t => 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 tb+                                       | 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 ta+                                       | 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

@@ -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