SimpleH 0.9.1 → 1.0

raw patch · 14 files changed

+394/−214 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• SimpleH.cabal +4/−3
• src/SimpleH/Applicative.hs +31/−10
• src/SimpleH/Arrow.hs +14/−7
• src/SimpleH/Classes.hs +1/−3
• src/SimpleH/Containers.hs +7/−3
• src/SimpleH/Core.hs +48/−11
• src/SimpleH/Foldable.hs +24/−1
• src/SimpleH/Functor.hs +16/−12
• src/SimpleH/Lens.hs +39/−18
• src/SimpleH/Monad.hs +82/−27
• src/SimpleH/Parser.hs +18/−6
• src/SimpleH/Reactive.hs +53/−28
• src/SimpleH/Reactive/Time.hs +47/−84
• src/SimpleH/Traversable.hs +10/−1

@@ -1,8 +1,9 @@  name:                SimpleH-version:             0.9.1+version:             1.0 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.         +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.+  synopsis: A light, clean and powerful Haskell utility library          license:             BSD3 license-file:        LICENSE author:              Marc Coiffier@@ -17,7 +18,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+  ghc-options:  -Wall -fno-warn-orphans source-repository head   type: git   location: git://github.com/lih/SimpleH.git

@@ -34,14 +34,14 @@ 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 (Unit f,Unit g) => Unit (f:**:g) where pure a = pure a:**:pure a+instance (Applicative f,Applicative g) => Applicative (f:**:g) where+  ff:**:fg <*> xf:**:xg = (ff<*>xf) :**: (fg<*>xg)  instance Applicative Tree instance Monad Tree where   join (Node (Node a subs) subs') = Node a (subs + map join subs')-instance (Applicative f,Applicative g) => Applicative (Compose f g) where+instance (Applicative f,Applicative g) => Applicative (f:.:g) where   Compose fs <*> Compose xs = Compose ((<*>)<$>fs<*>xs) deriving instance Unit Interleave instance Applicative Interleave@@ -60,9 +60,9 @@ instance Unit ZipList where   pure a = ZipList (repeat a) instance Applicative ZipList where-  ZipList fs <*> ZipList xs = ZipList (zip fs xs)-    where zip (f:fs) (x:xs) = f x:zip fs xs-          zip _ _ = []+  ZipList zf <*> ZipList zx = ZipList (zip_ zf zx)+    where zip_ (f:fs) (x:xs) = f x:zip_ fs xs+          zip_ _ _ = [] deriving instance Foldable ZipList  -- |The Tree equivalent to ZipList@@ -86,22 +86,42 @@ instance Applicative f => Applicative (Backwards f) where   Backwards fs <*> Backwards xs = Backwards (fs<**>xs) ++ap :: Applicative f => f (a -> b) -> f a -> f b++plusA :: (Applicative f,Semigroup a) => f a -> f a -> f a+zeroA :: (Unit f,Monoid a) => f a+oneA :: (Unit f,Ring a) => f a+timesA :: (Applicative f,Ring a) => f a -> f a -> f a++(*>) :: Applicative f => f b -> f a -> f a+(<*) :: Applicative f => f a -> f b -> f a+(<**>) :: Applicative f => f (a -> b) -> f a -> f b+ ap = (<*>) infixl 2 <*,*> infixl 2 <**> (*>) = liftA2 (flip const) (<*) = liftA2 const f <**> x = liftA2 (&) x f+ sequence_ = foldr (*>) (pure ())-traverse_ :: (Applicative f,Foldable t) => (a -> f b) -> t a -> f ()+sequence_ :: (Applicative f,Foldable t) => t (f a) -> f () traverse_ f = sequence_ . map f+traverse_ :: (Applicative f,Foldable t) => (a -> f b) -> t a -> f () for_ = flip traverse_+for_ :: (Applicative f,Foldable t) => t a -> (a -> f b) -> f () +forever :: Applicative f => f a -> f b forever m = undefined<$sequence_ (repeat m) +liftA :: Functor f => (a -> b) -> (f a -> f b) liftA = map+liftA2 :: Applicative f => (a -> b -> c) -> (f a -> f b -> f c) liftA2 f = \a b -> f<$>a<*>b+liftA3 :: Applicative f => (a -> b -> c -> d) -> (f a -> f b -> f c -> f d) liftA3 f = \a b c -> f<$>a<*>b<*>c+liftA4 :: Applicative f => (a -> b -> c -> d -> e) -> (f a -> f b -> f c -> f d -> f e) liftA4 f = \a b c d -> f<$>a<*>b<*>c<*>d  plusA = liftA2 (+)@@ -109,9 +129,10 @@ oneA = pure one timesA = liftA2 (*) +between :: Applicative f => f b -> f c -> f a -> f a between start end p = liftA3 (\_ b _ -> b) start p end -instance (Applicative f,Semigroup (g a)) => Semigroup (Compose f g a) where+instance (Applicative f,Semigroup (g a)) => Semigroup ((f:.:g) a) where   Compose f+Compose g = Compose ((+)<$>f<*>g)-instance (Applicative f,Monoid (g a)) => Monoid (Compose f g a) where+instance (Applicative f,Monoid (g a)) => Monoid ((f:.:g) a) where   zero = Compose (pure zero)

@@ -17,11 +17,13 @@ import SimpleH.Monad import SimpleH.Foldable -(^>>) = promap-(>>^) = (<&>)-infixr 4 ^>>,>>^-dup = arr (\a -> (a,a))+comapA :: Arrow arr => (a -> b) -> Flip arr c b -> Flip arr c a+app :: Apply k => k a b -> k a b +(^>>) :: Cofunctor (Flip f c) => (a -> b) -> f b c -> f a c+(>>^) :: Functor f => f a -> (a -> b) -> f b+dup :: Arrow arr => arr a (a, a)+ class (Split k,Choice k) => Arrow k where   arr :: (a -> b) -> k a b instance Arrow (->) where arr = id@@ -29,9 +31,6 @@   apply :: k (k a b,a) b instance Apply (->) where apply (f,x) = f x -comapA f (Flip g) = Flip (arr f >>> g)-app f = arr (f,) >>> apply- instance Monad m => Apply (Kleisli m) where   apply = Kleisli (\(Kleisli f,a) -> f a) instance Monad m => Arrow (Kleisli m) where@@ -48,3 +47,11 @@                                >>> arr (\(c,d) -> (,)<$>c<*>d)) instance Arrow k => Arrow (ListA k) where   arr f = ListA (arr (map f))++(^>>) = promap+(>>^) = (<&>)+infixr 4 ^>>,>>^+dup = arr (\a -> (a,a))++comapA f (Flip g) = Flip (arr f >>> g)+app f = arr (f,) >>> apply

