definitive-base (empty) → 1.0

raw patch · 26 files changed

+2553/−0 lines, 26 filesdep +arraydep +basedep +bytestring

Dependencies added: array, base, bytestring, clock, containers, deepseq, primitive, vector

Files

• Algebra.hs +28/−0
• Algebra/Applicative.hs +143/−0
• Algebra/Arrow.hs +59/−0
• Algebra/Classes.hs +50/−0
• Algebra/Core.hs +365/−0
• Algebra/Foldable.hs +93/−0
• Algebra/Functor.hs +107/−0
• Algebra/Lens.hs +321/−0
• Algebra/Monad.hs +23/−0
• Algebra/Monad/Base.hs +121/−0
• Algebra/Monad/Cont.hs +32/−0
• Algebra/Monad/Error.hs +44/−0
• Algebra/Monad/Foldable.hs +54/−0
• Algebra/Monad/RWS.hs +89/−0
• Algebra/Monad/Reader.hs +39/−0
• Algebra/Monad/State.hs +103/−0
• Algebra/Monad/Writer.hs +83/−0
• Algebra/Time.hs +138/−0
• Algebra/Traversable.hs +67/−0
• Data/Containers.hs +144/−0
• Data/Containers/Sequence.hs +64/−0
• Data/Probability.hs +20/−0
• Data/Reactive.hs +209/−0
• Data/TimeVal.hs +30/−0
• LICENSE +69/−0
• definitive-base.cabal +58/−0

