diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2013, Marc Coiffier
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Marc Coiffier nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/SimpleH.cabal b/SimpleH.cabal
new file mode 100644
--- /dev/null
+++ b/SimpleH.cabal
@@ -0,0 +1,22 @@
+
+name:                SimpleH
+version:             0.9
+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
+license-file:        LICENSE
+author:              Marc Coiffier
+maintainer:          marc.coiffier@gmail.com
+category:            Prelude
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules: SimpleH.Containers SimpleH.Parser SimpleH.Foldable SimpleH.Core SimpleH.Traversable SimpleH.Functor SimpleH.Reactive SimpleH.Monad SimpleH.Arrow SimpleH.Applicative SimpleH.Lens SimpleH.Reactive.TimeVal SimpleH.Reactive.Time SimpleH
+  other-modules: SimpleH.Classes       
+  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
+source-repository head
+  type: git
+  location: git://github.com/lih/SimpleH.git
diff --git a/src/SimpleH.hs b/src/SimpleH.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH.hs
@@ -0,0 +1,11 @@
+module SimpleH(
+  module SimpleH.Arrow,
+  module SimpleH.Lens,
+  module SimpleH.Traversable,
+  module SimpleH.Core
+            ) where
+
+import SimpleH.Arrow
+import SimpleH.Core hiding (flip)
+import SimpleH.Lens
+import SimpleH.Traversable
diff --git a/src/SimpleH/Applicative.hs b/src/SimpleH/Applicative.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Applicative.hs
@@ -0,0 +1,112 @@
+-- |A module describing applicative functors
+module SimpleH.Applicative(
+  module SimpleH.Functor,
+
+  Applicative(..),
+  ZipList(..),ZipTree(..),Backwards(..),
+
+  (*>),(<*),(<**>),ap,sequence_,traverse_,for_,forever,
+
+  between,
+  
+  liftA,liftA2,liftA3,liftA4,
+
+  plusA,zeroA,filter
+  ) where
+
+import SimpleH.Functor
+import SimpleH.Classes
+import SimpleH.Core
+import Data.Tree
+import SimpleH.Foldable
+
+instance Applicative (Either a)
+instance Monad (Either a) where join (Right a) = a
+                                join (Left a) = Left a
+instance Applicative ((->) a)
+instance Semigroup b => Semigroup (a -> b) where (+) = plusA
+instance Monoid b => Monoid (a -> b) where zero = zeroA
+instance Ring b => Ring (a -> b) where (*) = timesA ; one = oneA
+instance Monad ((->) a) where join f x = f x x
+instance Monoid w => Applicative ((,) w)
+instance Monoid w => Monad ((,) w) where
+  join ~(w,~(w',a)) = (w+w',a)
+instance Applicative []
+instance Monad [] where join = fold
+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
+  Compose fs <*> Compose xs = Compose ((<*>)<$>fs<*>xs)
+deriving instance Unit Interleave
+instance Applicative Interleave
+instance Monad Interleave where join = fold
+
+{-|
+A wrapper type for lists with zipping Applicative instances, such that
+@ZipList [f1,...,fn] '<*>' ZipList [x1,...,xn] == ZipList [f1 x1,...,fn xn]@
+-}
+newtype ZipList a = ZipList { getZipList :: [a] }
+instance Semigroup a => Semigroup (ZipList a) where (+) = plusA
+instance Monoid a => Monoid (ZipList a) where zero = zeroA
+
+instance Functor ZipList where
+  map f (ZipList l) = ZipList (map f l)
+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 _ _ = []
+deriving instance Foldable ZipList
+
+-- |The Tree equivalent to ZipList
+newtype ZipTree a = ZipTree (Tree a)
+instance Functor ZipTree where
+  map f (ZipTree t) = ZipTree (map f t)
+instance Unit ZipTree where
+  pure a = ZipTree (Node a (getZipList (pure (pure a))))
+instance Applicative ZipTree where
+  ZipTree (Node f fs) <*> ZipTree (Node x xs) =
+    ZipTree (Node (f x) (getZipList ((<*>)<$>ZipList fs<*>ZipList xs)))
+deriving instance Foldable ZipTree
+
+-- |A wrapper for applicative functors with actions executed in the reverse order
+newtype Backwards f a = Backwards { forwards :: f a }
+deriving instance Semigroup (f a) => Semigroup (Backwards f a)
+deriving instance Monoid (f a) => Monoid (Backwards f a)
+deriving instance Ring (f a) => Ring (Backwards f a)
+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)
+
+ap = (<*>)
+infixl 2 <*,*>
+infixl 3 <**>
+(*>) = liftA2 (flip const)
+(<*) = liftA2 const
+(<**>) = liftA2 (&)
+sequence_ = foldr (*>) (pure ())
+traverse_ :: (Applicative f,Foldable t) => (a -> f b) -> t a -> f ()
+traverse_ f = sequence_ . map f
+for_ = flip traverse_
+
+forever m = undefined<$sequence_ (repeat m)
+
+liftA = map
+liftA2 f = \a b -> f<$>a<*>b
+liftA3 f = \a b c -> f<$>a<*>b<*>c
+liftA4 f = \a b c d -> f<$>a<*>b<*>c<*>d
+
+plusA = liftA2 (+)
+zeroA = pure zero
+oneA = pure one
+timesA = liftA2 (*)
+
+between start end p = liftA3 (\_ b _ -> b) start p end
+
+instance (Applicative f,Semigroup (g a)) => Semigroup (Compose f g a) where
+  Compose f+Compose g = Compose ((+)<$>f<*>g)
+instance (Applicative f,Monoid (g a)) => Monoid (Compose f g a) where
+  zero = Compose (pure zero)
diff --git a/src/SimpleH/Arrow.hs b/src/SimpleH/Arrow.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Arrow.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE DefaultSignatures, TupleSections #-}
+module SimpleH.Arrow (
+  module SimpleH.Monad,
+  
+  Arrow(..),
+  (>>^),(^>>),
+
+  Apply(..),comapA,app,dup,
+
+  Kleisli(..),
+
+  ListA(..)
+  ) where
+
+import SimpleH.Core hiding (flip)
+import SimpleH.Classes
+import SimpleH.Monad
+import SimpleH.Foldable
+
+(^>>) = promap
+(>>^) = (<&>)
+infixr 4 ^>>,>>^
+dup = arr (\a -> (a,a))
+
+class (Split k,Choice k) => Arrow k where
+  arr :: (a -> b) -> k a b
+instance Arrow (->) where arr = id
+class Arrow k => Apply k where
+  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
+  arr a = Kleisli (pure . a)
+
+newtype ListA k a b = ListA { runListA :: k [a] [b] }
+instance Category k => Category (ListA k) where
+  id = ListA id
+  ListA a . ListA b = ListA (a . b)
+instance Arrow k => Choice (ListA k) where
+  ListA f <|> ListA g = ListA (arr partitionEithers >>> (f<#>g) >>> arr (uncurry (+)))
+instance Arrow k => Split (ListA k) where
+  ListA f <#> ListA g = ListA (arr (\l -> (fst<$>l,snd<$>l)) >>> (f<#>g)
+                               >>> arr (\(c,d) -> (,)<$>c<*>d))
+instance Arrow k => Arrow (ListA k) where
+  arr f = ListA (arr (map f))
diff --git a/src/SimpleH/Classes.hs b/src/SimpleH/Classes.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Classes.hs
@@ -0,0 +1,22 @@
+{-# LANGUAGE DefaultSignatures #-}
+module SimpleH.Classes where
+
+import SimpleH.Core
+
+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)
+class Applicative m => Monad m where
+  join :: m (m a) -> m a
+  join m = m >>= id
+  infixl 1 >>=
+  (>>=) :: m a -> (a -> m b) -> m b
+  ma >>= k = join (map k ma)
+
+
diff --git a/src/SimpleH/Containers.hs b/src/SimpleH/Containers.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Containers.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+module SimpleH.Containers(
+  DataMap(..),
+
+  AList(..),
+  
+  S.Set,M.Map,
+
+  member,delete,minsert,insert
+  )
+  where
+
+import SimpleH.Core
+import SimpleH.Functor
+import SimpleH.Lens
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+class DataMap m k a | m -> k a where
+  lookup :: k -> m -> Maybe a
+  alter :: (Maybe a -> Maybe a) -> k -> m -> m
+member = map (at (from _maybe)) . lookup
+delete = alter (const Nothing) 
+minsert = alter (const (Just zero))  
+insert = alter . const . Just
+
+instance Ord a => DataMap (S.Set a) a Void where
+  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
+    where bef = S.member a s ; aft = (_maybe %~ f) bef 
+instance Ord k => DataMap (M.Map k a) k a where
+  lookup = M.lookup ; alter = M.alter
+  
+instance Ord a => Semigroup (S.Set a) where (+) = S.union
+instance Ord a => Monoid (S.Set a) where zero = S.empty
+instance Ord k => Semigroup (M.Map k a) where (+) = M.union
+instance Ord k => Monoid (M.Map k a) where zero = M.empty
+instance Functor (M.Map k) where map = M.map
+
+newtype AList k a = AList { getAList :: [(k,a)] }
+
+newtype Bimap a b = Bimap (M.Map a b,M.Map b a)
+                  deriving (Semigroup,Monoid)
+_inverse :: Iso' (Bimap a b) (Bimap b a)
+_inverse = iso (\(Bimap (a,b)) -> Bimap (b,a)) (\(Bimap (a,b)) -> Bimap (b,a))
+
+instance (Ord a,Ord b) => DataMap (Bimap a b) a b where
+  lookup a (Bimap (ma,_)) = lookup a ma
+  alter f a (Bimap (ma,mb)) = Bimap (ma',
+                                     (maybe id delete b
+                                      >>> maybe id (insert a) b') mb)
+                                                  
+    where b = lookup a ma ; b' = lookup a ma'
+          ma' = alter f a ma
+instance (Ord b,Ord a) => DataMap (Flip Bimap b a) b a where
+  lookup b (Flip (Bimap (_,mb))) = lookup b mb
+  alter f b = from (_inverse._Flip) %~ alter f b
diff --git a/src/SimpleH/Core.hs b/src/SimpleH/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Core.hs
@@ -0,0 +1,238 @@
+{-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, DefaultSignatures, TupleSections, EmptyDataDecls #-}
+module SimpleH.Core(
+  -- * Basic union and product types
+  Void,(:*:),(:+:),vd,
+
+  -- * Basic group and ring structure
+  -- ** Classes
+  Semigroup(..),SubSemi(..),Monoid(..),Ring(..),
+  Unit(..),
+
+  -- ** Common monoids
+  Endo(..),Dual(..),OrdList(..),Interleave(..),Accum(..),Max(..),
+  Product(..),
+  
+  -- * Fundamental control operations
+  Category(..),(<<<),(>>>),(+++),
+  Choice(..),Split(..),
+  
+  -- * Misc functions
+  const,(&),fix,
+
+  first,second,
+
+  ifThenElse,bool,guard,fail,unit,when,unless,
+
+  comparing,tailSafe,headDef,
+
+  inOrder,insertOrd,invertOrd,
+  
+  -- * The rest is imported from the Prelude
+  module Prelude
+  ) where
+
+import Prelude hiding (
+  Functor(..),Monad(..),
+  sequence,mapM,mapM_,sequence_,(=<<),
+
+  map,(++),foldl,foldr,concat,filter,length,sum,lookup,
+  (+),(*),(.),id,const,
+
+  or,any,and,all,elem
+
+  ,until)
+import qualified Prelude as P
+import Data.Tree
+import Data.Ord(comparing)
+
+data Void
+type a:*:b = (a,b)
+type a:+:b = Either a b
+
+vd = undefined :: Void
+
+{-|
+The class of all types that have a binary operation. Note that the operation
+isn't necesarily commutative (in the case of lists, for example)
+-} 
+class Semigroup m where
+  (+) :: m -> m -> m
+  default (+) :: Num m => m -> m -> m
+  (+) = (P.+)
+infixl 6 +
+instance Semigroup Void where _+_ = undefined
+instance Semigroup () where _+_ = ()
+instance Semigroup Bool where (+) = (||)
+instance Semigroup Int
+instance Semigroup Float
+instance Semigroup Double
+instance Semigroup Integer
+instance Semigroup [a] where []+l = l ; (x:t)+l = x:(t+l)
+instance (Semigroup a,Semigroup b) => Semigroup (a:*:b) where ~(a,b) + ~(c,d) = (a+c,b+d)
+instance (Semigroup a,Semigroup b,Semigroup c) => Semigroup (a,b,c) where
+  ~(a,b,c) + ~(a',b',c') = (a+a',b+b',c+c')
+instance SubSemi b a => Semigroup (a:+:b) where
+  Left a+Left b = Left (a+b)
+  a+b = Right (from a+from b)
+    where from = cast <|> id
+instance Semigroup (Maybe a) where
+  Nothing + b = b ; a + _ = a
+
+-- |A monoid is a semigroup with a null element such that @zero + a == a + zero == a@
+class Semigroup m => Monoid m where
+  zero :: m
+  default zero :: Num m => m
+  zero = 0
+instance Monoid Void where zero = undefined
+instance Monoid () where zero = ()
+instance Monoid Int ; instance Monoid Integer
+instance Monoid Float ; instance Monoid Double
+instance Monoid [a] where zero = []
+instance (Monoid a,Monoid b) => Monoid (a:*:b) where zero = (zero,zero)
+instance (Monoid a,Monoid b,Monoid c) => Monoid (a,b,c) where
+  zero = (zero,zero,zero)
+instance (SubSemi b a,Monoid a) => Monoid (a:+:b) where zero = Left zero
+instance Monoid Bool where zero = False
+instance Monoid (Maybe a) where zero = Nothing
+
+class (Semigroup a,Semigroup b) => SubSemi a b where
+  cast :: b -> a
+instance Monoid a => SubSemi a () where cast _ = zero
+instance Monoid a => SubSemi a Void where cast _ = zero
+
+class Monoid m => Ring m where
+  one :: m
+  default one :: Num m => m
+  one = 1
+  (*) :: m -> m -> m
+  default (*) :: Num m => m -> m -> m
+  (*) = (P.*)
+
+infixl 7 *
+instance Ring Bool where one = True ; (*) = (&&)
+instance Ring Int
+instance Ring Integer
+instance Ring Float
+instance Ring Double
+instance Monoid a => Ring [a] where
+  one = zero:one
+  (a:as) * (b:bs) = a+b:as*bs
+  _ * _ = zero
+
+class Unit f where
+  pure :: a -> f a
+instance Unit (Either a) where pure = Right
+instance Unit Maybe where pure = Just
+instance Monoid w => Unit ((,) w) where pure a = (zero,a)
+instance Unit ((->) b) where pure = P.const
+instance Unit [] where pure a = [a]
+instance Unit Tree where pure a = Node a []
+instance Unit IO where pure = P.return
+
+class Category k where
+  id :: k a a
+  (.) :: k b c -> k a b -> k a c
+instance Category (->) where
+  id = P.id
+  (.) = (P..)
+(<<<) = (.) ; (>>>) = flip (<<<)
+infixr 1 >>>,<<<
+infixr 9 .
+
+class Category k => Choice k where
+  (<|>) :: k a c -> k b c -> k (a:+:b) c
+infixr 1 <|>
+instance Choice (->) where
+  (f <|> _) (Left a) = f a
+  (_ <|> g) (Right b) = g b
+
+class Category k => Split k where
+  (<#>) :: k a c -> k b d -> k (a,b) (c,d)
+infixr 2 <#>
+instance Split (->) where f <#> g = \ ~(a,b) -> (f a,g b)
+
+{-| The Product monoid -}
+newtype Product a = Product { getProduct :: a }
+instance Ring a => Semigroup (Product a) where
+  Product a+Product b = Product (a*b) 
+instance Ring a => Monoid (Product a) where
+  zero = Product one
+
+{-| 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 => Monoid (Endo k a) where zero = Endo id
+
+{-| 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
+  Accum Nothing + Accum Nothing = Accum Nothing
+  Accum a + Accum b = Accum (Just (from a+from b))
+    where from = maybe zero id
+instance Monoid a => Monoid (Accum a) where zero = Accum Nothing
+instance Unit Accum where pure = Accum . pure
+
+{-| The Max monoid, where @(+) =~ max@ -}
+newtype Max a = Max { getMax :: a }
+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
+
+{-| The dual of a monoid is the same as the original, with arguments reversed -}
+newtype Dual m = Dual { getDual :: m }
+instance Semigroup m => Semigroup (Dual m) where Dual a+Dual b = Dual (b+a)
+deriving instance Monoid m => Monoid (Dual m)
+instance Ring m => Ring (Dual m) where 
+  one = Dual one
+  Dual a * Dual b = Dual (b*a)
+
+-- |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
+  OrdList a + OrdList b = OrdList (a ++ b)
+    where (x:xt) ++ (y:yt) = m : insertOrd m' xt ++ yt
+            where (m,m') = inOrder x y
+          a ++ b = a + b
+deriving instance Ord a => Monoid (OrdList a)
+deriving instance Unit OrdList
+
+insertOrd e [] = [e]
+insertOrd e (x:xs) = a:insertOrd b xs
+  where (a,b) = inOrder e x
+
+newtype Interleave a = Interleave { interleave :: [a] }
+instance Semigroup (Interleave a) where
+  Interleave as + Interleave bs = Interleave (inter as bs)
+    where inter (a:as) bs = a:inter bs as
+          inter [] bs = bs
+deriving instance Monoid (Interleave a)
+
+(&) = flip ($)
+infixl 0 &
+
+infixr 1 +++
+f +++ g = first.f <|> second.g
+
+second a = id <#> a
+first a = a <#> id
+
+guard p = if p then pure vd else zero
+
+ifThenElse b th el = if b then th else el
+bool th el b = ifThenElse b th el
+tailSafe [] = [] ; tailSafe (_:t) = t
+headDef d [] = d ; headDef _ (x:_) = x
+
+fail = error
+const = pure
+fix f = y where y = f y
+
+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
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Foldable.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE TupleSections, MultiParamTypeClasses #-}
+module SimpleH.Foldable where
+
+import SimpleH.Core
+import SimpleH.Classes
+import SimpleH.Functor
+import Data.Tree
+
+class Functor t => Foldable t where
+  fold :: Monoid m => t m -> m
+instance Foldable Id where fold = getId
+instance Foldable (Either a) where
+  fold = pure zero <|> id
+instance Foldable Maybe where
+  fold (Just w) = w ; fold Nothing = zero
+instance Foldable ((,) a) where fold = snd
+instance Foldable [] where
+  fold [] = zero
+  fold (x:t) = x+fold t
+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
+  fold = getCompose >>> map fold >>> fold
+
+newtype Sized f a = Sized { getSized :: f a }
+instance (Foldable f,Semigroup (Sized f a),Monoid n,Num n) =>
+         SubSemi n (Sized f a) where
+  cast = size . getSized
+
+foldMap f = fold . map f
+convert = foldMap pure
+concat = fold
+sum = fold
+size :: (Foldable f,Num n,Monoid n) => f a -> n
+size c = sum (1<$c)
+count = size
+length :: (Num n,Monoid n) => [a] -> n
+length = count
+
+split :: (Foldable t,Monoid b,Monoid c) => t (b:+:c) -> (b,c)
+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)
+partition p = split . map (\a -> (if p a then Left else Right) (pure a))
+filter p = fst . partition p
+select = filter
+refuse = filter . map not
+
+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
+
+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 = map and . map
+any = map or . map
+elem e = any (e==)
diff --git a/src/SimpleH/Functor.hs b/src/SimpleH/Functor.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Functor.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE MultiParamTypeClasses, RankNTypes, DefaultSignatures #-}
+-- |A module for functors
+module SimpleH.Functor(
+  Functor(..),Cofunctor(..),Bifunctor(..),
+  
+  Id(..),Const(..),Flip(..),Compose(..),
+
+  (<$>),(|||),(<$),(<&>),void,left,right,
+  promap,map2,map3
+  ) where
+
+import qualified Prelude as P
+
+import SimpleH.Classes
+import SimpleH.Core
+import Data.Tree
+
+class Cofunctor f where
+  comap :: (a -> b) -> f b -> f a
+instance (Functor f,Cofunctor g) => Cofunctor (Compose f g) where
+  comap f (Compose c) = Compose (map (comap f) c)
+instance Cofunctor (Flip (->) a) where
+  comap f (Flip g) = Flip (g . f)
+instance Bifunctor (->)
+
+class Bifunctor p where
+  dimap :: (c -> a) -> (b -> d) -> p a b -> p c d
+  default dimap :: (Functor (p a),Cofunctor (Flip p d)) => (c -> a) -> (b -> d) -> p a b -> p c d
+  dimap f g = promap f . map g
+
+instance Functor [] where map f = f' where f' [] = [] ; f' (x:t) = f x:f' t
+instance Functor Tree where
+  map f (Node a subs) = Node (f a) (map (map f) subs)
+
+-- |The Identity Functor
+newtype Id a = Id { getId :: a }
+             deriving Show
+instance Unit Id where pure = Id
+instance Functor Id
+instance Applicative Id
+instance Monad Id where Id a >>= k = k a
+
+-- |The Constant Functor
+newtype Const a b = Const { getConst :: a }
+instance Semigroup (Const a b) where a+_ = a
+instance Functor (Const a) where map _ (Const a) = Const a
+instance Monoid a => Unit (Const a) where pure _ = Const zero
+instance Monoid a => Applicative (Const a) where
+  Const a <*> Const b = Const (a+b)
+
+-- |A motherflippin' functor
+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
+  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
+  map f = Sum . ((Left<$>map f) <|> (Right<$>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 ((->) a) where map = (.)
+deriving instance Functor Interleave
+deriving instance Functor OrdList
+
+instance Functor IO where map = P.fmap
+instance Applicative IO
+instance Monad IO where (>>=) = (P.>>=)
+
+(<$>) = 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
+x<&>f = map f x
+(<$) :: Functor f => b -> f a -> f b
+a <$ x = const a <$> x
+infixr 3 <$>,<$
+infixl 1 <&>
+infixr 1 |||
+
+left a = a ||| id
+right a = id ||| a
+
+void :: Functor f => f a -> f ()
+void = (()<$)
+
+map2 :: (Functor f, Functor f') => (a -> b) -> f (f' a) -> f (f' b)
+map2 = map map map
+map3 :: (Functor f, Functor f', Functor f'') => (a -> b) -> f (f' (f'' a)) -> f (f' (f'' b))
+map3 = map.map2
+
+promap :: Cofunctor (Flip f c) => (a -> b) -> f b c -> f a c
+promap f c = unFlip (comap f (Flip c))
diff --git a/src/SimpleH/Lens.hs b/src/SimpleH/Lens.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Lens.hs
@@ -0,0 +1,212 @@
+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, ViewPatterns, TupleSections #-}
+{-|
+A module providing simple Lens functionality.
+
+Lenses are a Haskell abstraction that allows you to access and modify
+part of a structure, compensating for and improving upon Haskell's
+horrendous record syntax and giving Haskell a first-class record system.
+
+This module defines three kinds of Lenses : Lenses that allow you to
+access part of a structure; Traversals that allow you to modify part
+of a structure; and Isos which may be reversed. Lenses of any kind can
+be composed with @(.)@, yielding a Lens of the most general kind, so
+that composing a Lens with a Traversal or Iso yields a Lens, and a
+Traversal with an Iso yields a Traversal.
+-}
+module SimpleH.Lens(
+  -- * The lens types
+  Iso,Iso',(:<->:),
+  LensLike,LensLike',
+  Getter,Getter',
+  Lens,Lens',
+  Traversal,Traversal',
+
+  -- * Constructing lenses
+  iso,from,lens,getter,prism,
+
+  -- * Extracting values
+  (^.),(^..),(^?),(%~),(%-),at,at',warp,set,
+  (-.),(.-),
+  
+  -- * Basic lenses
+  _1,_2,_l,_r,Compound(..),
+  _list,_head,_tail,
+
+  -- * Isomorphisms
+  Isomorphic(..),
+  adding,
+  _Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,
+  warp2,_mapping,_promapping,
+  IsoFunctor(..),IsoFunctor2(..),
+  _thunk
+  ) where
+
+import SimpleH.Core
+import SimpleH.Functor
+import SimpleH.Applicative
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Exception (evaluate)
+
+type LensLike f s t a b = (s -> f t) -> (a -> f b)
+type LensLike' f a b = LensLike f b b a a
+
+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 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)
+type Iso' a b = Iso b b a a
+type a :<->: b = Iso' a b
+
+data IsoT a b s t = IsoT (s -> a) (b -> t)
+instance Functor (IsoT a b s) where map f (IsoT u v) = IsoT u (map f v)
+instance Cofunctor (Flip (IsoT a b) t) where
+  comap f (Flip (IsoT u v)) = Flip (IsoT (promap f u) v)
+instance Bifunctor (IsoT a b)
+
+-- |Create an 'Iso' from two inverse functions.
+iso :: (a -> s) -> (t -> b) -> Iso s t a b
+iso f g = dimap f (map g)
+isoT :: Iso s t a b -> IsoT s t a b
+isoT i = getId<$>i (IsoT id Id)
+unIsoT :: IsoT s t a b -> Iso s t a b
+unIsoT (IsoT u v) = iso u v
+-- |Reverse an 'Iso'
+--
+-- @
+-- from :: 'Iso'' a b -> 'Iso'' b a
+-- @
+from :: Iso s t a b -> Iso b a t s
+from = isoT >>> (\ ~(IsoT u v) -> IsoT v u) >>> unIsoT
+-- |Create a 'Lens' from a getter and setter function.
+-- 
+-- @
+-- lens :: (a -> b) -> (a -> b -> a) -> 'Lens'' a b
+-- @
+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 f = lens f undefined
+
+-- |Create a 'Traversal' from a maybe getter and setter function.
+--
+-- @
+-- prism :: (a -> (a:+:b)) -> (a -> b -> a) -> 'Traversal'' a b
+-- @
+prism :: (a -> (b:+:s)) -> (a -> t -> b) -> Traversal s t a b 
+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 ^.,^..,^?,%~
+(^.) = flip at
+(^..) = flip at'
+-- |
+(%~) = warp
+(%-) = set
+(^?) :: (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
+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 l = getConst . l Const
+at' :: Iso s t a b -> t -> b
+at' i = at (from i)
+warp :: Traversal s t a b -> (s -> t) -> (a -> b)
+warp l = map getId . l . map Id
+set :: Traversal s t a b -> t -> (a -> b)
+set l = warp l . const 
+
+_1 :: Lens a b (a:*:c) (b:*:c)
+_1 = lens fst (flip (first . const))
+_2 :: Lens a b (c:*:a) (c:*:b)
+_2 = lens snd (flip (second . const))
+_l :: Traversal a b (a:+:c) (b:+:c)
+_l = prism ((id ||| Right) >>> swapE) (flip (left . const))
+_r :: Traversal a b (c:+:a) (c:+:b)
+_r = prism (Left ||| id) (flip (right . const))
+
+swapE = Right<|>Left
+
+class Compound a b s t | s -> a, b s -> t where
+  _each :: Traversal a b s t
+instance Compound a b (a,a) (b,b) where
+  _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''
+_list :: [a] :<->: (():+:(a:*:[a]))
+_list = iso (\l -> case l of
+                [] -> Left ()
+                (x:t) -> Right (x,t)) (const [] <|> uncurry (:))
+
+_head :: Traversal' [a] a
+_head = _list._r._1
+_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 (isoT -> IsoT u v) = map u `dimap` map (map v)
+_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)
+
+class Isomorphic b a t s | t -> b, t a -> s where
+  _iso :: Iso s t a b
+instance Isomorphic a b (Id a) (Id b) where
+  _iso = iso Id getId
+instance Isomorphic [a] [b] (OrdList a) (OrdList b) where
+  _iso = iso OrdList getOrdList
+instance Isomorphic a b (Const a c) (Const b c) where
+  _iso = iso Const getConst
+instance Isomorphic a b (Dual a) (Dual b) where
+  _iso = iso Dual getDual
+instance Isomorphic a b (Max a) (Max b) where
+  _iso = iso Max getMax
+instance Isomorphic (k a a) (k b b) (Endo k a) (Endo k b) where
+  _iso = iso Endo runEndo
+instance Isomorphic (f a b) (f c d) (Flip f b a) (Flip f d c) where
+  _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
+  _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' [a] (OrdList a)
+_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))
+_Backwards = iso Backwards forwards
+_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)
+
+class IsoFunctor f where
+  mapIso :: Iso s t a b -> Iso (f s) (f t) (f a) (f b)
+class IsoFunctor2 f where
+  mapIso2 :: Iso' a b -> Iso' c d -> Iso' (f a c) (f b d)
+
+instance IsoFunctor ((->) a) where mapIso = _mapping
+instance IsoFunctor2 (->) where mapIso2 i j = _promapping i._mapping j
+instance IsoFunctor2 (,) where
+  mapIso2 i j = iso (at i <#> at j) (at' i <#> at' j)
+instance IsoFunctor2 Either where
+  mapIso2 i j = iso (at i ||| at j) (at' i ||| at' j)
+
+adding :: (Num n,Monoid n) => n -> Iso' n n
+adding n = iso (+n) (subtract n)
+
+_thunk :: Iso a b (IO a) (IO b)
+_thunk = iso unsafePerformIO evaluate
diff --git a/src/SimpleH/Monad.hs b/src/SimpleH/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Monad.hs
@@ -0,0 +1,359 @@
+{-# LANGUAGE MultiParamTypeClasses, TupleSections, Rank2Types, UndecidableInstances, FunctionalDependencies #-}
+module SimpleH.Monad(
+  module SimpleH.Applicative,
+
+  -- * The basic Monad interface
+  Monad(..),MonadFix(..),MonadTrans(..),
+
+  -- * Monad utilities
+  Kleisli(..),_Kleisli,
+  (=<<),(<=<),(>=>),(>>),(<*=),return,
+  foldlM,foldrM,while,until,
+  
+  -- * Common monads
+  -- ** The RWS Monad
+  RWST(..),RWS,
+
+  -- *** The State Monad
+  MonadState(..),
+  StateT,State,
+  _stateT,eval,exec,_state,
+  (=~),(=-),gets,saving,
+  mapAccum,mapAccum_,mapAccumR,mapAccumR_,push,pop,withPrev,withNext,
+  
+  -- *** The Reader monad
+  MonadReader(..),
+  ReaderT,Reader,
+  _readerT,_reader,
+
+  -- *** The Writer monad
+  MonadWriter(..),
+  WriterT,Writer,
+  _writerT,_writer,
+  mute,intercept,
+
+  -- ** The Continuation monad
+  MonadCont(..),
+  ContT(..),Cont,
+  evalContT,
+  evalCont,
+
+  -- ** The List monad
+  MonadList(..),
+  ListT,
+  _listT,
+
+  -- ** The Error Monad
+  MonadError(..),try,
+  EitherT,
+  eitherT,runEitherT,
+  ) where
+
+import SimpleH.Classes
+import SimpleH.Applicative
+import SimpleH.Core hiding (flip)
+import SimpleH.Traversable
+import SimpleH.Lens
+import qualified Control.Exception as Ex
+import qualified Control.Monad.Fix as Fix
+
+instance (Traversable g,Monad f,Monad g) => Monad (Compose f g) where
+  join = Compose .map join.join.map sequence.getCompose.map getCompose
+
+-- |The class of all monads that have a fixpoint
+class Monad m => MonadFix m where
+  mfix :: (a -> m a) -> m a
+instance MonadFix Id where mfix = cfix
+instance MonadFix ((->) b) where mfix = cfix
+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) 
+mfixing f = fst<$>mfix (\ ~(_,b) -> f b )
+
+class MonadTrans t where
+  lift :: Monad m => m a -> t m a
+class MonadTrans t => MonadInternal t where
+  internal :: Monad m => (forall c. m (c,a) -> m (c,b)) ->
+              (t m a -> t m b)
+
+newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }
+instance Monad m => Category (Kleisli m) where
+  id = Kleisli pure
+  Kleisli f . Kleisli g = Kleisli (\a -> g a >>= f)
+instance Monad m => Choice (Kleisli m) where
+  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
+  _iso = iso Kleisli runKleisli
+_Kleisli = _iso :: Iso' (a -> m b) (Kleisli m a b)
+
+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 = folding (_Kleisli._Endo._Dual)
+foldrM = folding (_Kleisli._Endo)
+
+while e = fix (\w -> e >>= maybe (return()) (const w))
+until e = fix (\w -> e >>= maybe w return)
+
+infixr 2 >>,=<<
+infixr 1 <*=
+(>>) = (*>)
+(=<<) = flip (>>=)
+f <=< g = \a -> g a >>= f
+(>=>) = flip (<=<)
+a <*= f = a >>= \a -> f a >> return 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 runRWST
+
+instance (Unit f,Monoid w) => Unit (RWST r w s f) where
+  pure a = RWST (\ ~(_,s) -> pure (a,s,zero))
+instance Functor f => Functor (RWST r w s f) where
+  map f (RWST fa) = RWST (fa >>> map (\ ~(a,s,w) -> (f a,s,w)))
+instance (Monoid w,Monad m) => Applicative (RWST r w s m)
+instance (Monoid w,Monad m) => Monad (RWST r w s m) where
+  join mm = RWST (\ ~(r,s) -> do
+                     ~(m,s',w) <- runRWST mm (r,s)
+                     ~(a,s'',w') <- runRWST m (r,s')
+                     return (a,s'',w+w'))
+instance (Monoid w,MonadFix m) => MonadFix (RWST r w s m) where
+  mfix f = RWST (\x -> mfix (\ ~(a,_,_) -> runRWST (f a) x))
+instance (Monoid w,MonadCont m) => MonadCont (RWST r w s m) where
+  callCC f = RWST $ \(r,s) ->
+    callCC $ \k -> runRWST (f (\a -> lift (k (a,s,zero)))) (r,s)
+deriving instance Semigroup (m (a,s,w)) => Semigroup (RWST r w s m a)
+deriving instance Monoid (m (a,s,w)) => Monoid (RWST r w s m a)
+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) )
+  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) )
+  local f (RWST m) = RWST (\ ~(r,s) -> m (f r,s) )
+instance (Monad m,Monoid w) => MonadWriter w (RWST r w s m) where
+  tell w = RWST (\ ~(_,s) -> pure ((),s,w) )
+  listen (RWST m) = RWST (m >>> map (\ ~(a,s,w) -> ((w,a),s,w) ) )
+  censor (RWST m) = RWST (m >>> map (\ ~(~(a,f),s,w) -> (a,s,f w) ) )
+instance Foldable m => Foldable (RWST Void w Void m) where
+  fold (RWST m) = foldMap (\(w,_,_) -> w).m $ (vd,vd)
+instance Traversable m => Traversable (RWST Void w Void m) where
+  sequence (RWST m) = map (RWST . const . map (\((s,w),a) -> (a,s,w)))
+                      . sequence . map (\(a,s,w) -> sequence ((s,w),a))
+                      $ m (vd,vd)
+instance (Monoid w,MonadError e m) => MonadError e (RWST r w s m) where
+  throw = lift.throw
+  catch f (RWST m) = RWST (\x -> catch (flip runRWST x.f) (m x))
+instance Monoid w => MonadTrans (RWST r w s) where
+  lift m = RWST (\ ~(_,s) -> (,s,zero) <$> m)
+instance (Monoid w) => MonadInternal (RWST r w s) where
+  internal f (RWST m) = RWST (\ x -> f (m x <&> \ ~(a,s,w) -> ((s,w),a) )
+                                     <&> \ ~((s,w),b) -> (b,s,w) )
+  
+{-| A simple State Monad  -}
+class Monad m => MonadState s m | m -> s where
+  get :: m s
+  put :: s -> m ()
+  put = modify . const
+  modify :: (s -> s) -> m ()
+  modify f = get >>= put . f
+get_ = lift get ; put_ = lift . put ; modify_ = lift . modify  
+
+newtype StateT s m a = StateT (RWST Void Void s m a)
+                     deriving (Unit,Functor,Applicative,Monad,MonadFix,
+                               MonadTrans,MonadInternal,
+                               MonadCont,MonadState s)
+type State s a = StateT s Id a
+instance MonadReader r m => MonadReader r (StateT s m) where
+  ask = ask_ ; local = local_
+instance MonadWriter w m => MonadWriter w (StateT s m) where
+  tell = tell_ ; listen = listen_ ; censor = censor_
+deriving instance MonadError e m => MonadError e (StateT s m)
+deriving instance Semigroup (m (a,s,Void)) => Semigroup (StateT s m a)
+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 (\ ~(StateT s) -> s)
+_stateT :: Functor m => Iso' (s -> m (s,a)) (StateT s m a)
+_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)
+_state = _mapping _Id._stateT
+
+(=-) :: MonadState s m => Lens' s s' -> s' -> m ()
+infixl 0 =-,=~
+l =- x = modify (set l x)
+(=~) :: MonadState s m => Lens' s s' -> (s' -> s') -> m ()
+l =~ f = modify (warp l f)
+gets :: MonadState s m => Lens' s s' -> m s'
+gets l = at l<$>get
+
+saving :: MonadState s m => Lens' s s' -> m a -> m a
+saving l st = gets l >>= \s -> st <* (l =- s)
+
+mapAccum f t = traverse (at _state<$>f) t^.._state
+mapAccum_ = (map.map.map) snd mapAccum
+mapAccumR f t = traverse (at (_state._Backwards)<$>f) t^.._state._Backwards
+mapAccumR_ = (map.map.map) snd mapAccumR
+
+push = mapAccum_ (,)
+pop = mapAccumR_ (,)
+
+withPrev a e = (,)<$>push e a<*>e
+withNext e a = (,)<$>e<*>pop e 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)
+{-| A simple Reader monad -}
+newtype ReaderT r m a = ReaderT (RWST r Void Void m a) 
+                      deriving (Functor,Unit,Applicative,Monad,MonadFix,
+                                MonadTrans,MonadInternal,
+                                MonadReader r,MonadCont)
+type Reader r a = ReaderT r Id a
+
+_readerT :: Functor m => Iso' (r -> m a) (ReaderT r m a)
+_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 = _mapping _Id._readerT
+
+instance MonadState s m => MonadState s (ReaderT r m) where
+  get = get_ ; put = put_ ; modify = modify_
+instance MonadWriter w m => MonadWriter w (ReaderT r m) where
+  tell = tell_ ; listen = listen_ ; censor = censor_
+deriving instance Semigroup (m (a,Void,Void)) => Semigroup (ReaderT r m a)
+deriving instance Monoid (m (a,Void,Void)) => Monoid (ReaderT r m a)
+deriving instance Ring (m (a,Void,Void)) => Ring (ReaderT r m a)
+
+class (Monad m,Monoid w) => MonadWriter w m | m -> w where
+  tell :: w -> m ()
+  listen :: m a -> m (w,a)
+  censor :: m (a,w -> w) -> m a
+tell_ = lift . tell
+listen_ = internal (\m -> listen m <&> \(w,(c,a)) -> (c,(w,a)) )
+censor_ = internal (\m -> censor (m <&> \(c,(a,f)) -> ((c,a),f)))
+instance Monoid w => MonadWriter w ((,) w) where
+  tell w = (w,())
+  listen m@(w,_) = (w,m)
+  censor ~(w,~(a,f)) = (f w,a)
+  
+mute :: (MonadWriter w m,Monoid w) => m a -> m a
+mute m = censor (m<&>(,const zero))
+intercept :: (MonadWriter w m,Monoid w) => m a -> m (w,a)
+intercept = listen >>> mute
+
+{-| A simple Writer monad -}
+newtype WriterT w m a = WriterT (RWST Void w Void m a)
+                      deriving (Unit,Functor,Applicative,Monad,MonadFix
+                               ,Foldable,Traversable
+                               ,MonadTrans,MonadInternal
+                               ,MonadWriter w,MonadCont)
+type Writer w a = WriterT w Id a
+instance (Monoid w,MonadReader r m) => MonadReader r (WriterT w m) where
+  ask = ask_ ; local = local_
+instance (Monoid w,MonadState r m) => MonadState r (WriterT w m) where
+  get = get_ ; put = put_ ; modify = modify_
+deriving instance Semigroup (m (a,Void,w)) => Semigroup (WriterT w m a)
+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 = iso writerT runWriterT
+  where writerT w = WriterT (RWST (pure (w <&> \ ~(w,a) -> (a,vd,w) )))
+        runWriterT (WriterT (RWST m)) = m (vd,vd) <&> \ ~(a,_,w) -> (w,a)
+_writer = _Id._writerT
+
+{-| A simple continuation monad implementation  -}
+class Monad m => MonadCont m where
+  callCC :: ((a -> m b) -> m a) -> m a
+
+newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }
+                      deriving (Semigroup,Monoid,Ring)
+type Cont r a = ContT r Id a
+instance Unit m => Unit (ContT r m) where pure a = ContT ($a)
+instance Functor f => Functor (ContT r f) where
+  map f (ContT c) = ContT (\kb -> c (kb . f))
+instance Applicative m => Applicative (ContT r m) where
+  ContT cf <*> ContT ca = ContT (\kb -> cf (\f -> ca (\a -> kb (f a))))
+instance Monad m => Monad (ContT r m) where
+  ContT k >>= f = ContT (\cc -> k (\a -> runContT (f a) cc))
+instance MonadTrans (ContT r) where
+  lift m = ContT (m >>=)
+instance Monad m => MonadCont (ContT r m) where
+  callCC f = ContT (\k -> runContT (f (\a -> ContT (\_ -> k a))) k)
+
+evalContT c = runContT c return
+evalCont = getId . evalContT
+
+instance MonadTrans Backwards where
+  lift = Backwards
+instance MonadFix m => Monad (Backwards m) where
+  join (Backwards ma) = Backwards$mfixing (\a -> liftA2 (,) (forwards a) ma)
+
+class Monad m => MonadList m where
+  fork :: [a] -> m a
+instance MonadList [] where fork = id
+newtype ListT m a = ListT ((m`Compose`[]) a)
+                    deriving (Semigroup,Monoid,
+                              Functor,Applicative,Unit,Monad,
+                              Foldable,Traversable)
+_listT :: Iso' (m [a]) (ListT m a)
+_listT = iso (ListT . Compose) (\(ListT (Compose m)) -> m)
+instance Monad m => MonadList (ListT m) where
+  fork = at _listT . return 
+instance MonadFix m => MonadFix (ListT m) where
+  mfix f = at _listT (mfix (at' _listT . f . head))
+instance MonadTrans ListT where
+  lift ma = (return<$>ma)^._listT
+instance MonadState s m => MonadState s (ListT m) where
+  get = get_ ; modify = modify_ ; put = put_
+instance MonadWriter w m => MonadWriter w (ListT m) where
+  tell = lift.tell
+  listen = _listT-.map sequence.listen.-_listT
+  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
+
+class Monad m => MonadError e m where
+  throw :: e -> m Void
+  catch :: (e -> m a) -> m a -> m a
+try d = catch (\x -> const d (x::Void))
+instance MonadError e (Either e) where
+  throw = Left
+  catch f = f<|>Right
+instance MonadError Void [] where
+  throw = const zero
+  catch f [] = f vd
+  catch _ l = l
+newtype EitherT e m a = EitherT ((m`Compose`Either e) a)
+                      deriving (Unit,Functor,Applicative,Monad,MonadFix
+                               ,Foldable,Traversable)
+eitherT = EitherT . Compose
+runEitherT (EitherT m) = getCompose m
+
+instance Applicative Maybe
+instance Monad Maybe where join = fold
+instance MonadError Void Maybe where
+  throw = const Nothing
+  catch f Nothing = f vd
+  catch _ a = a
+instance Ex.Exception e => MonadError e IO where
+  throw = Ex.throw
+  catch = flip Ex.catch
+
diff --git a/src/SimpleH/Parser.hs b/src/SimpleH/Parser.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Parser.hs
@@ -0,0 +1,48 @@
+module SimpleH.Parser where
+
+import SimpleH.Core hiding (flip)
+import SimpleH.Monad
+import SimpleH.Traversable
+import SimpleH.Lens
+
+newtype ParserT w c m a = ParserT (StateT [c] (ListT (WriterT w m)) a)
+                        deriving (Unit,Functor,Applicative,Monoid,Semigroup,
+                                  Monad,MonadFix,MonadState [c],MonadWriter w)
+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 (\(ParserT p) -> p)
+_parserT :: Functor m => Iso' ([c] -> m (w,[([c],a)])) (ParserT w c m a)
+_parserT = _mapping (_writerT._listT)._stateT._ParserT
+_parser = _mapping _Id._parserT
+
+remaining :: (Monad m,Monoid w) => ParserT w c m [c]
+remaining = get 
+token :: (Monad m,Monoid w) => ParserT w c m c
+token = get >>= \s -> case s of [] -> zero ; c:t -> put t >> pure c
+many :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]
+many p = liftA2 (:) p (many p) <+> pure []
+many1 :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]
+many1 p = (:)<$>p<*>many p
+
+satisfy p = token <*= (guard . p)
+single c = void (satisfy (c==))
+
+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 = remaining >>= guard.null
+
+sepBy1 p sep = (:)<$>p<*>many (sep >> p)
+sepBy p sep = option [] (sepBy1 p sep)
+(<+>) = (+)
+oneOf = satisfy . elem
+noneOf = satisfy . map not . elem
+
+infixl 1 `sepBy`,`sepBy1`,<+>
+
+chain expr op e = chain where chain = (expr<**>op<*>chain) + e
diff --git a/src/SimpleH/Reactive.hs b/src/SimpleH/Reactive.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Reactive.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE RebindableSyntax, GeneralizedNewtypeDeriving, TupleSections, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ViewPatterns #-}
+module SimpleH.Reactive (
+  module SimpleH.Reactive.Time,
+  module SimpleH.Reactive.TimeVal,
+
+  -- * Reactive Events
+  Event,_event,
+
+  -- ** Contructing events
+  atTimes,
+  withTime,times,
+  mapFutures,
+
+  -- ** Combining events
+  (//),(<|*>),
+
+  -- ** Filtering events
+  groupE,mask,
+
+  -- ** Real-world event synchronization
+  sink,event,
+  
+  -- * Future values
+  Future,_future,_time,_value,futureIO,
+  ) where
+
+import SimpleH
+import Control.Concurrent
+import SimpleH.Reactive.TimeVal
+import System.IO.Unsafe (unsafeInterleaveIO)
+import Data.List (group)
+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 }
+                  deriving (Unit,Functor,Foldable,Traversable)
+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) (+)
+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)
+  _ <*> _ = zero
+instance (Bounded t,Ord t) => Monad (Event t) where
+  join = map (at' _event) >>> at' _event >>> map (sequence >>> map join >>> group >>> map last)
+         >>> merge >>> at _event
+    where merge [] = []
+          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)
+
+type EventRep t a = Compose [] (Future t) a
+_Event :: Iso (Event t a) (Event t' b) (EventRep t a) (EventRep t' b)
+_Event = 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
+
+{-| The \'splice\' operator. Occurs when @a@ occurs.
+
+> 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 ((==GT) . cmpFut b) es
+infixl 1 //
+
+{-|
+The \'over\' operator. Occurs only when @a@ occurs.
+
+> 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 <|*>
+
+-- |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)+))
+          where (xs,ys) = span ((==f^._value) . at _value) fs ; f = head fs
+
+mapFutures f = from _event %~ map f
+withTime = mapFutures (\(Future f) -> Future (_1%~timeVal <$> listen f))
+times = map2 fst withTime
+
+mask m e = (m // e) `withNext` (True,zero) >>= \((b,_),(_,e)) -> guard b >> e
+
+-- |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)
+
+-- |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
+_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)
+_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)
+futureIO :: IO a -> IO (Future Seconds a)
+futureIO m = do
+  val <- newEmptyMVar
+  forkIO $ putMVar val =<< m 
+  time <- timeIO (readMVar val)
+  return (Future (time,readMVar val^._thunk))
+
+
diff --git a/src/SimpleH/Reactive/Time.hs b/src/SimpleH/Reactive/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Reactive/Time.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE TupleSections, RecursiveDo #-}
+module SimpleH.Reactive.Time (
+  -- * Unambiguous times
+  Time,
+  timeVal,
+
+  -- * Time utilities
+  Seconds,
+  timeIO,waitTill,currentTime,
+  ) where
+
+import SimpleH
+import Control.Concurrent
+import SimpleH.Reactive.TimeVal
+import System.IO.Unsafe
+import Data.IORef
+import System.Clock
+import Control.Exception (AsyncException(..))
+
+type MinMax 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)))))
+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 
+    where cmp (a,a') (b,b') | a'<b = Just LT | b'<a = Just GT
+                            | a==a' && b==b' = Just EQ
+                            | otherwise = Nothing
+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
+instance Ord t => Monoid (Time t) where
+  zero = minBound
+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)
+  
+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
+
+timeIO io = do
+  sem <- newEmptyMVar
+  defined <- newIORef False
+  value <- newIORef undefined
+  forkIO $ mdo
+    io >> writeIORef value (Since t)
+    writeIORef defined True
+    t <- currentTime
+    putMVar sem ()
+    
+  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
+
+  
+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 Always io = () <$ forkIO io
+forkAt Never io = 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
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Reactive/TimeVal.hs
@@ -0,0 +1,23 @@
+module SimpleH.Reactive.TimeVal (
+  TimeVal(..)
+  ) where
+
+import SimpleH
+
+-- |A type wrapper that adds a Bounded instance for types that don't possess one.
+data TimeVal t = Always | Since t | Never
+                 deriving (Show,Eq,Ord)
+instance Functor TimeVal where
+  map f (Since a) = Since (f a)
+  map _ Always = Always
+  map _ Never = Never
+instance Unit TimeVal where pure = Since
+instance Applicative TimeVal
+instance Monad TimeVal where
+  join (Since b) = b
+  join Always = Always
+  join Never = Never
+
+instance Bounded (TimeVal t) where
+  minBound = Always ; maxBound = Never
+
diff --git a/src/SimpleH/Traversable.hs b/src/SimpleH/Traversable.hs
new file mode 100644
--- /dev/null
+++ b/src/SimpleH/Traversable.hs
@@ -0,0 +1,45 @@
+module SimpleH.Traversable(
+  module SimpleH.Applicative, module SimpleH.Foldable,
+
+  Traversable(..),Contravariant(..),
+
+  traverse,foreach,transpose,flip
+  ) where
+
+import SimpleH.Classes
+import SimpleH.Core hiding (flip,(&))
+import SimpleH.Applicative
+import SimpleH.Foldable
+import SimpleH.Lens
+import Data.Tree
+
+class Foldable t => Traversable t where
+  sequence :: Applicative f => t (f a) -> f (t a)
+instance Traversable ((,) c) where
+  sequence ~(c,m) = (,) c<$>m
+instance Traversable (Either a) where
+  sequence = pure . Left <|> map Right
+instance Traversable [] where
+  sequence (x:xs) = (:)<$>x<*>sequence xs
+  sequence [] = pure []
+deriving instance Traversable Interleave
+deriving instance Traversable OrdList
+deriving instance Traversable ZipList
+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
+  sequence = getCompose >>> map sequence >>> sequence >>> map Compose
+
+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 f t = sequence (map f t)
+foreach = flip traverse
+transpose = sequence
+flip = collect
+
+instance Compound a b [a] [b] where
+  _each = traverse