@@ -5,13 +5,11 @@  class Functor f where   map :: (a -> b) -> f a -> f b-  default map :: Applicative f => (a -> b) -> f a -> f b-  map f = (<*>) (pure f) class (Unit f, Functor f) => Applicative f where   infixl 2 <*>   (<*>) :: f (a -> b) -> f a -> f b   default (<*>) :: Monad f => f (a -> b) -> f a -> f b-  f <*> x = f >>= \f -> x >>= \x -> pure (f x)+  fs <*> xs = fs >>= \f -> map f xs class Applicative m => Monad m where   join :: m (m a) -> m a   join m = m >>= id

@@ -19,13 +19,17 @@ class DataMap m k a | m -> k a where   lookup :: k -> m -> Maybe a   alter :: (Maybe a -> Maybe a) -> k -> m -> m+member :: DataMap m k Void => k -> m -> Bool member = map (at (from _maybe)) . lookup-delete = alter (const Nothing) -minsert = alter (const (Just zero))  +delete :: DataMap m k a => k -> m -> m+delete = alter (const Nothing)+minsert :: (Monoid a, DataMap m k a) => k -> m -> m+minsert = alter (const (Just zero))+insert :: DataMap m k a => a -> k -> m -> m insert = alter . const . Just  instance Ord a => DataMap (S.Set a) a Void where-  lookup = _mapping _maybe-. S.member+  lookup = _mapping' _maybe-. S.member   alter f a s | bef && not aft = S.delete a s               | aft && not bef = S.insert a s               | otherwise = s

