Clean 0.4 → 0.6

raw patch · 7 files changed

+188/−77 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Clean.cabal +2/−2
• src/Clean/Applicative.hs +22/−8
• src/Clean/Core.hs +15/−1
• src/Clean/Functor.hs +8/−2
• src/Clean/Lens.hs +50/−18
• src/Clean/Monad.hs +91/−38
• src/Clean/Traversable.hs +0/−8

@@ -1,5 +1,5 @@ name:                Clean-version:             0.4+version:             0.6 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@@ -18,4 +18,4 @@   other-modules:       Clean.Classes    build-depends:       base ==4.6.*, containers   ghc-options:         -W-  extensions:          TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax+  extensions:          TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts

@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleContexts,FlexibleInstances #-} -- |A module describing applicative functors module Clean.Applicative(   module Clean.Functor,@@ -6,7 +5,11 @@   Applicative(..),   ZipList(..),ZipTree(..),Backwards(..), -  (*>),(<*),ap+  (*>),(<*),ap,++  liftA,liftA2,liftA3,liftA4,++  plusA,zeroA   ) where  import Clean.Functor@@ -18,7 +21,10 @@ instance Applicative (Either a) instance Monad (Either a) where join (Right a) = a                                 join (Left a) = Left a-instance Applicative ((->) 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@@ -34,15 +40,13 @@ 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-  a + b = (+)<$>a<*>b-instance Monoid a => Monoid (ZipList a) where zero = pure zero+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)@@ -74,8 +78,18 @@ 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 (&) xs <*> fs)+  Backwards fs <*> Backwards xs = Backwards (liftA2 (&) xs fs)  ap = (<*>) a *> b = flip const<$>a<*>b a <* b = const<$>a<*>b++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 (*)

