packages feed

Clean 0.3 → 0.4

raw patch · 13 files changed

+289/−116 lines, 13 files

Files

Clean.cabal view
@@ -1,5 +1,5 @@ name:                Clean-version:             0.3+version:             0.4 synopsis:            A light, clean and powerful utility library description:         A collection of the most useful stuff I've found cleaned up 		     and bundled in one convenient location@@ -14,7 +14,7 @@  library   hs-source-dirs: src-  exposed-modules:     Clean Clean.Monoid Clean.Functor Clean.Monad Clean.Arrow Clean.Applicative Clean.Foldable Clean.Traversable Clean.Lens Clean.Unit Clean.Core+  exposed-modules:     Clean Clean.Core Clean.Functor Clean.Applicative Clean.Monad Clean.Arrow Clean.Foldable Clean.Traversable Clean.Lens   other-modules:       Clean.Classes    build-depends:       base ==4.6.*, containers   ghc-options:         -W
src/Clean.hs view
@@ -1,11 +1,13 @@ module Clean(   module Clean.Monad,-  module Clean.Applicative,+  module Clean.Foldable,+  module Clean.Traversable,+  module Clean.Arrow,   module Clean.Core,-  module Clean.Monoid   ) where  import Clean.Monad-import Clean.Applicative-import Clean.Core-import Clean.Monoid+import Clean.Foldable+import Clean.Traversable+import Clean.Arrow+import Clean.Core hiding (flip)
src/Clean/Applicative.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts,FlexibleInstances #-} -- |A module describing applicative functors module Clean.Applicative(-  module Clean.Functor,module Clean.Unit,+  module Clean.Functor,    Applicative(..),   ZipList(..),ZipTree(..),Backwards(..),@@ -9,10 +9,8 @@   (*>),(<*),ap   ) where -import Clean.Monoid import Clean.Functor import Clean.Classes-import Clean.Unit import Clean.Core import Data.Tree import Clean.Foldable@@ -30,15 +28,22 @@ 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 Nil a => Nil (ZipList a) where zero = pure zero-instance Monoid a => Monoid (ZipList a) where+instance Semigroup a => Semigroup (ZipList a) where   a + b = (+)<$>a<*>b+instance Monoid a => Monoid (ZipList a) where zero = pure zero+ instance Functor ZipList where   map f (ZipList l) = ZipList (map f l) instance Unit ZipList where@@ -61,14 +66,15 @@     ZipTree (Node (f x) (getZipList ((<*>)<$>ZipList fs<*>ZipList xs))) deriving instance Foldable ZipTree --- |A wrapper for Applicative functors with action executed in the reverse order+-- |A wrapper for applicative functors with actions executed in the reverse order newtype Backwards f a = Backwards { forwards :: f a }-deriving instance Nil (f a) => Nil (Backwards 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 (map (flip ($)) xs <*> fs)+  Backwards fs <*> Backwards xs = Backwards (map (&) xs <*> fs)  ap = (<*>) a *> b = flip const<$>a<*>b
src/Clean/Arrow.hs view
@@ -1,30 +1,61 @@-{-# LANGUAGE DefaultSignatures #-}-module Clean.Arrow where+{-# LANGUAGE DefaultSignatures, TupleSections #-}+module Clean.Arrow (+  Arrow(..),+  (>>>),(<<<),(>>^),(^>>),(|||), -import Clean.Category+  Apply(..),app,++  Kleisli(..)+  ) where++import Clean.Core hiding (flip)+import Clean.Classes import Clean.Monad-import Clean.Core+import Clean.Traversable+import Clean.Lens -class Split ar => Arrow ar where-  arr :: (a -> b) -> ar a b+(>>>) = flip (.)+(<<<) = (.)+(^>>) = promap+(>>^) = (<&>)+infixr 4 >>>,<<<,^>>,>>^++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 Arrow k => Cofunctor (Flip k a) where+  comap f (Flip g) = Flip (arr f >>> g)+app f = arr (f,) >>> apply -class Profunctor p where-  promap :: (a -> b) -> p b c -> p a c-  default promap :: Arrow p => (a -> b) -> p b c -> p a c-  promap f = (arr f >>>) -infixr 4 $>>-($>>) = promap+a ||| b = (Left<$>a) <|> (Right<$>b) -a ||| b = (a >>> arr Left) <|> (b >>> arr Right)+instance (Monad f,Contravariant f,Monad g) => Monad (Compose f g) where+  join = map getCompose >>> getCompose >>> map collect+         >>> join >>> map join >>> Compose +kc = iso (Compose . runKleisli) (Kleisli . getCompose)+kc' = iso (Kleisli . getCompose) (Compose . runKleisli) newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }+instance Unit m => Unit (Kleisli m a) where pure = Kleisli . const . pure +instance Functor f => Functor (Kleisli f a) where map f m = m ^. kc.lam (map f).kc'+instance Monad m => Applicative (Kleisli m a)+instance Monad m => Monad (Kleisli m a) where join m = m ^. kc.lam (join . map (^.kc)).kc'+ 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,Applicative m) => Split (Kleisli m) where+instance Monad m => Split (Kleisli m) where   Kleisli f <#> Kleisli g = Kleisli (\(a,c) -> (,)<$>f a<*>g c)-instance (Monad m,Applicative m) => Arrow (Kleisli m) where+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)++++
src/Clean/Classes.hs view
@@ -2,7 +2,6 @@ module Clean.Classes where  import Clean.Core-import Clean.Unit  class Functor f where   map :: (a -> b) -> f a -> f b@@ -18,5 +17,4 @@   (>>=) :: m a -> (a -> m b) -> m b   ma >>= k = join (map k ma) infixl 1 >>=-  -  +
src/Clean/Core.hs view
@@ -1,9 +1,28 @@-{-# LANGUAGE NoRebindableSyntax #-}+{-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, FlexibleInstances, DefaultSignatures, TupleSections #-} module Clean.Core(-  Category(..),Choice(..),Split(..),(:*:),(:+:),+  -- * Basic union and product types+  (:*:),(:+:), -  first,second,left,right,ifThenElse,fail,-  +  -- * Basic group and ring structure+  -- ** Classes+  Semigroup(..),SubSemi(..),Monoid(..),Ring(..),+  Unit(..),++  -- ** Common monoids+  Endo(..),Dual(..),OrdList(..),Interleave(..),++  -- * Fundamental control operations+  Category(..),+  Choice(..),Split(..),++  -- * Misc functions+  const,(&),++  first,second,left,right,++  ifThenElse,guard,fail,++  -- * The rest is imported from the Prelude   module Prelude   ) where @@ -11,16 +30,74 @@   Functor(..),Monad(..),   sequence,mapM,mapM_,sequence_,(=<<), -  map,(++),filter,length,sum,-  (+),(.),id)+  map,(++),foldl,foldr,concat,filter,length,sum,+  (+),(*),(.),id,const) import qualified Prelude as P--ifThenElse b th el = if b then th else el-fail = error+import Data.Tree+import qualified Data.Set as S  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.+)+instance Semigroup () where _+_ = ()+instance Semigroup Bool where (+) = (||)+instance Semigroup Int+instance Semigroup Float+instance Semigroup Integer+instance Ord a => Semigroup (S.Set a) where (+) = S.union+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 SubSemi b a => Semigroup (a:+:b) where+  Left a+Left b = Left (a+b)+  a+b = Right (from a+from b)+    where from = to <|> id++-- |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 () where zero = ()+instance Monoid Int ; instance Monoid Integer ; instance Monoid Float+instance Ord a => Monoid (S.Set a) where zero = S.empty+instance Monoid [a] where zero = []+instance (Monoid a,Monoid b) => Monoid (a:*:b) where zero = (zero,zero)+instance (SubSemi b a,Monoid a) => Monoid (a:+:b) where zero = Left zero+instance Monoid Bool where zero = False++class (Semigroup a,Semigroup b) => SubSemi a b where+  to :: b -> a+instance Monoid a => SubSemi a () where to _ = 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.*)+instance Ring Bool where one = True ; (*) = (&&)+instance Ring Int+instance Ring Integer+instance Ring Float++class Unit f where+  pure :: a -> f a+instance Unit (Either a) where pure = Right+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@@ -39,7 +116,45 @@   (<#>) :: k a c -> k b d -> k (a,b) (c,d) instance Split (->) where f <#> g = \(a,b) -> (f a,g b) +{-| 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++{-| 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+newtype OrdList a = OrdList { getOrdList :: [a] }+instance Ord a => Semigroup (OrdList a) where+  OrdList a + OrdList b = OrdList (merge a b)+    where merge xs@(x:xt) ys@(y:yt) | x<y = x:merge xt ys+                                    | otherwise = y:merge xs yt+          merge a b = a+b+deriving instance Ord a => Monoid (OrdList a)+deriving instance Unit OrdList++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 ($)+ second a = id <#> a first a = a <#> id left a = a <|> id right a = id <|> a++guard p = if p then pure () else zero++ifThenElse b th el = if b then th else el+fail = error+const = pure
src/Clean/Foldable.hs view
@@ -2,8 +2,6 @@ module Clean.Foldable where  import Clean.Core-import Clean.Monoid-import Clean.Unit import Clean.Classes import Clean.Functor import Data.Tree@@ -16,6 +14,7 @@ instance Foldable [] where   fold [] = zero   fold (x:t) = x+fold t+deriving instance Foldable Interleave instance Foldable Tree where fold (Node m subs) = m + fold (map fold subs)  foldMap f e = fold (map f e)
src/Clean/Functor.hs view
@@ -1,23 +1,37 @@+{-# LANGUAGE FlexibleInstances #-} -- |A module for functors-module Clean.Functor(Functor(..),Id(..),Const(..),(<$>),(<$),(<&>),void) where+module Clean.Functor(+  Functor(..),Cofunctor(..),+  +  Id(..),Const(..),Flip(..),Compose(..), +  (<$>),(<$),(<&>),void,+  promap+  ) where+ import qualified Prelude as P -import Clean.Category import Clean.Classes-import Clean.Monoid-import Clean.Unit import Clean.Core import Data.Tree +class Cofunctor f where+  comap :: (a -> b) -> f b -> f a+instance Cofunctor (Flip (->) r) where+  comap f (Flip g) = Flip (g . f)+instance (Functor f,Cofunctor g) => Cofunctor (Compose f g) where+  comap f (Compose c) = Compose (map (comap f) c)+promap f c = unFlip (comap f (Flip c))+ 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 instance Nil a => Nil (Id a)+deriving instance Semigroup a => Semigroup (Id a) deriving instance Monoid w => Monoid (Id w)+deriving instance Ring w => Ring (Id w) instance Unit Id where pure = Id instance Functor Id instance Applicative Id@@ -25,16 +39,33 @@  -- |The Constant Functor newtype Const a b = Const { getConst :: a }-deriving instance Nil a => Nil (Const a b)-deriving instance Monoid w => Monoid (Const w a)+deriving instance Semigroup w => Semigroup (Const w a)+deriving instance Monoid a => Monoid (Const a b) instance Unit (Const a) where pure _ = Const undefined instance Functor (Const a) instance Applicative (Const a) instance Monad (Const a) where Const a >>= _ = Const a +-- |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 Product f g a = Product { getProduct :: f a:*:g a }+instance (Functor f,Functor g) => Functor (Product f g) where+  map f = Product . (map f <#> map f) . getProduct+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 ((,) b) where map f (b,a) = (b,f a) instance Functor ((->) a) where map = (.)+deriving instance Functor Interleave  instance Functor IO instance Applicative IO
src/Clean/Lens.hs view
@@ -4,6 +4,7 @@ import Clean.Core import Clean.Functor import Clean.Applicative+import Clean.Foldable  type LensLike f s t a b = (s -> f t) -> (a -> f b) type LensLike' f a b = LensLike f b b a a@@ -16,8 +17,10 @@ iso f g = lens f (const g) iso' :: (a -> b) -> (b -> a) -> Lens' a b iso' = iso+lam f = lens f const  (^.) :: a -> Lens' a b -> b+infixl 2 ^. x^.l = getConst (l Const x)  type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
src/Clean/Monad.hs view
@@ -1,21 +1,26 @@ {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TupleSections, Rank2Types #-} module Clean.Monad(   module Clean.Applicative,+   Monad(..),MonadFix(..),MonadTrans(..),+   MonadState(..),   MonadReader(..),MonadWriter(..),+   StateT(..),State,-  ReaderT(..),WriterT(..),+  ReaderT(..),Reader,WriterT(..),Writer,+  ContT(..),Cont,+     (=<<),(>>),return   ) where  import Clean.Classes import Clean.Applicative-import Clean.Core-import Clean.Monoid+import Clean.Core hiding (flip)+import Clean.Traversable  class MonadFix m where-  fix :: (a -> m a) -> m a+  mfix :: (a -> m a) -> m a class Monad m => MonadState s m where   get :: m s   put :: s -> m ()@@ -40,7 +45,12 @@ listen_ = internal (\m -> listen m<&> \(w,(c,a)) -> (c,(w,a))) censor_ = internal (\m -> censor (m<&> \(c,(a,f)) -> ((c,a),f))) -{- A simple State Monad  -}+fix f = f (fix f)+cfix f = map fix (collect f) +instance MonadFix Id where mfix = cfix+instance MonadFix ((->) b) where mfix = cfix++{-| A simple State Monad  -} newtype StateT s m a = StateT { runStateT :: s -> m (s,a) } type State s a = StateT s Id a instance Unit m => Unit (StateT s m) where pure a = StateT (\s -> pure (s,a))@@ -59,9 +69,10 @@   ask = ask_ ; local = local_ instance MonadWriter w m => MonadWriter w (StateT s m) where   tell = tell_ ; listen = listen_ ; censor = censor_--{- A simple Reader monad -}+  +{-| A simple Reader monad -} newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }+type Reader r a = ReaderT r Id a instance MonadTrans (ReaderT r) where   lift m = ReaderT (const m)   internal f (ReaderT r) = ReaderT (map snd . f . map ((),) . r)@@ -78,8 +89,9 @@ instance MonadWriter w m => MonadWriter w (ReaderT r m) where   tell = tell_ ; listen = listen_ ; censor = censor_   -{- A simple Writer monad -}+{-| A simple Writer monad -} newtype WriterT w m a = WriterT { runWriterT :: m (w,a) }+type Writer w a = WriterT w Id a instance Monoid w => MonadTrans (WriterT w) where   lift m = WriterT (map (zero,) m)   internal f (WriterT m) = WriterT (f m)@@ -98,6 +110,18 @@   ask = ask_ ; local = local_ instance (Monoid w,MonadState r m) => MonadState r (WriterT w m) where   get = get_ ; put = put_ ; modify = modify_++{-| A simple continuation monad implementation  -}+newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }+type Cont r a = ContT r Id a+instance Unit m => Unit (ContT r m) where pure a = ContT ($a)+instance Monad m => Functor (ContT r m)+instance Monad m => Applicative (ContT r m)+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 >>=)+  internal _ (ContT _) = undefined  (>>) = (*>) (=<<) = flip (>>=)
− src/Clean/Monoid.hs 
@@ -1,32 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-module Clean.Monoid where--import qualified Prelude as P-import Clean.Core--class Nil z where-  zero :: z-instance Nil () where zero = ()-instance Nil Int where zero = 0-instance Nil [a] where zero = []-instance (Nil a,Nil b) => Nil (a:*:b) where zero = (zero,zero)-instance Nil a => Nil (a:+:b) where zero = Left zero--class Nil m => Monoid m where-  (+) :: m -> m -> m-instance Monoid () where _+_ = ()-instance Monoid Int where (+) = (P.+)-instance Monoid [a] where []+l = l ; (x:t)+l = x:(t+l)-instance (Monoid a,Monoid b) => Monoid (a:*:b) where (a,b)+(c,d) = (a+c,b+d)-instance Submonoid b a => Monoid (a:+:b) where-  Left a+Left b = Left (a+b)-  a+b = Right (from a+from b)-    where from = to <|> id--class (Monoid a,Monoid b) => Submonoid a b where-  to :: b -> a-instance Monoid a => Submonoid a () where to _ = zero--newtype Endo k a = Endo { runEndo :: k a a }-instance Category k => Nil (Endo k a) where zero = Endo id-instance Category k => Monoid (Endo k a) where Endo f+Endo g = Endo (f . g)
src/Clean/Traversable.hs view
@@ -1,21 +1,21 @@+{-# LANGUAGE FlexibleInstances #-} module Clean.Traversable(-  module Clean.Foldable,module Clean.Applicative,+  module Clean.Applicative, -  Traversable(..),+  Traversable(..),Contravariant(..), -  traverse,foreach,transpose+  traverse,foreach,transpose,flip   ) where  import Clean.Classes-import Clean.Core-import Clean.Foldable+import Clean.Core hiding (flip,(&)) import Clean.Applicative import Data.Tree -class Foldable t => Traversable t where+class Traversable t where   sequence :: Applicative f => t (f a) -> f (t a) instance Traversable (Either a) where-  sequence = pure . Left <|> map Right +  sequence = pure . Left <|> map Right instance Traversable [] where   sequence (x:xs) = (:)<$>x<*>sequence xs   sequence [] = pure []@@ -24,8 +24,19 @@   sequence (Node a subs) = Node<$>a<*>sequence (map sequence subs) deriving instance Traversable ZipTree +class 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+instance (Applicative f,Contravariant f,Semigroup m) => Semigroup (f m) where+  fa + fb = (+)<$>fa<*>fb+instance (Applicative f,Contravariant f,Monoid m) => Monoid (f m) where+  zero = pure zero+instance (Applicative f,Contravariant f,Ring r) => Ring (f r) where+  one = pure one+  fa * fb = (*)<$>fa<*>fb+ traverse f t = sequence (map f t) foreach = flip traverse transpose = sequence--+flip = collect
− src/Clean/Unit.hs 
@@ -1,15 +0,0 @@-module Clean.Unit where--import qualified Prelude as P-import Clean.Core-import Clean.Monoid-import Data.Tree--class Unit f where-  pure :: a -> f a-instance Unit (Either a) where pure = Right-instance Monoid w => Unit ((,) w) where pure a = (zero,a)-instance Unit ((->) b) where pure = const-instance Unit [] where pure a = [a]-instance Unit Tree where pure a = Node a []-instance Unit IO where pure = P.return