@@ -2,18 +2,28 @@ module SimpleH.Core(   -- * Basic union and product types   Void,(:*:),(:+:),vd,-+     -- * Basic group and ring structure   -- ** Classes-  Semigroup(..),SubSemi(..),Monoid(..),Ring(..),+  Semigroup(..),Monoid(..),Ring(..),+  SubSemi(..),   Unit(..),    -- ** Common monoids-  Endo(..),Dual(..),OrdList(..),Interleave(..),Accum(..),Max(..),-  Product(..),++  -- *** Control monoids+  Endo(..),StrictEndo(..),++  -- *** Meta-monoids+  Dual(..),Product(..),++  -- *** Accumulating monoids+  OrdList(..),Interleave(..),Accum(..),Max(..),      -- * Fundamental control operations   Category(..),(<<<),(>>>),(+++),++  -- ** Splitting and Choosing   Choice(..),Split(..),      -- * Misc functions@@ -23,10 +33,11 @@    ifThenElse,bool,guard,fail,unit,when,unless, -  comparing,tailSafe,headDef,+  tailSafe,headDef, +  -- ** To use with 'OrdList'   Orderable(..),-  insertOrd,invertOrd,+  comparing,insertOrd,invertOrd,      -- * The rest is imported from the Prelude   module Prelude@@ -50,7 +61,8 @@ type a:*:b = (a,b) type a:+:b = Either a b -vd = undefined :: Void+vd :: Void+vd = undefined  {-| The class of all types that have a binary operation. Note that the operation@@ -138,7 +150,10 @@ instance Category (->) where   id = P.id   (.) = (P..)-(<<<) = (.) ; (>>>) = flip (<<<)+(<<<) :: Category k => k b c -> k a b -> k a c+(<<<) = (.)+(>>>) :: Category k => k a b -> k b c -> k a c+(>>>) = flip (<<<) infixr 1 >>>,<<< infixr 9 . @@ -166,6 +181,11 @@ 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 +newtype StrictEndo a = StrictEndo { runStrictEndo :: a -> a }+instance Semigroup (StrictEndo a) where+  StrictEndo f + StrictEndo g = StrictEndo h+    where h a = let fa = f a in fa `seq` g fa + {-| A monoid on Maybes, where the sum is the leftmost non-Nothing value. -} newtype Accum a = Accum { getAccum :: Maybe a } instance Monoid a => Semigroup (Accum a) where@@ -197,7 +217,7 @@ newtype OrdList a = OrdList { getOrdList :: [a] }                   deriving (Eq,Ord,Show) instance Orderable a => Semigroup (OrdList a) where-  OrdList a + OrdList b = OrdList (a ++ b)+  OrdList oa + OrdList ob = OrdList (oa ++ ob)     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@@ -212,6 +232,7 @@     where ~(x,y) | z = (a,b)                  | otherwise = (b,a)           z = a<=b+insertOrd :: Orderable t => t -> [t] -> [t] insertOrd e [] = [e] insertOrd e (x:xs) = a:y:ys   where (a,_,z) = inOrder e x@@ -219,33 +240,49 @@  newtype Interleave a = Interleave { interleave :: [a] } instance Semigroup (Interleave a) where-  Interleave as + Interleave bs = Interleave (inter as bs)+  Interleave ia + Interleave ib = Interleave (inter ia ib)     where inter (a:as) bs = a:inter bs as           inter [] bs = bs deriving instance Monoid (Interleave a) +(&) :: a -> (a -> b) -> b (&) = flip ($) infixl 0 &  infixr 1 ++++(+++) :: Split k => (a -> k c c) -> (b -> k d d) -> (a:+:b) -> k (c,d) (c,d) f +++ g = first.f <|> second.g +second :: Split k => k a b -> k (c,a) (c,b) second a = id <#> a+first :: Split k => k a b -> k (a,c) (b,c) first a = a <#> id -guard p = if p then pure vd else zero+guard :: (Unit m,Monoid (m ())) => Bool -> m ()+guard p = if p then unit else zero +ifThenElse :: Bool -> a -> a -> a ifThenElse b th el = if b then th else el+bool :: a -> a -> Bool -> a bool th el b = ifThenElse b th el+tailSafe :: [a] -> [a] tailSafe [] = [] ; tailSafe (_:t) = t+headDef :: a -> [a] -> a headDef d [] = d ; headDef _ (x:_) = x +fail :: String -> a fail = error+const :: Unit m => a -> m a const = pure+fix :: (a -> a) -> a fix f = y where y = f y +unit :: Unit m => m () unit = pure ()+when :: Unit m => Bool -> m () -> m () when p m = if p then m else unit+unless :: Unit m => Bool -> m () -> m () unless p m = if p then unit else m +invertOrd :: Ordering -> Ordering invertOrd GT = LT ; invertOrd LT = GT ; invertOrd EQ = EQ

@@ -20,7 +20,7 @@ instance Foldable Tree where fold (Node m subs) = m + fold (map fold subs) deriving instance Foldable Interleave deriving instance Foldable OrdList-instance (Foldable f,Foldable g) => Foldable (Compose f g) where+instance (Foldable f,Foldable g) => Foldable (f:.:g) where   fold = getCompose >>> map fold >>> fold  newtype Sized f a = Sized { getSized :: f a }@@ -28,12 +28,23 @@          SubSemi n (Sized f a) where   cast = size . getSized +instance (Foldable f,Foldable g) => Foldable (f:**:g) where+  fold (f:**:g) = fold f + fold g+instance (Foldable f,Foldable g) => Foldable (f:++:g) where+  fold (Sum (Left f)) = fold f+  fold (Sum (Right g)) = fold g++foldMap :: (Monoid m, Foldable t) => (a -> m) -> t a -> m foldMap f = fold . map f+convert :: (Unit f, Monoid (f a), Foldable t) => t a -> f a convert = foldMap pure+concat :: (Monoid m, Foldable t) => t m -> m concat = fold+sum :: (Monoid m, Foldable t) => t m -> m sum = fold size :: (Foldable f,Num n,Monoid n) => f a -> n size c = sum (1<$c)+count :: (Num n, Monoid n, Foldable f) => f a -> n count = size length :: (Num n,Monoid n) => [a] -> n length = count@@ -43,23 +54,35 @@ partitionEithers :: (Foldable t,Unit t,Monoid (t a),Monoid (t b))                     => t (a:+:b) -> (t a,t b) partitionEithers = split . map (pure|||pure)+partition :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> (f a, f a) partition p = split . map (\a -> (if p a then Left else Right) (pure a))+filter :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a filter p = fst . partition p+select :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a select = filter+refuse :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a refuse = filter . map not +compose :: (Category k, Foldable t) => t (k a a) -> k a a compose = runEndo . foldMap Endo  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' :: Foldable t => (a -> b -> a) -> a -> t b -> a foldl' f e t = runEndo (foldMap (\b -> Endo (\a -> a`seq`f a b)) t) e +toList :: Foldable t => t a -> [a]+toList = foldr (:) []+ find :: Foldable t => (a -> Bool) -> t a -> Maybe a find p = foldMap (filter p . Id) or :: Foldable t => t Bool -> Bool or = fold and :: Foldable t => t Bool -> Bool and = getProduct . fold . map Product+all :: Foldable t => (a -> Bool) -> t a -> Bool all = map and . map+any :: Foldable t => (a -> Bool) -> t a -> Bool any = map or . map+elem :: (Eq a,Foldable t) => a -> t a -> Bool elem e = any (e==)

@@ -3,7 +3,7 @@ module SimpleH.Functor(   Functor(..),Cofunctor(..),Bifunctor(..),   -  Id(..),Const(..),Flip(..),Compose(..),FProd(..),Sum(..),+  Id(..),Const(..),Flip(..),(:.:)(..),(:**:)(..),(:++:)(..),    (<$>),(|||),(<$),(<&>),void,left,right,   promap,map2,map3@@ -17,7 +17,7 @@  class Cofunctor f where   comap :: (a -> b) -> f b -> f a-instance (Functor f,Cofunctor g) => Cofunctor (Compose f g) where+instance (Functor f,Cofunctor g) => Cofunctor (f:.:g) where   comap f (Compose c) = Compose (map (comap f) c) instance Cofunctor (Flip (->) a) where   comap f (Flip g) = Flip (g . f)@@ -36,9 +36,9 @@ newtype Id a = Id { getId :: a }              deriving Show instance Unit Id where pure = Id-instance Functor Id+instance Functor Id where map f (Id a) = Id (f a) instance Applicative Id-instance Monad Id where Id a >>= k = k a+instance Monad Id where join (Id a) = a  -- |The Constant Functor newtype Const a b = Const { getConst :: a }@@ -52,16 +52,16 @@ newtype Flip f a b = Flip { unFlip :: f b a }  -- |The Composition functor-newtype Compose f g a = Compose { getCompose :: f (g a) }-instance (Unit f,Unit g) => Unit (Compose f g) where pure = Compose . pure . pure-instance (Functor f,Functor g) => Functor (Compose f g) where+newtype (f:.:g) a = Compose { getCompose :: f (g a) }+instance (Unit f,Unit g) => Unit (f:.:g) where pure = Compose . pure . pure+instance (Functor f,Functor g) => Functor (f:.:g) where   map f (Compose c) = Compose (map (map f) c) -newtype FProd f g a = FProd { getFProd :: f a:*:g a }-instance (Functor f,Functor g) => Functor (FProd f g) where-  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+data (f:**:g) a = f a:**:g a+instance (Functor f,Functor g) => Functor (f:**:g) where+  map f (a:**:b) = map f a:**:map f b+newtype (f:++:g) a = Sum { getSum :: f a:+:g a }+instance (Functor f,Functor g) => Functor (f:++:g) where   map f = Sum . (map f ||| map f) . getSum  instance Functor (Either b) where map f = Left <|> Right . f@@ -75,9 +75,11 @@ instance Applicative IO instance Monad IO where (>>=) = (P.>>=) +(<$>) :: Functor f => (a -> b) -> f a -> f b (<$>) = map (|||) :: (Choice k, Functor (k a), Functor (k b)) => k a c -> k b d -> k (a:+:b) (c:+:d) f ||| g = Left<$>f <|> Right<$>g+(<&>) :: Functor f => f a -> (a -> b) -> f b x<&>f = map f x (<$) :: Functor f => b -> f a -> f b a <$ x = const a <$> x@@ -85,7 +87,9 @@ infixl 1 <&> infixr 1 ||| +left :: (Choice k, Functor (k a), Functor (k c)) => k a b -> k (a:+:c) (b:+:c) left a = a ||| id+right :: (Choice k, Functor (k a), Functor (k c)) => k a b -> k (c:+:a) (c:+:b) right a = id ||| a  void :: Functor f => f a -> f ()

@@ -22,7 +22,7 @@   Traversal,Traversal',    -- * Constructing lenses-  iso,from,lens,getter,prism,+  iso,from,lens,getter,prism,simple,    -- * Extracting values   (^.),(^..),(^?),(%~),(%-),(%%~),(%%-),at,at',warp,set,@@ -36,7 +36,7 @@   Isomorphic(..),   adding,   _Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,-  warp2,_mapping,_promapping,+  warp2,_mapping,_mapping',_promapping,   IsoFunctor(..),IsoFunctor2(..),   _thunk   ) where@@ -53,7 +53,7 @@ type Lens s t a b = forall f.Functor f => LensLike f s t a b type Lens' a b = Lens b b a a type Getter s t a b = LensLike (Const s) s t a b-type Getter' u v a b = Getter b u a v+type Getter' a b = Getter b b a a type Traversal s t a b = forall f. Applicative f => LensLike f s t a b type Traversal' a b = Traversal b b a a type Iso s t a b = forall p f. (Functor f,Bifunctor p) => p s (f t) -> p a (f b)@@ -88,7 +88,7 @@ lens :: (a -> s) -> (a -> t -> b) -> Lens s t a b lens f g = \k a -> g a <$> k (f a)  -getter :: (a -> b) -> Getter' u v a b+getter :: (a -> b) -> Getter' a b getter f = lens f undefined  -- |Create a 'Traversal' from a maybe getter and setter function.@@ -101,24 +101,31 @@  -- |Retrieve a value from a structure using a 'Lens' (or 'Iso') infixl 8 ^.,^..,^?,%~,%-,%%~,%%-+(^.) :: a -> Getter b u a v -> b (^.) = flip at+(^..) :: t -> Iso s t a b -> b (^..) = flip at' -- |+(%~) :: Traversal s t a b -> (s -> t) -> (a -> b) (%~) = warp (%%~) :: Iso s t a b -> (b -> a) -> (t -> s) (%%~) i = warp (from i)+(%-) :: Traversal s t a b -> t -> (a -> b) (%-) = 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 -(-.) :: Getter' u v b c -> (a -> b) -> a -> c+simple :: Iso' a b -> Iso' a b+simple i = i++(-.) :: Getter c u b v -> (a -> b) -> a -> c l-.f = at l.f (.-) :: (b -> c) -> Iso s a t b -> a -> c f.-i = f.at' i infixr 9 -.,.--at :: Getter' u v a b -> a -> b+at :: Getter b u a v -> a -> b at l = getConst . l Const at' :: Iso s t a b -> t -> b at' i = at (from i)@@ -136,6 +143,7 @@ _r :: Traversal a b (c:+:a) (c:+:b) _r = prism (Left ||| id) (flip (right . const)) +swapE :: (b:+:a) -> (a:+:b) swapE = Right<|>Left  class Compound a b s t | s -> a, b s -> t where@@ -156,8 +164,10 @@ _tail :: Traversal' [a] [a] _tail = _list._r._2 -_mapping :: Functor f => Iso s t a b -> Iso (f s) (f t) (f a) (f b)+_mapping :: (Functor f,Functor f') => Iso s t a b -> Iso (f s) (f' t) (f a) (f' b) _mapping (isoT -> IsoT u v) = map u `dimap` map (map v)+_mapping' :: Functor f => Iso s t a b -> Iso (f s) (f t) (f a) (f b)+_mapping' = _mapping _promapping :: Bifunctor f => Iso s t a b -> Iso (f t x) (f s y) (f b x) (f a y) _promapping (isoT -> IsoT u v) = dimap v id`dimap` map (dimap u id) -- ^_promapping :: Bifunctor f => Iso' a b -> Iso' (f a c) (f b c)@@ -180,24 +190,35 @@   _iso = iso Flip unFlip instance Isomorphic Bool Bool (Maybe Void) (Maybe Void) where   _iso = iso (bool (Just zero) Nothing) (maybe False (const True))-instance Isomorphic (f (g a)) (f' (g' b)) (Compose f g a) (Compose f' g' b) where+instance Isomorphic (f (g a)) (f' (g' b)) ((f:.:g) a) ((f':.:g') b) where   _iso = iso Compose getCompose instance Isomorphic a b (Void,a) (Void,b) where   _iso = iso (vd,) snd-_Id = _iso :: Iso' a (Id 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)-_Endo = _iso :: Iso' (k a a) (Endo k a)-_maybe = _iso :: Iso' Bool (Maybe Void)-_Flip = _iso :: Iso' (f a b) (Flip f b a)-_Compose = _iso :: Iso (Compose f g a) (Compose f' g' b) (f (g a)) (f' (g' b))+_Id :: Iso (Id a) (Id b) a b+_Id = _iso+_OrdList :: Iso (OrdList a) (OrdList b) [a] [b]+_OrdList = _iso+_Dual :: Iso (Dual a) (Dual b) a b+_Dual = _iso+_Const :: Iso (Const a c) (Const b c) a b+_Const = _iso+_Max :: Iso (Max a) (Max b) a b +_Max = _iso+_Endo :: Iso (Endo k a) (Endo k b) (k a a) (k b b)+_Endo = _iso +_maybe :: Iso' Bool (Maybe Void)+_maybe = _iso +_Flip :: Iso (Flip f b a) (Flip f d c) (f a b) (f c d)+_Flip = _iso+_Compose :: Iso ((f:.:g) a) ((f':.:g') b) (f (g a)) (f' (g' b))+_Compose = _iso+_Backwards :: Iso (Backwards f a) (Backwards f b) (f a) (f b) _Backwards = iso Backwards forwards+_Accum :: Iso (Accum a) (Accum b) (Maybe a) (Maybe b) _Accum = iso Accum getAccum  warp2 :: Iso s t a b -> (s -> s -> t) -> (a -> a -> b)-warp2 i (**) = (\b b' -> ((b^.i) ** (b'^.i))^..i)+warp2 i f = (\b b' -> f (b^.i) (b'^.i)^..i)  class IsoFunctor f where   mapIso :: Iso s t a b -> Iso (f s) (f t) (f a) (f b)

@@ -9,6 +9,7 @@   Kleisli(..),_Kleisli,   (=<<),(<=<),(>=>),(>>),(<*=),return,   foldlM,foldrM,while,until,+  bind2,bind3,(>>>=),(>>>>=),      -- * Common monads   -- ** The RWS Monad@@ -47,7 +48,7 @@   -- ** The Error Monad   MonadError(..),try,   EitherT,-  eitherT,runEitherT,+  _eitherT   ) where  import SimpleH.Classes@@ -60,7 +61,7 @@ import Data.IORef import Control.Concurrent -instance (Traversable g,Monad f,Monad g) => Monad (Compose f g) where+instance (Traversable g,Monad f,Monad g) => Monad (f:.:g) where   join = Compose .map join.join.map sequence.getCompose.map getCompose  -- |The class of all monads that have a fixpoint@@ -71,9 +72,12 @@ instance MonadFix [] where mfix f = fix (f . head) instance MonadFix (Either e) where mfix f = fix (f . either undefined id) instance MonadFix IO where mfix = Fix.mfix-instance (Contravariant f,Monad f,Traversable g,MonadFix g) => MonadFix (Compose f g) where-  mfix f = Compose (map mfix (collect (getCompose . f)))-cfix f = map fix (collect f) +instance (MonadFix f,Traversable g,Monad g) => MonadFix (f:.:g) where+  mfix f = Compose $ mfix (map join . traverse (getCompose . f))+cfix :: Contravariant c => (a -> c a) -> c a+cfix f = map fix (collect f)++mfixing :: MonadFix f => (b -> f (a, b)) -> f a mfixing f = fst<$>mfix (\ ~(_,b) -> f b )  class MonadTrans t where@@ -90,31 +94,52 @@   Kleisli f <|> Kleisli g = Kleisli (f <|> g) instance Monad m => Split (Kleisli m) where   Kleisli f <#> Kleisli g = Kleisli (\(a,c) -> (,)<$>f a<*>g c)-instance Isomorphic (a -> m b) (a -> m c) (Kleisli m a b) (Kleisli m a c) where+instance Isomorphic (a -> m b) (c -> m' d) (Kleisli m a b) (Kleisli m' c d) where   _iso = iso Kleisli runKleisli-_Kleisli = _iso :: Iso' (a -> m b) (Kleisli m a b)+_Kleisli :: Iso (Kleisli m a b) (Kleisli m' c d) (a -> m b) (c -> m' d)+_Kleisli = _iso   folding :: (Foldable t,Monoid w) => Iso' (a -> c) w -> (b -> a -> c) -> a -> t b -> c   folding i f e t = at (from i) (foldMap (at i . f) t) e+foldlM :: (Foldable t,Monad m) => (b -> a -> m a) -> a -> t b -> m a foldlM = folding (_Kleisli._Endo._Dual)+foldrM :: (Foldable t,Monad m) => (b -> a -> m a) -> a -> t b -> m a foldrM = folding (_Kleisli._Endo) +while :: Monad m => m (Maybe a) -> m () while e = fix (\w -> e >>= maybe unit (const w))+until :: Monad m => m (Maybe a) -> m a until e = fix (\w -> e >>= maybe w return) +bind2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c+bind2 f a b = join (f<$>a<*>b)+(>>>=) :: Monad m => (m a,m b) -> (a -> b -> m c) -> m c+(a,b) >>>= f = bind2 f a b+bind3 :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d+bind3 f a b c = join (f<$>a<*>b<*>c)+(>>>>=) :: Monad m => (m a,m b,m c) -> (a -> b -> c -> m d) -> m d+(a,b,c) >>>>= f = bind3 f a b c+ infixr 2 >>,=<< infixr 1 <*=+(>>) :: Applicative f => f a -> f b -> f b (>>) = (*>)+(=<<) :: Monad m => (a -> m b) -> m a -> m b (=<<) = flip (>>=)+(<=<) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c) f <=< g = \a -> g a >>= f+(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) (>=>) = flip (<=<)+(<*=) :: Monad m => m a -> (a -> m b) -> m a a <*= f = a >>= (>>)<$>f<*>return+return :: Unit f => a -> f a return = pure  newtype RWST r w s m a = RWST { runRWST :: (r,s) -> m (a,s,w) } type RWS r w s a = RWST r w s Id a -_RWST :: Iso' ((r,s) -> m (a,s,w)) (RWST r w s m a)+_RWST :: Iso (RWST r w s m a) (RWST r' w' s' m' a')+         ((r,s) -> m (a,s,w)) ((r',s') -> m' (a',s',w')) _RWST = iso RWST runRWST  instance (Unit f,Monoid w) => Unit (RWST r w s f) where@@ -178,7 +203,12 @@ _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  +get_ :: (MonadTrans t, MonadState a m) => t m a+get_ = lift get+put_ :: (MonadTrans t, MonadState s m) => s -> t m ()+put_ = lift . put+modify_ :: (MonadTrans t, MonadState s m) => (s -> s) -> t m ()+modify_ = lift . modify    newtype StateT s m a = StateT (RWST Void Void s m a)                      deriving (Unit,Functor,Applicative,Monad,MonadFix,@@ -194,14 +224,16 @@ deriving instance Monoid (m (a,s,Void)) => Monoid (StateT s m a) deriving instance Ring (m (a,s,Void)) => Ring (StateT s m a) -_StateT :: Iso' (RWST Void Void s m a) (StateT s m a)+_StateT :: Iso (StateT s m a) (StateT t n b) (RWST Void Void s m a) (RWST Void Void t n b) _StateT = iso StateT (\ ~(StateT s) -> s)-_stateT :: Functor m => Iso' (s -> m (s,a)) (StateT s m a)+_stateT :: (Functor m,Functor n) => Iso (StateT s m a) (StateT t n b) (s -> m (s,a)) (t -> n (t,b)) _stateT = _mapping (_mapping $ iso (\ ~(s,a) -> (a,s,zero) ) (\(a,s,_) -> (s,a)))           ._promapping _iso._RWST._StateT-eval = (map . map) snd-exec = (map . map) fst-_state :: Iso' (s -> (s,a)) (State s a)+eval :: (Functor f, Functor f') => f (f' (a, b)) -> f (f' b)+eval = map2 snd+exec :: (Functor f, Functor f') => f (f' (a, b)) -> f (f' a)+exec = map2 fst+_state :: Iso (State s a) (State t b) (s -> (s,a)) (t -> (t,b)) _state = _mapping _Id._stateT  (=-) :: MonadState s m => Lens' s s' -> s' -> m ()@@ -215,23 +247,34 @@ saving :: MonadState s m => Lens' s s' -> m a -> m a saving l st = gets l >>= \s -> st <* (l =- s) +mapAccum :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> (s, t b) mapAccum f t = traverse (at _state<$>f) t^.._state+mapAccum_ :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> t b mapAccum_ = (map.map.map) snd mapAccum+mapAccumR :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> (s, t b) mapAccumR f t = traverse (at (_state._Backwards)<$>f) t^.._state._Backwards+mapAccumR_ :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> t b mapAccumR_ = (map.map.map) snd mapAccumR +push :: Traversable t => t a -> a -> t a push = mapAccum_ (,)+pop :: Traversable t => t a -> a -> t a pop = mapAccumR_ (,) -withPrev a e = (,)<$>push e a<*>e-withNext e a = (,)<$>e<*>pop e a+withPrev :: Traversable t => a -> t a -> t (a,a)+withPrev = flip (mapAccum_ (\a p -> (a,(p,a))))+withNext :: Traversable t => t a -> a -> t (a,a)+withNext = mapAccumR_ (\a p -> (a,(p,a)))  class Monad m => MonadReader r m where   ask :: m r   local :: (r -> r) -> m a -> m a instance MonadReader r ((->) r) where   ask = id ; local = (>>>)-ask_ = lift ask ; local_ f = internal (local f)+ask_ :: (MonadTrans t, MonadReader a m) => t m a+ask_ = lift ask+local_ :: (MonadInternal t, MonadReader r m) => (r -> r) -> t m a -> t m a+local_ f = internal (local f) {-| A simple Reader monad -} newtype ReaderT r m a = ReaderT (RWST r Void Void m a)                        deriving (Functor,Unit,Applicative,Monad,MonadFix,@@ -239,10 +282,11 @@                                 MonadReader r,MonadCont) type Reader r a = ReaderT r Id a -_readerT :: Functor m => Iso' (r -> m a) (ReaderT r m a)+_readerT :: (Functor m,Functor m') => Iso (ReaderT r m a) (ReaderT r' m' b) (r -> m a) (r' -> m' b) _readerT = iso readerT runReaderT   where readerT f = ReaderT (RWST (\ ~(r,_) -> f r<&>(,vd,vd) ))         runReaderT (ReaderT (RWST f)) r = f (r,vd) <&> \ ~(a,_,_) -> a+_reader :: Iso (Reader r a) (Reader r' b) (r -> a) (r' -> b) _reader = _mapping _Id._readerT  instance MonadState s m => MonadState s (ReaderT r m) where@@ -257,8 +301,12 @@   tell :: w -> m ()   listen :: m a -> m (w,a)   censor :: m (a,w -> w) -> m a++tell_ :: (MonadWriter w m, MonadTrans t) => w -> t m () tell_ = lift . tell+listen_ :: (MonadInternal t, MonadWriter w m) => t m a -> t m (w, a) listen_ = internal (\m -> listen m <&> \(w,(c,a)) -> (c,(w,a)) )+censor_ :: (MonadInternal t, MonadWriter w m) => t m (a, w -> w) -> t m a censor_ = internal (\m -> censor (m <&> \(c,(a,f)) -> ((c,a),f))) instance Monoid w => MonadWriter w ((,) w) where   tell w = (w,())@@ -285,10 +333,11 @@ deriving instance Monoid (m (a,Void,w)) => Monoid (WriterT w m a) deriving instance Ring (m (a,Void,w)) => Ring (WriterT w m a) -_writerT :: Functor m => Iso' (m (w,a)) (WriterT w m a)+_writerT :: (Functor m,Functor m') => Iso (WriterT w m a) (WriterT w' m' b) (m (w,a)) (m' (w',b)) _writerT = iso writerT runWriterT-  where writerT w = WriterT (RWST (pure (w <&> \ ~(w,a) -> (a,vd,w) )))+  where writerT mw = WriterT (RWST (pure (mw <&> \ ~(w,a) -> (a,vd,w) )))         runWriterT (WriterT (RWST m)) = m (vd,vd) <&> \ ~(a,_,w) -> (w,a)+_writer :: Iso (Writer w a) (Writer w' b) (w,a) (w',b) _writer = _Id._writerT  {-| A simple continuation monad implementation  -}@@ -310,7 +359,9 @@ instance Monad m => MonadCont (ContT r m) where   callCC f = ContT (\k -> runContT (f (\a -> ContT (\_ -> k a))) k) +evalContT :: Unit m => ContT r m r -> m r evalContT c = runContT c return+evalCont :: Cont r r -> r evalCont = getId . evalContT  instance MonadTrans Backwards where@@ -321,11 +372,11 @@ class Monad m => MonadList m where   fork :: [a] -> m a instance MonadList [] where fork = id-newtype ListT m a = ListT ((m`Compose`[]) a)+newtype ListT m a = ListT ((m:.:[]) a)                     deriving (Semigroup,Monoid,                               Functor,Applicative,Unit,Monad,                               Foldable,Traversable)-_listT :: Iso' (m [a]) (ListT m a)+_listT :: Iso (ListT m a) (ListT m' a') (m [a]) (m' [a']) _listT = iso (ListT . Compose) (\(ListT (Compose m)) -> m) instance Monad m => MonadList (ListT m) where   fork = at _listT . return @@ -341,11 +392,13 @@   censor = _listT-.censor.map (\l -> (fst<$>l,compose (snd<$>l))).-_listT instance Monad m => MonadError Void (ListT m) where   throw = const zero-  catch f m = (m^.._listT >>= \l -> case l of [] -> f vd^.._listT; l -> pure l)^._listT+  catch f mm = mm & _listT %%~ (\m -> m >>= \_l -> case _l of+                                   [] -> f vd^.._listT; l -> pure l)  class Monad m => MonadError e m where-  throw :: e -> m Void+  throw :: e -> m a   catch :: (e -> m a) -> m a -> m a+try :: MonadError Void m => m a -> m a -> m a try d = catch (\x -> const d (x::Void)) instance MonadError e (Either e) where   throw = Left@@ -354,11 +407,13 @@   throw = const zero   catch f [] = f vd   catch _ l = l-newtype EitherT e m a = EitherT ((m`Compose`Either e) a)+newtype EitherT e m a = EitherT ((m:.:Either e) a)                       deriving (Unit,Functor,Applicative,Monad,MonadFix                                ,Foldable,Traversable)-eitherT = EitherT . Compose-runEitherT (EitherT m) = getCompose m+instance MonadTrans (EitherT e) where+  lift m = (pure<$>m)^._eitherT+_eitherT :: (Functor m) => Iso (EitherT e m a) (EitherT f m b) (m (e:+:a)) (m (f:+:b))                              +_eitherT = iso (EitherT . Compose) (\(EitherT (Compose e)) -> e)  instance Applicative Maybe instance Monad Maybe where join = fold

@@ -11,10 +11,11 @@ type Parser w c a = ParserT w c Id a deriving instance (Monad m,Monoid w) => MonadError Void (ParserT w c m) -_ParserT :: Iso' (StateT [c] (ListT (WriterT w m)) a) (ParserT w c m a)+_ParserT :: Iso (ParserT w c m a) (ParserT x d n b) (StateT [c] (ListT (WriterT w m)) a) (StateT [d] (ListT (WriterT x n)) b) _ParserT = iso ParserT (\(ParserT p) -> p)-_parserT :: Functor m => Iso' ([c] -> m (w,[([c],a)])) (ParserT w c m a)+_parserT :: (Functor n,Functor m) => Iso (ParserT w c m a) (ParserT x d n b) ([c] -> m (w,[([c],a)])) ([d] -> n (x,[([d],b)])) _parserT = _mapping (_writerT._listT)._stateT._ParserT+_parser :: Iso (Parser w c a) (Parser x d b) ([c] -> (w,[([c],a)])) ([d] -> (x,[([d],b)])) _parser = _mapping _Id._parserT  remaining :: (Monad m,Monoid w) => ParserT w c m [c]@@ -26,23 +27,34 @@ many1 :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a] many1 p = (:)<$>p<*>many p +satisfy :: (Monoid w, Monad m) => (c -> Bool) -> ParserT w c m c satisfy p = token <*= (guard . p)+single :: (Eq c, Monoid w, Monad m) => c -> ParserT w c m () single c = void (satisfy (c==)) +several :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m () several l = traverse_ single l  option :: (Monoid w,Monad m) => a -> ParserT w c m a -> ParserT w c m a option a p = p+pure a -eoi :: (Monad m,Monoid w) => ParserT w c m Void+eoi :: (Monad m,Monoid w) => ParserT w c m () eoi = remaining >>= guard.null +sepBy1 ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a] sepBy1 p sep = (:)<$>p<*>many (sep >> p)+sepBy ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a] sepBy p sep = option [] (sepBy1 p sep)++(<+>) :: Semigroup m => m -> m -> m (<+>) = (+)-oneOf = satisfy . elem-noneOf = satisfy . map not . elem +oneOf :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m c+oneOf = satisfy . flip elem+noneOf :: (Eq c, Monoid w, Monad m, Foldable t) => t c -> ParserT w c m c+noneOf = satisfy . map not . flip elem+ infixl 1 `sepBy`,`sepBy1`,<+> -chain expr op e = chain where chain = (expr<**>op<*>chain) + e+chain :: (Semigroup (f b), Applicative f) => f a -> f (a -> b -> b) -> f b -> f b+chain expr op e = fix $ \_chain -> ((&)<$>expr<*>op<*>_chain) + e