@@ -0,0 +1,28 @@+{-# LANGUAGE ImplicitParams #-}+module Algebra (+  module Algebra.Core,+  module Algebra.Arrow,+  module Algebra.Traversable,+  module Algebra.Lens,+  trace,trace2,mtrace,debug,++  cli+  ) where++import Algebra.Arrow+import Algebra.Core hiding (flip)+import Algebra.Lens+import Algebra.Traversable+import System.Environment (getArgs)++trace :: String -> a -> a+trace s x = (putStrLn s^.thunk)`seq`x+trace2 :: String -> String -> a -> a+trace2 b a x = trace b (x`seq`trace a x)+mtrace :: Unit f => String -> f ()+mtrace str = trace str (pure ())+debug :: Show a => a -> a+debug x = trace (show x) x++cli :: (( ?cliargs :: [String] ) => IO a) -> IO a+cli main = getArgs >>= \a -> let ?cliargs = a in main

@@ -0,0 +1,143 @@+-- |A module describing applicative functors+module Algebra.Applicative(+  module Algebra.Functor,++  Applicative(..),+  ZipList(..),ZipTree(..),Backwards(..),++  (*>),(<*),(<**>),ap,sequence_,traverse_,for_,forever,++  between,+  +  liftA,liftA2,liftA3,liftA4,++  plusA,zeroA+  ) where++import Algebra.Functor+import Algebra.Classes+import Algebra.Core+import Data.Tree+import Algebra.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 Semiring b => Semiring (a -> b) where (*) = timesA+instance Ring b => Ring (a -> b) where 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 Maybe+instance Monad Maybe where join = fold++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')+deriving instance Unit Interleave+instance Applicative Interleave+instance Monad Interleave where join = fold++instance (Applicative f,Applicative g) => Applicative (f:.:g) where+  Compose fs <*> Compose xs = Compose ((<*>)<$>fs<*>xs)++{-|+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 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+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 Semiring (f a) => Semiring (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 (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,Semiring 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 1 <**>+infixl 3 <*,*>+(*>) = liftA2 (flip const)+(<*) = liftA2 const+f <**> x = liftA2 (&) x f++sequence_ = foldr (*>) (pure ())+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 = fix (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 (+)+zeroA = pure zero+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 ((f:.:g) a) where+  Compose f+Compose g = Compose ((+)<$>f<*>g)+instance (Applicative f,Monoid (g a)) => Monoid ((f:.:g) a) where+  zero = Compose (pure zero)

@@ -0,0 +1,59 @@+{-# LANGUAGE DefaultSignatures, TupleSections #-}+module Algebra.Arrow (+  module Algebra.Monad,+ +  Arrow(..),+  (>>^),(^>>),++  Apply(..),comapA,app,dup,++  Kleisli(..),++  ListA(..)+  ) where++import Algebra.Core hiding (flip)+import Algebra.Classes+import Algebra.Monad++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+instance Monad m => Arrow (StateA m) where+  arr f = StateA (f<$>get)++class Arrow k => Apply k where+  apply :: k (k a b,a) b+instance Apply (->) where apply (f,x) = f x++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))++(^>>) = promap+(>>^) = (<&>)+infixr 4 ^>>,>>^+dup = arr (\a -> (a,a))++comapA f (Flip g) = Flip (arr f >>> g)+app f = arr (f,) >>> apply

@@ -0,0 +1,50 @@+{-# LANGUAGE DefaultSignatures #-}+module Algebra.Classes where++import Algebra.Core++class Functor f where+  map :: (a -> b) -> f a -> f b+class (Unit f, Functor f) => Applicative f where+  infixl 1 <*>+  (<*>) :: f (a -> b) -> f a -> f b+  default (<*>) :: Monad f => f (a -> b) -> f a -> f b+  fs <*> xs = fs >>= \f -> map f xs+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)++-- |The class of all monads that have a fixpoint+class Monad m => MonadFix m where+  mfix :: (a -> m a) -> m a+class MonadTrans t where+  lift :: Monad m => m a -> t m a+class MonadTrans t => ConcreteMonad t where+  generalize :: Monad m => t Id a -> t m a++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+class Monad m => MonadReader r m | m -> r where+  ask :: m r+  local :: (r -> r) -> m a -> 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+class (SubSemi acc w,MonadWriter w m) => MonadWriterAcc w acc m where+  getAcc :: m acc++class Monad m => MonadList m where+  fork :: [a] -> m a+class Monad m => MonadCont m where+  callCC :: ((a -> m b) -> m a) -> m a+class Monad m => MonadError e m | m -> e where+  throw :: e -> m a+  catch :: (e -> m a) -> m a -> m a

@@ -0,0 +1,365 @@+{-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, DefaultSignatures, TupleSections, EmptyDataDecls #-}+module Algebra.Core(+  -- * Raw data+  Handle,+  Bytes,readBytes,writeBytes,contentBytes,+  Chunk,readChunk,writeChunk,contentChunk,+  +  -- * Basic union and product types+  Void,(:*:),(:+:),+  +  -- * Basic group and ring structure+  -- ** Classes+  Semigroup(..),Monoid(..),Negative(..),Disjonctive(..),Semiring(..),Ring(..),+  SubSemi(..),+  Unit(..),++  -- ** Common monoids++  -- *** Control monoids+  Endo(..),StrictEndo(..),++  -- *** Meta-monoids+  Dual(..),Product(..),++  -- *** Accumulating monoids+  OrdList(..),Interleave(..),Accum(..),Max(..),Id(..),+  +  -- * Fundamental control operations+  Category(..),(<<<),(>>>),(+++),++  -- ** Splitting and Choosing+  Choice(..),Split(..),+  +  -- * Misc functions+  const,(&),($^),is,fix,++  first,second,++  ifThenElse,bool,guard,fail,unit,when,unless,++  tailSafe,headDef,fromMaybe,++  rmod,inside,swap,++  -- ** Lazily ordering values+  Orderable(..),+  comparing,insertOrd,invertOrd,+  +  -- * The rest is imported from the Prelude+  module Prelude+  ) where++import Prelude hiding (+  readFile,writeFile,++  Functor(..),Monad(..),++  sequence,mapM,mapM_,sequence_,(=<<),++  map,(++),foldl,foldr,foldr1,concat,filter,length,sum,lookup,+  (+),(*),(.),id,const,(-),++  or,any,and,all,elem,++  until,negate)+import qualified Prelude as P+import Data.Tree+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString as BSS+import GHC.IO.Handle (Handle)+import Data.Ord (comparing)++type Chunk = BSS.ByteString+type Bytes = BSL.ByteString++readBytes :: String -> IO Bytes+readBytes = BSL.readFile+readChunk :: String -> IO Chunk+readChunk = BSS.readFile+writeBytes :: String -> Bytes -> IO ()+writeBytes = BSL.writeFile+writeChunk :: String -> Chunk -> IO ()+writeChunk = BSS.writeFile+contentBytes :: Handle -> IO Bytes+contentBytes = BSL.hGetContents+contentChunk :: Handle -> IO Chunk+contentChunk = BSS.hGetContents++data Void+type a:*:b = (a,b)+type a:+:b = Either a b++{-|+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 Bytes where (+) = BSL.append+instance Semigroup Chunk where (+) = BSS.append+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 Bytes where zero = BSL.empty+instance Monoid Chunk where zero = BSS.empty+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 => Negative m where+  negate :: m -> m+  default negate :: Num m => m -> m+  negate = P.negate+instance Negative Int ; instance Negative Integer+instance Negative Float ; instance Negative Double+instance Negative Bool where negate = not++class Monoid m => Disjonctive m where+  (-) :: m -> m -> m+  default (-) :: Num m => m -> m -> m+  (-) = (P.-)+instance Disjonctive Int ; instance Disjonctive Integer+instance Disjonctive Float ; instance Disjonctive Double+instance Disjonctive Bool where a - b = not (a==b)+instance (Disjonctive a,Disjonctive b) => Disjonctive (a:*:b) where (a,b)-(c,d) = (a-c,b-d)++class Monoid m => Semiring m where+  (*) :: m -> m -> m+  default (*) :: Num m => m -> m -> m+  (*) = (P.*)+class Semiring m => Ring m where+  one :: m+  default one :: Num m => m+  one = 1+  +infixl 7 *+instance Semiring Bool where (*) = (&&)+instance Ring Bool where one = True +instance Semiring Int ; instance Ring Int+instance Semiring Integer ; instance Ring Integer+instance Semiring Float ; instance Ring Float+instance Semiring Double ; instance Ring Double++instance Monoid a => Semiring [a] where+  (a:as) * (b:bs) = a+b:as*bs+  _ * _ = zero+instance Monoid a => Ring [a] where+  one = zero:one+instance (Semiring a,Semiring b) => Semiring (a:*:b) where+  ~(a,b) * ~(c,d) = (a*c,b*d)+instance (Ring a,Ring b) => Ring (a:*:b) where+  one = (one,one)++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..)+(<<<) :: 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 .++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 }+                  deriving (Eq,Ord,Show)+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 (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+  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 Identity Functor+newtype Id a = Id { getId :: a }+             deriving Show+instance Unit Id where pure = Id++{-| The Max monoid, where @(+) =~ max@ -}+newtype Max a = Max { getMax :: a }+              deriving (Eq,Ord,Bounded,Show)+instance Ord a => Semigroup (Max a) where Max a+Max b = Max (max a b)+instance (Ord a,Bounded a) => Monoid (Max a) where zero = Max minBound+instance (Ord a,Bounded a) => Semiring (Max a) where Max a * Max b = Max (min a b)+instance (Ord a,Bounded a) => Ring (Max a) where one = Max maxBound++{-| 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 Semiring m => Semiring (Dual m) where Dual a * Dual b = Dual (b*a)+instance Ring m => Ring (Dual m) where one = Dual one++-- |An ordered list. The semigroup instance merges two lists so that+-- the result remains in ascending order.+newtype OrdList a = OrdList { getOrdList :: [a] }+                  deriving (Eq,Ord,Show)+instance Orderable a => Semigroup (OrdList a) where+  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+          a ++ b = a + b+deriving instance Orderable a => Monoid (OrdList a)+deriving instance Unit OrdList++class Ord t => Orderable t where+  inOrder :: t -> t -> (t,t,Bool)+instance Ord t => Orderable (Max t) where+  inOrder (Max a) (Max b) = (Max x,Max y,z)+    where ~(x,y) | z = (a,b)+                 | otherwise = (b,a)+          z = a<=b+insertOrd :: Orderable t => t -> [t] -> [t]+insertOrd e [] = [e]+insertOrd e (x:xs) = a:y:ys+  where (a,_,z) = inOrder e x+        ~(y:ys) = if z then x:xs else insertOrd e xs++newtype Interleave a = Interleave { interleave :: [a] }+instance Semigroup (Interleave a) where+  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 &+is :: a -> (a -> Bool) -> Bool+is = (&)++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 :: (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++inside :: Ord t => t -> t -> (t -> Bool)+inside x y = \z -> x<z && z<y++rmod :: (RealFrac m,Ring m) => m -> m -> m+a`rmod`b = b * r +  where _n :: Int+        (_n,r) = properFraction (a/b)+infixl 7 `rmod`++swap :: (a,b) -> (b,a)+swap (a,b) = (b,a)++fromMaybe :: a -> Maybe a -> a+fromMaybe a = maybe a id++($^) :: (a -> b -> c) -> b -> a -> c+($^) = flip

@@ -0,0 +1,93 @@+{-# LANGUAGE TupleSections, MultiParamTypeClasses #-}+module Algebra.Foldable where++import Algebra.Core+import Algebra.Classes+import Algebra.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 (f:.:g) where+  fold = getCompose >>> map fold >>> fold++instance (Foldable f,Semigroup (f a),Monoid n,Num n) => SubSemi n (f a) where+  cast = size++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 = foldl' (+) 0 (1<$c)+length :: [a] -> Int+length = size++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 (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+select :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a+select p = fst . partition p+refuse :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a+refuse = select . 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+foldr1 :: (a -> a -> a) -> [a] -> a+foldr1 f ~(e:t) = foldr f e t+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+foldl1' :: (a -> a -> a) -> [a] -> a+foldl1' f ~(e:t) = foldl' f e t++toList :: Foldable t => t a -> [a]+toList = foldr (:) []++find :: Foldable t => (a -> Bool) -> t a -> Maybe a+find p = foldMap (select 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==)++empty :: Foldable f => f a -> Bool+empty = foldr (const (const False)) True+nonempty :: Foldable f => f a -> Bool+nonempty = not . empty

@@ -0,0 +1,107 @@+{-# LANGUAGE MultiParamTypeClasses, RankNTypes, DefaultSignatures #-}+-- |A module for functors+module Algebra.Functor(+  Functor(..),Cofunctor(..),Bifunctor(..),Commutative(..),+  +  Id(..),Const(..),Flip(..),(:.:)(..),(:**:)(..),(:++:)(..),++  (<$>),(|||),(<$),(<&>),void,left,right,+  promap,map2,map3+  ) where++import qualified Prelude as P++import Algebra.Classes+import Algebra.Core+import Data.Tree++class Cofunctor f where+  comap :: (a -> b) -> f b -> f a+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)+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++class Commutative f where+  commute :: f a b -> f b a+instance Commutative (,) where+  commute (a,b) = (b,a)++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) (map2 f subs)++instance Functor Id where map f (Id a) = Id (f a)+instance Applicative Id+instance Monad Id where join (Id a) = a++-- |The Constant Functor+newtype Const a b = Const { getConst :: a }+instance Semigroup a => Semigroup (Const a b) where Const a+Const b = Const (a+b)+instance Monoid a => Monoid (Const a b) where zero = Const zero+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 }+                  deriving (Semigroup,Monoid)++-- |The Composition functor+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 (map2 f c)++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+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.>>=)++(<$>) :: 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+infixr 2 <$>,<$+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 ()+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 map map2++promap :: Cofunctor (Flip f c) => (a -> b) -> f b c -> f a c+promap f c = unFlip (comap f (Flip c))

@@ -0,0 +1,321 @@+{-# 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 Algebra.Lens(+  -- * The lens types+  Iso,Iso',(:<->:),+  LensLike,LensLike',+  Fold,Fold',+  Getter,Getter',+  Lens,Lens',+  Traversal,Traversal',++  -- * Constructing lenses+  iso,from,lens,getter,prism,sat,simple,(.+),forl,forl_,++  -- * Extracting values+  (^.),(^..),(^?),has,(^??),(%~),(%-),(%%~),(%%-),by,yb,warp,set,+  (-.),(.-),+  +  -- * Basic lenses+  Lens1(..),Lens2(..),Lens3(..),Lens4(..),+  Trav1(..),Trav2(..),+  Compound(..),+  _list,_head,_tail,+  +  -- * Isomorphisms+  Isomorphic(..),++  -- ** Miscellaneous+  thunk,chunk,++  -- ** Type wrappers+  _Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,++  -- ** Algebraic isomorphisms+  negated,commuted,adding,++  -- ** Higher-order isomorphisms+  warp2,mapping,mapping',promapping,++  IsoFunctor(..),(<.>),IsoFunctor2(..)+  ) where++import Algebra.Core+import Algebra.Functor+import Algebra.Applicative+import System.IO.Unsafe (unsafePerformIO)+import Control.Exception (evaluate)+import Data.ByteString.Lazy (toStrict,fromStrict)++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' 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 Fold s t a b = forall f. (Semigroup (f b),Applicative f) => LensLike f s t a b+type Fold' a b = Fold 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) -> Traversal' a b+getter f = \k a -> a<$k (f a)++-- |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)++simple :: Traversal a b a b -> Traversal a b a b+simple l = l++sat :: (a -> Bool) -> Traversal' a a+sat p = \k a -> (if p a then k else pure) a++(.+) :: Fold s t a b -> Fold s t a b -> Fold s t a b+f .+ f' = \k a -> f k a + f' k a+infixr 8 .+++-- |Retrieve a value from a structure using a 'Lens' (or 'Iso')+infixl 8 ^.,^..,^?,^??,%~,%-,%%~,%%-+(^.) :: a -> Getter b b a a -> b+(^.) = flip by+(^..) :: a -> Iso a a b b -> b+(^..) = flip yb+-- |+(%~) :: 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 -> Fold' a b -> f b+x^?l = getConst $ l (Const . pure) x+(^??) :: a -> ((b -> Const [b] b) -> a -> Const [b] a) -> [b]+x^??l = getConst $ l (Const . pure) x++(-.) :: Getter c u b v -> (a -> b) -> a -> c+l-.f = by l.f+(.-) :: (b -> c) -> Iso a a b b -> a -> c+f.-i = f.yb i+infixr 9 -.,.-+by :: Getter b u a v -> a -> b+by l = getConst . l Const+yb :: Iso s t a b -> t -> b+yb i = by (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 ++forl :: LensLike f a b c d -> c -> (a -> f b) -> f d+forl l c f = l f c+forl_ :: Functor f => LensLike f a a c c -> c -> (a -> f ()) -> f ()+forl_ l c f = void $ l (\a -> a<$f a) c++class Lens1 s t a b | a -> s, a t -> b where+  _1 :: Lens s t a b+class Lens2 s t a b | a -> s, a t -> b where+  _2 :: Lens s t a b+class Lens3 s t a b | a -> s, a t -> b where+  _3 :: Lens s t a b+class Lens4 s t a b | a -> s, a t -> b where+  _4 :: Lens s t a b+class Trav1 s t a b | a -> s, a t -> b where+  _l :: Traversal s t a b+class Trav2 s t a b | a -> s, a t -> b where+  _r :: Traversal s t a b+instance Lens1 a b (a:*:c) (b:*:c) where+  _1 = lens fst (flip (first . const))+instance Lens1 a b (a,c,d) (b,c,d) where+  _1 = lens (\ ~(a,_,_) -> a) (\ (_,c,d) b -> (b,c,d))+instance Lens1 a b (a,c,d,e) (b,c,d,e) where+  _1 = lens (\ ~(a,_,_,_) -> a) (\ (_,c,d,e) b -> (b,c,d,e))+instance Lens2 a b (c:*:a) (c:*:b) where+  _2 = lens snd (flip (second . const))+instance Lens2 a b (c,a,d) (c,b,d) where+  _2 = lens (\ ~(_,a,_) -> a ) (\ ~(c,_,d) b -> (c,b,d))+instance Lens2 a b (c,a,d,e) (c,b,d,e) where+  _2 = lens (\ ~(_,a,_,_) -> a ) (\ ~(c,_,d,e) b -> (c,b,d,e))+instance Lens3 a b (c,d,a) (c,d,b) where+  _3 = lens (\ ~(_,_,a) -> a ) (\ ~(c,d,_) b -> (c,d,b))+instance Lens3 a b (c,d,a,e) (c,d,b,e) where+  _3 = lens (\ ~(_,_,a,_) -> a ) (\ ~(c,d,_,e) b -> (c,d,b,e))+instance Lens4 a b (c,d,e,a) (c,d,e,b) where+  _4 = lens (\ ~(_,_,_,a) -> a ) (\ ~(c,d,e,_) b -> (c,d,e,b))+instance Trav1 a b (a:+:c) (b:+:c) where+  _l = prism ((id ||| Right) >>> swapE) (flip (left . const))+    where swapE :: (b:+:a) -> (a:+:b)+          swapE = Right<|>Left+instance Trav1 a b [a] [b] where+  _l = prism f g+    where f [] = Left []+          f (a:_) = Right a+          g [] _ = []+          g _ b = [b]+instance Trav2 a b (c:+:a) (c:+:b) where+  _r = prism (Left ||| id) (flip (right . const))+instance Trav2 a b (Maybe a) (Maybe b) where+  _r = prism (\a -> maybe (Left Nothing) Right a) (flip (<$))++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''+instance Compound a b (a:+:a) (b:+:b) where+  _each k = map Left . k <|> map Right . k+_list :: [a] :<->: (():+:(a:*:[a]))+_list = iso (\l -> case l of+                [] -> Left ()+                (x:t) -> Right (x,t)) (const [] <|> uncurry (:))++_head :: Traversal' [a] a+_head = _l+_tail :: Traversal' [a] [a]+_tail = _list._r._2++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)++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 a) (Maybe Void) where+  _iso = iso (bool (Just zero) Nothing) (maybe False (const True))+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 (zero,) snd+_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 (Maybe Void) (Maybe a) Bool Bool+_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 g b) (f a) (g 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 f = \a a' -> yb i (by i a`f`by i a')++class IsoFunctor f where+  mapIso :: Iso s t a b -> Iso (f s) (f t) (f a) (f b)+class IsoFunctor2 f where+  mapIso2 :: (a:<->:c) -> (b:<->:d) -> (f a b:<->:f c d)++-- | An infix synonym for 'mapIso2'+(<.>) :: IsoFunctor2 f => (a:<->:c) -> (b:<->:d) -> (f a b:<->:f c d)+(<.>) = mapIso2+infixr 9 <.>++instance IsoFunctor ((->) a) where mapIso = mapping+instance IsoFunctor2 (->) where mapIso2 i j = promapping i.mapping j+instance IsoFunctor2 (,) where+  mapIso2 i j = iso (by i <#> by j) (yb i <#> yb j)+instance IsoFunctor2 Either where+  mapIso2 i j = iso (by i ||| by j) (yb i ||| yb j)++adding :: (Num n,Semigroup n) => n -> Iso' n n+adding n = iso (+n) (subtract n)++thunk :: Iso a b (IO a) (IO b)+thunk = iso unsafePerformIO evaluate+chunk :: Bytes:<->:Chunk+chunk = iso toStrict fromStrict++negated :: (Negative a,Negative b) => Iso a b a b+negated = iso negate negate+commuted :: Commutative f => Iso (f a b) (f c d) (f b a) (f d c)+commuted = iso commute commute++newtype Test a = Test (Const (Product Bool) a)+               deriving (Semigroup,Monoid,Functor,Unit+                        ,Applicative)+has :: Fold' a b -> a -> Bool+has l x = x^?l & \(Test (Const (Product b))) -> b++

@@ -0,0 +1,23 @@+module Algebra.Monad(+  module Algebra.Monad.Base,++  -- * Common monads+  module Algebra.Monad.RWS,+  module Algebra.Monad.State,+  module Algebra.Monad.Reader,+  module Algebra.Monad.Writer,+  module Algebra.Monad.Cont,+  module Algebra.Monad.Foldable,+  module Algebra.Monad.Error+  ) where++import Algebra.Monad.Base++import Algebra.Monad.RWS+import Algebra.Monad.State+import Algebra.Monad.Reader+import Algebra.Monad.Writer+import Algebra.Monad.Cont+import Algebra.Monad.Foldable+import Algebra.Monad.Error+

@@ -0,0 +1,121 @@+module Algebra.Monad.Base (+  module Algebra.Classes,module Algebra.Applicative,module Algebra.Core,+  module Algebra.Traversable,module Algebra.Lens,+  +  -- * Monad utilities+  Kleisli(..),_Kleisli,+  (=<<),joinMap,(<=<),(>=>),(>>),(<*=),only,return,+  foldlM,foldrM,findM,while,until,+  bind2,bind3,(>>>=),(>>>>=),+  +  -- * Instance utilities+  Compose'(..),_Compose'+  ) where++import Algebra.Classes+import Algebra.Applicative+import Algebra.Core hiding (flip)+import Algebra.Traversable+import Algebra.Lens+import qualified Control.Monad.Fix as Fix++-- MonadFix instances+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 (Traversable g,Monad f,Monad g) => Monad (f:.:g) where+  join = Compose .map join.join.map sequence.getCompose.map getCompose+instance (MonadFix f,Traversable g,Monad g) => MonadFix (f:.:g) where+  mfix f = Compose $ mfix (map join . traverse (getCompose . f))+instance Monad m => MonadTrans ((:.:) m) where+  lift = Compose . pure+instance Monad m => ConcreteMonad ((:.:) m) where+  generalize = _Compose %%~ map (pure.yb _Id)++instance MonadFix m => Monad (Backwards m) where+  join (Backwards ma) = Backwards$mfixing (\a -> liftA2 (,) (forwards a) ma)+instance MonadFix m => MonadFix (Backwards m) where+  mfix f = by _Backwards $ mfix (yb _Backwards.f)+instance MonadTrans Backwards where+  lift = Backwards+instance ConcreteMonad Backwards where+  generalize = _Backwards %%~ pure.yb _Id++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) (c -> m' d) (Kleisli m a b) (Kleisli m' c d) where+  _iso = iso Kleisli runKleisli++cfix :: Contravariant c => (a -> c a) -> c a+cfix = map fix . collect++mfixing :: MonadFix f => (b -> f (a, b)) -> f a+mfixing f = fst<$>mfix (\ ~(_,b) -> f 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 = yb i (foldMap (by i . f) t) e+foldlM :: (Foldable t,Monad m) => (a -> b -> m a) -> a -> t b -> m a+foldlM = folding (_Kleisli._Endo._Dual) . flip+foldrM :: (Foldable t,Monad m) => (b -> a -> m a) -> t b -> a -> m a+foldrM = flip . folding (_Kleisli._Endo)+findM :: (Foldable t,Monad m) => (a -> m (Maybe b)) -> t a -> m (Maybe b)+findM f = foldr fun (return Nothing)+  where fun a b = maybe b (return . Just) =<< f a++while :: Monad m => m Bool -> m ()+while e = fix (\w -> e >>= bool w unit)+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 =<<+infixl 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)+only :: (Monoid (m ()),Monad m) => (a -> Bool) -> m a -> m a+only p m = m <*= guard . p+return :: Unit f => a -> f a+return = pure++joinMap :: Monad m => (a -> m b) -> m a -> m b+joinMap = (=<<)++newtype Compose' f g a = Compose' ((g:.:f) a)+                       deriving (Semigroup,Monoid,Unit,Functor,Applicative,Monad,MonadFix,Foldable,Traversable)+_Compose' :: Iso (Compose' f g a) (Compose' h i b) (g (f a)) (i (h b))+_Compose' = _Compose.iso Compose' (\(Compose' c) -> c)+instance Monad m => MonadTrans (Compose' m) where+  lift = by _Compose' . map pure+instance Monad m => ConcreteMonad (Compose' m) where+  generalize = _Compose' %%~ pure . yb _Id+++

@@ -0,0 +1,32 @@+module Algebra.Monad.Cont (+  -- * The MonadCont class+  MonadCont(..),+  +  -- * The Continuation transformer+  ContT(..),Cont,+  contT, cont+  ) where++import Algebra.Monad.Base++{-| A simple continuation monad implementation  -}+newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }+                      deriving (Semigroup,Monoid,Semiring,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)++contT :: (Monad m,Unit m') => Iso (ContT r m r) (ContT r' m' r') (m r) (m' r')+contT = iso (\m -> ContT (m >>=)) (\c -> runContT c return)+cont :: Iso (Cont r r) (Cont r' r') r r'+cont = _Id.contT+

@@ -0,0 +1,44 @@+module Algebra.Monad.Error (+  -- * The MonadError class+  MonadError(..),try,(!+),tryMay,throwIO,++  -- * The Either transformer+  EitherT,+  _eitherT+  ) where++import Algebra.Monad.Base+import qualified Control.Exception as Ex++try :: MonadError e m => m a -> m a -> m a+try = catch . const+tryMay :: MonadError e m => m a -> m (Maybe a)+tryMay m = catch (\_ -> return Nothing) (Just<$>m)++(!+) :: MonadError Void m => m a -> m a -> m a+(!+) = flip try+infixr 0 !+++instance MonadError e (Either e) where+  throw = Left+  catch f = f<|>Right+instance MonadError Void [] where+  throw = const zero+  catch f [] = f zero+  catch _ l = l+newtype EitherT e m a = EitherT (Compose' (Either e) m a)+                      deriving (Unit,Functor,Applicative,Monad,MonadFix+                               ,Foldable,Traversable,MonadTrans)+_eitherT :: (Functor m) => Iso (EitherT e m a) (EitherT f m b) (m (e:+:a)) (m (f:+:b))                              +_eitherT = _Compose'.iso EitherT (\(EitherT e) -> e)++instance MonadError Void Maybe where+  throw = const Nothing+  catch f Nothing = f zero+  catch _ a = a+instance MonadError Ex.SomeException IO where+  throw = Ex.throw+  catch = flip Ex.catch+throwIO :: Ex.Exception e => e -> IO ()+throwIO = throw . Ex.toException+

@@ -0,0 +1,54 @@+{-# LANGUAGE UndecidableInstances #-}+module Algebra.Monad.Foldable (+  -- * The MonadList class+  MonadList(..),+  +  -- * Foldable monads transformers+  -- ** The List transformer+  ListT,listT,+  -- ** The Tree transformer+  TreeT(..),treeT,+  -- ** The Maybe transformer+  MaybeT(..),maybeT+  ) where++import Algebra.Monad.Base+import Algebra.Monad.RWS+import Data.Tree (Tree(..))++instance MonadList [] where fork = id++newtype ListT m a = ListT (Compose' [] m a)+                    deriving (Semigroup,Monoid,+                              Functor,Applicative,Unit,Monad,+                              Foldable,Traversable,MonadTrans)+listT :: Iso (ListT m a) (ListT m' a') (m [a]) (m' [a'])+listT = _Compose'.iso ListT (\(ListT l) -> l)+instance Monad m => MonadList (ListT m) where+  fork = by listT . return +instance MonadFix m => MonadFix (ListT m) where+  mfix f = by listT (mfix (yb listT . f . head))+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 mm = mm & listT %%~ (\m -> m >>= \_l -> case _l of+                                   [] -> f zero^..listT; l -> pure l)++newtype TreeT m a = TreeT (Compose' Tree m a)+                  deriving (Functor,Unit,Applicative,Monad,MonadFix,+                            Foldable,Traversable,MonadTrans)+treeT :: Iso (TreeT m a) (TreeT n b) (m (Tree a)) (n (Tree b))+treeT = _Compose'.iso TreeT (\(TreeT t) -> t)++newtype MaybeT m a = MaybeT (Compose' Maybe m a)+                  deriving (Functor,Unit,Applicative,Monad,MonadFix,+                            Foldable,Traversable,MonadTrans)+maybeT :: Iso (MaybeT m a) (MaybeT m' b) (m (Maybe a)) (m' (Maybe b))+maybeT = _Compose'.iso MaybeT (\(MaybeT m) -> m)++

@@ -0,0 +1,89 @@+{-# LANGUAGE UndecidableInstances #-}+module Algebra.Monad.RWS (+  RWST(..),RWS,MonadInternal(..),_RWST,++  -- * Default methods+  get_,put_,modify_,local_,ask_,tell_,listen_,censor_,getAcc_+  ) where++import Algebra.Monad.Base++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++-- Instances+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 Semiring (m (a,s,w)) => Semiring (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 $ (zero,zero)+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 (zero,zero)+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,MonadList m) => MonadList (RWST r w s m) where+  fork = lift . fork+instance Monoid w => MonadTrans (RWST r w s) where+  lift m = RWST (\ ~(_,s) -> (,s,zero) <$> m)+instance Monoid w => ConcreteMonad (RWST r w s) where+  generalize (RWST s) = RWST (\x -> pure (s x^.._Id))+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) )+  +class MonadTrans t => MonadInternal t where+  internal :: Monad m => (forall c. m (c,a) -> m (c,b)) ->+              (t m a -> t m b)++_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++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  +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)+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)))+getAcc_ :: (MonadTrans t,MonadWriterAcc w acc m) => t m acc+getAcc_ = lift getAcc

@@ -0,0 +1,39 @@+{-# LANGUAGE UndecidableInstances #-}+module Algebra.Monad.Reader (+  -- *** The Reader monad+  MonadReader(..),+  ReaderT,Reader,+  readerT,reader,+  ) where++import Algebra.Monad.Base+import Algebra.Monad.RWS++instance MonadReader r ((->) r) where+  ask = id ; local = (>>>)++{-| 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,MonadList)+type Reader r a = ReaderT r Id a++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_+instance MonadWriterAcc w acc m => MonadWriterAcc w acc (ReaderT r m) where+  getAcc = getAcc_+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 Semiring (m (a,Void,Void)) => Semiring (ReaderT r m a)+deriving instance Ring (m (a,Void,Void)) => Ring (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<&>(,zero,zero) ))+        _runReaderT (ReaderT (RWST f)) r = f (r,zero) <&> \ ~(a,_,_) -> a+reader :: Iso (Reader r a) (Reader r' b) (r -> a) (r' -> b)+reader = mapping _Id.readerT+

@@ -0,0 +1,103 @@+{-# LANGUAGE UndecidableInstances #-}+module Algebra.Monad.State (+  -- * The State Monad+  MonadState(..),+  StateT,State,+  stateT,eval,exec,state,+  (=~),(=-),(^>=),gets,getl,saving,+  Next,Prev,+  mapAccum,mapAccum_,mapAccumR,mapAccumR_,push,pop,withPrev,withNext,++  -- * The State Arrow+  StateA(..),stateA,+  ) where++import Algebra.Monad.RWS+import Algebra.Monad.Base++instance MonadState (IO ()) IO where+  get = return unit+  put a = a+  modify f = put (f unit)++newtype StateT s m a = StateT (RWST Void Void s m a)+                     deriving (Unit,Functor,Applicative,Monad,MonadFix,+                               MonadTrans,MonadInternal,+                               MonadCont,MonadState s,MonadList)+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_+instance (MonadWriterAcc w acc m) => MonadWriterAcc w acc (StateT s m) where+  getAcc = lift getAcc+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 Semiring (m (a,s,Void)) => Semiring (StateT s m a)+deriving instance Ring (m (a,s,Void)) => Ring (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,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 :: (s ->  (a, b)) -> (s -> b)+eval = map snd+exec :: Functor f => f (a, b) -> f a+exec = map fst+state :: Iso (State s a) (State t b) (s -> (s,a)) (t -> (t,b))+state = mapping _Id.stateT++(=-) :: MonadState s m => Traversal' s s' -> s' -> m ()+infixl 0 =-,=~+l =- x = modify (set l x)+(=~) :: MonadState s m => Traversal' s a -> (a -> a) -> m ()+l =~ f = modify (warp l f)+(^>=) :: MonadState s m => LensLike m a a s s -> (a -> m ()) -> m ()+l ^>= k = get >>= \s -> forl_ l s k+gets :: MonadState s m => (s -> a) -> m a+gets = (get<&>) +getl :: MonadState s m => Getter' s a -> m a+getl l = by l<$>get++saving :: MonadState s m => Lens' s s' -> m a -> m a+saving l st = getl l >>= \s -> st <* (l =- s)++-- * The State Arrow+newtype StateA m s a = StateA (StateT s m a)+stateA :: Iso (StateA m s a) (StateA m' s' a') (StateT s m a) (StateT s' m' a')+stateA = iso StateA (\(StateA s) -> s)+instance Monad m => Category (StateA m) where+  id = StateA get+  StateA sbc . StateA sab = StateA $ (^.stateT) $ \a ->+    (sab^..stateT) a >>= \(a',b) -> (a',).snd <$> (sbc^..stateT) b+instance Monad m => Split (StateA m) where+  StateA sac <#> StateA sbd = StateA $ (^.stateT)+                              $ map2 (\((a',c),(b',d)) -> ((a',b'),(c,d)))+                              $ (Kleisli (sac^..stateT) <#> Kleisli (sbd^..stateT)) ^.. _Kleisli+instance Monad m => Choice (StateA m) where+  StateA sac <|> StateA sbc = StateA $ (^.stateT) $+                              l Left (sac^..stateT)<|>l Right (sbc^..stateT)+    where l = map2 . first++mapAccum :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> (s, t b)+mapAccum f t = traverse (by 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 (by (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_ (,)++type Next a = a+type Prev a = a+withPrev :: Traversable t => a -> t a -> t (Prev a,a)+withPrev = flip (mapAccum_ (\a p -> (a,(p,a))))+withNext :: Traversable t => t a -> a -> t (a,Next a)+withNext = mapAccumR_ (\a p -> (a,(a,p)))

@@ -0,0 +1,83 @@+{-# LANGUAGE UndecidableInstances #-}+module Algebra.Monad.Writer (+    -- * The Writer monad+  MonadWriter(..),+  mute,intercept,++  -- * The Writer transformer+  WriterT,Writer,+  writerT,writer,pureWriter,++  -- * Keeping track of where we are+  MonadWriterAcc(..),++  -- ** Implementation+  WriterAccT,WriterAcc,+  writerAccT,writerAcc+  ) where++import Algebra.Monad.Base+import Algebra.Monad.RWS++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,MonadList)+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 Semiring (m (a,Void,w)) => Semiring (WriterT w m a)+deriving instance Ring (m (a,Void,w)) => Ring (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 mw = WriterT (RWST (pure (mw <&> \ ~(w,a) -> (a,zero,w) )))+        _runWriterT (WriterT (RWST m)) = m (zero,zero) <&> \ ~(a,_,w) -> (w,a)+writer :: Iso (Writer w a) (Writer w' b) (w,a) (w',b)+writer = _Id.writerT+pureWriter :: Monoid w => Iso (w,a) (w',b) a b+pureWriter = iso (zero,) snd++{-| The canonical representation of a WriterAcc Monad -}+newtype WriterAccT w acc m a = WA { runWA :: RWST () w acc m a }+                             deriving (Functor,Unit,Monad,Applicative,MonadFix,MonadTrans)+type WriterAcc w acc a = WriterAccT w acc Id a++instance (Monad m,SubSemi acc w,Monoid w) => MonadWriter w (WriterAccT w acc m) where+  tell w = WA (tell w >> modify (+ cast w))+  listen = WA . listen . runWA+  censor (WA m) = WA $ do+    cur <- get+    (w,a) <- listen (censor m)+    put $ cur + cast w+    return a+instance (Monad m,Monoid w,SubSemi acc w) => MonadWriterAcc w acc (WriterAccT w acc m) where+  getAcc = WA get  +instance (MonadState s m,Monoid w,SubSemi acc w) => MonadState s (WriterAccT w acc m) where+  get = WA (lift get)+  put = WA . lift . put++_WriterAccT :: Iso (WriterAccT w acc m a) (WriterAccT w' acc' m' a') (RWST () w acc m a) (RWST () w' acc' m' a')+_WriterAccT = iso WA runWA+writerAccT :: (SubSemi acc w,SubSemi acc' w',Monoid acc,Monoid acc',Functor m)+              => Iso (WriterAccT w acc m a) (WriterAccT w' acc' m' a') (m (a,acc,w)) (m' (a',acc',w'))+writerAccT = iso (\m (_,s) -> m <&> \(a,s',w) -> (a,s+s',w)) ($zero)._RWST._WriterAccT+writerAcc :: (SubSemi acc w,SubSemi acc' w',Monoid acc,Monoid acc',Functor m)+             => Iso (WriterAcc w acc a) (WriterAcc w' acc' a') (a,acc,w) (a',acc',w')+writerAcc = _Id.writerAccT

@@ -0,0 +1,138 @@+{-# LANGUAGE TupleSections, RecursiveDo, Rank2Types, DeriveDataTypeable, ImplicitParams #-}+module Algebra.Time (+  -- * Unambiguous times+  Time,+  module Data.TimeVal,+  timeVal,++  -- * Time utilities+  Seconds,+  timeIO,waitTill,currentTime,timeOrigin,++  -- * Conversion functions+  ms,mus,ns,minutes,hours,days+  ) where++import Algebra+import Control.Concurrent+import Data.TimeVal+import System.IO.Unsafe+import Data.IORef+import System.Clock+import Control.Exception (handle,Exception(..))+import Data.Typeable++data Freezed = Freezed+             deriving (Typeable,Show)+instance Exception Freezed  ++-- |A type wrappers for timestamps that can be compared unambiguously+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 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 fa fb) + ~(Time fa' fb') = Time (mapTL mini fa fa') (mapTL maxi fb fb')+    where mini h x x' = if h < x then x else max x x'+          maxi h x x' = if h > x then max x x' else x+-- |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 => Semiring (Time t) where+  ~(Time fa fb) * ~(Time fa' fb') = Time (mapTL mini fa fa') (mapTL maxi fb fb')+    where mini h x x' = if h < x then min x x' else x+          maxi h x x' = if h > x then x else min x x'+instance Ord t => Ring (Time t) where+  one = maxBound+instance Ord t => Orderable (Time t) where+  inOrder a b = (a*b,if z then b else a,z)+    where z = a<=b++mapTL :: Bounded c => (a -> b -> b -> c) -> (a -> b) -> (a -> b) -> a -> c+mapTL _max fa fa' h = _max h x x'`unamb`_max h x' x+  where x = fa h ; x' = fa' h++instance Bounded (Time t) where+  minBound = Time (pure minBound) (pure minBound)+  maxBound = Time (pure maxBound) (pure maxBound)+instance Unit Time where+  pure t = Time (pure (pure t)) (pure (pure t)) ++amb :: IO a -> IO a -> IO a+ma `amb` mb = do+  res <- newEmptyMVar+  ta <- forkIO $ handle (\Freezed -> unit) $ ma >>= putMVar res . Left+  tb <- forkIO $ handle (\Freezed -> unit) $ mb >>= putMVar res . Right++  takeMVar res >>= \c -> case c of+    Left a -> a <$ killThread tb+    Right a -> a <$ killThread ta+ambBnd :: Bounded a => IO a -> IO a -> IO a+ambBnd a b = try (return maxBound) (a`amb`b)+unamb :: Bounded a => a -> a -> a+unamb = warp2 (from thunk) ambBnd++type Seconds = Double++-- |A Time's pure value. May not be defined immediately.+timeVal :: Time t -> TimeVal t+timeVal (Time fa _) = fa maxBound++-- |Constructs a Time representing the time by which the argument terminates.+--+-- Warning: This function executes its argument, ignoring its+-- value. Thus, it would be wise to use it on idempotent blocking+-- actions, such as @readMVar@.+timeIO :: IO a -> IO (Time Seconds)+timeIO io = do+  sem <- newEmptyMVar+  ret <- newIORef id+  +  minAction <- newIORef $ \tm -> readIORef ret <**> amb (readMVar sem) (+    Since<$>case tm of+       Always -> currentTime+       Since t -> waitTill t >> currentTime+       Never -> throw (toException Freezed))+  maxAction <- newIORef $ \tm -> readIORef ret <**> amb (readMVar sem) (+    case tm of+      Always -> throw (toException Freezed)+      Since t -> waitTill t >> pure Never+      Never -> Since<$>currentTime)+    +  let refAction ref = \t -> unsafePerformIO (join (readIORef ref<*>pure t))+  _ <- forkIO $ void $ mfix $ \t -> do +    t' <- catch (\_ -> return Never) (io >> return (pure t))+    writeIORef minAction (const (pure t'))+    writeIORef maxAction (const (pure t'))+    writeIORef ret (const t')+    putMVar sem t'+    currentTime+    +  return $ Time (refAction minAction) (refAction maxAction)+  +waitTill :: Seconds -> IO ()+waitTill t = do+  now <- t `seq` currentTime+  when (t>now) $ threadDelay (floor $ (t-now)*1000000)++seconds :: TimeSpec -> Seconds+seconds t = fromIntegral (sec t) + fromIntegral (nsec t)/1000000000 :: Seconds+currentTime :: IO Seconds+currentTime = seconds<$>getTime Realtime+timeOrigin :: (( ?birthTime :: Seconds ) => IO a) -> IO a+timeOrigin m = currentTime >>= \t -> let ?birthTime = t in m++ms,mus,ns,minutes,hours,days :: Seconds -> Seconds+ms = (/1000)+mus = (/1000000)+ns = (/1000000000)+minutes = (*60)+hours = (*3600)+days = (*(3600*24))

@@ -0,0 +1,67 @@+module Algebra.Traversable(+  module Algebra.Applicative, module Algebra.Foldable,++  Traversable(..),Contravariant(..),++  traverse,foreach,transpose,flip,project,doTimes,converted,folded,+  ) where++import Algebra.Classes+import Algebra.Core hiding (flip,(&))+import Algebra.Applicative+import Algebra.Foldable+import Algebra.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 (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+instance Traversable Maybe where+  sequence Nothing = pure Nothing+  sequence (Just a) = Just<$>a++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++converted :: (Unit f,Unit g,Foldable f,Foldable g,Monoid (f a),Monoid (g b)) => Iso (f a) (f b) (g a) (g b)+converted = iso convert convert+folded :: (Unit f',Foldable f,Monoid m) => Iso m m' (f m) (f' m')+folded = iso fold pure++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+doTimes :: Applicative f => Int -> f a -> f [a]+doTimes n m = sequence (m <$ [1..n])+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+-- | The Contravariant version of 'traverse'+project :: (Contravariant c,Functor f) => (a -> c b) -> f a -> c (f b)+project f x = collect (map f x)++instance Compound a b [a] [b] where+  _each = traverse

@@ -0,0 +1,144 @@+{-# LANGUAGE MultiParamTypeClasses, ViewPatterns, ScopedTypeVariables #-}+module Data.Containers(+  -- * The basic data class+  DataMap(..),Indexed(..),OrderedMap(..),+  +  member,delete,touch,insert,singleton,fromList,+  _set,_map,cached,++  -- * Map instances+  -- ** Sets and maps+  Set,Map,+  +  -- ** Bimaps+  Bimap(..),toMap,keysSet,++  -- ** Relations+  Relation(..),domains,ranges,related,link+  )+  where++import Algebra+import qualified Data.Set as S+import qualified Data.Map as M+import Data.Map (Map)+import Data.Set (Set)+import Control.Concurrent.MVar++class Monoid m => DataMap m k a | m -> k a where+  at :: k -> Lens' m (Maybe a)+class Indexed f i | f -> i where+  keyed :: Iso (f (i,a)) (f (i,b)) (f a) (f b) +class OrderedMap m k a m' k' a' | m -> k a, m' -> k' a' where+  ascList :: Iso [(k,a)] [(k',a')] m m'++_set :: Set a -> Set a+_set = id+_map :: Map a b -> Map a b+_map = id++member :: DataMap m k Void => k -> Lens' m Bool+member k = at k.from _maybe+delete :: DataMap m k a => k -> m -> m+delete k = at k %- Nothing+insert :: DataMap m k a => k -> a -> m -> m+insert k a = at k %- Just a+touch :: (Monoid a, DataMap m k a) => k -> m -> m+touch k = insert k zero+singleton :: DataMap m k a => k -> a -> m+singleton = map2 ($zero) insert+fromList :: DataMap m k a => [(k,a)] -> m+fromList l = compose (uncurry insert<$>l) zero++instance Ord a => DataMap (Set a) a Void where+  at k = lens (S.member k) (flip (bool (S.insert k) (S.delete k)))._maybe+instance Eq b => OrderedMap (Set a) a Void (Set b) b Void where+  ascList = iso S.toAscList S.fromAscList . mapping (_iso.commuted)+instance Ord k => DataMap (Map k a) k a where+  at k = lens (M.lookup k) (\m a -> M.alter (const a) k m)+instance Eq k' => OrderedMap (Map k a) k a (Map k' a') k' a' where +  ascList = iso M.toAscList M.fromAscList+  +instance Ord a => Semigroup (Set a) where (+) = S.union+instance Ord a => Monoid (Set a) where zero = S.empty+instance Ord a => Disjonctive (Set a) where (-) = S.difference+instance Ord a => Semiring (Set a) where (*) = S.intersection+instance Functor Set where map = S.mapMonotonic+instance Foldable Set where fold = S.foldr (+) zero++instance Ord k => Semigroup (Map k a) where (+) = M.union+instance Ord k => Monoid (Map k a) where zero = M.empty+instance Ord k => Disjonctive (Map k a) where (-) = M.difference+instance (Ord k,Semigroup a) => Semiring (Map k a) where (*) = M.intersectionWith (+)+instance Functor (Map k) where map = M.map+instance Foldable (Map k) where fold = M.foldr (+) zero+instance Eq k => Traversable (Map k) where sequence = (ascList._Compose) sequence+instance Indexed (Map k) k where keyed = iso (M.mapWithKey (,)) (map snd)++-- |An invertible map+newtype Bimap a b = Bimap (Map a b,Map b a)+                  deriving (Show,Semigroup,Monoid,Disjonctive,Semiring)+instance Commutative Bimap where+  commute (Bimap (b,a)) = Bimap (a,b)++instance (Ord a,Ord b) => DataMap (Bimap a b) a b where+  at a = lens lookup setAt+    where lookup ma = toMap ma^.at a+          setAt (Bimap (ma,mb)) b' = Bimap (+            maybe id delete (b' >>= \b'' -> mb^.at b'') ma & at a %- b',+            mb & maybe id delete b >>> maybe id (flip insert a) b')+            where b = ma^.at a +instance (Ord b,Ord a) => DataMap (Flip Bimap b a) b a where+  at k = from (commuted._Flip).at k+instance (Ord a,Ord b,Ord c,Ord d) => OrderedMap (Bimap a b) a b (Bimap c d) c d where+  ascList = iso (toMap >>> \m -> m^.ascList) (\l -> Bimap (l^..ascList,l^..ascList.mapping commuted))+toMap :: Bimap a b -> Map a b+toMap (Bimap (a,_)) = a++keysSet :: (Eq a,Eq b) => Iso (Set a) (Set b) (Map a Void) (Map b Void)+keysSet = ascList.from ascList++--- |The Relation type+newtype Relation a b = Relation (Map a (Set b),Map b (Set a))+                     deriving (Show,Semigroup,Monoid,Eq,Ord)+_Relation :: Iso (Relation a b) (Relation c d) (Map a (Set b),Map b (Set a)) (Map c (Set d),Map d (Set c))+_Relation = iso Relation (\(Relation r) -> r)+instance Commutative Relation where+  commute (Relation (a,b)) = Relation (b,a)++-- |Define a Relation from its ranges. O(1) <-> O(1,n*ln(n)) +ranges :: (Ord c,Ord d) => Iso (Map a (Set b)) (Map c (Set d)) (Relation a b) (Relation c d)+ranges = iso (\(Relation (rs,_)) -> rs) fromRanges+  where fromRanges rs = Relation (rs,compose (rs^.keyed <&> \ (a,bs) -> compose $ bs <&> \b ->+                                              at b%~Just . touch a . fold) zero)+-- |Define a Relation from its domain (uses the Commutative instance)+domains :: (Ord c,Ord d) => Iso (Map b (Set a)) (Map d (Set c)) (Relation a b) (Relation c d)+domains = commuted.ranges++instance (Ord k,Ord a) => DataMap (Relation k a) k (Set a) where+  at a = lens (\(Relation (rs,_)) -> rs^.at a) setRan+    where setRan (Relation (rs,ds)) (fold -> ran) = Relation (+            rs & at a %- if empty ran then Nothing else Just ran,+            adjust ds)+            where oldRan = fold $ rs^.at a+                  adjust = compose ((oldRan-ran) <&> \b -> at b.traverse.member a %- False)+                           >>> compose ((ran-oldRan) <&> \b -> at b %~ Just . touch a . fold)++may :: (Monoid (f b),Foldable f) => Iso (Maybe (f a)) (Maybe (f b)) (f a) (f b)+may = iso (\f -> if empty f then Nothing else Just f) (maybe zero id)++related :: (Ord a,Ord b) => a -> Lens' (Relation a b) (Set b)+related a = at a.from may++link :: (Ord a,Ord b) => a -> b -> Lens' (Relation a b) Bool+link a b = related a.member b++cached :: forall a b. Ord a => (a -> b) -> a -> b+cached f = \a -> g a^.thunk+  where g a = do+          m <- vm `seq` takeMVar vm+          case m^.at a of+            Just b -> putMVar vm m >> return b+            Nothing -> let b = f a in putMVar vm (insert a b m) >> return b+        vm = newMVar (zero :: Map a b)^.thunk+

@@ -0,0 +1,64 @@+module Data.Containers.Sequence (+  Sequence(..),Stream(..),take,drop,++  -- * Strict and lazy slices (bytestrings on arbitrary Storable types)+  Slice,Slices,slice,slices,_Slices,breadth,++  V.unsafeWith+  ) where++import Algebra hiding (splitAt,take,drop)+import qualified Data.List as L+import qualified Data.ByteString.Lazy as Bytes+import qualified Data.ByteString.Char8 as Char8+import qualified Data.Vector.Storable as V++class Monoid t => Sequence t where+  splitAt :: Int -> t -> (t,t)++take :: Sequence t => Int -> t -> t+take = map2 fst splitAt+drop :: Sequence t => Int -> t -> t+drop = map2 snd splitAt++instance V.Storable a => Semigroup (V.Vector a) where (+) = (V.++)+instance V.Storable a => Monoid (V.Vector a) where zero = V.empty+  +instance Sequence [a] where+  splitAt = L.splitAt+instance Sequence Bytes where+  splitAt = Bytes.splitAt . fromIntegral+instance V.Storable a => Sequence (V.Vector a) where+  splitAt = V.splitAt++class Stream c s | s -> c where+  uncons :: s -> Maybe (c,s)+  cons :: c -> s -> s+instance Stream a [a] where+  uncons [] = Nothing+  uncons (x:xs) = Just (x,xs)+  cons = (:)+instance Stream Char Chunk where+  uncons = Char8.uncons+  cons = Char8.cons++type Slice a = V.Vector a+newtype Slices a = Slices [Slice a]+                    deriving (Semigroup,Monoid)+_Slices :: Iso (Slices a) (Slices b) [Slice a] [Slice b]+_Slices = iso Slices (\(Slices cs) -> cs)+instance V.Storable a => Sequence (Slices a) where+  splitAt _ (Slices []) = zero+  splitAt n (Slices (h:t))+    | l>n = let (vh,vt) = splitAt n h in (Slices [vh],Slices (vt:t))+    | l==n = (Slices [h],Slices t)+    | otherwise = let ~(c1,c2) = splitAt (n-l) (Slices t) in (c1 & _Slices %%~ (h:),c2)+      where l = V.length h+slice :: (V.Storable a,V.Storable b) => Iso (Slice a) (Slice b) [a] [b]+slice = iso (V.unfoldr uncons) (V.foldr (:) [])++slices :: (V.Storable a,V.Storable b) => Iso (Slices a) (Slices b) (Slice a) (Slice b)+slices = iso pure V.concat . _Slices++breadth :: V.Storable a => Slices a -> Int+breadth s = s^.._Slices & foldMap V.length

@@ -0,0 +1,20 @@+module Data.Probability where++import Algebra++newtype ProbT t m a = ProbT (WriterT (Product t) (ListT m) a)+                    deriving (Unit,Functor,Applicative,Monad+                             ,MonadFix,MonadWriter (Product t))+type Prob t a = ProbT t Id a+                             +_ProbT :: Iso (ProbT t m a) (ProbT t' m' a') (WriterT (Product t) (ListT m) a) (WriterT (Product t') (ListT m') a')+_ProbT = iso ProbT (\(ProbT p) -> p)+probT :: (Functor m,Functor m') => Iso (ProbT t m a) (ProbT t' m' a') (m [(Product t,a)]) (m' [(Product t',a')])+probT = listT.writerT._ProbT+prob :: Iso (Prob t a) (Prob t' a') [(Product t,a)] [(Product t',a')]+prob = _Id.probT++instance (Monad m,Ring t,Fractional t) => MonadList (ProbT t m) where+  fork l = pure [(Product x,a) | a <- l]^.probT+    where x = 1/size l+

@@ -0,0 +1,209 @@+{-# LANGUAGE RebindableSyntax, GeneralizedNewtypeDeriving, TupleSections, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ViewPatterns #-}+module Data.Reactive (+  -- * Reactive Modules+  module Algebra.Time,++  -- * Reactive Events+  Event,_event,headE,Reactive(..),++  -- ** Contructing events+  atTimes,mkEvent,+  withTime,times,times',+  mapFutures,++  -- ** Combining events+  (//),(<|*>),(<*|>),+               +  -- ** Filtering events+  groupE,mask,++  -- ** Real-world event synchronization+  realize,realtime,realizeRT,eventMay,event,react,react2,react3,+  +  -- * Future values+  Future,_future,_time,_value,futureIO,+  ) where++import Algebra+import Control.Concurrent+import Data.TimeVal+import System.IO.Unsafe (unsafeInterleaveIO)+import Data.List (group)+import Algebra.Time++-- |An event (a list of time-value pairs of increasing times)+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+  pure a = Reactive a zero+instance Functor (Reactive t) where +  map f (Reactive a e) = Reactive (f a) (map f e)+instance Ord t => Applicative (Reactive t) where+  Reactive f fs <*> Reactive x xs = Reactive (f x) (cons f fs<*>cons x xs)+    where cons a = _event %%~ ((minBound,a)^._future :)++instance (Ord t,Show t,Show a) => Show (Event t a) where show = show . yb _event+instance Ord t => Semigroup (Event t a) where+  (+) = (++)^.(_event<.>_event<.>_event)+    where (x:xt) ++ (y:yt) = a : zs+            where (a,b,sw) = inOrder x y+                  zs | b==maxBound = if sw then xt else yt+                     | sw = xt ++ (y:yt)+                     | otherwise = (x:xt) ++ yt+          a ++ [] = a+          [] ++ b = b+instance Ord t => Monoid (Event t a) where+  zero = [(maxBound,undefined)]^.mapping _future._event+instance Ord t => Applicative (Event t) where+  fe@(yb _event -> ff:_) <*> xe@(yb _event -> fx:_) =+    ste & traverse (by state) & yb 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 (yb _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+  join = _event %%~ merge . map2 (yb _event)+    where+      merge [] = []+      merge [t] = t^._value+      merge (xs:ys:t) = xi + merge ((ys&_value%~add xe) : t) & _head._time%~(tx+)+        where add = warp2 _OrdList (+)+              (tx,(xi,xe)) = xs^.._future & _2%~break (ltFut ys)+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 <&> by _future . (_1 %~ pure))^._event++{-| The \'splice\' operator. Occurs when @a@ occurs.++> by t: a // b = (a,before t: b)+-}+(//) :: Ord t => Event t a -> Event t b -> Event t (a, Event t b)+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 //++{-|+The \'over\' operator. Occurs only when @a@ occurs.++> by t: a <|*> (bi,b) = a <*> (minBound,bi):b+-}+(<*|>) :: Ord t => Event t (a -> b) -> Reactive t a -> Event t b+ef <*|> Reactive a ea = (traverse tr (ef // ea) ^.. state <&> snd) a+  where tr (f,as) = traverse_ put as >> f<$>get+infixl 1 <*|>+(<|*>) :: Ord t => Reactive t (a -> b) -> Event t a -> Event t b+f <|*> a = (&)<$>a<*|>f+infixr 1 <|*>++-- |Group the occurences of an event by equality. Occurs when the first occurence of a group occurs. +groupE :: (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_ (by _time<$>xs)+)):zs+          where (xs,ys) = span ((==f^._value) . by _value) fs ; f = head fs+                ~(z:zs) = group_ ys+                sum_ = foldl' (+) zero+headE :: Event t a -> a+headE = by _value . head . yb _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 (Time t,a)+withTime = mapFutures (_future %%~ listen)+times :: Ord t => Event t a -> Event t (Time t)+times = map2 fst withTime+times' :: (Ord t,Monoid t) => Event t a -> Event t t+times' = map2 (fold . timeVal) times++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. Actions are evaluated+-- as closely to their specified time as possible. However, they are+-- all executed in order, even if it means delaying the next action+-- further than its required time. For real-time realization of+-- events, see the 'realizeRT' function+realize :: Event Seconds (IO ()) -> IO ()+realize l = traverse_ (sink_ . first timeVal) (withTime l)+  where sink_ (Since t,v) = waitTill t >> v+        sink_ (Always,v) = v+        sink_ (Never,_) = unit++-- |Creates a real-time action event (an event that skips "frames" as needed) from an ordinary event.+realtime :: Event Seconds (IO ()) -> Event Seconds (IO ())+realtime e = (e & flip withNext (maxBound,undefined).withTime) <&> \((_,m),(t,_)) -> do+  c <- currentTime+  when (pure c<t) m+        +-- |Sinks a frame event into the real-world, skipping frames if they come+-- too late, thus always performing the frame closest to the current time.+realizeRT :: Event Seconds (IO ()) -> IO ()+realizeRT = realize . realtime++eventMay :: IO (Maybe a) -> IO (Event Seconds a)+eventMay m = by _event <$> do+  c <- newChan+  sem <- newEmptyMVar+  _ <- forkIO $ do+    while $ do+      a <- newEmptyMVar+      writeChan c a+      foldMap (const True)<$>(m <*= maybe unit (putMVar a))+    putMVar sem ()+  let event' ~(a:as) = unsafeInterleaveIO $ do+        (:)<$>futureIO (takeMVar a)<*>event' as+  (event' =<< getChanContents c) <*= \e -> do+    t <- forkIO $ traverse_ (yb thunk . timeVal . by _time) e+    forkIO (takeMVar sem <* killThread t)+event :: IO a -> IO (Event Seconds a)+event = eventMay . try (pure Nothing) . map Just+react :: IO a -> (Event Seconds a -> IO (Event Seconds (IO ()))) -> IO ()+react a f = realize =<< join (f<$>event a)+react2 :: IO a -> IO b -> (Event Seconds a -> Event Seconds b -> IO (Event Seconds (IO ()))) -> IO ()+react2 a b f = realize =<< join (f<$>event a<*>event b)+react3 :: IO a -> IO b -> IO c -> (Event Seconds a -> Event Seconds b -> Event Seconds c -> IO (Event Seconds (IO ()))) -> IO ()+react3 a b c f = realize =<< join (f<$>event a<*>event b<*>event c)++-- |A Future value (a value with a timestamp)+newtype Future t a = Future (Time t,a)+                   deriving (Show,Functor,Unit,Applicative,Traversable,Foldable,Monad,Semigroup,Monoid)+instance Ord t => Eq (Future t a) where f == f' = compare f f'==EQ+instance Ord t => Ord (Future t a) where compare = cmpFut+instance Ord t => Bounded (Future t a) where+  minBound = (minBound,undefined)^._future+  maxBound = (maxBound,undefined)^._future+instance Ord t => Orderable (Future t a) where+  inOrder (Future (t,a)) (Future (t',b)) = (Future (tx,x),Future (ty,y),z)+    where (tx,ty,z) = inOrder t t'+          ~(x,y) = if z then (a,b) else (b,a)+_future :: Iso (Future t a) (Future t' b) (Time t,a) (Time t',b)+_future = iso Future (\(Future ~(t,a)) -> (t,a))+_time :: Lens (Time t) (Time t') (Future t a) (Future t' a)+_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 +  time <- timeIO (readMVar val)+  return (Future (time,try (return undefined) (readMVar val)^.thunk))++

@@ -0,0 +1,30 @@+module Data.TimeVal (+  TimeVal(..)+  ) where++import Algebra++-- |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 Foldable TimeVal where+  fold (Since t) = t+  fold _ = zero+instance Traversable TimeVal where+  sequence (Since t) = Since<$>t+  sequence Always = pure Always+  sequence Never = pure Never++instance Bounded (TimeVal t) where+  minBound = Always ; maxBound = Never+

@@ -0,0 +1,69 @@+Bill and Ted's Public License+=============================++Everyone is permitted to copy and distribute verbatim or modified+copies of this license document, and changing it is allowed as long as+the name of the license is changed.++PREAMBLE+--------++The “Greater Lunduke License” is inspired, in part, by the wisdom of+the Two Great Ones, Bill S. Preston, Esq. and Ted “Theodore” Logan.+Namely that we should all “be excellent to each other”, that being+“bogus” is “most non-triumphant” and that all dudes should “party on”.++This license applies those concepts in such a way that it is+applicable to all forms of content, including, but not limited to:+software, books, music, movies and various works of art.++TERMS AND CONDITIONS+--------------------++### 1. Be Excellent To Each Other.++The consumer of this work is granted the right to utilize this work in+conjunction with any mechanism that is capable of utilizing it, in the+form supplied by the content creator, without limitation as to+specific hardware or software.++The consumer of this work may make copies of this work (physical or+otherwise) for backup purposes.++The consumer of this work may lend this work to another individual+provided that the following two conditions are met :+  +  1. the lender no longer utilizes or possesses the work+  2. the work is not presently lent to another individual++The consumer of this work may sell this work to another individual+provided that the following two conditions are met :++  1. the seller no longer utilizes or possesses the work +  2. once the work is sold, the seller relinquishes all rights and+      copies of the work to the buyer.++### 2. Don’t Be Bogus.++The consumer of this work shall not redistribute modified, or+unmodified, copies of this work without explicit written permission+from the creator of this work.  The only exceptions allowed to this+rule are the provisions outlined in section 1 of this license++The consumer of this work shall not hold the creator of this work+liable for anything the consumer does, or does not, do, or the results+of utilizing this work.++### 3. Party On, Dudes!++The creator of this work provides the work in a form that contains no+mechanism to disable the utilization of the work after a specific+date, period of time or number of uses.++If additional works, which are created and wholly owned by the work’s+creator, are required to utilize this work, those additional works+must also be made available to the consumer so long as the following+conditions are met :+  +  1. doing so is possible+  2. doing so does not cause harm to the creator of the work.

@@ -0,0 +1,58 @@+name:          definitive-base+version:       1.0++synopsis:      The base modules of the Definitive framework.+description:     The Definitive framework is an attempt at harnessing the declarative+  nature of Haskell to provide a solid and simple base for writing +  real-world programs, as well as complex algorithms.+  +  This package contains the base modules of the framework, and provides+  only the most basic functionality, ranging from basic algebraic+  structures, such as monoids and rings, to functors, applicative functors,+  monads and transformers.+  +  Lenses are used heavily in all the framework's abstractions, replacing+  more traditional functions ('WriterT' and 'runWriterT' are implemented+  in the same isomorphism 'writerT', for example). When used wisely,+  lenses can greatly improve clarity in both code and thought, so I+  tried to provide for them in the most ubiquitous way possible,+  defining them as soon as possible. Isomorphisms in particular are+  surprisingly useful in many instances, from converting between types+  to acting on a value's representation as if it were the value itself.+  +  Packages using the Definitive framework should be compiled with the +  RebindableSyntax flag and include the Algebra module, which exports+  the same interface as the Prelude, except for some extras.+  +  Here is a list of design differences between the standard Prelude+  and the Definitive framework :+  +    - The '+', '-', 'negate', and '*' are now part of the Semigroup,+      Disjonctive, Negative, Semiring classes instead of Num (default+      instances are defined to reimplement the Prelude, making it easy+      to adjust your code for compatibility) +    +    - The mapM, traverseM, liftM, and such functions have been hidden,+      since they only reimplement the traverse, map, and other simpler+      functions.+  +    - Lenses are used whenever possible instead of more usual functions.+      You are encouraged to read the interface for the Algebra.Lens+      module, which contains everything you will need to be able to use+      lenses to their full potential (except maybe a good explanation).+  +      +author:        Marc Coiffier+maintainer:    marc.coiffier@gmail.com+license:       OtherLicense+license-file:  LICENSE++build-type:    Simple+cabal-version: >=1.10++library+  exposed-modules: Algebra Algebra.Arrow Algebra.Core Algebra.Classes Algebra.Monad Algebra.Monad.Base Algebra.Applicative Algebra.Functor Algebra.Foldable Algebra.Traversable Algebra.Lens Algebra.Monad.RWS Algebra.Monad.State Algebra.Monad.Reader Algebra.Monad.Writer Algebra.Monad.Cont Algebra.Monad.Foldable Algebra.Monad.Error Data.Containers Algebra.Time Data.TimeVal Data.Containers.Sequence Data.Probability Data.Reactive+  build-depends: base (== 4.6.*), containers (== 0.5.*), deepseq (== 1.3.*), array (== 0.5.*), bytestring (== 0.10.*), clock (== 0.4.*), vector (== 0.10.*), primitive (== 0.5.*)+  default-extensions: TypeSynonymInstances NoMonomorphismRestriction StandaloneDeriving GeneralizedNewtypeDeriving TypeOperators RebindableSyntax FlexibleInstances FlexibleContexts FunctionalDependencies TupleSections MultiParamTypeClasses Rank2Types+  ghc-options: -Wall -fno-warn-orphans -threaded+  default-language: Haskell2010