packages feed

SimpleH 1.0.1 → 1.2

raw patch · 48 files changed

+2676/−2138 lines, 48 filesdep +cpudep +networkdep +time

Dependencies added: cpu, network, time, unix

Files

LICENSE view
@@ -1,30 +1,72 @@-Copyright (c) 2013, Marc Coiffier+% The Greater Lunduke License+% [Bryan Lunduke][]+% February of 2013 (Version 1.0)  -All rights reserved.+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. -Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+PREAMBLE+-------- -    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.+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”. -    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.+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. -    * Neither the name of Marc Coiffier nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.+TERMS AND CONDITIONS+-------------------- -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+### 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.++
+ README.md view
@@ -0,0 +1,20 @@+SimpleH : A simple Haskell for the simple programmer+====================================================++The Haskell Prelude is a very useful library that is automatically+loaded when compiling a Haskell source file. It defines most of the+functions that are needed to write a simple Haskell program, including+numeric functions, list functions, I/O functions and fundamental+control structures (Monads, Functors and the like).++SimpleH isn't meant to replace the Prelude but to complement it.+However, it redefines some standard classes in order to simplify their+functionality so it may not interact nicely with other libraries that+make use of the standard bindings. Still, I tried to keep the+redefining to a minimum and to render the SimpleH experience as+seamless as possible.++_Warning:_ since I started writing SimpleH just a few weeks back,+I haven't taken the time to properly document it yet, so you have to+already be familiar with basic Haskell concepts in order to understand+it. Sorry.
SimpleH.cabal view
@@ -1,24 +1,28 @@- name:                SimpleH-version:             1.0.1+version:             1.2 synopsis:            A light, clean and powerful Haskell utility library-description: SimpleH is a Prelude complement that defines a few very useful abstractions, such as Monad transformers, Lenses, parser combinators, reactive abstractions and a few others.-  synopsis: A light, clean and powerful Haskell utility library         -license:             BSD3+description: SimpleH is a Prelude complement that defines a few very +  useful abstractions, such as Monad transformers, Lenses, parser +  combinators, reactive events and a few others.         +license:             OtherLicense license-file:        LICENSE author:              Marc Coiffier maintainer:          marc.coiffier@gmail.com category:            Prelude build-type:          Simple-cabal-version:       >=1.8+extra-source-files:  README.md+cabal-version:       >=1.10  library-  exposed-modules: SimpleH.Containers SimpleH.Parser SimpleH.Foldable SimpleH.Core SimpleH.Traversable SimpleH.Functor SimpleH.Reactive SimpleH.Monad SimpleH.Arrow SimpleH.Applicative SimpleH.Lens SimpleH.Reactive.TimeVal SimpleH.Reactive.Time SimpleH SimpleH.File SimpleH.Parser.CmdArgs-  other-modules: SimpleH.Classes       -  build-depends:       base ==4.6.*, containers ==0.5.*, bytestring ==0.10.*, directory ==1.2.*, filepath ==1.3.*, clock ==0.3.*+  exposed-modules: Data.Containers Data.Serialize Control.Parser Control.Parser.CmdArgs Control.Parser.HTTP Control.Reactive Control.Lens Control.Reactive.Time Control.Reactive.TimeVal Algebra.Foldable Algebra.Core Algebra.Traversable Algebra.Functor Algebra.Monad Algebra.Arrow Algebra.Applicative Algebra.Monad.RWS Algebra.Monad.State Algebra.Monad.Foldable Algebra.Monad.Cont Algebra.Monad.Reader Algebra.Monad.Error Algebra.Monad.Writer System.Simple System.Simple.Network System.Simple.File SimpleH+  other-modules: Algebra.Classes Algebra.Monad.Base       +  other-extensions:    MultiParamTypeClasses, ScopedTypeVariables, RebindableSyntax, GeneralizedNewtypeDeriving, TupleSections, FlexibleInstances, RankNTypes, ViewPatterns, Rank2Types, FunctionalDependencies, RecursiveDo, DeriveDataTypeable, ImplicitParams, NoRebindableSyntax, DefaultSignatures, EmptyDataDecls, UndecidableInstances+  build-depends:       base >=4.6 && <4.7, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11, cpu >=0.1 && <0.2, clock >=0.3 && <0.4, network >=2.4 && <2.5, directory >=1.2 && <1.3, filepath >=1.3 && <1.4, unix >=2.6 && <2.7, time >=1.4 && <1.5   hs-source-dirs:      src-  extensions:  TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts, FunctionalDependencies-  ghc-options:  -Wall -fno-warn-orphans+  default-language:    Haskell2010+  default-extensions: TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts, FunctionalDependencies, TupleSections, MultiParamTypeClasses, Rank2Types+  ghc-options: -Wall -fno-warn-orphans+ source-repository head   type: git   location: git://github.com/lih/SimpleH.git
+ src/Algebra/Applicative.hs view
@@ -0,0 +1,141 @@+-- |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,filter+  ) 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 Ring b => Ring (a -> b) where (*) = timesA ; one = oneA+instance Monad ((->) a) where join f x = f x x+instance Monoid w => Applicative ((,) w)+instance Monoid w => Monad ((,) w) where+  join ~(w,~(w',a)) = (w+w',a)+instance Applicative []+instance Monad [] where join = fold+instance Applicative 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 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,Ring a) => f a -> f a -> f a++(*>) :: Applicative f => f b -> f a -> f a+(<*) :: Applicative f => f a -> f b -> f a+(<**>) :: Applicative f => f (a -> b) -> f a -> f b++ap = (<*>)+infixl 1 <*+infixl 2 <**>,*>+(*>) = 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)
+ src/Algebra/Arrow.hs view
@@ -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
+ src/Algebra/Classes.hs view
@@ -0,0 +1,48 @@+{-# 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 2 <*>+  (<*>) :: 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+  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 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+
+ src/Algebra/Core.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, DefaultSignatures, TupleSections, EmptyDataDecls #-}+module Algebra.Core(+  -- * Raw data+  BS.ByteString,BS.readFile,BS.writeFile,BS.hGetContents,++  -- * Basic union and product types+  Void,(:*:),(:+:),+  +  -- * Basic group and ring structure+  -- ** Classes+  Semigroup(..),Monoid(..),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,++  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)+import qualified Prelude as P+import Data.Tree+import qualified Data.ByteString as BS+import Data.Ord (comparing)++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 [a] where []+l = l ; (x:t)+l = x:(t+l)+instance (Semigroup a,Semigroup b) => Semigroup (a:*:b) where ~(a,b) + ~(c,d) = (a+c,b+d)+instance (Semigroup a,Semigroup b,Semigroup c) => Semigroup (a,b,c) where+  ~(a,b,c) + ~(a',b',c') = (a+a',b+b',c+c')+instance SubSemi b a => Semigroup (a:+:b) where+  Left a+Left b = Left (a+b)+  a+b = Right (from a+from b)+    where from = cast <|> id+instance Semigroup (Maybe a) where+  Nothing + b = b ; a + _ = a++-- |A monoid is a semigroup with a null element such that @zero + a == a + zero == a@+class Semigroup m => Monoid m where+  zero :: m+  default zero :: Num m => m+  zero = 0+instance Monoid Void where zero = undefined+instance Monoid () where zero = ()+instance Monoid Int ; instance Monoid Integer+instance Monoid Float ; instance Monoid Double+instance Monoid [a] where zero = []+instance (Monoid a,Monoid b) => Monoid (a:*:b) where zero = (zero,zero)+instance (Monoid a,Monoid b,Monoid c) => Monoid (a,b,c) where+  zero = (zero,zero,zero)+instance (SubSemi b a,Monoid a) => Monoid (a:+:b) where zero = Left zero+instance Monoid Bool where zero = False+instance Monoid (Maybe a) where zero = Nothing++class (Semigroup a,Semigroup b) => SubSemi a b where+  cast :: b -> a+instance Monoid a => SubSemi a () where cast _ = zero+instance Monoid a => SubSemi a Void where cast _ = zero++class Monoid m => Ring m where+  one :: m+  default one :: Num m => m+  one = 1+  (*) :: m -> m -> m+  default (*) :: Num m => m -> m -> m+  (*) = (P.*)++infixl 7 *+instance Ring Bool where one = True ; (*) = (&&)+instance Ring Int+instance Ring Integer+instance Ring Float+instance Ring Double+instance Monoid a => Ring [a] where+  one = zero:one+  (a:as) * (b:bs) = a+b:as*bs+  _ * _ = zero+instance (Ring a,Ring b) => Ring (a:*:b) where+  one = (one,one) ; ~(a,b) * ~(c,d) = (a*c,b*d)++-- class Ring n => Integral n where+--   fromInteger :: Integer -> n+--   toInteger :: n -> Integer+  +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 }+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) => Ring (Max a) where+  one = Max maxBound+  Max a * Max b = Max (min a b)++{-| The dual of a monoid is the same as the original, with arguments reversed -}+newtype Dual m = Dual { getDual :: m }+instance Semigroup m => Semigroup (Dual m) where Dual a+Dual b = Dual (b+a)+deriving instance Monoid m => Monoid (Dual m)+instance Ring m => Ring (Dual m) where +  one = Dual one+  Dual a * Dual b = Dual (b*a)++-- |An ordered list. The semigroup instance merges two lists so that+-- the result remains in ascending order.+newtype OrdList a = OrdList { getOrdList :: [a] }+                  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)
+ src/Algebra/Foldable.hs view
@@ -0,0 +1,95 @@+{-# 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++newtype Sized f a = Sized { getSized :: f a }+instance (Foldable f,Semigroup (Sized f a),Monoid n,Num n) =>+         SubSemi n (Sized f a) where+  cast = size . getSized++instance (Foldable f,Foldable g) => Foldable (f:**:g) where+  fold (f:**:g) = fold f + fold g+instance (Foldable f,Foldable g) => Foldable (f:++:g) where+  fold (Sum (Left f)) = fold f+  fold (Sum (Right g)) = fold g++foldMap :: (Monoid m, Foldable t) => (a -> m) -> t a -> m+foldMap f = fold . map f+convert :: (Unit f, Monoid (f a), Foldable t) => t a -> f a+convert = foldMap pure+concat :: (Monoid m, Foldable t) => t m -> m+concat = fold+sum :: (Monoid m, Foldable t) => t m -> m+sum = fold+size :: (Foldable f,Num n,Monoid n) => f a -> n+size c = sum (1<$c)+count :: (Num n, Monoid n, Foldable f) => f a -> n+count = size+length :: (Num n,Monoid n) => [a] -> n+length = count++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 p = fst . partition p+select :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a+select = filter+refuse :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a+refuse = filter . map not++compose :: (Category k, Foldable t) => t (k a a) -> k a a+compose = runEndo . foldMap Endo++foldr :: Foldable t => (b -> a -> a) -> a -> t b -> a+foldr f e t = (runEndo . getDual) (foldMap (\b -> Dual (Endo (f b))) t) e+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 (filter p . Id)+or :: Foldable t => t Bool -> Bool+or = fold+and :: Foldable t => t Bool -> Bool+and = getProduct . fold . map Product+all :: Foldable t => (a -> Bool) -> t a -> Bool+all = map and . map+any :: Foldable t => (a -> Bool) -> t a -> Bool+any = map or . map+elem :: (Eq a,Foldable t) => a -> t a -> Bool+elem e = any (e==)++empty :: Foldable f => f a -> Bool+empty = foldr (const (const False)) True
+ src/Algebra/Functor.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE MultiParamTypeClasses, RankNTypes, DefaultSignatures #-}+-- |A module for functors+module Algebra.Functor(+  Functor(..),Cofunctor(..),Bifunctor(..),+  +  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++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 3 <$>,<$+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))
+ src/Algebra/Monad.hs view
@@ -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+
+ src/Algebra/Monad/Base.hs view
@@ -0,0 +1,118 @@+module Algebra.Monad.Base (+  module Algebra.Classes,module Algebra.Applicative,module Algebra.Core,+  module Algebra.Traversable,module Control.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 Control.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+  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+  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) => (b -> a -> m a) -> a -> t b -> m a+foldlM = folding (_Kleisli._Endo._Dual)+foldrM :: (Foldable t,Monad m) => (b -> a -> m a) -> a -> t b -> m a+foldrM = folding (_Kleisli._Endo)+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+  generalize = _Compose' %%~ pure . yb _Id+++
+ src/Algebra/Monad/Cont.hs view
@@ -0,0 +1,34 @@+module Algebra.Monad.Cont (+  -- * The MonadCont class+  MonadCont(..),+  +  -- * The Continuation transformer+  ContT(..),Cont,+  evalContT,+  evalCont+  ) 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,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 >>=)+  generalize = undefined+instance Monad m => MonadCont (ContT r m) where+  callCC f = ContT (\k -> runContT (f (\a -> ContT (\_ -> k a))) k)++evalContT :: Unit m => ContT r m r -> m r+evalContT c = runContT c return+evalCont :: Cont r r -> r+evalCont = getId . evalContT+
+ src/Algebra/Monad/Error.hs view
@@ -0,0 +1,40 @@+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 Void 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)++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+
+ src/Algebra/Monad/Foldable.hs view
@@ -0,0 +1,53 @@+{-# 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)++
+ src/Algebra/Monad/RWS.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE UndecidableInstances #-}+module Algebra.Monad.RWS (+  RWST(..),RWS,MonadInternal(..),_RWST,++  -- * Default methods+  get_,put_,modify_,local_,ask_,tell_,listen_,censor_+  ) 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 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)+  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)))+
+ src/Algebra/Monad/Reader.hs view
@@ -0,0 +1,36 @@+{-# 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_+deriving instance Semigroup (m (a,Void,Void)) => Semigroup (ReaderT r m a)+deriving instance Monoid (m (a,Void,Void)) => Monoid (ReaderT r m a)+deriving instance Ring (m (a,Void,Void)) => Ring (ReaderT r m a)++_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+
+ src/Algebra/Monad/State.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE UndecidableInstances #-}+module Algebra.Monad.State (+  -- * The State Monad+  MonadState(..),+  StateT,State,+  stateT,eval,exec,state,+  (=~),(=-),gets,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_+deriving instance MonadError e m => MonadError e (StateT s m)+deriving instance Semigroup (m (a,s,Void)) => Semigroup (StateT s m a)+deriving instance Monoid (m (a,s,Void)) => Monoid (StateT s m a)+deriving instance Ring (m (a,s,Void)) => Ring (StateT s m a)++_StateT :: Iso (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 :: (Functor f, Functor f') => f (f' (a, b)) -> f (f' b)+eval = map2 snd+exec :: (Functor f, Functor f') => f (f' (a, b)) -> f (f' a)+exec = map2 fst+state :: Iso (State s a) (State t b) (s -> (s,a)) (t -> (t,b))+state = _mapping _Id.stateT++(=-) :: MonadState s m => Lens' s s' -> s' -> m ()+infixl 0 =-,=~+l =- x = modify (set l x)+(=~) :: MonadState s m => Lens' s s' -> (s' -> s') -> m ()+l =~ f = modify (warp l f)+gets :: MonadState s m => Lens' s s' -> m s'+gets l = by l<$>get++saving :: MonadState s m => Lens' s s' -> m a -> m a+saving l st = gets 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)))
+ src/Algebra/Monad/Writer.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE UndecidableInstances #-}+module Algebra.Monad.Writer (+    -- * The Writer monad+  MonadWriter(..),+  mute,intercept,++  -- * The Writer transformer+  WriterT,Writer,+  _writerT,_writer+  ) 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 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++
+ src/Algebra/Traversable.hs view
@@ -0,0 +1,57 @@+module Algebra.Traversable(+  module Algebra.Applicative, module Algebra.Foldable,++  Traversable(..),Contravariant(..),++  traverse,foreach,transpose,flip+  ) where++import Algebra.Classes+import Algebra.Core hiding (flip,(&))+import Algebra.Applicative+import Algebra.Foldable+import Control.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++traverse :: (Applicative f,Traversable t) => (a -> f b) -> t a -> f (t b)+traverse f t = sequence (map f t)+foreach :: (Applicative f,Traversable t) => t a -> (a -> f b) -> f (t b)+foreach = flip traverse+transpose :: (Applicative f,Traversable t) => t (f a) -> f (t a)+transpose = sequence+flip :: (Contravariant c,Functor f) => f (c a) -> c (f a)+flip = collect++instance Compound a b [a] [b] where+  _each = traverse
+ src/Control/Lens.hs view
@@ -0,0 +1,296 @@+{-# 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 Control.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,(.+),++  -- * Extracting values+  (^.),(^..),(^?),has,(^??),(%~),(%-),(%%~),(%%-),by,yb,warp,set,+  (-.),(.-),+  +  -- * Basic lenses+  Lens1(..),Lens2(..),Lens3(..),Lens4(..),+  Trav1(..),Trav2(..),+  Compound(..),+  _list,_head,_tail,++  -- * Isomorphisms+  Isomorphic(..),+  adding,_swapped,+  _Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,+  warp2,_mapping,_mapping',_promapping,+  IsoFunctor(..),(<.>),IsoFunctor2(..),+  _thunk+  ) where++import Algebra.Core+import Algebra.Functor+import Algebra.Applicative+import System.IO.Unsafe (unsafePerformIO)+import Control.Exception (evaluate)++type LensLike f s t a b = (s -> f t) -> (a -> f b)+type LensLike' f a b = LensLike f b b a a++type Lens s t a b = forall f.Functor f => LensLike f s t a b+type Lens' a b = Lens b b a a+type Getter s t a b = LensLike (Const s) s t a b+type Getter' 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)++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++simple :: Iso' a b -> Iso' a b+simple i = i++(-.) :: 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 ++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 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 = _list._r._1+_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++_swapped :: Iso (a,b) (c,d) (b,a) (d,c)+_swapped = iso (\(b,a) -> (a,b)) (\(c,d) -> (d,c))++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++
+ src/Control/Parser.hs view
@@ -0,0 +1,200 @@+-- |A module providing simple Parser combinator functionality. Useful+-- for small parsing tasks such as identifier parsing or command-line+-- argument parsing+module Control.Parser (+  module SimpleH,+  -- * The ParserT Type+  ParserT(..),Parser,ParserA(..),_ParserA,++  -- ** The Stream class+  Stream(..),emptyStream,++  -- ** Converting to/from Parsers+  parserT,parser,runParser,runParserT,pureParser,eitherParser,++  -- * Basic combinators+  (<+>),(>*>),(<*<),+  token,satisfy,+  oneOf,noneOf,single,+  several,+  remaining,eoi,++  -- ** Specialized utilities+  readable,number,digit,letter,alNum,quotedString,space,spaces,eol,+  +  -- * Basic combinators+  many,many1,sepBy,sepBy1,+  chainl,chainr                          +  ) where++import SimpleH++import qualified Data.ByteString.Char8 as BS+import Data.Char++newtype ParserT w s m a = ParserT (StateT s (ListT (WriterT w m)) a)+                        deriving (Unit,Functor,Applicative,Monoid,Semigroup,+                                  Monad,MonadFix,MonadState s,MonadWriter w)+type Parser w c a = ParserT w c Id a+deriving instance (Monad m,Monoid w) => MonadError Void (ParserT w c m)+instance Monoid w => MonadTrans (ParserT w s) where+  lift = ParserT . lift . lift . lift+  generalize = parserT %%~ map (pure.yb _Id)+_ParserT :: Iso (ParserT w s m a) (ParserT x t n b) (StateT s (ListT (WriterT w m)) a) (StateT t (ListT (WriterT x n)) b)+_ParserT = iso ParserT (\(ParserT p) -> p)+parserT :: (Functor n,Functor m) => Iso (ParserT w s m a) (ParserT x t n b) (s -> m (w,[(s,a)])) (t -> n (x,[(t,b)]))+parserT = _mapping (_writerT._listT).stateT._ParserT+parser :: Iso (Parser w s a) (Parser x t b) (s -> (w,[(s,a)])) (t -> (x,[(t,b)]))+parser = _mapping _Id.parserT+runParser :: Parser Void s a -> s -> [(s,a)]+runParser = map snd . yb parser+runParserT :: Functor m => ParserT Void s m a -> s -> m [(s,a)]+runParserT = map2 snd . (^..parserT)+pureParser :: (Monoid w,Monad m) => (s -> [a]) -> ParserT w s m a+pureParser p = (\a -> pure (zero,[(a,b) | b <- p a]))^.parserT+eitherParser :: Monoid w => (s -> Either w a) :<->: Parser w s a+eitherParser = iso (\p s -> (,[])<|>pure.pure.(s,) $ p s)+               (\p' s -> case p' s of+                   (w,[]) -> Left w+                   (_,((_,a):_)) -> Right a).parser+               +  +-- |The @(+)@ operator with lower priority+(<+>) :: Semigroup m => m -> m -> m+(<+>) = (+)+(>*>) :: (Monoid w, Monad m) => ParserT w a m b -> ParserT w b m c -> ParserT w a m c+(>*>) = (>>>)^..(_ParserA<.>_ParserA<.>_ParserA)+(<*<) :: (Monoid w, Monad m) => ParserT w b m c -> ParserT w a m b -> ParserT w a m c+(<*<) = flip (>*>)++newtype ParserA w m s a = ParserA (ParserT w s m a)+_ParserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (ParserT w s m a) (ParserT w' s' m' a')+_ParserA = iso ParserA (\(ParserA p) -> p)+parserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (StateA (ListT (WriterT w m)) s a) (StateA (ListT (WriterT w' m')) s' a') +parserA = from stateA._ParserT._ParserA+instance (Monoid w,Monad m) => Category (ParserA w m) where+  id = ParserA get+  (.) = (.)^.(parserA<.>parserA<.>parserA)+instance (Monoid w,Monad m) => Split (ParserA w m) where+  (<#>) = (<#>)^.(parserA<.>parserA<.>parserA)+instance (Monoid w,Monad m) => Choice (ParserA w m) where+  (<|>) = (<|>)^.(parserA<.>parserA<.>parserA)+instance (Monoid w,Monad m) => Arrow (ParserA w m) where+  arr f = arr f^.parserA++-- |The remaining Stream to parse+remaining :: (Monad m,Monoid w) => ParserT w s m s+remaining = get+-- |Consume a token from the Stream+token :: (Monad m,Monoid w,Stream c s) => ParserT w s m c+{-# SPECIALIZE token :: (Monad m,Monoid w) => ParserT w [c] m c #-}+token = get >>= \s -> case uncons s of+  Nothing -> zero+  Just (c,t) -> put t >> pure c++-- |Parse zero, one or more successive occurences of a parser.+many :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]+many p = liftA2 (:) p (many p) <+> pure []+-- |Parse one or more successiveé occurences of a parser.+many1 :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]+many1 p = (:)<$>p<*>many p++-- |Consume a token and succeed if it verifies a predicate+satisfy :: (Monoid w, Monad m, Stream c s) => (c -> Bool) -> ParserT w s m c+{-# SPECIALIZE satisfy :: (Monoid w, Monad m) => (c -> Bool) -> ParserT w [c] m c #-}+satisfy p = token <*= guard . p+-- |Consume a single fixed token or fail.+single :: (Eq c, Monoid w, Monad m, Stream c s) => c -> ParserT w s m ()+single = void . satisfy . (==)++-- |Consume a structure of characters or fail+several :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m ()+{-# SPECIALIZE several :: (Eq c, Monoid w, Monad m) => [c] -> ParserT w [c] m () #-}+several l = traverse_ single l++-- |Try to consume a parser. Return a default value when it fails.+option :: (Monoid w,Monad m) => a -> ParserT w s m a -> ParserT w s m a+option a p = p+pure a++-- |Succeed only if we are by the End Of Input.+eoi :: (Monad m,Monoid w,Stream c s) => ParserT w s m ()+eoi = remaining >>= guard.emptyStream+-- |The end of line+eol :: (Monad m,Monoid w,Stream Char s) => ParserT w s m ()+eol = single '\n'++-- |Parse one or more successive occurences of a parser separated by+-- occurences of a second parser.+sepBy1 ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a]+sepBy1 p sep = (:)<$>p<*>many (sep >> p)+-- |Parse zero or more successive occurences of a parser separated by+-- occurences of a second parser.+sepBy ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a]+sepBy p sep = option [] (sepBy1 p sep)++-- |Parse a member of a set of values+oneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c+oneOf = satisfy . flip elem+-- |Parse anything but a member of a set+noneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c+noneOf = satisfy . map not . flip elem++-- |Parse a litteral decimal number+number :: (Monoid w,Monad m,Stream Char s,Num n) => ParserT w s m n+number = fromInteger.read <$> many1 digit+-- |Parse a single decimal digit+digit :: (Monoid w,Monad m,Stream Char s) => ParserT w s m Char+digit = satisfy isDigit+alNum :: (Monoid w,Monad m,Stream Char s) => ParserT w s m Char+alNum = satisfy isAlphaNum+letter :: (Monoid w,Monad m,Stream Char s) => ParserT w s m Char+letter = satisfy isAlpha+-- |Parse a delimited string, unsing '\\' as the quoting character+quotedString :: (Monoid w,Monad m,Stream Char s) => Char -> ParserT w s m String+quotedString d = between (single d) (single d) (many ch)+  where ch = single '\\' *> unquote<$>token+             <+> noneOf (d:"\\")+        unquote 'n' = '\n'+        unquote 't' = '\t'+        unquote c = c+-- |A single space+space :: (Monoid w,Monad m,Stream Char s) => ParserT w s m Char+space = satisfy isSpace+-- |Many spaces+spaces :: (Monoid w,Monad m,Stream Char s) => ParserT w s m String+spaces = many1 space++infixl 1 `sepBy`,`sepBy1`+infixr 0 <+>++-- |Chain an operator with an initial value and several tail values.+chainr :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (b -> a -> a) -> ParserT w s m b -> ParserT w s m a+chainr expr op e = compose<$>many (op<**>e)<*>expr+-- |Chain an operator with an initial value+chainl :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (a -> b -> a) -> ParserT w s m b -> ParserT w s m a+chainl expr op e = compose<$>many (flip<$>op<*>e)<**>expr++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 BS.ByteString where+  uncons = BS.uncons+  cons = BS.cons++-- |Test if a Stream is empty+emptyStream :: Stream c s => s -> Bool+emptyStream = maybe True (const False) . uncons++class Serializable t where+  encode :: t -> BS.ByteString+  decode :: Parser String BS.ByteString t+instance Serializable BS.ByteString where+  encode = id ; decode = get++readable :: (Monoid w,Monad m,Read a) => ParserT w String m a +readable = map (pure.pure.map swap) (readsPrec 0)^.parserT+
+ src/Control/Parser/CmdArgs.hs view
@@ -0,0 +1,47 @@+module Control.Parser.CmdArgs (+  -- * Exported modules+  module Control.Parser,++  -- * Preprocessing command-line arguments+  OptDescr(..),ArgDescr(..),usageInfo,+  tokenize,+  +  -- * Example usage+  -- $tutorial+ ) where++import Control.Parser+import System.Console.GetOpt++-- |Create a Parser that preprocesses the command-line arguments,+-- splitting options and their arguments into a user-defined data+-- type.+tokenize :: [OptDescr a] -> (String -> a) -> Parser String [String] [a]+tokenize options wrap = p^.parser+  where p a = (concat err,pure (a,bs))+          where (bs,_,err) = getOpt (ReturnInOrder wrap) options a++{- $tutorial++This module is intended to provide simple parsing functionality to the+handling of command-line arguments. Here is an example of how this module+may be used.+++>data Option = Help | Version | Other String+>           deriving Eq+>  +>options = [+>  Option ['h'] ["help"] (NoArg Help) "Display this menu.",+>  Option ['v'] ["version"] (NoArg Version) "Show the version of this program"+>  ]+>+>mainAxiom = single Help >> lift (putStrLn (usageInfo options))+>          <+> single Version >> lift (putStrLn "Version: 1.0")+>+>main = void $ do+>    getArgs >>= (mainAxiom <*< tokenize options Other)++-}++
+ src/Control/Parser/HTTP.hs view
@@ -0,0 +1,62 @@+module Control.Parser.HTTP (+  module Control.Parser,++  URI(..),uriId,uri,++  Request(..),ReqType(..),Response(..),Status(..),Header(..),Host,+  reqLine,request+  ) where++import Control.Parser hiding (space,spaces)+import Data.Char+import Data.List (intercalate)++data URI = URI {+  uriScheme :: String,+  uriUser :: Maybe String,+  uriHost :: String,+  uriPort :: Maybe Int,+  uriPath :: [String],+  uriRequest :: Maybe String,+  uriFragment :: Maybe String+  }+         deriving Show++uriId :: (Monoid w,Stream Char s,Monad m) => ParserT w s m String+uriId = many1 (satisfy (\c -> isAlphaNum c || c`elem`['-','_','~','.']))++uri :: (Monoid w,Stream Char s,Monad m) => ParserT w s m URI+uri = URI<$>(uriId <* several "://")+      <*>tryMay (uriId <* single '@')+      <*>uriId+      <*>tryMay (single ':' *> number)+      <*>many ("/"<$single '/' <+> uriId)+      <*>tryMay (single '?' >> many (noneOf "#"))+      <*>tryMay (single '#' >> many token)+++data Request = Request ReqType [Header] Host FilePath+data ReqType = GET | HEAD | POST ByteString+data Response = Response Status [Header] ByteString+data Status = OK | NotFound+data Header = Header String String+type Host = String++space :: (Monoid w, Monad m, Stream Char s) => ParserT w s m Char+space = sp <+> (nl >> sp)+  where sp = oneOf " \t"+spaces :: (Monoid w, Monad m, Stream Char s) => ParserT w s m String+spaces = many space+nl :: (Monoid w, Monad m, Stream Char s) => ParserT w s m ()+nl = try (single '\n') (several "\r\n")+word :: (Monoid w, Monad m, Stream Char s) => ParserT w s m String+word = quotedString '"' <+> many (noneOf " \t\n")+line :: (Monoid w, Monad m, Stream Char s) => ParserT w s m String+line = intercalate " " <$> (spaces >> (word`sepBy`spaces)) <* (spaces >> nl)++reqLine :: (Monoid w, Monad m) => ParserT w String m [String]+reqLine = pureParser (pure<$>words)+request :: (Monoid w, Monad m) => ParserT w String m [String]+request = do+  _ <- line >*> reqLine+  many (line <*= guard . not . null)
+ src/Control/Reactive.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE RebindableSyntax, GeneralizedNewtypeDeriving, TupleSections, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ViewPatterns #-}+module Control.Reactive (+  -- * Reactive Modules+  module Control.Reactive.Time,+  module Control.Reactive.TimeVal,++  -- * 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,realizeRT,eventMay,event,react,react2,react3,+  +  -- * Future values+  Future,_future,_time,_value,futureIO,+  ) where++import SimpleH+import Control.Concurrent+import Control.Reactive.TimeVal+import System.IO.Unsafe (unsafeInterleaveIO)+import Data.List (group)+import Control.Reactive.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 2 <*|>+(<|*>) :: Ord t => Reactive t (a -> b) -> Event t a -> Event t b+f <|*> a = (&)<$>a<*|>f+infixr 1 <|*>++-- |Group the occurences of an event by equality. Occurs when the first occurence of a group occurs. +groupE :: (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+-- |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 l = traverse_ (sink_ . first timeVal) (withTime l)+  where sink_ (Since t,v) = currentTime >>= \c -> when (c<=t) (waitTill t >> v)+        sink_ (Always,v) = v+        sink_ (Never,_) = unit+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 . 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,readMVar val^._thunk))++
+ src/Control/Reactive/Time.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE TupleSections, RecursiveDo, Rank2Types, DeriveDataTypeable, ImplicitParams #-}+module Control.Reactive.Time (+  -- * Unambiguous times+  Time,+  timeVal,++  -- * Time utilities+  Seconds,+  timeIO,waitTill,currentTime,timeOrigin+  ) where++import SimpleH+import Control.Concurrent+import Control.Reactive.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 => Ring (Time t) where+  one = maxBound+  ~(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 => Orderable (Time t) where+  inOrder a b = (a*b,if z then b else a,z)+    where z = a<=b++mapTL :: (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 -> pure a <* killThread tb+    Right a -> pure a <* killThread ta+unamb :: a -> a -> a+unamb = warp2 (from _thunk) amb++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+
+ src/Control/Reactive/TimeVal.hs view
@@ -0,0 +1,30 @@+module Control.Reactive.TimeVal (+  TimeVal(..)+  ) where++import SimpleH++-- |A type wrapper that adds a Bounded instance for types that don't possess one.+data TimeVal t = Always | Since t | Never+                 deriving (Show,Eq,Ord)+instance Functor TimeVal where+  map f (Since a) = Since (f a)+  map _ Always = Always+  map _ Never = Never+instance Unit TimeVal where pure = Since+instance Applicative TimeVal+instance Monad TimeVal where+  join (Since b) = b+  join Always = Always+  join Never = Never+instance 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+
+ src/Data/Containers.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Data.Containers(+  DataMap(..),+  Set,Map,ascList,++  member,delete,touch,insert,singleton,fromList+  )+  where++import SimpleH+import qualified Data.Set as S+import qualified Data.Map as M+import Data.Map (Map)+import Data.Set (Set)++class Monoid m => DataMap m k a | m -> k a where+  at :: k -> Lens' m (Maybe a)+class Indexed f i | f -> i where+  withKeys :: f a -> f (i,a)+member :: DataMap m k a => k -> m -> Bool+member k = by (at k) >>> yb _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 Ord k => DataMap (Map k a) k a where+  at k = lens (M.lookup k) (\m a -> M.alter (const a) k m)+  +instance Ord a => Semigroup (Set a) where (+) = S.union+instance Ord a => Monoid (Set a) where zero = S.empty+instance (Ord a,Monoid a) => Ring (Set a) where+  one = singleton zero zero+  (*) = 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 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 withKeys = M.mapWithKey (,)++ascList :: (Eq k,Eq k') => Iso [(k,a)] [(k',a')] (Map k a) (Map k' a')+ascList = iso M.toAscList M.fromAscList++newtype Bimap a b = Bimap (Map a b,Map b a)+                  deriving (Semigroup,Monoid)+_inverse :: Iso (Bimap a b) (Bimap c d) (Bimap b a) (Bimap d c)+_inverse = iso (\(Bimap (b,a)) -> Bimap (a,b)) (\(Bimap (c,d)) -> Bimap (d,c))++instance (Ord a,Ord b) => DataMap (Bimap a b) a b where+  at a = lens lookup setAt+    where lookup (Bimap (ma,_)) = ma^.at a+          setAt (Bimap (ma,mb)) b' = Bimap (+            ma',mb & maybe id delete b >>> maybe id (flip insert a) b')+            where b = ma^.at a ; ma' = ma & at a %- b'+instance (Ord b,Ord a) => DataMap (Flip Bimap b a) b a where+  at k = from (_inverse._Flip).at k
+ src/Data/Serialize.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Serialize (+  module Control.Parser,+  Serializable(..)+  ) where++import Control.Parser+import Data.ByteString.Lazy.Builder+import qualified Data.ByteString as BS+import Data.ByteString.Unsafe+import Data.Word+import Foreign.Ptr+import Foreign.Storable+import qualified Data.Monoid as M+import System.Endian++class Serializable t where+  encode :: t -> Builder+  serializable :: Parser String ByteString t ++instance Semigroup Builder where (+) = M.mappend+instance Monoid Builder where zero = M.mempty++withByteString :: ByteString -> (Ptr a -> IO b) -> b+withByteString b f = unsafeUseAsCString b (f . castPtr)^._thunk++storable :: forall a. Storable a => Parser String ByteString a+storable = p^.parser+  where p s | BS.length s >= sz = (zero,pure (unsafeDrop sz s,res))+            | otherwise = ("Input too short",zero)+          where res = withByteString s peek :: a+                sz = sizeOf res+  +instance Serializable Word8 where+  encode = word8+  serializable = storable+instance Serializable Word32 where+  encode = word32BE+  serializable = fromBE32<$>storable+instance Serializable Word64 where+  encode = word64BE+  serializable = fromBE64<$>storable+instance (Serializable a,Serializable b) => Serializable (a:*:b) where+  encode (a,b) = encode a+encode b+  serializable = (,)<$>serializable<*>serializable+instance (Serializable a,Serializable b) => Serializable (a:+:b) where+  encode (Left a) = word8 0+encode a+  encode (Right b) = word8 1+encode b+  serializable = storable >>= \x -> case x :: Word8 of+    0 -> Left<$>serializable+    1 -> Right<$>serializable+    _ -> tell "Invalid encoding" >> zero
src/SimpleH.hs view
@@ -1,11 +1,11 @@-module SimpleH(-  module SimpleH.Arrow,-  module SimpleH.Lens,-  module SimpleH.Traversable,-  module SimpleH.Core+module SimpleH (+  module Algebra.Core,+  module Algebra.Arrow,+  module Algebra.Traversable,+  module Control.Lens   ) where -import SimpleH.Arrow-import SimpleH.Core hiding (flip)-import SimpleH.Lens-import SimpleH.Traversable+import Algebra.Arrow+import Algebra.Core hiding (flip)+import Control.Lens+import Algebra.Traversable
− src/SimpleH/Applicative.hs 
@@ -1,138 +0,0 @@--- |A module describing applicative functors-module SimpleH.Applicative(-  module SimpleH.Functor,--  Applicative(..),-  ZipList(..),ZipTree(..),Backwards(..),--  (*>),(<*),(<**>),ap,sequence_,traverse_,for_,forever,--  between,-  -  liftA,liftA2,liftA3,liftA4,--  plusA,zeroA,filter-  ) where--import SimpleH.Functor-import SimpleH.Classes-import SimpleH.Core-import Data.Tree-import SimpleH.Foldable--instance Applicative (Either a)-instance Monad (Either a) where join (Right a) = a-                                join (Left a) = Left a-instance Applicative ((->) a)-instance Semigroup b => Semigroup (a -> b) where (+) = plusA-instance Monoid b => Monoid (a -> b) where zero = zeroA-instance Ring b => Ring (a -> b) where (*) = timesA ; one = oneA-instance Monad ((->) a) where join f x = f x x-instance Monoid w => Applicative ((,) w)-instance Monoid w => Monad ((,) w) where-  join ~(w,~(w',a)) = (w+w',a)-instance Applicative []-instance Monad [] where join = fold--instance (Unit f,Unit g) => Unit (f:**:g) where pure a = pure a:**:pure a-instance (Applicative f,Applicative g) => Applicative (f:**:g) where-  ff:**:fg <*> xf:**:xg = (ff<*>xf) :**: (fg<*>xg)--instance Applicative Tree-instance Monad Tree where-  join (Node (Node a subs) subs') = Node a (subs + map join subs')-instance (Applicative f,Applicative g) => Applicative (f:.:g) where-  Compose fs <*> Compose xs = Compose ((<*>)<$>fs<*>xs)-deriving instance Unit Interleave-instance Applicative Interleave-instance Monad Interleave where join = fold--{-|-A wrapper type for lists with zipping Applicative instances, such that-@ZipList [f1,...,fn] '<*>' ZipList [x1,...,xn] == ZipList [f1 x1,...,fn xn]@--}-newtype ZipList a = ZipList { getZipList :: [a] }-instance Semigroup a => Semigroup (ZipList a) where (+) = plusA-instance Monoid a => Monoid (ZipList a) where zero = zeroA--instance Functor ZipList where-  map f (ZipList l) = ZipList (map f l)-instance Unit ZipList where-  pure a = ZipList (repeat a)-instance Applicative ZipList where-  ZipList 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 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,Ring a) => f a -> f a -> f a--(*>) :: Applicative f => f b -> f a -> f a-(<*) :: Applicative f => f a -> f b -> f a-(<**>) :: Applicative f => f (a -> b) -> f a -> f b--ap = (<*>)-infixl 1 <*-infixl 2 <**>,*>-(*>) = 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 = undefined<$sequence_ (repeat m)--liftA :: Functor f => (a -> b) -> (f a -> f b)-liftA = map-liftA2 :: Applicative f => (a -> b -> c) -> (f a -> f b -> f c)-liftA2 f = \a b -> f<$>a<*>b-liftA3 :: Applicative f => (a -> b -> c -> d) -> (f a -> f b -> f c -> f d)-liftA3 f = \a b c -> f<$>a<*>b<*>c-liftA4 :: Applicative f => (a -> b -> c -> d -> e) -> (f a -> f b -> f c -> f d -> f e)-liftA4 f = \a b c d -> f<$>a<*>b<*>c<*>d--plusA = liftA2 (+)-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)
− src/SimpleH/Arrow.hs 
@@ -1,59 +0,0 @@-{-# LANGUAGE DefaultSignatures, TupleSections #-}-module SimpleH.Arrow (-  module SimpleH.Monad,-  -  Arrow(..),-  (>>^),(^>>),--  Apply(..),comapA,app,dup,--  Kleisli(..),--  ListA(..)-  ) where--import SimpleH.Core hiding (flip)-import SimpleH.Classes-import SimpleH.Monad-import SimpleH.Foldable--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-class Arrow k => Apply k where-  apply :: k (k a b,a) b-instance Apply (->) where apply (f,x) = f x-instance Monad m => Arrow (StateA m) where-  arr f = StateA (f<$>get)--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
− src/SimpleH/Classes.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-module SimpleH.Classes where--import SimpleH.Core--class Functor f where-  map :: (a -> b) -> f a -> f b-class (Unit f, Functor f) => Applicative f where-  infixl 2 <*>-  (<*>) :: f (a -> b) -> f a -> f b-  default (<*>) :: Monad f => f (a -> b) -> f a -> f b-  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)--
− src/SimpleH/Containers.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-module SimpleH.Containers(-  DataMap(..),--  AList(..),-  -  S.Set,M.Map,--  member,delete,minsert,insert-  )-  where--import SimpleH.Core-import SimpleH.Functor-import SimpleH.Lens-import qualified Data.Set as S-import qualified Data.Map as M--class DataMap m k a | m -> k a where-  lookup :: k -> m -> Maybe a-  alter :: (Maybe a -> Maybe a) -> k -> m -> m-member :: DataMap m k Void => k -> m -> Bool-member = map (at (from _maybe)) . lookup-delete :: DataMap m k a => k -> m -> m-delete = alter (const Nothing)-minsert :: (Monoid a, DataMap m k a) => k -> m -> m-minsert = alter (const (Just zero))-insert :: DataMap m k a => a -> k -> m -> m-insert = alter . const . Just--instance Ord a => DataMap (S.Set a) a Void where-  lookup = _mapping' _maybe-. S.member-  alter f a s | bef && not aft = S.delete a s-              | aft && not bef = S.insert a s-              | otherwise = s-    where bef = S.member a s ; aft = (_maybe %~ f) bef -instance Ord k => DataMap (M.Map k a) k a where-  lookup = M.lookup ; alter = M.alter-  -instance Ord a => Semigroup (S.Set a) where (+) = S.union-instance Ord a => Monoid (S.Set a) where zero = S.empty-instance Ord k => Semigroup (M.Map k a) where (+) = M.union-instance Ord k => Monoid (M.Map k a) where zero = M.empty-instance Functor (M.Map k) where map = M.map--newtype AList k a = AList { getAList :: [(k,a)] }--newtype Bimap a b = Bimap (M.Map a b,M.Map b a)-                  deriving (Semigroup,Monoid)-_inverse :: Iso' (Bimap a b) (Bimap b a)-_inverse = iso (\(Bimap (a,b)) -> Bimap (b,a)) (\(Bimap (a,b)) -> Bimap (b,a))--instance (Ord a,Ord b) => DataMap (Bimap a b) a b where-  lookup a (Bimap (ma,_)) = lookup a ma-  alter f a (Bimap (ma,mb)) = Bimap (ma',-                                     (maybe id delete b-                                      >>> maybe id (insert a) b') mb)-                                                  -    where b = lookup a ma ; b' = lookup a ma'-          ma' = alter f a ma-instance (Ord b,Ord a) => DataMap (Flip Bimap b a) b a where-  lookup b (Flip (Bimap (_,mb))) = lookup b mb-  alter f b = from (_inverse._Flip) %~ alter f b
− src/SimpleH/Core.hs 
@@ -1,285 +0,0 @@-{-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, DefaultSignatures, TupleSections, EmptyDataDecls #-}-module SimpleH.Core(-  -- * Basic union and product types-  Void,(:*:),(:+:),-  -  -- * Basic group and ring structure-  -- ** Classes-  Semigroup(..),Monoid(..),Ring(..),-  SubSemi(..),-  Unit(..),--  -- ** Common monoids--  -- *** Control monoids-  Endo(..),StrictEndo(..),--  -- *** Meta-monoids-  Dual(..),Product(..),--  -- *** Accumulating monoids-  OrdList(..),Interleave(..),Accum(..),Max(..),-  -  -- * Fundamental control operations-  Category(..),(<<<),(>>>),(+++),--  -- ** Splitting and Choosing-  Choice(..),Split(..),-  -  -- * Misc functions-  const,(&),fix,--  first,second,--  ifThenElse,bool,guard,fail,unit,when,unless,--  tailSafe,headDef,--  -- ** To use with 'OrdList'-  Orderable(..),-  comparing,insertOrd,invertOrd,-  -  -- * The rest is imported from the Prelude-  module Prelude-  ) where--import Prelude hiding (-  Functor(..),Monad(..),-  sequence,mapM,mapM_,sequence_,(=<<),--  map,(++),foldl,foldr,foldr1,concat,filter,length,sum,lookup,-  (+),(*),(.),id,const,--  or,any,and,all,elem--  ,until)-import qualified Prelude as P-import Data.Tree-import Data.Ord(comparing)--data Void-type a:*:b = (a,b)-type a:+:b = Either a b--{-|-The class of all types that have a binary operation. Note that the operation-isn't necesarily commutative (in the case of lists, for example)--} -class Semigroup m where-  (+) :: m -> m -> m-  default (+) :: Num m => m -> m -> m-  (+) = (P.+)-infixl 6 +-instance Semigroup Void where _+_ = undefined-instance Semigroup () where _+_ = ()-instance Semigroup Bool where (+) = (||)-instance Semigroup Int-instance Semigroup Float-instance Semigroup Double-instance Semigroup Integer-instance Semigroup [a] where []+l = l ; (x:t)+l = x:(t+l)-instance (Semigroup a,Semigroup b) => Semigroup (a:*:b) where ~(a,b) + ~(c,d) = (a+c,b+d)-instance (Semigroup a,Semigroup b,Semigroup c) => Semigroup (a,b,c) where-  ~(a,b,c) + ~(a',b',c') = (a+a',b+b',c+c')-instance SubSemi b a => Semigroup (a:+:b) where-  Left a+Left b = Left (a+b)-  a+b = Right (from a+from b)-    where from = cast <|> id-instance Semigroup (Maybe a) where-  Nothing + b = b ; a + _ = a---- |A monoid is a semigroup with a null element such that @zero + a == a + zero == a@-class Semigroup m => Monoid m where-  zero :: m-  default zero :: Num m => m-  zero = 0-instance Monoid Void where zero = undefined-instance Monoid () where zero = ()-instance Monoid Int ; instance Monoid Integer-instance Monoid Float ; instance Monoid Double-instance Monoid [a] where zero = []-instance (Monoid a,Monoid b) => Monoid (a:*:b) where zero = (zero,zero)-instance (Monoid a,Monoid b,Monoid c) => Monoid (a,b,c) where-  zero = (zero,zero,zero)-instance (SubSemi b a,Monoid a) => Monoid (a:+:b) where zero = Left zero-instance Monoid Bool where zero = False-instance Monoid (Maybe a) where zero = Nothing--class (Semigroup a,Semigroup b) => SubSemi a b where-  cast :: b -> a-instance Monoid a => SubSemi a () where cast _ = zero-instance Monoid a => SubSemi a Void where cast _ = zero--class Monoid m => Ring m where-  one :: m-  default one :: Num m => m-  one = 1-  (*) :: m -> m -> m-  default (*) :: Num m => m -> m -> m-  (*) = (P.*)--infixl 7 *-instance Ring Bool where one = True ; (*) = (&&)-instance Ring Int-instance Ring Integer-instance Ring Float-instance Ring Double-instance Monoid a => Ring [a] where-  one = zero:one-  (a:as) * (b:bs) = a+b:as*bs-  _ * _ = zero-instance (Ring a,Ring b) => Ring (a:*:b) where-  one = (one,one) ; ~(a,b) * ~(c,d) = (a*c,b*d)--class Unit f where-  pure :: a -> f a-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 }-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 Max monoid, where @(+) =~ max@ -}-newtype Max a = Max { getMax :: a }-              deriving (Eq,Ord,Bounded,Show)-instance Ord a => Semigroup (Max a) where Max a+Max b = Max (max a b)-instance (Ord a,Bounded a) => Monoid (Max a) where zero = Max minBound-instance (Ord a,Bounded a) => Ring (Max a) where-  one = Max maxBound-  Max a * Max b = Max (min a b)--{-| The dual of a monoid is the same as the original, with arguments reversed -}-newtype Dual m = Dual { getDual :: m }-instance Semigroup m => Semigroup (Dual m) where Dual a+Dual b = Dual (b+a)-deriving instance Monoid m => Monoid (Dual m)-instance Ring m => Ring (Dual m) where -  one = Dual one-  Dual a * Dual b = Dual (b*a)---- |An ordered list. The semigroup instance merges two lists so that--- the result remains in ascending order.-newtype OrdList a = OrdList { getOrdList :: [a] }-                  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 &--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
− src/SimpleH/File.hs 
@@ -1,54 +0,0 @@-module SimpleH.File (-  -- * Exported modules-  module System.FilePath,module SimpleH,--  -- * The File interface-  File(..),-  getFile,showFile,--  _file,_directory,--  getCurrentDirectory-  ) where--import SimpleH-import System.Directory-import System.FilePath ((</>))-import System.IO.Unsafe-import qualified Data.ByteString as BS--data File = File (Maybe String) (Maybe BS.ByteString)-          | Directory [(String,File)]-          deriving Show--il :: IO a -> IO a-il = unsafeInterleaveIO--getFile :: FilePath -> IO File-getFile path = il $ do-  d <- doesDirectoryExist path-  if d then do-    files <- unsafeInterleaveIO (getDirectoryContents path)-    return $ Directory [(name,unsafePerformIO (getFile (path</>name)))-                       | name <- files, not (name`elem`[".",".."])]-    else File<$>il (tryMay $ traverse (at' _thunk) =<< readFile path)-         <*>il (tryMay $ BS.readFile path)--showFile :: File -> String-showFile = showFile' 0-  where showFile' n (Directory fs) = "/"+foldMap (-          \(nm,f) -> "\n"+replicate n ' '+nm+showFile' (n+2) f) fs-        showFile' _ (File (Just c) _) = ": "+show (takeWhile (/='\n') c)-        showFile' _ (File _ (Just _)) = ": <bin>"-        showFile' _ _ = ": <not-readable>"--_File :: ((Maybe String,Maybe BS.ByteString):+:[(String,File)]) :<->: File-_File = iso f' f-  where f (File x y) = Left (x,y)-        f (Directory d) = Right d-        f' = uncurry File <|> Directory-_file :: Traversal' File (Maybe String,Maybe BS.ByteString)-_file = from _File._l-_directory :: Traversal' File [(String,File)]-_directory = from _File._r-
− src/SimpleH/Foldable.hs 
@@ -1,92 +0,0 @@-{-# LANGUAGE TupleSections, MultiParamTypeClasses #-}-module SimpleH.Foldable where--import SimpleH.Core-import SimpleH.Classes-import SimpleH.Functor-import Data.Tree--class Functor t => Foldable t where-  fold :: Monoid m => t m -> m-instance Foldable Id where fold = getId-instance Foldable (Either a) where-  fold = pure zero <|> id-instance Foldable Maybe where-  fold (Just w) = w ; fold Nothing = zero-instance Foldable ((,) a) where fold = snd-instance Foldable [] where-  fold [] = zero-  fold (x:t) = x+fold t-instance Foldable Tree where fold (Node m subs) = m + fold (map fold subs)-deriving instance Foldable Interleave-deriving instance Foldable OrdList-instance (Foldable f,Foldable g) => Foldable (f:.:g) where-  fold = getCompose >>> map fold >>> fold--newtype Sized f a = Sized { getSized :: f a }-instance (Foldable f,Semigroup (Sized f a),Monoid n,Num n) =>-         SubSemi n (Sized f a) where-  cast = size . getSized--instance (Foldable f,Foldable g) => Foldable (f:**:g) where-  fold (f:**:g) = fold f + fold g-instance (Foldable f,Foldable g) => Foldable (f:++:g) where-  fold (Sum (Left f)) = fold f-  fold (Sum (Right g)) = fold g--foldMap :: (Monoid m, Foldable t) => (a -> m) -> t a -> m-foldMap f = fold . map f-convert :: (Unit f, Monoid (f a), Foldable t) => t a -> f a-convert = foldMap pure-concat :: (Monoid m, Foldable t) => t m -> m-concat = fold-sum :: (Monoid m, Foldable t) => t m -> m-sum = fold-size :: (Foldable f,Num n,Monoid n) => f a -> n-size c = sum (1<$c)-count :: (Num n, Monoid n, Foldable f) => f a -> n-count = size-length :: (Num n,Monoid n) => [a] -> n-length = count--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 p = fst . partition p-select :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a-select = filter-refuse :: (Unit f, Monoid (f a), Foldable t) => (a -> Bool) -> t a -> f a-refuse = filter . map not--compose :: (Category k, Foldable t) => t (k a a) -> k a a-compose = runEndo . foldMap Endo--foldr :: Foldable t => (b -> a -> a) -> a -> t b -> a-foldr f e t = (runEndo . getDual) (foldMap (\b -> Dual (Endo (f b))) t) e-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 (filter p . Id)-or :: Foldable t => t Bool -> Bool-or = fold-and :: Foldable t => t Bool -> Bool-and = getProduct . fold . map Product-all :: Foldable t => (a -> Bool) -> t a -> Bool-all = map and . map-any :: Foldable t => (a -> Bool) -> t a -> Bool-any = map or . map-elem :: (Eq a,Foldable t) => a -> t a -> Bool-elem e = any (e==)
− src/SimpleH/Functor.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, RankNTypes, DefaultSignatures #-}--- |A module for functors-module SimpleH.Functor(-  Functor(..),Cofunctor(..),Bifunctor(..),-  -  Id(..),Const(..),Flip(..),(:.:)(..),(:**:)(..),(:++:)(..),--  (<$>),(|||),(<$),(<&>),void,left,right,-  promap,map2,map3-  ) where--import qualified Prelude as P--import SimpleH.Classes-import SimpleH.Core-import Data.Tree--class Cofunctor f where-  comap :: (a -> b) -> f b -> f a-instance (Functor f,Cofunctor g) => Cofunctor (f:.:g) where-  comap f (Compose c) = Compose (map (comap f) c)-instance Cofunctor (Flip (->) a) where-  comap f (Flip g) = Flip (g . f)-instance Bifunctor (->)--class Bifunctor p where-  dimap :: (c -> a) -> (b -> d) -> p a b -> p c d-  default dimap :: (Functor (p a),Cofunctor (Flip p d)) => (c -> a) -> (b -> d) -> p a b -> p c d-  dimap f g = promap f . map g--instance Functor [] where map f = f' where f' [] = [] ; f' (x:t) = f x:f' t-instance Functor Tree where-  map f (Node a subs) = Node (f a) (map2 f subs)---- |The Identity Functor-newtype Id a = Id { getId :: a }-             deriving Show-instance Unit Id where pure = Id-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 Functor (Const a) where map _ (Const a) = Const a-instance Monoid a => Unit (Const a) where pure _ = Const zero-instance Monoid a => Applicative (Const a) where-  Const a <*> Const b = Const (a+b)---- |A motherflippin' functor-newtype Flip f a b = Flip { unFlip :: f b a }---- |The Composition functor-newtype (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 3 <$>,<$-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))
− src/SimpleH/Lens.hs 
@@ -1,258 +0,0 @@-{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, ViewPatterns, TupleSections #-}-{-|-A module providing simple Lens functionality.--Lenses are a Haskell abstraction that allows you to access and modify-part of a structure, compensating for and improving upon Haskell's-horrendous record syntax and giving Haskell a first-class record system.--This module defines three kinds of Lenses : Lenses that allow you to-access part of a structure; Traversals that allow you to modify part-of a structure; and Isos which may be reversed. Lenses of any kind can-be composed with @(.)@, yielding a Lens of the most general kind, so-that composing a Lens with a Traversal or Iso yields a Lens, and a-Traversal with an Iso yields a Traversal.--}-module SimpleH.Lens(-  -- * The lens types-  Iso,Iso',(:<->:),-  LensLike,LensLike',-  Fold,Fold',-  Getter,Getter',-  Lens,Lens',-  Traversal,Traversal',--  -- * Constructing lenses-  iso,from,lens,getter,prism,sat,simple,(.+),--  -- * Extracting values-  (^.),(^..),(^?),(^??),(%~),(%-),(%%~),(%%-),at,at',warp,set,-  (-.),(.-),-  -  -- * Basic lenses-  _1,_2,_l,_r,_Just,Compound(..),-  _list,_head,_tail,--  -- * Isomorphisms-  Isomorphic(..),-  adding,-  _Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,-  warp2,_mapping,_mapping',_promapping,-  IsoFunctor(..),(<.>),IsoFunctor2(..),-  _thunk-  ) where--import SimpleH.Core-import SimpleH.Functor-import SimpleH.Applicative-import System.IO.Unsafe (unsafePerformIO)-import Control.Exception (evaluate)--type LensLike f s t a b = (s -> f t) -> (a -> f b)-type LensLike' f a b = LensLike f b b a a--type Lens s t a b = forall f.Functor f => LensLike f s t a b-type Lens' a b = Lens b b a a-type Getter s t a b = LensLike (Const s) s t a b-type Getter' 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)--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 at-(^..) :: a -> Iso a a b b -> b-(^..) = flip at'--- |-(%~) :: Traversal s t a b -> (s -> t) -> (a -> b)-(%~) = warp-(%%~) :: Iso s t a b -> (b -> a) -> (t -> s)-(%%~) i = warp (from i)-(%-) :: Traversal s t a b -> t -> (a -> b)-(%-) = set-(%%-) :: Iso s t a b -> a -> (t -> s)-(%%-) i = set (from i)-(^?) :: (Unit f,Monoid (f b)) => a -> 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--simple :: Iso' a b -> Iso' a b-simple i = i--(-.) :: Getter c u b v -> (a -> b) -> a -> c-l-.f = at l.f-(.-) :: (b -> c) -> Iso a a b b -> a -> c-f.-i = f.at' i-infixr 9 -.,.--at :: Getter b u a v -> a -> b-at l = getConst . l Const-at' :: Iso s t a b -> t -> b-at' i = at (from i)-warp :: Traversal s t a b -> (s -> t) -> (a -> b)-warp l = map getId . l . map Id-set :: Traversal s t a b -> t -> (a -> b)-set l = warp l . const --_1 :: Lens a b (a:*:c) (b:*:c)-_1 = lens fst (flip (first . const))-_2 :: Lens a b (c:*:a) (c:*:b)-_2 = lens snd (flip (second . const))-_l :: Traversal a b (a:+:c) (b:+:c)-_l = prism ((id ||| Right) >>> swapE) (flip (left . const))-_r :: Traversal a b (c:+:a) (c:+:b)-_r = prism (Left ||| id) (flip (right . const))-_Just :: Traversal a b (Maybe a) (Maybe b)-_Just = prism (\a -> maybe (Left Nothing) Right a) (flip (<$))--swapE :: (b:+:a) -> (a:+:b)-swapE = Right<|>Left--class Compound a b s t | s -> a, b s -> t where-  _each :: Traversal a b s t-instance Compound a b (a,a) (b,b) where-  _each k (a,a') = (,)<$>k a<*>k a'-instance Compound a b (a,a,a) (b,b,b) where-  _each k (a,a',a'') = (,,)<$>k a<*>k a'<*>k a''-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 = _list._r._1-_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 Void) (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' Bool (Maybe Void)-_maybe = _iso -_Flip :: Iso (Flip f b a) (Flip f d c) (f a b) (f c d)-_Flip = _iso-_Compose :: Iso ((f:.:g) a) ((f':.:g') b) (f (g a)) (f' (g' b))-_Compose = _iso-_Backwards :: Iso (Backwards f a) (Backwards f b) (f a) (f b)-_Backwards = iso Backwards forwards-_Accum :: Iso (Accum a) (Accum b) (Maybe a) (Maybe b)-_Accum = iso Accum getAccum--warp2 :: Iso s t a b -> (s -> s -> t) -> (a -> a -> b)-warp2 i f = \a a' -> at' i (at i a`f`at 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 (at i <#> at j) (at' i <#> at' j)-instance IsoFunctor2 Either where-  mapIso2 i j = iso (at i ||| at j) (at' i ||| at' j)--adding :: (Num n,Semigroup n) => n -> Iso' n n-adding n = iso (+n) (subtract n)--_thunk :: Iso a b (IO a) (IO b)-_thunk = iso unsafePerformIO evaluate
− src/SimpleH/Monad.hs 
@@ -1,452 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TupleSections, Rank2Types, UndecidableInstances, FunctionalDependencies #-}-module SimpleH.Monad(-  module SimpleH.Applicative,--  -- * The basic Monad interface-  Monad(..),MonadFix(..),MonadTrans(..),--  -- * Monad utilities-  Kleisli(..),_Kleisli,-  (=<<),(<=<),(>=>),(>>),(<*=),return,-  foldlM,foldrM,while,until,-  bind2,bind3,(>>>=),(>>>>=),-  -  -- * Common monads-  -- ** The RWS Monad-  RWST(..),RWS,--  -- *** The State Monad-  MonadState(..),-  IOLens,_ioref,_mvar,-  StateT,State,-  stateT,eval,exec,state,-  (=~),(=-),gets,saving,-  mapAccum,mapAccum_,mapAccumR,mapAccumR_,push,pop,withPrev,withNext,--  -- **** The State Arrow-  StateA(..),stateA,-    -  -- *** The Reader monad-  MonadReader(..),-  ReaderT,Reader,-  _readerT,_reader,--  -- *** The Writer monad-  MonadWriter(..),-  WriterT,Writer,-  _writerT,_writer,-  mute,intercept,--  -- ** The Continuation monad-  MonadCont(..),-  ContT(..),Cont,-  evalContT,-  evalCont,--  -- ** The List monad-  MonadList(..),-  ListT,-  _listT,--  -- ** The Error Monad-  MonadError(..),try,tryMay,-  EitherT,-  _eitherT-  ) where--import SimpleH.Classes-import SimpleH.Applicative-import SimpleH.Core hiding (flip)-import SimpleH.Traversable-import SimpleH.Lens-import qualified Control.Exception as Ex-import qualified Control.Monad.Fix as Fix-import Data.IORef-import Control.Concurrent--instance (Traversable g,Monad f,Monad g) => Monad (f:.:g) where-  join = Compose .map join.join.map sequence.getCompose.map getCompose---- |The class of all monads that have a fixpoint-class Monad m => MonadFix m where-  mfix :: (a -> m a) -> m a-instance MonadFix Id where mfix = cfix-instance MonadFix ((->) b) where mfix = cfix-instance MonadFix [] where mfix f = fix (f . head)-instance MonadFix (Either e) where mfix f = fix (f . either undefined id)-instance MonadFix IO where mfix = Fix.mfix-instance MonadFix m => MonadFix (Backwards m) where-  mfix f = at _Backwards $ mfix (at' _Backwards.f)-instance (MonadFix f,Traversable g,Monad g) => MonadFix (f:.:g) where-  mfix f = Compose $ mfix (map join . traverse (getCompose . f))-cfix :: Contravariant c => (a -> c a) -> c a-cfix = map fix . collect--mfixing :: MonadFix f => (b -> f (a, b)) -> f a-mfixing f = fst<$>mfix (\ ~(_,b) -> f b )--class MonadTrans t where-  lift :: Monad m => m a -> t m a-class MonadTrans t => MonadInternal t where-  internal :: Monad m => (forall c. m (c,a) -> m (c,b)) ->-              (t m a -> t m b)--newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }-instance Monad m => Category (Kleisli m) where-  id = Kleisli pure-  Kleisli f . Kleisli g = Kleisli (\a -> g a >>= f)-instance Monad m => Choice (Kleisli m) where-  Kleisli f <|> Kleisli g = Kleisli (f <|> g)-instance Monad m => Split (Kleisli m) where-  Kleisli f <#> Kleisli g = Kleisli (\(a,c) -> (,)<$>f a<*>g c)-instance Isomorphic (a -> m b) (c -> m' d) (Kleisli m a b) (Kleisli m' c d) where-  _iso = iso Kleisli runKleisli-_Kleisli :: Iso (Kleisli m a b) (Kleisli m' c d) (a -> m b) (c -> m' d)-_Kleisli = _iso --folding :: (Foldable t,Monoid w) => Iso' (a -> c) w -> (b -> a -> c) -> a -> t b -> c  -folding i f e t = at (from i) (foldMap (at i . f) t) e-foldlM :: (Foldable t,Monad m) => (b -> a -> m a) -> a -> t b -> m a-foldlM = folding (_Kleisli._Endo._Dual)-foldrM :: (Foldable t,Monad m) => (b -> a -> m a) -> a -> t b -> m a-foldrM = folding (_Kleisli._Endo)--while :: Monad m => m (Maybe a) -> m ()-while e = fix (\w -> e >>= maybe unit (const w))-until :: Monad m => m (Maybe a) -> m a-until e = fix (\w -> e >>= maybe w return)--bind2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c-bind2 f a b = join (f<$>a<*>b)-(>>>=) :: Monad m => (m a,m b) -> (a -> b -> m c) -> m c-(a,b) >>>= f = bind2 f a b-bind3 :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d-bind3 f a b c = join (f<$>a<*>b<*>c)-(>>>>=) :: Monad m => (m a,m b,m c) -> (a -> b -> c -> m d) -> m d-(a,b,c) >>>>= f = bind3 f a b c--infixr 2 =<<-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-return :: Unit f => a -> f a-return = pure--newtype RWST r w s m a = RWST { runRWST :: (r,s) -> m (a,s,w) }-type RWS r w s a = RWST r w s Id a--_RWST :: Iso (RWST r w s m a) (RWST r' w' s' m' a')-         ((r,s) -> m (a,s,w)) ((r',s') -> m' (a',s',w'))-_RWST = iso RWST runRWST--instance (Unit f,Monoid w) => Unit (RWST r w s f) where-  pure a = RWST (\ ~(_,s) -> pure (a,s,zero))-instance Functor f => Functor (RWST r w s f) where-  map f (RWST fa) = RWST (fa >>> map (\ ~(a,s,w) -> (f a,s,w)))-instance (Monoid w,Monad m) => Applicative (RWST r w s m)-instance (Monoid w,Monad m) => Monad (RWST r w s m) where-  join mm = RWST (\ ~(r,s) -> do-                     ~(m,s',w) <- runRWST mm (r,s)-                     ~(a,s'',w') <- runRWST m (r,s')-                     return (a,s'',w+w'))-instance (Monoid w,MonadFix m) => MonadFix (RWST r w s m) where-  mfix f = RWST (\x -> mfix (\ ~(a,_,_) -> runRWST (f a) x))-instance (Monoid w,MonadCont m) => MonadCont (RWST r w s m) where-  callCC f = RWST $ \(r,s) ->-    callCC $ \k -> runRWST (f (\a -> lift (k (a,s,zero)))) (r,s)-deriving instance Semigroup (m (a,s,w)) => Semigroup (RWST r w s m a)-deriving instance Monoid (m (a,s,w)) => Monoid (RWST r w s m a)-deriving instance Ring (m (a,s,w)) => Ring (RWST r w s m a)-instance (Monad m,Monoid w) => MonadState s (RWST r w s m) where-  get = RWST (\ ~(_,s) -> pure (s,s,zero) )-  put s = RWST (\ _ -> pure ((),s,zero) )-  modify f = RWST (\ ~(_,s) -> pure ((),f s,zero) )-instance (Monad m,Monoid w) => MonadReader r (RWST r w s m) where-  ask = RWST (\ ~(r,s) -> pure (r,s,zero) )-  local f (RWST m) = RWST (\ ~(r,s) -> m (f r,s) )-instance (Monad m,Monoid w) => MonadWriter w (RWST r w s m) where-  tell w = RWST (\ ~(_,s) -> pure ((),s,w) )-  listen (RWST m) = RWST (m >>> map (\ ~(a,s,w) -> ((w,a),s,w) ) )-  censor (RWST m) = RWST (m >>> map (\ ~(~(a,f),s,w) -> (a,s,f w) ) )-instance Foldable m => Foldable (RWST Void w Void m) where-  fold (RWST m) = foldMap (\(w,_,_) -> w).m $ (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 => MonadTrans (RWST r w s) where-  lift m = RWST (\ ~(_,s) -> (,s,zero) <$> m)-instance (Monoid w) => MonadInternal (RWST r w s) where-  internal f (RWST m) = RWST (\ x -> f (m x <&> \ ~(a,s,w) -> ((s,w),a) )-                                     <&> \ ~((s,w),b) -> (b,s,w) )-  -{-| A simple State Monad  -}-class Monad m => MonadState s m | m -> s where-  get :: m s-  put :: s -> m ()-  put = modify . const-  modify :: (s -> s) -> m ()-  modify f = get >>= put . f-instance MonadState (IO ()) IO where-  get = return unit-  put a = a-  modify f = put (f unit)-type IOLens a = Lens' (IO ()) (IO a)-_ioref :: IORef a -> IOLens a-_ioref r = lens (const (readIORef r)) (\x a -> x >> a >>= writeIORef r)-_mvar :: MVar a -> IOLens a-_mvar r = lens (const (readMVar r)) (\x a -> x >> a >>= putMVar r)--get_ :: (MonadTrans t, MonadState a m) => t m a-get_ = lift get-put_ :: (MonadTrans t, MonadState s m) => s -> t m ()-put_ = lift . put-modify_ :: (MonadTrans t, MonadState s m) => (s -> s) -> t m ()-modify_ = lift . modify  --newtype StateT s m a = StateT (RWST Void Void s m a)-                     deriving (Unit,Functor,Applicative,Monad,MonadFix,-                               MonadTrans,MonadInternal,-                               MonadCont,MonadState s)-type State s a = StateT s Id a-instance MonadReader r m => MonadReader r (StateT s m) where-  ask = ask_ ; local = local_-instance MonadWriter w m => MonadWriter w (StateT s m) where-  tell = tell_ ; listen = listen_ ; censor = censor_-deriving instance MonadError e m => MonadError e (StateT s m)-deriving instance Semigroup (m (a,s,Void)) => Semigroup (StateT s m a)-deriving instance Monoid (m (a,s,Void)) => Monoid (StateT s m a)-deriving instance Ring (m (a,s,Void)) => Ring (StateT s m a)--_StateT :: Iso (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 :: (Functor f, Functor f') => f (f' (a, b)) -> f (f' b)-eval = map2 snd-exec :: (Functor f, Functor f') => f (f' (a, b)) -> f (f' a)-exec = map2 fst-state :: Iso (State s a) (State t b) (s -> (s,a)) (t -> (t,b))-state = _mapping _Id.stateT--(=-) :: MonadState s m => Lens' s s' -> s' -> m ()-infixl 0 =-,=~-l =- x = modify (set l x)-(=~) :: MonadState s m => Lens' s s' -> (s' -> s') -> m ()-l =~ f = modify (warp l f)-gets :: MonadState s m => Lens' s s' -> m s'-gets l = at l<$>get--saving :: MonadState s m => Lens' s s' -> m a -> m a-saving l st = gets l >>= \s -> st <* (l =- s)---- * 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 (at state<$>f) t^..state-mapAccum_ :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> t b-mapAccum_ = (map.map.map) snd mapAccum-mapAccumR :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> (s, t b)-mapAccumR f t = traverse (at (state._Backwards)<$>f) t^..state._Backwards-mapAccumR_ :: Traversable t => (a -> s -> (s, b)) -> t a -> s -> t b-mapAccumR_ = (map.map.map) snd mapAccumR--push :: Traversable t => t a -> a -> t a-push = mapAccum_ (,)-pop :: Traversable t => t a -> a -> t a-pop = mapAccumR_ (,)--withPrev :: Traversable t => a -> t a -> t (a,a)-withPrev = flip (mapAccum_ (\a p -> (a,(p,a))))-withNext :: Traversable t => t a -> a -> t (a,a)-withNext = mapAccumR_ (\a p -> (a,(p,a)))--class Monad m => MonadReader r m | m -> r where-  ask :: m r-  local :: (r -> r) -> m a -> m a-instance MonadReader r ((->) r) where-  ask = id ; local = (>>>)-ask_ :: (MonadTrans t, MonadReader a m) => t m a-ask_ = lift ask-local_ :: (MonadInternal t, MonadReader r m) => (r -> r) -> t m a -> t m a-local_ f = internal (local f)-{-| A simple Reader monad -}-newtype ReaderT r m a = ReaderT (RWST r Void Void m a) -                      deriving (Functor,Unit,Applicative,Monad,MonadFix,-                                MonadTrans,MonadInternal,-                                MonadReader r,MonadCont)-type Reader r a = ReaderT r Id 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--instance MonadState s m => MonadState s (ReaderT r m) where-  get = get_ ; put = put_ ; modify = modify_-instance MonadWriter w m => MonadWriter w (ReaderT r m) where-  tell = tell_ ; listen = listen_ ; censor = censor_-deriving instance Semigroup (m (a,Void,Void)) => Semigroup (ReaderT r m a)-deriving instance Monoid (m (a,Void,Void)) => Monoid (ReaderT r m a)-deriving instance Ring (m (a,Void,Void)) => Ring (ReaderT r m a)--class (Monad m,Monoid w) => MonadWriter w m | m -> w where-  tell :: w -> m ()-  listen :: m a -> m (w,a)-  censor :: m (a,w -> w) -> m a--tell_ :: (MonadWriter w m, MonadTrans t) => w -> t m ()-tell_ = lift . tell-listen_ :: (MonadInternal t, MonadWriter w m) => t m a -> t m (w, a)-listen_ = internal (\m -> listen m <&> \(w,(c,a)) -> (c,(w,a)) )-censor_ :: (MonadInternal t, MonadWriter w m) => t m (a, w -> w) -> t m a-censor_ = internal (\m -> censor (m <&> \(c,(a,f)) -> ((c,a),f)))-instance Monoid w => MonadWriter w ((,) w) where-  tell w = (w,())-  listen m@(w,_) = (w,m)-  censor ~(w,~(a,f)) = (f w,a)-  -mute :: (MonadWriter w m,Monoid w) => m a -> m a-mute m = censor (m<&>(,const zero))-intercept :: (MonadWriter w m,Monoid w) => m a -> m (w,a)-intercept = listen >>> mute--{-| A simple Writer monad -}-newtype WriterT w m a = WriterT (RWST Void w Void m a)-                      deriving (Unit,Functor,Applicative,Monad,MonadFix-                               ,Foldable,Traversable-                               ,MonadTrans,MonadInternal-                               ,MonadWriter w,MonadCont)-type Writer w a = WriterT w Id a-instance (Monoid w,MonadReader r m) => MonadReader r (WriterT w m) where-  ask = ask_ ; local = local_-instance (Monoid w,MonadState r m) => MonadState r (WriterT w m) where-  get = get_ ; put = put_ ; modify = modify_-deriving instance Semigroup (m (a,Void,w)) => Semigroup (WriterT w m a)-deriving instance Monoid (m (a,Void,w)) => Monoid (WriterT w m a)-deriving instance Ring (m (a,Void,w)) => Ring (WriterT w m a)--_writerT :: (Functor m,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--{-| A simple continuation monad implementation  -}-class Monad m => MonadCont m where-  callCC :: ((a -> m b) -> m a) -> m a--newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }-                      deriving (Semigroup,Monoid,Ring)-type Cont r a = ContT r Id a-instance Unit m => Unit (ContT r m) where pure a = ContT ($a)-instance Functor f => Functor (ContT r f) where-  map f (ContT c) = ContT (\kb -> c (kb . f))-instance Applicative m => Applicative (ContT r m) where-  ContT cf <*> ContT ca = ContT (\kb -> cf (\f -> ca (\a -> kb (f a))))-instance Monad m => Monad (ContT r m) where-  ContT k >>= f = ContT (\cc -> k (\a -> runContT (f a) cc))-instance MonadTrans (ContT r) where-  lift m = ContT (m >>=)-instance Monad m => MonadCont (ContT r m) where-  callCC f = ContT (\k -> runContT (f (\a -> ContT (\_ -> k a))) k)--evalContT :: Unit m => ContT r m r -> m r-evalContT c = runContT c return-evalCont :: Cont r r -> r-evalCont = getId . evalContT--instance MonadTrans Backwards where-  lift = Backwards-instance MonadFix m => Monad (Backwards m) where-  join (Backwards ma) = Backwards$mfixing (\a -> liftA2 (,) (forwards a) ma)--class Monad m => MonadList m where-  fork :: [a] -> m a-instance MonadList [] where fork = id-newtype ListT m a = ListT ((m:.:[]) a)-                    deriving (Semigroup,Monoid,-                              Functor,Applicative,Unit,Monad,-                              Foldable,Traversable)-_listT :: Iso (ListT m a) (ListT m' a') (m [a]) (m' [a'])-_listT = iso (ListT . Compose) (\(ListT (Compose m)) -> m)-instance Monad m => MonadList (ListT m) where-  fork = at _listT . return -instance MonadFix m => MonadFix (ListT m) where-  mfix f = at _listT (mfix (at' _listT . f . head))-instance MonadTrans ListT where-  lift ma = (return<$>ma)^._listT-instance MonadState s m => MonadState s (ListT m) where-  get = get_ ; modify = modify_ ; put = put_-instance MonadWriter w m => MonadWriter w (ListT m) where-  tell = lift.tell-  listen = _listT-.map sequence.listen.-_listT-  censor = _listT-.censor.map (\l -> (fst<$>l,compose (snd<$>l))).-_listT-instance Monad m => MonadError Void (ListT m) where-  throw = const zero-  catch f mm = mm & _listT %%~ (\m -> m >>= \_l -> case _l of-                                   [] -> f zero^.._listT; l -> pure l)--class Monad m => MonadError e m | m -> e where-  throw :: e -> m a-  catch :: (e -> m a) -> m a -> m a-try :: MonadError Void m => m a -> m a -> m a-try d = catch (\x -> const d (x::Void))-tryMay :: MonadError Ex.SomeException m => m a -> m (Maybe a)-tryMay m = catch (\(Ex.SomeException _) -> return Nothing) (Just<$>m)--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 ((m:.:Either e) a)-                      deriving (Unit,Functor,Applicative,Monad,MonadFix-                               ,Foldable,Traversable)-instance MonadTrans (EitherT e) where-  lift m = (pure<$>m)^._eitherT-_eitherT :: (Functor m) => Iso (EitherT e m a) (EitherT f m b) (m (e:+:a)) (m (f:+:b))                              -_eitherT = iso (EitherT . Compose) (\(EitherT (Compose e)) -> e)--instance Applicative Maybe-instance Monad Maybe where join = fold-instance MonadError Void Maybe where-  throw = const Nothing-  catch f Nothing = f zero-  catch _ a = a-instance Ex.Exception e => MonadError e IO where-  throw = Ex.throw-  catch = flip Ex.catch-
− src/SimpleH/Parser.hs 
@@ -1,148 +0,0 @@--- |A module providing simple Parser combinator functionality. Useful--- for small parsing tasks such as identifier parsing or command-line--- argument parsing-module SimpleH.Parser (-  module SimpleH,-  -- * The ParserT Type-  ParserT(..),Parser,ParserA(..),_ParserA,-  -- ** The Stream class-  Stream(..),empty,-  -- ** Converting to/from Parsers-  parserT,parser,runParser,pureParser,-  -  -- * Basic utilities-  (<+>),(>*>),token,satisfy,remaining,oneOf,noneOf,single,several,eoi,-  -  -- * Basic combinators-  many,many1,sepBy,sepBy1,-  chainl,chainr                          -  ) where--import SimpleH--import qualified Data.ByteString as BS--newtype ParserT w s m a = ParserT (StateT s (ListT (WriterT w m)) a)-                        deriving (Unit,Functor,Applicative,Monoid,Semigroup,-                                  Monad,MonadFix,MonadState s,MonadWriter w)-type Parser w c a = ParserT w c Id a-deriving instance (Monad m,Monoid w) => MonadError Void (ParserT w c m)-instance Monoid w => MonadTrans (ParserT w s) where-  lift = ParserT . lift . lift . lift--_ParserT :: Iso (ParserT w s m a) (ParserT x t n b) (StateT s (ListT (WriterT w m)) a) (StateT t (ListT (WriterT x n)) b)-_ParserT = iso ParserT (\(ParserT p) -> p)-parserT :: (Functor n,Functor m) => Iso (ParserT w s m a) (ParserT x t n b) (s -> m (w,[(s,a)])) (t -> n (x,[(t,b)]))-parserT = _mapping (_writerT._listT).stateT._ParserT-parser :: Iso (Parser w s a) (Parser x t b) (s -> (w,[(s,a)])) (t -> (x,[(t,b)]))-parser = _mapping _Id.parserT-runParser :: Parser Void s a -> s -> [(s,a)]-runParser p = snd . (p^..parser)-pureParser :: (Monoid w,Monad m) => (a -> [b]) -> ParserT w a m b-pureParser p = (\a -> pure (zero,[(a,b) | b <- p a]))^.parserT---- |The @(+)@ operator with lower priority-(<+>) :: Semigroup m => m -> m -> m-(<+>) = (+)-(>*>) :: (Monoid w, Monad m) => ParserT w a m b -> ParserT w b m c -> ParserT w a m c-(>*>) = (>>>)^..(_ParserA<.>_ParserA<.>_ParserA)--newtype ParserA w m s a = ParserA (ParserT w s m a)-_ParserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (ParserT w s m a) (ParserT w' s' m' a')-_ParserA = iso ParserA (\(ParserA p) -> p)-parserA :: Iso (ParserA w m s a) (ParserA w' m' s' a') (StateA (ListT (WriterT w m)) s a) (StateA (ListT (WriterT w' m')) s' a') -parserA = from stateA._ParserT._ParserA-instance (Monoid w,Monad m) => Category (ParserA w m) where-  id = ParserA get-  (.) = (.)^.(parserA<.>parserA<.>parserA)-instance (Monoid w,Monad m) => Split (ParserA w m) where-  (<#>) = (<#>)^.(parserA<.>parserA<.>parserA)-instance (Monoid w,Monad m) => Choice (ParserA w m) where-  (<|>) = (<|>)^.(parserA<.>parserA<.>parserA)-instance (Monoid w,Monad m) => Arrow (ParserA w m) where-  arr f = arr f^.parserA---- |The remaining Stream to parse-remaining :: (Monad m,Monoid w) => ParserT w s m s-remaining = get--- |Consume a token from the Stream-token :: (Monad m,Monoid w,Stream c s) => ParserT w s m c-{-# SPECIALIZE token :: (Monad m,Monoid w) => ParserT w [c] m c #-}-token = get >>= \s -> case uncons s of-  Nothing -> zero-  Just (c,t) -> put t >> pure c---- |Parse zero, one or more successive occurences of a parser.-many :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]-many p = liftA2 (:) p (many p) <+> pure []--- |Parse one or more successiveé occurences of a parser.-many1 :: (Monoid w,Monad m) => ParserT w c m a -> ParserT w c m [a]-many1 p = (:)<$>p<*>many p---- |Consume a token and succeed if it verifies a predicate-satisfy :: (Monoid w, Monad m, Stream c s) => (c -> Bool) -> ParserT w s m c-{-# SPECIALIZE satisfy :: (Monoid w, Monad m) => (c -> Bool) -> ParserT w [c] m c #-}-satisfy p = token <*= guard . p--- |Consume a single fixed token or fail.-single :: (Eq c, Monoid w, Monad m, Stream c s) => c -> ParserT w s m ()-single = void . satisfy . (==)---- |Consume a structure of characters or fail-several :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m ()-{-# SPECIALIZE several :: (Eq c, Monoid w, Monad m) => [c] -> ParserT w [c] m () #-}-several l = traverse_ single l---- |Try to consume a parser. Return a default value when it fails.-option :: (Monoid w,Monad m) => a -> ParserT w s m a -> ParserT w s m a-option a p = p+pure a---- |Succeed only if we are at the End Of Input.-eoi :: (Monad m,Monoid w,Stream c s) => ParserT w s m ()-eoi = remaining >>= guard.empty---- |Parse one or more successive occurences of a parser separated by--- occurences of a second parser.-sepBy1 ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a]-sepBy1 p sep = (:)<$>p<*>many (sep >> p)--- |Parse zero or more successive occurences of a parser separated by--- occurences of a second parser.-sepBy ::(Monoid w, Monad m) => ParserT w c m a -> ParserT w c m b -> ParserT w c m [a]-sepBy p sep = option [] (sepBy1 p sep)---- |Parse a member of a set of values-oneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c-oneOf = satisfy . flip elem--- |Parse anything but a member of a set-noneOf :: (Eq c, Monoid w, Monad m, Foldable t, Stream c s) => t c -> ParserT w s m c-noneOf = satisfy . map not . flip elem--infixl 1 `sepBy`,`sepBy1`-infixr 0 <+>---- |Chain an operator with an initial value and several tail values.-chainr :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (b -> a -> a) -> ParserT w s m b -> ParserT w s m a-chainr expr op e = compose<$>many (op<**>e)<*>expr--- |Chain an operator with an initial value-chainl :: (Monoid w,Stream c s,Monad m) => ParserT w s m a -> ParserT w s m (a -> b -> a) -> ParserT w s m b -> ParserT w s m a-chainl expr op e = compose<$>many (flip<$>op<*>e)<**>expr---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 = (:)---- |Test if a Stream is empty-empty :: Stream c s => s -> Bool-empty = maybe True (const False) . uncons--class Serializable t where-  encode :: t -> BS.ByteString-  decode :: Parser String BS.ByteString t-instance Serializable BS.ByteString where-  encode = id-  decode = get-
− src/SimpleH/Parser/CmdArgs.hs 
@@ -1,49 +0,0 @@-module SimpleH.Parser.CmdArgs (-  -- * Exported modules-  module SimpleH.Parser,--  -- * Preprocessing command-line arguments-  OptDescr(..),ArgDescr(..),usageInfo,-  tokenize,-  -  -- * Example usage-  -- $tutorial- ) where--import SimpleH.Parser-import System.Console.GetOpt---- |Create a Parser that preprocesses the command-line arguments,--- splitting options and their arguments into a user-defined data--- type.-tokenize :: Monad m => [OptDescr a] -> (String -> a) -> ParserT String [String] m [a]-tokenize options wrap = p^.parserT-  where p a = pure (concat err,pure (a,bs))-          where (bs,_,err) = getOpt (ReturnInOrder wrap) options a--{- $tutorial--This module is intended to provide simple parsing functionality to the-handling of command-line arguments. Here is an example of how this module-may be used.--->data Option = Help | Version | Other String->           deriving Eq->  ->options = [->  Option ['h'] ["help"] (NoArg Help) "Display this menu.",->  Option ['v'] ["version"] (NoArg Version) "Show the version of this program"->  ]->->(>>>>) = (>>>)^.(_ParserA<.>_ParserA<.>parserT._ParserA)->->doit = single Help >> lift (putStrLn (usageInfo options))->     <+> single Version >> lift (putStrLn "Version: 1.0")->->main = void $ do->    getArgs >>= (tokenize options Other >>>> doit)---}--
− src/SimpleH/Reactive.hs 
@@ -1,171 +0,0 @@-{-# LANGUAGE RebindableSyntax, GeneralizedNewtypeDeriving, TupleSections, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ViewPatterns #-}-module SimpleH.Reactive (-  -- * Reactive Modules-  module SimpleH.Reactive.Time,-  module SimpleH.Reactive.TimeVal,--  -- * Reactive Events-  Event,_event,headE,Reactive(..),--  -- ** Contructing events-  atTimes,mkEvent,-  withTime,times,-  mapFutures,--  -- ** Combining events-  (//),(<|*>),(<*|>),-               -  -- ** Filtering events-  groupE,mask,--  -- ** Real-world event synchronization-  sink,event,-  -  -- * Future values-  Future,_future,_time,_value,futureIO,-  ) where--import SimpleH-import Control.Concurrent-import SimpleH.Reactive.TimeVal-import System.IO.Unsafe (unsafeInterleaveIO)-import Data.List (group)-import SimpleH.Reactive.Time---- |An event (a list of time-value pairs of increasing times)-newtype Event t a = Event { getEvent :: (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 . at' _event-instance Ord t => Semigroup (Event t a) where-  (+) = warp2 (from _Event) (+)-instance Ord t => Monoid (Event t a) where zero = []^._event-instance Ord t => Applicative (Event t) where-  fe@(at' _event -> ff:_) <*> xe@(at' _event -> fx:_) =-    ste & traverse (at state) & at' state & map snd & \st ->-    br ((ff^._time)+(fx^._time)) (st (ff^._value,fx^._value))-    where ste = map (\f (_,x) -> ((f,x),f x)) fe-              + map (\x (f,_) -> ((f,x),f x)) xe-          br t (at' _event -> e) = 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 = map (at' _event) >>> at' _event >>> map (sequence >>> map join)-         >>> merge >>> at _event-    where merge [] = []-          merge [t] = t-          merge ([]:t) = merge t-          merge ((x:xs):ys:t) = x:merge (add xs ys : t)-            where add = warp2 _OrdList (+)--type EventRep t a = OrdList (Future t a)-_Event :: Iso (Event t a) (Event t' b) (EventRep t a) (EventRep t' b)-_Event = _Compose.iso Event getEvent-_event :: Iso (Event t a) (Event t' b) [Future t a] [Future t' b]-_event = _OrdList._Event-atTimes :: [t] -> Event t ()-atTimes ts = (ts <&> \t -> (pure t,())^._future)^._event-mkEvent :: [(t,a)] -> Event t a-mkEvent as = (as <&> at _future . (_1 %~ pure))^._event--{-| The \'splice\' operator. Occurs when @a@ occurs.--> at 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.--> at 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 2 <*|>-(<|*>) :: Ord t => Reactive t (a -> b) -> Event t a -> Event t b-f <|*> a = (&)<$>a<*|>f-infixr 1 <|*>---- |Group the occurences of an event by equality. Occurs when the first occurence of a group occurs. -groupE :: (Eq a, Ord t) => Event t a -> Event t (Event t a)-groupE = _event %%~ group_ . (+repeat (Future (maxBound,undefined)))-  where group_ fs = (f & _value %- (xs^._event))-                    : (z & _time %~ (sum_ (at _time<$>xs)+)):zs-          where (xs,ys) = span ((==f^._value) . at _value) fs ; f = head fs-                ~(z:zs) = group_ ys-                sum_ = foldl' (+) zero-headE :: Event t a -> a-headE = at _value . head . at' _event--mapFutures :: (Future t a -> Future t' b) -> Event t a -> Event t' b-mapFutures f = _event %%~ map f-withTime :: Ord t => Event t a -> Event t (TimeVal t,a)-withTime = mapFutures (\(Future f) -> Future (_1%~timeVal <$> listen f))-times :: Ord t => Event t a -> Event t (TimeVal t)-times = map2 fst withTime--mask :: 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 time as possible-sink :: Event Seconds (IO ()) -> IO ()-sink l = traverse_ sink_ (withTime l)-  where sink_ (Since t,v) = waitTill t >> v-        sink_ (Always,v) = v-        sink_ (Never,_) = unit-event :: IO a -> IO (Event Seconds a)-event m = at _event <$> do-  c <- newChan-  _ <- forkIO $ forever $ do-    a <- newEmptyMVar-    writeChan c a-    putMVar a =<< m-  let event' ~(a:as) = unsafeInterleaveIO $ do-        (:)<$>futureIO (takeMVar a)<*>event' as-  (event' =<< getChanContents c)-    <*= forkIO . traverse_ (at' _thunk . timeVal . at _time)---- |A Future value (a value with a timestamp)-newtype Future t a = Future (Time t,a)-                   deriving (Show,Functor,Unit,Applicative,Traversable,Foldable,Monad,Semigroup,Monoid)-instance Ord t => Eq (Future t a) where f == f' = compare f f'==EQ-instance Ord t => Ord (Future t a) where compare = cmpFut-instance Ord t => Orderable (Future t a) where-  inOrder (Future (t,a)) (Future (t',b)) = (Future (tx,x),Future (ty,y),z)-    where (tx,ty,z) = inOrder t t'-          ~(x,y) = if z then (a,b) else (b,a)-_future :: Iso (Future t a) (Future t' b) (Time t,a) (Time t',b)-_future = iso Future (\(Future ~(t,a)) -> (t,a))-_time :: Lens (Time t) (Time t') (Future t a) (Future t' a)-_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,readMVar val^._thunk))--
− src/SimpleH/Reactive/Time.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE TupleSections, RecursiveDo, RankNTypes, DeriveDataTypeable #-}-module SimpleH.Reactive.Time (-  -- * Unambiguous times-  Time,-  timeVal,--  -- * Time utilities-  Seconds,-  timeIO,waitTill,currentTime-  ) where--import SimpleH-import Control.Concurrent-import SimpleH.Reactive.TimeVal-import System.IO.Unsafe-import Data.IORef-import System.Clock-import Control.Exception (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 fa') + ~(Time fb fb') = Time (mapT max fa fb) (mapT max fa' fb')--- |The Time monoid where @zero == minBound@-instance Ord t => Monoid (Time t) where-  zero = minBound--- |The Time ring where @(*) == min@ and @one == maxBound@-instance Ord t => Ring (Time t) where-  one = maxBound-  ~(Time fa fa') * ~(Time fb fb') = Time (mapT min fa fb) (mapT min fa' fb')-instance Ord t => Orderable (Time t) where-  inOrder a b = (a*b,if z then b else a,z)-    where z = a<=b--mapT :: (t -> t -> a) -> (t -> t) -> (t -> t) -> t -> a-mapT f fa fb h = f a (fb a) `unamb` f b (fa b)-  where a = fa h ; b = fb h--instance Bounded (Time t) where-  minBound = Time (pure 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 -> pure a <* killThread tb-    Right a -> pure a <* killThread ta-unamb :: a -> a -> a-unamb = warp2 (from _thunk) amb--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 at which the argument terminates.------ Warning: This function executes its argument, ignoring its--- value. Thus, it would be wise to use it on repeatable blocking--- actions, such as @readMVar@.-timeIO :: IO a -> IO (Time Seconds)-timeIO io = do-  sem <- newEmptyMVar-  ret <- newIORef id-  -  minAction <- newIORef $ \tm -> readIORef ret <**> Since<$>amb (readMVar sem) (-    case tm of-       Always -> currentTime-       Since t -> waitTill t >> currentTime-       Never -> throw Freezed)-  maxAction <- newIORef $ \tm -> readIORef ret <**> amb (Since<$>readMVar sem) (-    case tm of-      Always -> throw 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 -    _ <- io -    writeIORef minAction (const (pure (pure t)))-    writeIORef maxAction (const (pure (pure t)))-    writeIORef ret (const (pure 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
− src/SimpleH/Reactive/TimeVal.hs 
@@ -1,30 +0,0 @@-module SimpleH.Reactive.TimeVal (-  TimeVal(..)-  ) where--import SimpleH---- |A type wrapper that adds a Bounded instance for types that don't possess one.-data TimeVal t = Always | Since t | Never-                 deriving (Show,Eq,Ord)-instance Functor TimeVal where-  map f (Since a) = Since (f a)-  map _ Always = Always-  map _ Never = Never-instance Unit TimeVal where pure = Since-instance Applicative TimeVal-instance Monad TimeVal where-  join (Since b) = b-  join Always = Always-  join Never = Never-instance 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-
− src/SimpleH/Traversable.hs 
@@ -1,54 +0,0 @@-module SimpleH.Traversable(-  module SimpleH.Applicative, module SimpleH.Foldable,--  Traversable(..),Contravariant(..),--  traverse,foreach,transpose,flip-  ) where--import SimpleH.Classes-import SimpleH.Core hiding (flip,(&))-import SimpleH.Applicative-import SimpleH.Foldable-import SimpleH.Lens-import Data.Tree--class Foldable t => Traversable t where-  sequence :: Applicative f => t (f a) -> f (t a)-instance Traversable ((,) c) where-  sequence ~(c,m) = (,) c<$>m-instance Traversable (Either a) where-  sequence = pure . Left <|> map Right-instance Traversable [] where-  sequence (x:xs) = (:)<$>x<*>sequence xs-  sequence [] = pure []-deriving instance Traversable Interleave-deriving instance Traversable OrdList-deriving instance Traversable ZipList-instance Traversable Tree where-  sequence (Node a subs) = Node<$>a<*>sequence (map sequence subs)-deriving instance Traversable ZipTree-instance (Traversable f,Traversable g) => Traversable (f:.:g) where-  sequence = getCompose >>> map sequence >>> sequence >>> map Compose-instance (Traversable f,Traversable g) => Traversable (f:**:g) where-  sequence (f:**:g) = (:**:)<$>sequence f<*>sequence g-instance (Traversable f,Traversable g) => Traversable (f:++:g) where-  sequence (Sum (Left f)) = Sum . Left<$>sequence f-  sequence (Sum (Right g)) = Sum . Right<$>sequence g--class Functor t => Contravariant t where-  collect :: Functor f => f (t a) -> t (f a)-instance Contravariant Id where collect f = Id (map getId f)-instance Contravariant ((->) a) where collect f = \a -> map ($a) f--traverse :: (Applicative f,Traversable t) => (a -> f b) -> t a -> f (t b)-traverse f t = sequence (map f t)-foreach :: (Applicative f,Traversable t) => t a -> (a -> f b) -> f (t b)-foreach = flip traverse-transpose :: (Applicative f,Traversable t) => t (f a) -> f (t a)-transpose = sequence-flip :: (Contravariant c,Functor f) => f (c a) -> c (f a)-flip = collect--instance Compound a b [a] [b] where-  _each = traverse
+ src/System/Simple.hs view
@@ -0,0 +1,9 @@+module System.Simple (+  module System.Simple.File,+  module System.Simple.Network,+  module System.IO+  ) where++import System.Simple.File+import System.Simple.Network+import System.IO (Handle)
+ src/System/Simple/File.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE RankNTypes, ImplicitParams #-}+module System.Simple.File (+  -- * Exported modules+  module System.FilePath,module SimpleH,++  -- * The File interface+  File(..),DirEntry(..),+  getFile,+  +  workingDirectory,+  Location(..),+  pathTo,++  -- ** Status+  modTime,+  +  -- ** Useful Lenses+  file,contents,child,descendant,+  named,withExtension,+  fileName,entry,text,fileData,+  ) where++import SimpleH+import Data.Containers+import Control.Reactive.Time+import System.Directory +import System.FilePath ((</>),FilePath)+import System.IO.Unsafe+import System.Posix.Process (getProcessID)+import Data.Time.Clock.POSIX+import qualified Data.ByteString as BS+import qualified Prelude as P++data File = File (Maybe String) (Maybe BS.ByteString)+          | Directory (Map String File) +instance Show File where+  show (File _ _) = "File"+  show (Directory d) = show d+instance Semigroup File where+  Directory d + Directory d' = Directory (d+d')+  a + _ = a++data DirEntry = DirEntry FilePath File+              deriving Show+instance Lens1 String String DirEntry DirEntry where+  _1 = from _DirEntry._1+instance Lens2 File File DirEntry DirEntry where+  _2 = from _DirEntry._2+fileName :: Lens' DirEntry String+fileName = _1+entry :: Lens' DirEntry File+entry = _2++il :: IO a -> IO a+il = unsafeInterleaveIO+getFile :: FilePath -> IO File+getFile path = do+  d <- doesDirectoryExist path+  if d then do+    files <- unsafeInterleaveIO (getDirectoryContents path)+    return $ Directory $ fromList [+      (name,unsafePerformIO (getFile (path</>name)))+      | name <- files, not (name`elem`[".",".."])]+    else File<$>il (tryMay $ traverse (yb _thunk) =<< P.readFile path)+         <*>il (tryMay $ BS.readFile path)++_File :: ((Maybe String,Maybe BS.ByteString):+:Map String File) :<->: File+_File = iso f' f+  where f (File x y) = Left (x,y)+        f (Directory d) = Right d+        f' = uncurry File <|> Directory+_DirEntry :: (FilePath,File) :<->: DirEntry+_DirEntry = iso (uncurry DirEntry) (\ ~(DirEntry p f) -> (p,f))+file :: Traversal' File (Maybe String,Maybe BS.ByteString)+file = from _File._l+contents :: Traversal' File (Map String File)+contents = from _File._r+child :: Traversal' File File+child = contents.traverse+descendant :: Fold' File File+descendant = id .+ child.descendant+text :: Traversal' File String+text = file._1._r+fileData :: Traversal' File ByteString+fileData = file._2._r++named :: (String -> Bool) -> Traversal' DirEntry DirEntry+named p = sat (\(DirEntry name _) -> p name)+withExtension :: String -> Traversal' DirEntry DirEntry+withExtension e = named (\s -> drop (length s-(length e+1)) s==('.':e))++-- |The working directory, as a DirEntry+workingDirectory :: IO File+workingDirectory = getFile =<< getCurrentDirectory++modTime :: FilePath -> IO Seconds+modTime p = getModificationTime p <&> realToFrac . utcTimeToPOSIXSeconds++data Location = Self | Owner | System | Here++pathTo :: ( ?progName :: FilePath ) => Location -> FilePath+pathTo Self = (getTemporaryDirectory^._thunk) </> ?progName + "-" + show (getProcessID^._thunk) +pathTo Owner = getHomeDirectory^._thunk </> "." + ?progName+pathTo System = "/usr/share" </> ?progName+pathTo Here = getCurrentDirectory^._thunk+
+ src/System/Simple/Network.hs view
@@ -0,0 +1,15 @@+module System.Simple.Network (Socket,PortNumber,listenOn,accept) where++import SimpleH+import Network (Socket)+import qualified Network as Net+import System.IO+import Data.Word (Word16)++type PortNumber = Word16++listenOn :: PortNumber -> IO Socket+listenOn = Net.listenOn . Net.PortNumber . fromIntegral++accept :: Socket -> IO Handle+accept = map2 (\(h,_,_) -> h) Net.accept