@@ -1,4 +1,4 @@-{-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, FlexibleInstances, DefaultSignatures, TupleSections #-}+{-# LANGUAGE NoRebindableSyntax, MultiParamTypeClasses, DefaultSignatures, TupleSections, EmptyDataDecls #-} module Clean.Core(   -- * Basic union and product types   (:*:),(:+:),@@ -36,6 +36,7 @@ import Data.Tree import qualified Data.Set as S +data Void type a:*:b = (a,b) type a:+:b = Either a b @@ -47,6 +48,7 @@   (+) :: m -> m -> m   default (+) :: Num m => m -> m -> m   (+) = (P.+)+instance Semigroup Void where _+_ = undefined instance Semigroup () where _+_ = () instance Semigroup Bool where (+) = (||) instance Semigroup Int@@ -65,6 +67,7 @@   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 Ord a => Monoid (S.Set a) where zero = S.empty@@ -88,6 +91,10 @@ instance Ring Int instance Ring Integer instance Ring Float+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@@ -115,6 +122,13 @@ 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)++{-| The Product monoid -}+newtype Product a = Product 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 }

@@ -1,7 +1,7 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses, RankNTypes, DefaultSignatures #-} -- |A module for functors module Clean.Functor(-  Functor(..),Cofunctor(..),+  Functor(..),Cofunctor(..),Bifunctor(..),      Id(..),Const(..),Flip(..),Compose(..), @@ -22,6 +22,12 @@ 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))++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 Bifunctor (->)  instance Functor [] where map f = f' where f' [] = [] ; f' (x:t) = f x:f' t instance Functor Tree where

@@ -1,6 +1,24 @@-{-# LANGUAGE Rank2Types #-}-module Clean.Lens where+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies #-}+{-| A module providing simple Lens functionality  -}+module Clean.Lens(+  -- * The lens types+  Iso,Iso',MkIso(..),+  LensLike,LensLike',+  Lens,Lens',+  Traversal,Traversal', +  -- * Constructing lenses+  iso,from,lens,lam,prism,++  -- * Extracting values+  (^.),(%~),(.~),++  -- * Basic lenses+  _1,_2,_l,_r,_both,+  _list,_head,_tail,_dropping,+  Wrapped(..),wrapping+  ) where+ import Clean.Core import Clean.Functor import Clean.Applicative@@ -10,32 +28,36 @@ 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 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 +data MkIso a b s t = MkIso (s -> a) (b -> t)+instance Functor (MkIso a b s) where map f (MkIso u v) = MkIso u (map f v)+instance Cofunctor (Flip (MkIso a b) t) where+  comap f (Flip (MkIso u v)) = Flip (MkIso (promap f u) v)+instance Bifunctor (MkIso a b)++iso :: (a -> s) -> (t -> b) -> Iso s t a b+iso f g = dimap f (map g)+from :: MkIso t s b a -> Iso a b s t+from (MkIso u v) = iso v u 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 lam f = lens f const+prism :: (a -> (b:+:s)) -> (a -> t -> b) -> Traversal s t a b +prism f g = \k a -> (pure <|> map (g a) . k) (f a)  (^.) :: 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-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' (a:*:b) a _1 = lens fst (\(_,b) a -> (a,b)) _2 :: Lens' (a:*:b) b _2 = lens snd (\(a,_) b -> (a,b))@@ -44,7 +66,10 @@ _r :: Traversal' (a:+:b) b _r = prism (\e -> (const (Left e) <|> Right) e) (const Right) -_list :: Lens' [a] (():+:(a:*:[a]))+_both :: Traversal a b (a,a) (b,b)+_both k (a,a') = (,)<$>k a<*>k a'++_list :: Iso' [a] (():+:(a:*:[a])) _list = iso (\l -> case l of                 [] -> Left ()                 (x:t) -> Right (x,t)) (const [] <|> uncurry (:))@@ -54,6 +79,13 @@ _tail :: Traversal' [a] [a] _tail = _list._r._2 -_drop :: Int -> Traversal' [a] [a]-_drop n = foldr (.) id (_tail<$[1..n])+_dropping :: Int -> Traversal' [a] [a]+_dropping n = foldr (.) id (_tail<$[1..n]) +_mapping :: Functor f => MkIso s t a b -> Iso (f s) (f t) (f a) (f b)+_mapping (MkIso u v) = dimap (map u) (map (map v))++class Wrapped s t a b | a -> s, b -> t, a t -> s, b s -> t where+  wrapped :: Iso s t a b +wrapping :: Wrapped b b a a => (a -> b) -> Iso' a b+wrapping _ = wrapped

@@ -1,17 +1,27 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TupleSections, Rank2Types #-}+{-# LANGUAGE MultiParamTypeClasses, TupleSections, Rank2Types, UndecidableInstances #-} module Clean.Monad(   module Clean.Applicative, +  -- * The basic Monad interface   Monad(..),MonadFix(..),MonadTrans(..),-+  (=<<),(>>),return,+  +  -- * Common monads+  -- ** The State Monad   MonadState(..),-  MonadReader(..),MonadWriter(..),-   StateT(..),State,-  ReaderT(..),Reader,WriterT(..),Writer,-  ContT(..),Cont,-  -  (=<<),(>>),return+  evalStateT,execStateT,runState,execState,evalState,++  -- ** The Reader monad+  MonadReader(..),ReaderT(..),Reader,++  -- ** The Writer monad+  MonadWriter(..),WriterT(..),Writer,runWriter,++  -- ** The Continuation monad+  MonadCont(..),ContT(..),Cont,evalContT,evalCont++   ) where  import Clean.Classes@@ -19,37 +29,31 @@ import Clean.Core hiding (flip) import Clean.Traversable -class MonadFix m where+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)+fix f = f (fix f)+cfix f = map fix (collect f) ++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++(>>) = (*>)+(=<<) = flip (>>=)+return = pure+ 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))) -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@@ -69,9 +73,30 @@   ask = ask_ ; local = local_ instance MonadWriter w m => MonadWriter w (StateT s m) where   tell = tell_ ; listen = listen_ ; censor = censor_-  +instance MonadCont m => MonadCont (StateT s m) where+  callCC f = StateT (\s -> callCC $ \k -> runStateT (f (\a -> lift (k (s,a)))) s)+instance MonadFix m => MonadFix (StateT s m) where+  mfix f = StateT (\s -> mfix (\ ~(_,a) -> runStateT (f a) s))+deriving instance Semigroup (m (s,a)) => Semigroup (StateT s m a)+deriving instance Monoid (m (s,a)) => Monoid (StateT s m a)+deriving instance Ring (m (s,a)) => Ring (StateT s m a)++evalStateT = map (map snd) . runStateT +execStateT = map (map fst) . runStateT+runState :: State s a -> s -> (s,a)+runState = map getId . runStateT+execState :: State s a -> s -> s+execState = map fst . runState+evalState :: State s a -> s -> a+evalState = map snd . runState++class Monad m => MonadReader r m where+  ask :: m r+  local :: (r -> r) -> m a -> m a+ask_ = lift ask ; local_ f m = internal (local f) m {-| A simple Reader monad -} newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }+                      deriving (Semigroup,Monoid,Ring) type Reader r a = ReaderT r Id a instance MonadTrans (ReaderT r) where   lift m = ReaderT (const m)@@ -88,7 +113,19 @@   get = get_ ; put = put_ ; modify = modify_ instance MonadWriter w m => MonadWriter w (ReaderT r m) where   tell = tell_ ; listen = listen_ ; censor = censor_-  +instance MonadCont m => MonadCont (ReaderT r m) where+  callCC f = ReaderT (\r -> callCC (\k -> runReaderT (f (lift . k)) r))+instance MonadFix m => MonadFix (ReaderT r m) where+  mfix f = ReaderT (\r -> mfix (\a -> runReaderT (f a) r))++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+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 Writer monad -} newtype WriterT w m a = WriterT { runWriterT :: m (w,a) } type Writer w a = WriterT w Id a@@ -104,15 +141,26 @@     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))+  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_+deriving instance Semigroup (m (w,a)) => Semigroup (WriterT w m a)+deriving instance Monoid (m (w,a)) => Monoid (WriterT w m a)+deriving instance Ring (m (w,a)) => Ring (WriterT w m a)+instance (Monoid w,MonadFix m) => MonadFix (WriterT w m) where+  mfix f = WriterT (mfix (runWriterT . f . snd)) +runWriter = getId . runWriterT+ {-| 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 Monad m => Functor (ContT r m)@@ -122,9 +170,14 @@ instance MonadTrans (ContT r) where   lift m = ContT (m >>=)   internal _ (ContT _) = undefined--(>>) = (*>)-(=<<) = flip (>>=)-return = pure+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+  internal f (Backwards m) = Backwards (snd<$>f (((),)<$>m))+instance MonadFix m => Monad (Backwards m) where+  Backwards ma >>= k = Backwards$fst<$>mfix (\r -> liftA2 (,) (forwards (k (snd r))) ma)

@@ -1,4 +1,3 @@-{-# LANGUAGE FlexibleInstances #-} module Clean.Traversable(   module Clean.Applicative, @@ -28,13 +27,6 @@   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