@@ -1,10 +1,11 @@ {-# LANGUAGE RebindableSyntax, GeneralizedNewtypeDeriving, TupleSections, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ViewPatterns #-} module SimpleH.Reactive (+  -- * Reactive Modules   module SimpleH.Reactive.Time,   module SimpleH.Reactive.TimeVal,    -- * Reactive Events-  Event,_event,Reactive(..),+  Event,_event,headE,Reactive(..),    -- ** Contructing events   atTimes,mkEvent,@@ -32,7 +33,7 @@ import SimpleH.Reactive.Time  -- |An event (a list of time-value pairs of increasing times)-newtype Event t a = Event { getEvent :: Compose OrdList (Future t) a }+newtype Event t a = Event { getEvent :: (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@@ -41,20 +42,20 @@   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 :)+    where cons a = _event %%~ ((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) (+) instance Ord t => Monoid (Event t a) where zero = []^._event 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+  fe@(at' _event -> ff:_) <*> xe@(at' _event -> fx:_) =+    ste & traverse (at _state) & at' _state & map snd & \st ->+    br ((ff^._time)+(fx^._time)) (st (ff^._value,fx^._value))+    where ste = 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)+          br t (at' _event -> e) = uniq (map (_time %- t) b + a)^._event+            where (b,a) = span (\f -> f^._time<t) e                   uniq = map last . group   _ <*> _ = zero instance Ord t => Monad (Event t) where@@ -63,15 +64,17 @@     where merge [] = []           merge [t] = t           merge ([]:t) = merge t-          merge ((x:xs):ys:t) = x:merge (sum xs ys : t)-            where sum = warp2 _OrdList (+)+          merge ((x:xs):ys:t) = x:merge (add xs ys : t)+            where add = warp2 _OrdList (+)  type EventRep t a = OrdList (Future t a) _Event :: Iso (Event t a) (Event t' b) (EventRep t a) (EventRep t' b) _Event = _Compose.iso Event getEvent _event :: Iso (Event t a) (Event t' b) [Future t a] [Future t' b] _event = _OrdList._Event+atTimes :: [t] -> Event t () atTimes ts = (ts <&> \t -> (pure t,())^._future)^._event+mkEvent :: [(t,a)] -> Event t a mkEvent as = (as <&> at _future . (_1 %~ pure))^._event  {-| The \'splice\' operator. Occurs when @a@ occurs.@@ -79,9 +82,9 @@ > at t: a // b = (a,before t: b) -} (//) :: 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 (flip ltFut b) es+ea // eb = mapAccum_ fun (ea^.._event) (eb^.._event) ^. _event+  where fun a bs = (ys,a & _value %~ (,xs^._event))+          where (xs,ys) = span (flip ltFut a) bs infixl 1 //  {-|@@ -90,7 +93,7 @@ > at t: a <|*> (bi,b) = a <*> (minBound,bi):b -} (<*|>) :: Ord t => Event t (a -> b) -> Reactive t a -> Event t b-fs <*|> Reactive a as = (traverse tr (fs // as) ^.. _state <&> snd) a+ef <*|> Reactive a ea = (traverse tr (ef // ea) ^.. _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@@ -98,25 +101,44 @@ infixr 1 <|*>  -- |Group the occurences of an event by equality. Occurs when the first occurence of a group occurs. -groupE = _event %%~ groupE . (+repeat (Future (maxBound,undefined)))-  where groupE fs = (f & _value %- xs):(z & _time %~ (sum (at _time<$>xs)+)):zs+groupE :: (Eq a, Ord t) => Event t a -> Event t (Event t a)+groupE = _event %%~ group_ . (+repeat (Future (maxBound,undefined)))+  where group_ fs = (f & _value %- (xs^._event))+                    : (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+                ~(z:zs) = group_ ys+                sum_ = foldl' (+) zero+headE :: Event t a -> a+headE = at _value . head . at' _event +mapFutures :: (Future t a -> Future t' b) -> Event t a -> Event t' b mapFutures f = _event %%~ map f+withTime :: Ord t => Event t a -> Event t (TimeVal t,a) withTime = mapFutures (\(Future f) -> Future (_1%~timeVal <$> listen f))+times :: Ord t => Event t a -> Event t (TimeVal t) times = map2 fst withTime -mask m e = (m // e) `withNext` (True,zero) >>= \((b,_),(_,e)) -> guard b >> e+mask :: Ord t => Event t Bool -> Event t a -> Event t a+mask m ea = (m // ea) `withNext` (True,zero) >>= \((b,_),(_,a)) -> guard b >> a --- |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 = unsafeInterleaveIO $ do-          f <- futureIO (timeVal t `seq` m)-          fs <- event' (f^._time)-          return (f:fs)+-- |Sinks an action event into the Real World. Actions are evaluated as+-- closely to their time as possible+sink :: Event Seconds (IO ()) -> IO ()+sink l = traverse_ sink_ (withTime l)+  where sink_ (Since t,v) = waitTill t >> v+        sink_ (Always,v) = v+        sink_ (Never,_) = unit+event :: IO a -> IO (Event Seconds a)+event m = at _event <$> do+  c <- newChan+  _ <- forkIO $ forever $ do+    a <- newEmptyMVar+    writeChan c a+    putMVar a =<< m+  let event' ~(a:as) = unsafeInterleaveIO $ do+        (:)<$>futureIO (takeMVar a)<*>event' as+  (event' =<< getChanContents c)+    <*= forkIO . traverse_ (at' _thunk . timeVal . at _time)  -- |A Future value (a value with a timestamp) newtype Future t a = Future (Time t,a)@@ -133,13 +155,16 @@ _time = from _future._1 _value :: Lens a b (Future t a) (Future t b) _value = from _future._2+ cmpFut :: Ord t => Future t a -> Future t b -> Ordering cmpFut a b = compare (a^._time) (b^._time)+ltFut :: Ord t => Future t a -> Future t b -> Bool ltFut a b = cmpFut a b == LT+ futureIO :: IO a -> IO (Future Seconds a) futureIO m = do   val <- newEmptyMVar-  forkIO $ putMVar val =<< m +  _ <- forkIO $ putMVar val =<< m    time <- timeIO (readMVar val)   return (Future (time,readMVar val^._thunk)) 

@@ -16,121 +16,84 @@ import Data.IORef import System.Clock -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 (Bounds (TimeVal t)))))-_Time = iso Time (\(Time t) -> t)+data Time t = Time (TimeVal t -> TimeVal t) (TimeVal t -> TimeVal 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 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+  compare ~(Time fa fa') ~(Time fb fb') =+    cmp fa fb' `unamb` invertOrd (cmp fb fa')+    where cmp f f' = compare a (f'$!a)+            where a = f maxBound -- |The Time semigroup where @ta + tb == max ta tb@ instance Ord t => Semigroup (Time t) where-  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+  ~(Time fa fa') + ~(Time fb fb') = Time (mapT max fa fb) (mapT max fa' fb') -- |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+  ~(Time fa fa') * ~(Time fb fb') = Time (mapT min fa fb) (mapT min fa' fb') instance Ord t => Orderable (Time t) where   inOrder a b = (a*b,if z then b else a,z)     where z = a<=b +mapT :: (t -> t -> a) -> (t -> t) -> (t -> t) -> t -> a+mapT f fa fb h = f a (fb$!a) `unamb` f b (fa$!b)+  where a = fa h ; b = fb h+ instance Bounded (Time t) where-  minBound = Time (pure (pure (pure (pure (minBound,minBound)))))-  maxBound = Time (pure (pure (pure (pure (maxBound,maxBound)))))+  minBound = Time (pure minBound) (pure minBound)+  maxBound = Time (pure maxBound) (pure maxBound) instance Unit Time where-  pure t = Time (pure (pure (pure (pure (pure t,pure t)))))+  pure t = Time (pure (pure t)) (pure (pure t))  +amb :: IO a -> IO a -> IO a+ma `amb` mb = do+  res <- newEmptyMVar+  ta <- forkIO $ ma >>= putMVar res . Left+  tb <- forkIO $ mb >>= putMVar res . Right+  +  takeMVar res >>= \c -> case c of+    Left a -> killThread tb >> return a+    Right a -> killThread ta >> return a+unamb :: a -> a -> a+unamb = warp2 (from _thunk) amb  type Seconds = Double --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)-timeVal (Time t) = at _thunk $ do-  r <- newIORef undefined-  t >>= flip tillPoint (writeIORef r <=< (&) (minBound,maxBound))-  fst <$> readIORef r+timeVal :: Time t -> TimeVal t+timeVal (Time fa _) = fa maxBound -timeIO io = mdo+timeIO :: IO a -> IO (Time Seconds)+timeIO io = do   sem <- newEmptyMVar-  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-    _ioref action =- pure (pure t^.._Time)-    _ioref lookup =- pure (\_ _ _ -> pure (pure t,pure t))-    _ioref notify =- pure (const (const (const unit)))-    t <- currentTime+  minAction <- newIORef $ \tm -> Since<$>case tm of+    Always -> currentTime+    Since t -> (waitTill t >> currentTime) `amb` readMVar sem+    Never -> readMVar sem+  maxAction <- newIORef $ \tm -> case tm of+    Always -> Since<$>readMVar sem+    Since t -> (waitTill t >> pure Never) `amb` (Since<$>readMVar sem)+    Never -> Since<$>currentTime+    +  let refAction ref = \t -> unsafePerformIO (join (readIORef ref<*>pure t))+  _ <- forkIO $ do+    t <- io >> currentTime+    writeIORef minAction (const (pure (pure t)))+    writeIORef maxAction (const (pure (pure t)))     putMVar sem t     -  return $ Time $ join (readIORef action) --- print_ s a = putStrLn (s+": "+show a) >> pure a-+  return $ Time (refAction minAction) (refAction maxAction)   +waitTill :: Seconds -> IO () waitTill t = do   now <- t `seq` currentTime   when (t>now) $ threadDelay (floor $ (t-now)*1000000)-forkAt (Since t) io = () <$ forkIO (waitTill t >> io)-forkAt Always io = () <$ forkIO io-forkAt Never _ = return () +seconds :: TimeSpec -> Seconds seconds t = fromIntegral (sec t) + fromIntegral (nsec t)/1000000000 :: Seconds+currentTime :: IO Seconds currentTime = seconds<$>getTime Realtime

