packages feed

Clean (empty) → 0.3

raw patch · 15 files changed

+558/−0 lines, 15 filesdep +basedep +containerssetup-changed

Dependencies added: base, containers

Files

+ Clean.cabal view
@@ -0,0 +1,21 @@+name:                Clean+version:             0.3+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+license:             BSD3+license-file:        LICENSE+author:              Marc Coiffier+maintainer:          marc.coiffier@gmail.com+-- copyright:           +category:            Control+build-type:          Simple+cabal-version:       >=1.8++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+  other-modules:       Clean.Classes +  build-depends:       base ==4.6.*, containers+  ghc-options:         -W+  extensions:          TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax
+ 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
+ src/Clean.hs view
@@ -0,0 +1,11 @@+module Clean(+  module Clean.Monad,+  module Clean.Applicative,+  module Clean.Core,+  module Clean.Monoid+  ) where++import Clean.Monad+import Clean.Applicative+import Clean.Core+import Clean.Monoid
+ src/Clean/Applicative.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE FlexibleContexts #-}+-- |A module describing applicative functors+module Clean.Applicative(+  module Clean.Functor,module Clean.Unit,++  Applicative(..),+  ZipList(..),ZipTree(..),Backwards(..),++  (*>),(<*),ap+  ) where++import Clean.Monoid+import Clean.Functor+import Clean.Classes+import Clean.Unit+import Clean.Core+import Data.Tree+import Clean.Foldable++instance Applicative (Either a)+instance Monad (Either a) where join (Right a) = a+                                join (Left a) = Left a+instance Applicative ((->) a) +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')++{-|+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+  a + b = (+)<$>a<*>b+instance Functor ZipList where+  map f (ZipList l) = ZipList (map f l)+instance Unit ZipList where+  pure a = ZipList (repeat a)+    where repeat a = a: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 action executed in the reverse order+newtype Backwards f a = Backwards { forwards :: f a }+deriving instance Nil (f a) => Nil (Backwards f a)+deriving instance Monoid (f a) => Monoid (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)++ap = (<*>)+a *> b = flip const<$>a<*>b+a <* b = const<$>a<*>b
+ src/Clean/Arrow.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DefaultSignatures #-}+module Clean.Arrow where++import Clean.Category+import Clean.Monad+import Clean.Core++class Split ar => Arrow ar where+  arr :: (a -> b) -> ar a b+instance Arrow (->) where arr = id++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 = (a >>> arr Left) <|> (b >>> arr Right)++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,Applicative 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+  arr a = Kleisli (pure . a)
+ src/Clean/Classes.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DefaultSignatures #-}+module Clean.Classes where++import Clean.Core+import Clean.Unit++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+  (<*>) :: 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+  (>>=) :: m a -> (a -> m b) -> m b+  ma >>= k = join (map k ma)+infixl 1 >>=+  +
+ src/Clean/Core.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE NoRebindableSyntax #-}+module Clean.Core(+  Category(..),Choice(..),Split(..),(:*:),(:+:),++  first,second,left,right,ifThenElse,fail,+  +  module Prelude+  ) where++import Prelude hiding (+  Functor(..),Monad(..),+  sequence,mapM,mapM_,sequence_,(=<<),++  map,(++),filter,length,sum,+  (+),(.),id)+import qualified Prelude as P++ifThenElse b th el = if b then th else el+fail = error++type a:*:b = (a,b)+type a:+:b = Either a b++class Category k where+  id :: k a a+  (.) :: k b c -> k a b -> k a c+instance Category (->) where+  id = P.id+  (.) = (P..)++class Category k => Choice k where+  (<|>) :: k a c -> k b c -> k (a:+:b) c+infixr 3 <|>+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)+instance Split (->) where f <#> g = \(a,b) -> (f a,g b)++second a = id <#> a+first a = a <#> id+left a = a <|> id+right a = id <|> a
+ src/Clean/Foldable.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TupleSections #-}+module Clean.Foldable where++import Clean.Core+import Clean.Monoid+import Clean.Unit+import Clean.Classes+import Clean.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 [] where+  fold [] = zero+  fold (x:t) = x+fold t+instance Foldable Tree where fold (Node m subs) = m + fold (map fold subs)++foldMap f e = fold (map f e)+concat = fold+sum = fold++split ch = foldMap (\a -> ((,zero)<|>(zero,)) (ch a))+partition p = split (\a -> (if p a then Left else Right) (pure a))+filter p = fst . partition p++count = sum . map (const 1)+length :: (Num n,Monoid n) => [a] -> n+length = count++foldl f e t = runEndo (foldMap (\b -> Endo (\a -> f a b)) t) e+foldr f e t = runEndo (foldMap (\b -> Endo (f b)) t) e
+ src/Clean/Functor.hs view
@@ -0,0 +1,48 @@+-- |A module for functors+module Clean.Functor(Functor(..),Id(..),Const(..),(<$>),(<$),(<&>),void) where++import qualified Prelude as P++import Clean.Category+import Clean.Classes+import Clean.Monoid+import Clean.Unit+import Clean.Core+import Data.Tree++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 Monoid w => Monoid (Id w)+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 }+deriving instance Nil a => Nil (Const a b)+deriving instance Monoid w => Monoid (Const w a)+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++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 = (.)++instance Functor IO+instance Applicative IO+instance Monad IO where (>>=) = (P.>>=)++(<$>) = map+x<&>f = map f x+a <$ x = const a <$> x++void :: Functor f => f a -> f ()+void = map (const ())
+ src/Clean/Lens.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE Rank2Types #-}+module Clean.Lens where++import Clean.Core+import Clean.Functor+import Clean.Applicative++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++lens :: (a -> s) -> (a -> t -> b) -> Lens s t a b+lens f g = \k a -> g a <$> k (f a) +iso :: (a -> s) -> (t -> b) -> Lens s t a b+iso f g = lens f (const g)+iso' :: (a -> b) -> (b -> a) -> Lens' a b+iso' = iso++(^.) :: a -> Lens' a b -> b+x^.l = getConst (l Const x)++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++(%~) :: Traversal' a b -> (b -> b) -> (a -> a)+(l %~ f) a = getId (l (pure . f) a)+(.~) :: Traversal' a b -> b -> (a -> a)+l .~ x = l %~ const x++prism :: (a -> (b:+:s)) -> (a -> t -> b) -> Traversal s t a b +prism f g = \k a -> (pure <|> map (g a) . k) (f a)+prism' :: (a -> (a:+:b)) -> (a -> b -> a) -> Traversal' a b+prism' = prism++_1 = lens fst (\(_,b) a -> (a,b))+_2 :: Lens' (a:*:b) b+_2 = lens snd (\(a,_) b -> (a,b))+_l :: Traversal' (a:+:b) a+_l = prism (\e -> (Right <|> const (Left e)) e) (const Left)+_r :: Traversal' (a:+:b) b+_r = prism (\e -> (const (Left e) <|> Right) e) (const Right)++_list :: Lens' [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++_drop :: Int -> Traversal' [a] [a]+_drop n = foldr (.) id (_tail<$[1..n])+
+ src/Clean/Monad.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TupleSections, Rank2Types #-}+module Clean.Monad(+  module Clean.Applicative,+  Monad(..),MonadFix(..),MonadTrans(..),+  MonadState(..),+  MonadReader(..),MonadWriter(..),+  StateT(..),State,+  ReaderT(..),WriterT(..),+  (=<<),(>>),return+  ) where++import Clean.Classes+import Clean.Applicative+import Clean.Core+import Clean.Monoid++class MonadFix m where+  fix :: (a -> m a) -> m a+class Monad m => MonadState s m 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 where+  ask :: m r+  local :: (r -> r) -> m a -> m a+class (Monad m,Monoid w) => MonadWriter w m where+  tell :: w -> m ()+  listen :: m a -> m (w,a)+  censor :: m (a,w -> w) -> m a++class MonadTrans t where+  lift :: Monad m => m a -> t m a+  internal :: Monad m => (forall c. m (c,a) -> m (c,b)) -> t m a -> t m b+pure_ = lift . pure+get_ = lift get ; put_ = lift . put ; modify_ = lift . modify  +ask_ = lift ask ; local_ f m = internal (local f) m+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)))++{- 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))+instance Monad m => Functor (StateT s m) +instance Monad m => Applicative (StateT s m)+instance Monad m => Monad (StateT s m) where+  StateT st >>= k = StateT (\s -> st s >>= \ ~(s',a) -> runStateT (k a) s')+instance MonadTrans (StateT s) where+  lift m = StateT (\s -> map (s,) m)+  internal f (StateT st) = StateT (f . st)+instance Monad m => MonadState s (StateT s m) where+  get = StateT (\s -> pure (s,s))+  put x = StateT (\_ -> pure (x,()))+  modify f = StateT (\s -> pure (f s,()))+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_++{- A simple Reader monad -}+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }+instance MonadTrans (ReaderT r) where+  lift m = ReaderT (const m)+  internal f (ReaderT r) = ReaderT (map snd . f . map ((),) . r)+instance Monad m => Unit (ReaderT r m) where pure = pure_+instance Monad m => Functor (ReaderT r m)+instance Monad m => Applicative (ReaderT r m)+instance Monad m => Monad (ReaderT r m) where+  ReaderT rd >>= k = ReaderT (\r -> rd r >>= \a -> runReaderT (k a) r)+instance Monad m => MonadReader r (ReaderT r m) where+  ask = ReaderT pure+  local f (ReaderT rd) = ReaderT (rd . f)+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_+  +{- A simple Writer monad -}+newtype WriterT w m a = WriterT { runWriterT :: m (w,a) }+instance Monoid w => MonadTrans (WriterT w) where+  lift m = WriterT (map (zero,) m)+  internal f (WriterT m) = WriterT (f m)+instance (Monoid w,Monad m) => Unit (WriterT w m) where pure = pure_+instance (Monoid w,Monad m) => Functor (WriterT w m)+instance (Monoid w,Monad m) => Applicative (WriterT w m)+instance (Monoid w,Monad m) => Monad (WriterT w m) where+  wr >>= k = WriterT $ do+    (w,a) <- runWriterT wr+    map (first (w+)) (runWriterT (k a))+instance (Monad m,Monoid w) => MonadWriter w (WriterT w m) where+  tell w = WriterT (pure (w,()))+  listen (WriterT m) = WriterT (m<&> \(w,a) -> (w,(w,a)))+  censor (WriterT m) = WriterT (m<&> \(w,(a,f)) -> (f w,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_++(>>) = (*>)+(=<<) = flip (>>=)+return = pure++
+ src/Clean/Monoid.hs view
@@ -0,0 +1,32 @@+{-# 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
@@ -0,0 +1,31 @@+module Clean.Traversable(+  module Clean.Foldable,module Clean.Applicative,++  Traversable(..),++  traverse,foreach,transpose+  ) where++import Clean.Classes+import Clean.Core+import Clean.Foldable+import Clean.Applicative+import Data.Tree++class Foldable t => Traversable t where+  sequence :: Applicative f => t (f a) -> f (t a)+instance Traversable (Either a) where+  sequence = pure . Left <|> map Right +instance Traversable [] where+  sequence (x:xs) = (:)<$>x<*>sequence xs+  sequence [] = pure []+deriving instance Traversable ZipList+instance Traversable Tree where+  sequence (Node a subs) = Node<$>a<*>sequence (map sequence subs)+deriving instance Traversable ZipTree++traverse f t = sequence (map f t)+foreach = flip traverse+transpose = sequence++
+ src/Clean/Unit.hs view
@@ -0,0 +1,15 @@+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