diff --git a/Control/Applicative.hs b/Control/Applicative.hs new file mode 100644 --- /dev/null +++ b/Control/Applicative.hs @@ -0,0 +1,222 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Applicative +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- This module describes a structure intermediate between a functor and +-- a monad: it provides pure expressions and sequencing, but no binding. +-- (Technically, a strong lax monoidal functor.) For more details, see +-- /Applicative Programming with Effects/, +-- by Conor McBride and Ross Paterson, online at +-- . +-- +-- This interface was introduced for parsers by Niklas Röjemo, because +-- it admits more sharing than the monadic interface. The names here are +-- mostly based on recent parsing work by Doaitse Swierstra. +-- +-- This class is also useful with instances of the +-- 'Data.Traversable.Traversable' class. + +module Control.Applicative ( + -- * Applicative functors + Applicative(..), + -- * Alternatives + Alternative(..), + -- * Instances + Const(..), WrappedMonad(..), WrappedArrow(..), ZipList(..), + -- * Utility functions + (<$>), (<$), (*>), (<*), (<**>), + liftA, liftA2, liftA3, + optional, some, many + ) where + +#ifdef __HADDOCK__ +import Prelude +#endif + +import Control.Monad.Instances () + + +import Control.Arrow + (Arrow(arr, (>>>), (&&&)), ArrowZero(zeroArrow), ArrowPlus((<+>))) +import Control.Monad (liftM, ap, MonadPlus(..)) +import Data.Monoid (Monoid(..)) + +infixl 3 <|> +infixl 4 <$>, <$ +infixl 4 <*>, <*, *>, <**> + +-- | A functor with application. +-- +-- Instances should satisfy the following laws: +-- +-- [/identity/] +-- @'pure' 'id' '<*>' v = v@ +-- +-- [/composition/] +-- @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@ +-- +-- [/homomorphism/] +-- @'pure' f '<*>' 'pure' x = 'pure' (f x)@ +-- +-- [/interchange/] +-- @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@ +-- +-- The 'Functor' instance should satisfy +-- +-- @ +-- 'fmap' f x = 'pure' f '<*>' x +-- @ +-- +-- If @f@ is also a 'Monad', define @'pure' = 'return'@ and @('<*>') = 'ap'@. + +class Functor f => Applicative f where + -- | Lift a value. + pure :: a -> f a + + -- | Sequential application. + (<*>) :: f (a -> b) -> f a -> f b + +-- | A monoid on applicative functors. +class Applicative f => Alternative f where + -- | The identity of '<|>' + empty :: f a + -- | An associative binary operation + (<|>) :: f a -> f a -> f a + +-- instances for Prelude types + +instance Applicative Maybe where + pure = return + (<*>) = ap + +instance Alternative Maybe where + empty = Nothing + Nothing <|> p = p + Just x <|> _ = Just x + +instance Applicative [] where + pure = return + (<*>) = ap + +instance Alternative [] where + empty = [] + (<|>) = (++) + +instance Applicative IO where + pure = return + (<*>) = ap + +instance Applicative ((->) a) where + pure = const + (<*>) f g x = f x (g x) + +instance Monoid a => Applicative ((,) a) where + pure x = (mempty, x) + (u, f) <*> (v, x) = (u `mappend` v, f x) + +-- new instances + +newtype Const a b = Const { getConst :: a } + +instance Functor (Const m) where + fmap _ (Const v) = Const v + +instance Monoid m => Applicative (Const m) where + pure _ = Const mempty + Const f <*> Const v = Const (f `mappend` v) + +newtype WrappedMonad m a = WrapMonad { unwrapMonad :: m a } + +instance Monad m => Functor (WrappedMonad m) where + fmap f (WrapMonad v) = WrapMonad (liftM f v) + +instance Monad m => Applicative (WrappedMonad m) where + pure = WrapMonad . return + WrapMonad f <*> WrapMonad v = WrapMonad (f `ap` v) + +instance MonadPlus m => Alternative (WrappedMonad m) where + empty = WrapMonad mzero + WrapMonad u <|> WrapMonad v = WrapMonad (u `mplus` v) + +newtype WrappedArrow a b c = WrapArrow { unwrapArrow :: a b c } + +instance Arrow a => Functor (WrappedArrow a b) where + fmap f (WrapArrow a) = WrapArrow (a >>> arr f) + +instance Arrow a => Applicative (WrappedArrow a b) where + pure x = WrapArrow (arr (const x)) + WrapArrow f <*> WrapArrow v = WrapArrow (f &&& v >>> arr (uncurry id)) + +instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where + empty = WrapArrow zeroArrow + WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v) + +-- | Lists, but with an 'Applicative' functor based on zipping, so that +-- +-- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@ +-- +newtype ZipList a = ZipList { getZipList :: [a] } + +instance Functor ZipList where + fmap f (ZipList xs) = ZipList (map f xs) + +instance Applicative ZipList where + pure x = ZipList (repeat x) + ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs) + +-- extra functions + +-- | A synonym for 'fmap'. +(<$>) :: Functor f => (a -> b) -> f a -> f b +f <$> a = fmap f a + +-- | Replace the value. +(<$) :: Functor f => a -> f b -> f a +(<$) = (<$>) . const + +-- | Sequence actions, discarding the value of the first argument. +(*>) :: Applicative f => f a -> f b -> f b +(*>) = liftA2 (const id) + +-- | Sequence actions, discarding the value of the second argument. +(<*) :: Applicative f => f a -> f b -> f a +(<*) = liftA2 const + +-- | A variant of '<*>' with the arguments reversed. +(<**>) :: Applicative f => f a -> f (a -> b) -> f b +(<**>) = liftA2 (flip ($)) + +-- | Lift a function to actions. +-- This function may be used as a value for `fmap` in a `Functor` instance. +liftA :: Applicative f => (a -> b) -> f a -> f b +liftA f a = pure f <*> a + +-- | Lift a binary function to actions. +liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c +liftA2 f a b = f <$> a <*> b + +-- | Lift a ternary function to actions. +liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d +liftA3 f a b c = f <$> a <*> b <*> c + +-- | One or none. +optional :: Alternative f => f a -> f (Maybe a) +optional v = Just <$> v <|> pure Nothing + +-- | One or more. +some :: Alternative f => f a -> f [a] +some v = some_v + where many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v + +-- | Zero or more. +many :: Alternative f => f a -> f [a] +many v = many_v + where many_v = some_v <|> pure [] + some_v = (:) <$> v <*> many_v diff --git a/Control/Monad/Instances.hs b/Control/Monad/Instances.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Instances.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_NHC98 --prelude #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Instances +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- 'Functor' and 'Monad' instances for @(->) r@ and +-- 'Functor' instances for @(,) a@ and @'Either' a@. + +module Control.Monad.Instances (Functor(..),Monad(..)) where + +import Prelude + +import Control.Monad.Reader () +import Control.Monad.Error () + +{- +instance Functor ((->) r) where + fmap = (.) + +instance Monad ((->) r) where + return = const + f >>= k = \ r -> k (f r) r +-} + +instance Functor ((,) a) where + fmap f (x,y) = (x, f y) + +{- +instance Functor (Either a) where + fmap _ (Left x) = Left x + fmap f (Right y) = Right (f y) +-} diff --git a/Data/Foldable.hs b/Data/Foldable.hs new file mode 100644 --- /dev/null +++ b/Data/Foldable.hs @@ -0,0 +1,298 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Foldable +-- Copyright : Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Class of data structures that can be folded to a summary value. +-- +-- Many of these functions generalize "Prelude", "Control.Monad" and +-- "Data.List" functions of the same names from lists to any 'Foldable' +-- functor. To avoid ambiguity, either import those modules hiding +-- these names or qualify uses of these function names with an alias +-- for this module. + +module Data.Foldable ( + -- * Folds + Foldable(..), + -- ** Special biased folds + foldr', + foldl', + foldrM, + foldlM, + -- ** Folding actions + -- *** Applicative actions + traverse_, + for_, + sequenceA_, + asum, + -- *** Monadic actions + mapM_, + forM_, + sequence_, + msum, + -- ** Specialized folds + toList, + concat, + concatMap, + and, + or, + any, + all, + sum, + product, + maximum, + maximumBy, + minimum, + minimumBy, + -- ** Searches + elem, + notElem, + find + ) where + +import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_, + elem, notElem, concat, concatMap, and, or, any, all, + sum, product, maximum, minimum) +import qualified Prelude (foldl, foldr, foldl1, foldr1) +import Control.Applicative +import Control.Monad (MonadPlus(..)) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Monoid (Monoid(..), ) +import Data.MonoidExample + +#ifdef __NHC__ +import Control.Arrow (ArrowZero(..)) -- work around nhc98 typechecker problem +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts (build) +#endif + +-- | Data structures that can be folded. +-- +-- Minimal complete definition: 'foldMap' or 'foldr'. +-- +-- For example, given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Foldable Tree +-- > foldMap f Empty = mempty +-- > foldMap f (Leaf x) = f x +-- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r +-- +-- This is suitable even for abstract types, as the monoid is assumed +-- to satisfy the monoid laws. +-- +class Foldable t where + -- | Combine the elements of a structure using a monoid. + fold :: Monoid m => t m -> m + fold = foldMap id + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMap :: Monoid m => (a -> m) -> t a -> m + foldMap f = foldr (mappend . f) mempty + + -- | Right-associative fold of a structure. + -- + -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ + foldr :: (a -> b -> b) -> b -> t a -> b + foldr f z t = appEndo (foldMap (Endo . f) t) z + + -- | Left-associative fold of a structure. + -- + -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ + foldl :: (a -> b -> a) -> a -> t b -> a + foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z + + -- | A variant of 'foldr' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ + foldr1 :: (a -> a -> a) -> t a -> a + foldr1 f xs = fromMaybe (error "foldr1: empty structure") + (foldr mf Nothing xs) + where mf x Nothing = Just x + mf x (Just y) = Just (f x y) + + -- | A variant of 'foldl' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ + foldl1 :: (a -> a -> a) -> t a -> a + foldl1 f xs = fromMaybe (error "foldl1: empty structure") + (foldl mf Nothing xs) + where mf Nothing y = Just y + mf (Just x) y = Just (f x y) + +-- instances for Prelude types + +instance Foldable Maybe where + foldr _f z Nothing = z + foldr f z (Just x) = f x z + + foldl _f z Nothing = z + foldl f z (Just x) = f z x + +instance Foldable [] where + foldr = Prelude.foldr + foldl = Prelude.foldl + foldr1 = Prelude.foldr1 + foldl1 = Prelude.foldl1 + +-- | Fold over the elements of a structure, +-- associating to the right, but strictly. +foldr' :: Foldable t => (a -> b -> b) -> b -> t a -> b +foldr' f z xs = foldl f' id xs z + where f' k x w = k $! f x w + +-- | Monadic fold over the elements of a structure, +-- associating to the right, i.e. from right to left. +foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b +foldrM f z xs = foldl f' return xs z + where f' k x w = f x w >>= k + +-- | Fold over the elements of a structure, +-- associating to the left, but strictly. +foldl' :: Foldable t => (a -> b -> a) -> a -> t b -> a +foldl' f z xs = foldr f' id xs z + where f' x k w = k $! f w x + +-- | Monadic fold over the elements of a structure, +-- associating to the left, i.e. from left to right. +foldlM :: (Foldable t, Monad m) => (a -> b -> m a) -> a -> t b -> m a +foldlM f z xs = foldr f' return xs z + where f' x k w = f w x >>= k + +-- | Map each element of a structure to an action, evaluate +-- these actions from left to right, and ignore the results. +traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f () +traverse_ f = foldr ((*>) . f) (pure ()) + +-- | 'for_' is 'traverse_' with its arguments flipped. +for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f () +{-# INLINE for_ #-} +for_ = flip traverse_ + +-- | Map each element of a structure to a monadic action, evaluate +-- these actions from left to right, and ignore the results. +mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m () +mapM_ f = foldr ((>>) . f) (return ()) + +-- | 'forM_' is 'mapM_' with its arguments flipped. +forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m () +{-# INLINE forM_ #-} +forM_ = flip mapM_ + +-- | Evaluate each action in the structure from left to right, +-- and ignore the results. +sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f () +sequenceA_ = foldr (*>) (pure ()) + +-- | Evaluate each monadic action in the structure from left to right, +-- and ignore the results. +sequence_ :: (Foldable t, Monad m) => t (m a) -> m () +sequence_ = foldr (>>) (return ()) + +-- | The sum of a collection of actions, generalizing 'concat'. +asum :: (Foldable t, Alternative f) => t (f a) -> f a +{-# INLINE asum #-} +asum = foldr (<|>) empty + +-- | The sum of a collection of actions, generalizing 'concat'. +msum :: (Foldable t, MonadPlus m) => t (m a) -> m a +{-# INLINE msum #-} +msum = foldr mplus mzero + +-- These use foldr rather than foldMap to avoid repeated concatenation. + +-- | List of elements of a structure. +toList :: Foldable t => t a -> [a] +#ifdef __GLASGOW_HASKELL__ +toList t = build (\ c n -> foldr c n t) +#else +toList = foldr (:) [] +#endif + +-- | The concatenation of all the elements of a container of lists. +concat :: Foldable t => t [a] -> [a] +concat = fold + +-- | Map a function over all the elements of a container and concatenate +-- the resulting lists. +concatMap :: Foldable t => (a -> [b]) -> t a -> [b] +concatMap = foldMap + +-- | 'and' returns the conjunction of a container of Bools. For the +-- result to be 'True', the container must be finite; 'False', however, +-- results from a 'False' value finitely far from the left end. +and :: Foldable t => t Bool -> Bool +and = getAll . foldMap All + +-- | 'or' returns the disjunction of a container of Bools. For the +-- result to be 'False', the container must be finite; 'True', however, +-- results from a 'True' value finitely far from the left end. +or :: Foldable t => t Bool -> Bool +or = getAny . foldMap Any + +-- | Determines whether any element of the structure satisfies the predicate. +any :: Foldable t => (a -> Bool) -> t a -> Bool +any p = getAny . foldMap (Any . p) + +-- | Determines whether all elements of the structure satisfy the predicate. +all :: Foldable t => (a -> Bool) -> t a -> Bool +all p = getAll . foldMap (All . p) + +-- | The 'sum' function computes the sum of the numbers of a structure. +sum :: (Foldable t, Num a) => t a -> a +sum = getSum . foldMap Sum + +-- | The 'product' function computes the product of the numbers of a structure. +product :: (Foldable t, Num a) => t a -> a +product = getProduct . foldMap Product + +-- | The largest element of a non-empty structure. +maximum :: (Foldable t, Ord a) => t a -> a +maximum = foldr1 max + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a +maximumBy cmp = foldr1 max' + where max' x y = case cmp x y of + GT -> x + _ -> y + +-- | The least element of a non-empty structure. +minimum :: (Foldable t, Ord a) => t a -> a +minimum = foldr1 min + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. +minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a +minimumBy cmp = foldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x + +-- | Does the element occur in the structure? +elem :: (Foldable t, Eq a) => a -> t a -> Bool +elem = any . (==) + +-- | 'notElem' is the negation of 'elem'. +notElem :: (Foldable t, Eq a) => a -> t a -> Bool +notElem x = not . elem x + +-- | The 'find' function takes a predicate and a structure and returns +-- the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +find :: Foldable t => (a -> Bool) -> t a -> Maybe a +find p = listToMaybe . concatMap (\ x -> if p x then [x] else []) diff --git a/Data/MonoidExample.hs b/Data/MonoidExample.hs new file mode 100644 --- /dev/null +++ b/Data/MonoidExample.hs @@ -0,0 +1,259 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Monoid +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The Monoid class with various general-purpose instances. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Data.MonoidExample ( + -- * Monoid typeclass + Dual(..), + Endo(..), + -- * Bool wrappers + All(..), + Any(..), + -- * Num wrappers + Sum(..), + Product(..), + -- * Maybe wrappers + -- $MaybeExamples + First(..), + Last(..) + ) where + +import Prelude +import Data.Monoid (Monoid(..), ) + + +{- +-- just for testing +import Data.Maybe +import Test.QuickCheck +-- -} + +{- +-- --------------------------------------------------------------------------- +-- | The monoid class. +-- A minimal complete definition must supply 'mempty' and 'mappend', +-- and these should satisfy the monoid laws. + +class Monoid a where + mempty :: a + -- ^ Identity of 'mappend' + mappend :: a -> a -> a + -- ^ An associative operation + mconcat :: [a] -> a + + -- ^ Fold a list using the monoid. + -- For most types, the default definition for 'mconcat' will be + -- used, but the function is included in the class definition so + -- that an optimized version can be provided for specific types. + + mconcat = foldr mappend mempty + +-- Monoid instances. + +instance Monoid [a] where + mempty = [] + mappend = (++) + +instance Monoid b => Monoid (a -> b) where + mempty _ = mempty + mappend f g x = f x `mappend` g x + +instance Monoid () where + -- Should it be strict? + mempty = () + _ `mappend` _ = () + mconcat _ = () + +instance (Monoid a, Monoid b) => Monoid (a,b) where + mempty = (mempty, mempty) + (a1,b1) `mappend` (a2,b2) = + (a1 `mappend` a2, b1 `mappend` b2) + +instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where + mempty = (mempty, mempty, mempty) + (a1,b1,c1) `mappend` (a2,b2,c2) = + (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2) + +instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where + mempty = (mempty, mempty, mempty, mempty) + (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) = + (a1 `mappend` a2, b1 `mappend` b2, + c1 `mappend` c2, d1 `mappend` d2) + +instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) => + Monoid (a,b,c,d,e) where + mempty = (mempty, mempty, mempty, mempty, mempty) + (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) = + (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2, + d1 `mappend` d2, e1 `mappend` e2) + +-- lexicographical ordering +instance Monoid Ordering where + mempty = EQ + LT `mappend` _ = LT + EQ `mappend` y = y + GT `mappend` _ = GT +-} + + +-- | The dual of a monoid, obtained by swapping the arguments of 'mappend'. +newtype Dual a = Dual { getDual :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Monoid a => Monoid (Dual a) where + mempty = Dual mempty + Dual x `mappend` Dual y = Dual (y `mappend` x) + +-- | The monoid of endomorphisms under composition. +newtype Endo a = Endo { appEndo :: a -> a } + +instance Monoid (Endo a) where + mempty = Endo id + Endo f `mappend` Endo g = Endo (f . g) + +-- | Boolean monoid under conjunction. +newtype All = All { getAll :: Bool } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Monoid All where + mempty = All True + All x `mappend` All y = All (x && y) + +-- | Boolean monoid under disjunction. +newtype Any = Any { getAny :: Bool } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Monoid Any where + mempty = Any False + Any x `mappend` Any y = Any (x || y) + +-- | Monoid under addition. +newtype Sum a = Sum { getSum :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Num a => Monoid (Sum a) where + mempty = Sum 0 + Sum x `mappend` Sum y = Sum (x + y) + +-- | Monoid under multiplication. +newtype Product a = Product { getProduct :: a } + deriving (Eq, Ord, Read, Show, Bounded) + +instance Num a => Monoid (Product a) where + mempty = Product 1 + Product x `mappend` Product y = Product (x * y) + +-- $MaybeExamples +-- To implement @find@ or @findLast@ on any 'Foldable': +-- +-- @ +-- findLast :: Foldable t => (a -> Bool) -> t a -> Maybe a +-- findLast pred = getLast . foldMap (\x -> if pred x +-- then Last (Just x) +-- else Last Nothing) +-- @ +-- +-- Much of Data.Map's interface can be implemented with +-- Data.Map.alter. Some of the rest can be implemented with a new +-- @alterA@ function and either 'First' or 'Last': +-- +-- > alterA :: (Applicative f, Ord k) => +-- > (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a) +-- > +-- > instance Monoid a => Applicative ((,) a) -- from Control.Applicative +-- +-- @ +-- insertLookupWithKey :: Ord k => (k -> v -> v -> v) -> k -> v +-- -> Map k v -> (Maybe v, Map k v) +-- insertLookupWithKey combine key value = +-- Arrow.first getFirst . alterA doChange key +-- where +-- doChange Nothing = (First Nothing, Just value) +-- doChange (Just oldValue) = +-- (First (Just oldValue), +-- Just (combine key value oldValue)) +-- @ + +-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to +-- : \"Any semigroup @S@ may be +-- turned into a monoid simply by adjoining an element @e@ not in @S@ +-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since +-- there is no \"Semigroup\" typeclass providing just 'mappend', we +-- use 'Monoid' instead. +{- +instance Monoid a => Monoid (Maybe a) where + mempty = Nothing + Nothing `mappend` m = m + m `mappend` Nothing = m + Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) +-} + + +-- | Maybe monoid returning the leftmost non-Nothing value. +newtype First a = First { getFirst :: Maybe a } +#ifndef __HADDOCK__ + deriving (Eq, Ord, Read, Show) +#else /* __HADDOCK__ */ +instance Eq a => Eq (First a) +instance Ord a => Ord (First a) +instance Read a => Read (First a) +instance Show a => Show (First a) +#endif + +instance Monoid (First a) where + mempty = First Nothing + r@(First (Just _)) `mappend` _ = r + First Nothing `mappend` r = r + +-- | Maybe monoid returning the rightmost non-Nothing value. +newtype Last a = Last { getLast :: Maybe a } +#ifndef __HADDOCK__ + deriving (Eq, Ord, Read, Show) +#else /* __HADDOCK__ */ +instance Eq a => Eq (Last a) +instance Ord a => Ord (Last a) +instance Read a => Read (Last a) +instance Show a => Show (Last a) +#endif + +instance Monoid (Last a) where + mempty = Last Nothing + _ `mappend` r@(Last (Just _)) = r + r `mappend` Last Nothing = r + +{- +{-------------------------------------------------------------------- + Testing +--------------------------------------------------------------------} +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = oneof [return Nothing, Just `fmap` arbitrary] + +prop_mconcatMaybe :: [Maybe [Int]] -> Bool +prop_mconcatMaybe x = + fromMaybe [] (mconcat x) == mconcat (catMaybes x) + +prop_mconcatFirst :: [Maybe Int] -> Bool +prop_mconcatFirst x = + getFirst (mconcat (map First x)) == listToMaybe (catMaybes x) +prop_mconcatLast :: [Maybe Int] -> Bool +prop_mconcatLast x = + getLast (mconcat (map Last x)) == listLastToMaybe (catMaybes x) + where listLastToMaybe [] = Nothing + listLastToMaybe lst = Just (last lst) +-- -} diff --git a/Data/Traversable.hs b/Data/Traversable.hs new file mode 100644 --- /dev/null +++ b/Data/Traversable.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Traversable +-- Copyright : Conor McBride and Ross Paterson 2005 +-- License : BSD-style (see the LICENSE file in the distribution) +-- +-- Maintainer : ross@soi.city.ac.uk +-- Stability : experimental +-- Portability : portable +-- +-- Class of data structures that can be traversed from left to right, +-- performing an action on each element. +-- +-- See also +-- +-- * /Applicative Programming with Effects/, +-- by Conor McBride and Ross Paterson, online at +-- . +-- +-- * /The Essence of the Iterator Pattern/, +-- by Jeremy Gibbons and Bruno Oliveira, +-- in /Mathematically-Structured Functional Programming/, 2006, and online at +-- . +-- +-- Note that the functions 'mapM' and 'sequence' generalize "Prelude" +-- functions of the same names from lists to any 'Traversable' functor. +-- To avoid ambiguity, either import the "Prelude" hiding these names +-- or qualify uses of these function names with an alias for this module. + +module Data.Traversable ( + Traversable(..), + for, + forM, + fmapDefault, + foldMapDefault, + ) where + +import Prelude hiding (mapM, sequence, foldr) +import qualified Prelude (mapM, foldr) +import Control.Applicative +import Data.Foldable (Foldable()) +import Data.Monoid (Monoid) + +-- | Functors representing data structures that can be traversed from +-- left to right. +-- +-- Minimal complete definition: 'traverse' or 'sequenceA'. +-- +-- Instances are similar to 'Functor', e.g. given a data type +-- +-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a) +-- +-- a suitable instance would be +-- +-- > instance Traversable Tree +-- > traverse f Empty = pure Empty +-- > traverse f (Leaf x) = Leaf <$> f x +-- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r +-- +-- This is suitable even for abstract types, as the laws for '<*>' +-- imply a form of associativity. +-- +-- The superclass instances should satisfy the following: +-- +-- * In the 'Functor' instance, 'fmap' should be equivalent to traversal +-- with the identity applicative functor ('fmapDefault'). +-- +-- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be +-- equivalent to traversal with a constant applicative functor +-- ('foldMapDefault'). +-- +class (Functor t, Foldable t) => Traversable t where + -- | Map each element of a structure to an action, evaluate + -- these actions from left to right, and collect the results. + traverse :: Applicative f => (a -> f b) -> t a -> f (t b) + traverse f = sequenceA . fmap f + + -- | Evaluate each action in the structure from left to right, + -- and collect the results. + sequenceA :: Applicative f => t (f a) -> f (t a) + sequenceA = traverse id + + -- | Map each element of a structure to a monadic action, evaluate + -- these actions from left to right, and collect the results. + mapM :: Monad m => (a -> m b) -> t a -> m (t b) + mapM f = unwrapMonad . traverse (WrapMonad . f) + + -- | Evaluate each monadic action in the structure from left to right, + -- and collect the results. + sequence :: Monad m => t (m a) -> m (t a) + sequence = mapM id + +-- instances for Prelude types + +instance Traversable Maybe where + traverse _f Nothing = pure Nothing + traverse f (Just x) = Just <$> f x + +instance Traversable [] where + traverse f = Prelude.foldr cons_f (pure []) + where cons_f x ys = (:) <$> f x <*> ys + + mapM = Prelude.mapM + +-- general functions + +-- | 'for' is 'traverse' with its arguments flipped. +for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b) +{-# INLINE for #-} +for = flip traverse + +-- | 'forM' is 'mapM' with its arguments flipped. +forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b) +{-# INLINE forM #-} +forM = flip mapM + +-- | This function may be used as a value for `fmap` in a `Functor` instance. +fmapDefault :: Traversable t => (a -> b) -> t a -> t b +fmapDefault f = getId . traverse (Id . f) + +-- | This function may be used as a value for `Data.Foldable.foldMap` +-- in a `Foldable` instance. +foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m +foldMapDefault f = getConst . traverse (Const . f) + +-- local instances + +newtype Id a = Id { getId :: a } + +instance Functor Id where + fmap f (Id x) = Id (f x) + +instance Applicative Id where + pure = Id + Id f <*> Id x = Id (f x) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,83 @@ +This library (libraries/base) is derived from code from several +sources: + + * Code from the GHC project which is largely (c) The University of + Glasgow, and distributable under a BSD-style license (see below), + + * Code from the Haskell 98 Report which is (c) Simon Peyton Jones + and freely redistributable (but see the full license for + restrictions). + + * Code from the Haskell Foreign Function Interface specification, + which is (c) Manuel M. T. Chakravarty and freely redistributable + (but see the full license for restrictions). + +The full text of these licenses is reproduced below. All of the +licenses are BSD-style or compatible. + +----------------------------------------------------------------------------- + +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +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 name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE 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 +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE 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. + +----------------------------------------------------------------------------- + +Code derived from the document "Report on the Programming Language +Haskell 98", is distributed under the following license: + + Copyright (c) 2002 Simon Peyton Jones + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Language. + +----------------------------------------------------------------------------- + +Code derived from the document "The Haskell 98 Foreign Function +Interface, An Addendum to the Haskell 98 Report" is distributed under +the following license: + + Copyright (c) 2002 Manuel M. T. Chakravarty + + The authors intend this Report to belong to the entire Haskell + community, and so we grant permission to copy and distribute it for + any purpose, provided that it is reproduced in its entirety, + including this Notice. Modified versions of this Report may also be + copied and distributed for any purpose, provided that the modified + version is clearly presented as such, and that it does not claim to + be a definition of the Haskell 98 Foreign Function Interface. + +----------------------------------------------------------------------------- diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,10 @@ +These are the modules for applicative functors and friends, +as found in GHC-6.6 and higher. +We provide them for use in versions up to GHC-6.4. +This package can be used for backward compatibility. + + +ToDo: + +Add various instances of Foldable and Traversable for base types like Map, +but these will be less efficient as you don't have access to their implementations. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/special-functors.cabal b/special-functors.cabal new file mode 100644 --- /dev/null +++ b/special-functors.cabal @@ -0,0 +1,25 @@ +Name: special-functors +Version: 1.0 +Synopsis: Control.Applicative, Data.Foldable, Data.Traversable (compatibility package) +Category: Generics +Description: + This package contains Control.Applicative, Data.Foldable, Data.Traversable + from 6.8's base for use in earlier GHC versions +License: BSD3 +License-file: LICENSE +Author: libraries@haskell.org +Maintainer: haskell@henning-thielemann.de +Tested-With: GHC==6.4.1 +Build-Depends: base<2, mtl +Build-Type: Simple +Extensions: CPP +GHC-Options: -funbox-strict-fields -Wall +GHC-Prof-Options: -funbox-strict-fields -auto-all -Wall +Exposed-Modules: + Control.Monad.Instances + Control.Applicative + Data.Foldable + Data.Traversable +Other-Modules: + Data.MonoidExample +Extra-Source-Files: README