@@ -28,17 +28,26 @@ instance Traversable Tree where   sequence (Node a subs) = Node<$>a<*>sequence (map sequence subs) deriving instance Traversable ZipTree-instance (Traversable f,Traversable g) => Traversable (Compose f g) where+instance (Traversable f,Traversable g) => Traversable (f:.:g) where   sequence = getCompose >>> map sequence >>> sequence >>> map Compose+instance (Traversable f,Traversable g) => Traversable (f:**:g) where+  sequence (f:**:g) = (:**:)<$>sequence f<*>sequence g+instance (Traversable f,Traversable g) => Traversable (f:++:g) where+  sequence (Sum (Left f)) = Sum . Left<$>sequence f+  sequence (Sum (Right g)) = Sum . Right<$>sequence g  class Functor t => Contravariant t where   collect :: Functor f => f (t a) -> t (f a) instance Contravariant Id where collect f = Id (map getId f) instance Contravariant ((->) a) where collect f = \a -> map ($a) f +traverse :: (Applicative f,Traversable t) => (a -> f b) -> t a -> f (t b) traverse f t = sequence (map f t)+foreach :: (Applicative f,Traversable t) => t a -> (a -> f b) -> f (t b) foreach = flip traverse+transpose :: (Applicative f,Traversable t) => t (f a) -> f (t a) transpose = sequence+flip :: (Contravariant c,Functor f) => f (c a) -> c (f a) flip = collect  instance Compound a b [a] [b] where