packages feed

SimpleH (empty) → 0.9

raw patch · 18 files changed

+1631/−0 lines, 18 filesdep +basedep +clockdep +containerssetup-changed

Dependencies added: base, clock, containers

Files

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