diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Donnacha Oisín Kidney + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/constrained-monads.cabal b/constrained-monads.cabal new file mode 100644 --- /dev/null +++ b/constrained-monads.cabal @@ -0,0 +1,53 @@ +name: constrained-monads +version: 0.1.0.0 +synopsis: Typeclasses and instances for monads with constraints. +description: A library for monads with constraints over the types they contain. This allows set, etc to conform to the monad class. It is structured as a prelude replacement: everything that doesn't conflict with the new definitions of 'Functor', 'Monad', etc is reexported. + +homepage: https://github.com/oisdk/constrained-monads#readme +license: MIT +license-file: LICENSE +author: Donnacha Oisín Kidney +maintainer: mail@doisinkidney.com +copyright: 2016 Donnacha Oisín Kidney +category: Control +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Control.Monad.Constrained + , Control.Monad.Constrained.Trans + , Control.Monad.Constrained.State + , Control.Monad.Constrained.Reader + , Control.Monad.Constrained.Error + , Control.Monad.Constrained.Writer + , Control.Monad.Constrained.IO + , Control.Monad.Constrained.Cont + , Control.Monad.Constrained.IntSet + build-depends: base >= 4.9 && < 5 + , containers >= 0.5 + , transformers >= 0.5 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite constrained-monads-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base >= 4.9 && < 5 + , constrained-monads >= 0.1 + , doctest >= 0.11 + , QuickCheck >= 2.8 + , containers >= 0.5 + , transformers >= 0.5 + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + -Wall + default-language: Haskell2010 + + + +source-repository head + type: git + location: https://github.com/oisdk/constrained-monads diff --git a/src/Control/Monad/Constrained.hs b/src/Control/Monad/Constrained.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained.hs @@ -0,0 +1,1207 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | A module for constrained monads. This module is intended to be imported +-- with the @-XRebindableSyntax@ extension turned on: everything from the +-- "Prelude" (that doesn't conflict with the new 'Functor', 'Applicative', etc) is +-- reexported, so these type classes can be used the same way that the "Prelude" +-- classes are used. +module Control.Monad.Constrained + ( + -- * Basic Classes + Functor(..) + ,Applicative(..) + ,Monad(..) + ,Alternative(..) + ,Traversable(..) + , + -- * Horrible type-level stuff + Vect(..) + ,AppVect(..) + ,liftAP + ,liftAM + , + -- * Useful functions + guard + ,ensure + ,(<**>) + ,(<$>) + ,(=<<) + ,(<=<) + ,(>=>) + ,foldM + ,traverse_ + ,sequenceA + ,sequenceA_ + ,mapAccumL + ,replicateM + ,void + ,forever + ,for_ + , + -- * Syntax + ifThenElse + ,fail + ,(>>) + ,return + ,module RestPrelude) + where + +import GHC.Exts + +import Prelude as RestPrelude hiding (Applicative (..), + Functor (..), + Monad (..), + Traversable (..), + (<$>), (=<<)) + +import qualified Control.Applicative +import qualified Prelude + +import Data.Functor.Identity (Identity (..)) + +import Data.IntMap.Strict (IntMap) +import Data.Map.Strict (Map) +import Data.Sequence (Seq) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Tree (Tree(..)) + +import Control.Monad.Trans.Cont (ContT) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Control.Monad.Trans.Identity (IdentityT (..)) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Control.Monad.Trans.Reader (ReaderT (..), mapReaderT) +import Control.Monad.Trans.State (StateT (..)) +import qualified Control.Monad.Trans.State.Strict as Strict (StateT (..)) +import Control.Monad.Trans.State.Strict (state, runState) + +import Control.Arrow (first) +import Data.Tuple (swap) + +-------------------------------------------------------------------------------- +-- Type-level shenanigans +-------------------------------------------------------------------------------- + +-- | A heterogeneous list, for storing the arguments to 'liftA'. (There /has/ to +-- be a better way to do this). +infixr 5 :- +data Vect xs where + Nil :: Vect '[] + (:-) :: x -> Vect xs -> Vect (x ': xs) + +-- | Another heterogeneous list, for storing the arguments to 'liftA', wrapped +-- in their applicatives. +infixr 5 :* +data AppVect f xs where + NilA :: AppVect f '[] + (:*) :: f x -> AppVect f xs -> AppVect f (x ': xs) + +-------------------------------------------------------------------------------- +-- Standard classes +-------------------------------------------------------------------------------- + +-- | This is the same class as 'Prelude.Functor' from the Prelude. Most of the +-- functions here are simply rewritten versions of those, with one difference: +-- types can indicate /which/ types they can contain. This allows +-- 'Data.Set.Set' to be made into a monad, as well as some other exotic types. +-- (but, to be fair, 'Data.Set.Set' is kind of the poster child for this +-- technique). +-- +-- The way that types indicate what they can contain is with the 'Suitable' +-- associated type. +-- +-- The default implementation is for types which conform to the "Prelude"'s +-- 'Prelude.Functor'. The way to make a standard 'Prelude.Functor' conform +-- is by indicating that it has no constraints. For instance, for @[]@: +-- +-- @instance 'Functor' [] where +-- type 'Suitable' [] a = () +-- fmap = map +-- (<$) = (Prelude.<$)@ +-- +-- Monomorphic types can also conform, using GADT aliases. For instance, +-- if you create an alias for 'Data.IntSet.IntSet' of kind @* -> *@: +-- +-- @data IntSet a where +-- IntSet :: IntSet.'Data.IntSet.IntSet' -> IntSet 'Int'@ +-- +-- It can be made to conform to 'Functor' like so: +-- +-- @instance 'Functor' IntSet where +-- type 'Suitable' IntSet a = a ~ 'Int' +-- 'fmap' f (IntSet xs) = IntSet (IntSet.'Data.IntSet.map' f xs) +-- x '<$' xs = if 'null' xs then 'empty' else 'pure' x@ +-- +-- It can also be made conform to 'Foldable', etc. This type is provided in +-- "Control.Monad.Constrained.IntSet". +class Functor f where + {-# MINIMAL fmap #-} + -- | Indicate which types can be contained by 'f'. For instance, + -- 'Data.Set.Set' conforms like so: + -- + -- @instance 'Functor' 'Set' where + -- type 'Suitable' 'Set' a = 'Ord' a + -- 'fmap' = 'Set.map'@ + type Suitable f a :: Constraint + + -- | Maps a function over a functor + fmap + :: Suitable f b + => (a -> b) -> f a -> f b + + -- | Replace all values in the input with a default value. + infixl 4 <$ + (<$) :: Suitable f a => a -> f b -> f a + (<$) = fmap . const + {-# INLINE (<$) #-} + +-- | A functor with application. +-- +-- This class is slightly different (although equivalent) to the class +-- provided in the Prelude. This is to facilitate the lifting of functions +-- to arbitrary numbers of arguments. +-- +-- A minimal complete definition must include implementations of 'liftA' +-- functions satisfying 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 other methods have the following default definitions, which may +-- be overridden with equivalent specialized implementations: +-- +-- * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@ +-- +-- * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@ +-- +-- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy +-- +-- * @'fmap' f x = 'pure' f '<*>' x@ +-- +-- If @f@ is also a 'Monad', it should satisfy +-- +-- * @'pure' = 'return'@ +-- +-- * @('<*>') = 'ap'@ +-- +-- (which implies that 'pure' and '<*>' satisfy the applicative functor laws). +class Functor f => + Applicative f where + {-# MINIMAL liftA #-} + + -- | Lift a value. + pure + :: Suitable f a + => a -> f a + pure x = liftA (\Nil -> x) NilA + {-# INLINE pure #-} + + infixl 4 <*> + + -- | Sequential application. + (<*>) + :: Suitable f b + => f (a -> b) -> f a -> f b + fs <*> xs = liftA (\(f :- x :- Nil) -> f x) (fs :* xs :* NilA) + {-# INLINE (<*>) #-} + + infixl 4 *> + -- | Sequence actions, discarding the value of the first argument. + (*>) + :: Suitable f b + => f a -> f b -> f b + (*>) = liftA2 (const id) + {-# INLINE (*>) #-} + + infixl 4 <* + -- | Sequence actions, discarding the value of the second argument. + (<*) + :: Suitable f a + => f a -> f b -> f a + (<*) = liftA2 const + {-# INLINE (<*) #-} + -- | The shenanigans introduced by this function are to account for the fact + -- that you can't (I don't think) write an arbitrary lift function on + -- non-monadic applicatives that have constrained types. For instance, if + -- the only present functions are: + -- + -- @'pure' :: 'Suitable' f a => a -> f b + --'fmap' :: 'Suitable' f b => (a -> b) -> f a -> f b + --('<*>') :: 'Suitable' f b => f (a -> b) -> f a -> f b@ + -- + -- I can't see a way to define: + -- + -- @'liftA2' :: 'Suitable' f c => (a -> b -> c) -> f a -> f b -> f c@ + -- + -- Of course, if: + -- + -- @('>>=') :: 'Suitable' f b => f a -> (a -> f b) -> f b@ + -- + -- is available, 'liftA2' could be defined as: + -- + -- @'liftA2' f xs ys = do + -- x <- xs + -- y <- ys + -- 'pure' (f x)@ + -- + -- But now we can't define the 'liftA' functions for things which are + -- 'Applicative' but not 'Monad' (square matrices, + -- 'Control.Applicative.ZipList's, etc). Also, some types have a more + -- efficient @('<*>')@ than @('>>=')@ (see, for instance, the + -- + -- monad). + -- + -- The one missing piece is @-XApplicativeDo@: I can't figure out a way + -- to get do-notation to desugar to using the 'liftA' functions, rather + -- than @('<*>')@. + -- + -- It would also be preferable to avoid the two intermediate structures + -- ('Vect', 'AppVect', etc). Ideally GHC would optimize them away, but + -- it seems unlikely. + -- + -- Utility definitions of this function are provided: if your 'Applicative' + -- is a @Prelude.'Prelude.Applicative'@, 'liftA' can be defined in terms of + -- @('<*>')@. 'liftAP' does exactly this. + -- + -- Alternatively, if your applicative is a 'Monad', 'liftA' can be defined + -- in terms of @('>>=')@, which is what 'liftAM' does. + liftA + :: Suitable f b + => (Vect xs -> b) -> AppVect f xs -> f b + + liftA2 + :: Suitable f c + => (a -> b -> c) -> f a -> f b -> f c + liftA2 f xs ys = + liftA + (\(x :- y :- Nil) -> + f x y) + (xs :* ys :* NilA) + liftA3 + :: Suitable f d + => (a -> b -> c -> d) -> f a -> f b -> f c -> f d + liftA3 f xs ys zs = + liftA + (\(x :- y :- z :- Nil) -> + f x y z) + (xs :* ys :* zs :* NilA) + liftA4 + :: Suitable f e + => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e + liftA4 f ws xs ys zs = + liftA + (\(w :- x :- y :- z :- Nil) -> + f w x y z) + (ws :* xs :* ys :* zs :* NilA) + liftA5 + :: Suitable f g + => (a -> b -> c -> d -> e -> g) + -> f a + -> f b + -> f c + -> f d + -> f e + -> f g + liftA5 f vs ws xs ys zs = + liftA + (\(v :- w :- x :- y :- z :- Nil) -> + f v w x y z) + (vs :* ws :* xs :* ys :* zs :* NilA) + + liftA6 + :: Suitable f h + => (a -> b -> c -> d -> e -> g -> h) + -> f a + -> f b + -> f c + -> f d + -> f e + -> f g + -> f h + liftA6 f us vs ws xs ys zs = + liftA + (\(u :- v :- w :- x :- y :- z :- Nil) -> + f u v w x y z) + (us :* vs :* ws :* xs :* ys :* zs :* NilA) + + liftA7 + :: Suitable f i + => (a -> b -> c -> d -> e -> g -> h -> i) + -> f a + -> f b + -> f c + -> f d + -> f e + -> f g + -> f h + -> f i + liftA7 f ts us vs ws xs ys zs = + liftA + (\(t :- u :- v :- w :- x :- y :- z :- Nil) -> + f t u v w x y z) + (ts :* us :* vs :* ws :* xs :* ys :* zs :* NilA) + + liftA8 + :: Suitable f j + => (a -> b -> c -> d -> e -> g -> h -> i -> j) + -> f a + -> f b + -> f c + -> f d + -> f e + -> f g + -> f h + -> f i + -> f j + liftA8 f ss ts us vs ws xs ys zs = + liftA + (\(s :- t :- u :- v :- w :- x :- y :- z :- Nil) -> + f s t u v w x y z) + (ss :* ts :* us :* vs :* ws :* xs :* ys :* zs :* NilA) + + liftA9 + :: Suitable f k + => (a -> b -> c -> d -> e -> g -> h -> i -> j -> k) + -> f a + -> f b + -> f c + -> f d + -> f e + -> f g + -> f h + -> f i + -> f j + -> f k + liftA9 f rs ss ts us vs ws xs ys zs = + liftA + (\(r :- s :- t :- u :- v :- w :- x :- y :- z :- Nil) -> + f r s t u v w x y z) + (rs :* ss :* ts :* us :* vs :* ws :* xs :* ys :* zs :* NilA) + +-- | A variant of '<*>' with the arguments reversed. +(<**>) :: (Applicative f, Suitable f b) => f a -> f (a -> b) -> f b +(<**>) = liftA2 (flip ($)) + +-- | A definition of 'liftA' which uses the "Prelude"'s @('Prelude.<*>')@. +liftAP :: (Prelude.Applicative f) => (Vect xs -> b) -> (AppVect f xs -> f b) +liftAP f NilA = Prelude.pure (f Nil) +liftAP f (x :* NilA) = Prelude.fmap (f . (:-Nil)) x +liftAP f (x :* xs) = ((f .) . (:-)) Prelude.<$> x Prelude.<*> liftAP id xs + +-- | A definition of 'liftA' which uses 's @('>>=')@. +liftAM :: (Monad f, Suitable f b) => (Vect xs -> b) -> (AppVect f xs -> f b) +liftAM f NilA = pure (f Nil) +liftAM f (x :* NilA) = fmap (f . (:-Nil)) x +liftAM f (x :* xs) = x >>= \y -> liftAM (f . (y:-)) xs +{- | The 'Monad' class defines the basic operations over a /monad/, +a concept from a branch of mathematics known as /category theory/. +From the perspective of a Haskell programmer, however, it is best to +think of a monad as an /abstract datatype/ of actions. +Haskell's @do@ expressions provide a convenient syntax for writing +monadic expressions. + +Instances of 'Monad' should satisfy the following laws: + +* @'return' a '>>=' k = k a@ +* @m '>>=' 'return' = m@ +* @m '>>=' (\\x -> k x '>>=' h) = (m '>>=' k) '>>=' h@ + +Furthermore, the 'Monad' and 'Applicative' operations should relate as follows: + +* @'pure' = 'return'@ +* @('<*>') = 'ap'@ + +The above laws imply: + +* @'fmap' f xs = xs '>>=' 'return' . f@ +* @('>>') = ('*>')@ + +and that 'pure' and ('<*>') satisfy the applicative functor laws. + +The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO' +defined in the ""Prelude"" satisfy these laws. +-} +class Applicative f => + Monad f where + infixl 1 >>= + -- | Sequentially compose two actions, passing any value produced + -- by the first as an argument to the second. + (>>=) + :: Suitable f b + => f a -> (a -> f b) -> f b +-- | A monoid on applicative functors. +-- +-- If defined, 'some' and 'many' should be the least solutions +-- of the equations: +-- +-- * @some v = (:) '<$>' v '<*>' many v@ +-- +-- * @many v = some v '<|>' 'pure' []@ +class Applicative f => + Alternative f where + {-# MINIMAL empty, (<|>) #-} + -- | The identity of '<|>' + empty :: Suitable f a => f a + infixl 3 <|> + -- | An associative binary operation + (<|>) + :: Suitable f a + => f a -> f a -> f a + -- | One or more. + some :: Suitable f [a] => f a -> f [a] + some v = some_v + where + many_v = some_v <|> pure [] + some_v = liftA2 (:) v many_v + + -- | Zero or more. + many :: Suitable f [a] => f a -> f [a] + many v = many_v + where + many_v = some_v <|> pure [] + some_v = liftA2 (:) v many_v + +-- | Functors representing data structures that can be traversed from +-- left to right. +-- +-- A definition of 'traverse' must satisfy the following laws: +-- +-- [/naturality/] +-- @t . 'traverse' f = 'traverse' (t . f)@ +-- for every applicative transformation @t@ +-- +-- [/identity/] +-- @'traverse' Identity = Identity@ +-- +-- [/composition/] +-- @'traverse' (Compose . 'fmap' g . f) = Compose . 'fmap' ('traverse' g) . 'traverse' f@ +-- +-- A definition of 'sequenceA' must satisfy the following laws: +-- +-- [/naturality/] +-- @t . 'sequenceA' = 'sequenceA' . 'fmap' t@ +-- for every applicative transformation @t@ +-- +-- [/identity/] +-- @'sequenceA' . 'fmap' Identity = Identity@ +-- +-- [/composition/] +-- @'sequenceA' . 'fmap' Compose = Compose . 'fmap' 'sequenceA' . 'sequenceA'@ +-- +-- where an /applicative transformation/ is a function +-- +-- @t :: (Applicative f, Applicative g) => f a -> g a@ +-- +-- preserving the 'Applicative' operations, i.e. +-- +-- * @t ('pure' x) = 'pure' x@ +-- +-- * @t (x '<*>' y) = t x '<*>' t y@ +-- +-- and the identity functor @Identity@ and composition of functors @Compose@ +-- are defined as +-- +-- > newtype Identity a = Identity a +-- > +-- > instance Functor Identity where +-- > fmap f (Identity x) = Identity (f x) +-- > +-- > instance Applicative Identity where +-- > pure x = Identity x +-- > Identity f <*> Identity x = Identity (f x) +-- > +-- > newtype Compose f g a = Compose (f (g a)) +-- > +-- > instance (Functor f, Functor g) => Functor (Compose f g) where +-- > fmap f (Compose x) = Compose (fmap (fmap f) x) +-- > +-- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where +-- > pure x = Compose (pure (pure x)) +-- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x) +-- +-- (The naturality law is implied by parametricity.) +-- +-- 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 where +-- > 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 (Foldable t, Functor t) => + Traversable t where + -- | Map each element of a structure to an action, evaluate these actions + -- from left to right, and collect the results. For a version that ignores + -- the results see 'traverse_'. + traverse + :: (Suitable t b, Applicative f, Suitable f (t b)) + => (a -> f b) -> t a -> f (t b) + + +-------------------------------------------------------------------------------- +-- useful functions +-------------------------------------------------------------------------------- + +infixl 4 <$> +-- | An infix synonym for 'fmap'. +-- +-- The name of this operator is an allusion to '$'. +-- Note the similarities between their types: +-- +-- > ($) :: (a -> b) -> a -> b +-- > (<$>) :: Functor f => (a -> b) -> f a -> f b +-- +-- Whereas '$' is function application, '<$>' is function +-- application lifted over a 'Functor'. +-- +-- ==== __Examples__ +-- +-- Convert from a @'Maybe' 'Int'@ to a @'Maybe' 'String'@ using 'show': +-- +-- >>> show <$> Nothing +-- Nothing +-- >>> show <$> Just 3 +-- Just "3" +-- +-- Convert from an @'Either' 'Int' 'Int'@ to an @'Either' 'Int'@ +-- 'String' using 'show': +-- +-- >>> show <$> Left 17 +-- Left 17 +-- >>> show <$> Right 17 +-- Right "17" +-- +-- Double each element of a list: +-- +-- >>> (*2) <$> [1,2,3] +-- [2,4,6] +-- +-- Apply 'even' to the second element of a pair: +-- +-- >>> even <$> (2,2) +-- (2,True) +-- +(<$>) :: (Functor f, Suitable f b) => (a -> b) -> f a -> f b +(<$>) = fmap + +infixr 1 =<<, <=< +-- | A flipped version of '>>=' +(=<<) :: (Monad f, Suitable f b) => (a -> f b) -> f a -> f b +(=<<) = flip (>>=) + +-- | Right-to-left Kleisli composition of monads. @('>=>')@, with the arguments flipped. +-- +-- Note how this operator resembles function composition @('.')@: +-- +-- > (.) :: (b -> c) -> (a -> b) -> a -> c +-- > (<=<) :: Monad m => (b -> m c) -> (a -> m b) -> a -> m c +(<=<) :: (Monad f, Suitable f c) => (b -> f c) -> (a -> f b) -> a -> f c +(f <=< g) x = f =<< g x + +infixl 1 >=> + +-- | Left-to-right Kleisli composition of monads. +(>=>) :: (Monad f, Suitable f c) => (a -> f b) -> (b -> f c) -> a -> f c +(f >=> g) x = f x >>= g + +-- | @'forever' act@ repeats the action infinitely. +forever :: (Applicative f, Suitable f b) => f a -> f b +{-# INLINE forever #-} +forever a = let a' = a *> a' in a' + +-- | Monadic fold over the elements of a structure, +-- associating to the left, i.e. from left to right. +foldM :: (Foldable t, Monad m, Suitable m b) => (b -> a -> m b) -> b -> t a -> m b +foldM f z0 xs = foldr f' pure xs z0 + where f' x k z = f z x >>= k + +-- | 'for_' is 'traverse_' with its arguments flipped. For a version +-- that doesn't ignore the results see 'Data.Traversable.for'. +-- +-- >>> for_ [1..4] print +-- 1 +-- 2 +-- 3 +-- 4 +for_ :: (Foldable t, Applicative f, Suitable f ()) => t a -> (a -> f b) -> f () +{-# INLINE for_ #-} +for_ = flip traverse_ + +-- | Map each element of a structure to an action, evaluate these +-- actions from left to right, and ignore the results. For a version +-- that doesn't ignore the results see 'traverse'. +traverse_ :: (Applicative f, Foldable t, Suitable f ()) => (a -> f b) -> t a -> f () +traverse_ f = foldr (\e a -> f e *> a) (pure ()) + +-- | Evaluate each action in the structure from left to right, and +-- ignore the results. For a version that doesn't ignore the results +-- see 'Data.Traversable.sequenceA'. +sequenceA_ :: (Foldable t, Applicative f, Suitable f ()) => t (f a) -> f () +sequenceA_ = foldr (*>) (pure ()) + +-- | @'guard' b@ is @'pure' ()@ if @b@ is 'True', +-- and 'empty' if @b@ is 'False'. +guard :: (Alternative f, Suitable f ()) => Bool -> f () +guard True = pure () +guard False = empty + +-- | @'ensure' b x@ is @x@ if @b@ is 'True', +-- and 'empty' if @b@ is 'False'. +ensure :: (Alternative f, Suitable f a) => Bool -> f a -> f a +ensure True x = x +ensure False _ = empty + +-- | Evaluate each action in the structure from left to right, and +-- and collect the results. For a version that ignores the results +-- see 'sequenceA_'. +sequenceA + :: (Applicative f, Suitable t a, Suitable f (t a), Traversable t) + => t (f a) -> f (t a) +sequenceA = traverse id + +-- |The 'mapAccumL' function behaves like a combination of 'fmap' +-- and 'foldl'; it applies a function to each element of a structure, +-- passing an accumulating parameter from left to right, and returning +-- a final value of this accumulator together with the new structure. +mapAccumL :: (Traversable t, Suitable t c) => (a -> b -> (a, c)) -> a -> t b -> (a, t c) +mapAccumL f s t = swap $ runState (traverse (state . (swap .: flip f)) t) s where + (.:) = (.).(.) + +-- | @'replicateM' n act@ performs the action @n@ times, +-- gathering the results. +replicateM :: (Applicative m, Suitable m [a]) => Int -> m a -> m [a] +{-# INLINEABLE replicateM #-} +{-# SPECIALISE replicateM :: Int -> IO a -> IO [a] #-} +{-# SPECIALISE replicateM :: Int -> Maybe a -> Maybe [a] #-} +replicateM cnt0 f = + loop cnt0 + where + loop cnt + | cnt <= 0 = pure [] + | otherwise = liftA2 (:) f (loop (cnt - 1)) + +-- | @'void' value@ discards or ignores the result of evaluation, such +-- as the return value of an 'System.IO.IO' action. +-- +-- ==== __Examples__ +-- +-- Replace the contents of a @'Maybe' 'Int'@ with unit: +-- +-- >>> void Nothing +-- Nothing +-- >>> void (Just 3) +-- Just () +-- +-- Replace the contents of an @'Either' 'Int' 'Int'@ with unit, +-- resulting in an @'Either' 'Int' '()'@: +-- +-- >>> void (Left 8675309) +-- Left 8675309 +-- >>> void (Right 8675309) +-- Right () +-- +-- Replace every element of a list with unit: +-- +-- >>> void [1,2,3] +-- [(),(),()] +-- +-- Replace the second element of a pair with unit: +-- +-- >>> void (1,2) +-- (1,()) +-- +-- Discard the result of an 'System.IO.IO' action: +-- +-- >>> traverse print [1,2] +-- 1 +-- 2 +-- [(),()] +-- >>> void $ traverse print [1,2] +-- 1 +-- 2 +void :: (Functor f, Suitable f ()) => f a -> f () +void = (<$) () + +-------------------------------------------------------------------------------- +-- syntax +-------------------------------------------------------------------------------- + +-- | Function to which the @if ... then ... else@ syntax desugars to +ifThenElse :: Bool -> a -> a -> a +ifThenElse True t _ = t +ifThenElse False _ f = f + +-- | Called on a failed pattern match in a monadic bind. To be avoided. +fail :: String -> a +fail = error + +-- | Sequence two actions, discarding the result of the first. Alias for +-- @('*>')@. +(>>) + :: (Applicative f, Suitable f b) + => f a -> f b -> f b +(>>) = (*>) + +-- | Alias for 'pure'. +return + :: (Applicative f, Suitable f a) + => a -> f a +return = pure + +-------------------------------------------------------------------------------- +-- instances +-------------------------------------------------------------------------------- + +instance Functor [] where + type Suitable [] a = () + fmap = map + (<$) = (Prelude.<$) + +instance Applicative [] where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Alternative [] where + empty = [] + (<|>) = (++) + +instance Monad [] where + (>>=) = (Prelude.>>=) + +instance Traversable [] where + traverse f = foldr (liftA2 (:) . f) (pure []) + +instance Functor Maybe where + type Suitable Maybe a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative Maybe where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Alternative Maybe where + empty = Control.Applicative.empty + (<|>) = (Control.Applicative.<|>) + +instance Monad Maybe where + (>>=) = (Prelude.>>=) + +instance Traversable Maybe where + traverse _ Nothing = pure Nothing + traverse f (Just x) = fmap Just (f x) + +instance Functor IO where + type Suitable IO a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative IO where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Alternative IO where + empty = Control.Applicative.empty + (<|>) = (Control.Applicative.<|>) + +instance Monad IO where + (>>=) = (Prelude.>>=) + +instance Functor Identity where + type Suitable Identity a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative Identity where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Monad Identity where + (>>=) = (Prelude.>>=) + +instance Traversable Identity where + traverse f (Identity x) = fmap Identity (f x) + +instance Functor (Either e) where + type Suitable (Either e) a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative (Either a) where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Monad (Either a) where + (>>=) = (Prelude.>>=) + +instance Traversable (Either a) where + traverse f = either (pure . Left) (fmap Right . f) + +instance Functor Set where + type Suitable Set a = Ord a + fmap = Set.map + x <$ xs = if null xs then Set.empty else Set.singleton x + +instance Applicative Set where + pure = Set.singleton + fs <*> xs = foldMap (`Set.map` xs) fs + xs *> ys = if null xs then Set.empty else ys + xs <* ys = if null ys then Set.empty else xs + liftA = liftAM + +instance Monad Set where + (>>=) = flip foldMap + +instance Alternative Set where + empty = Set.empty + (<|>) = Set.union + +instance Functor (Map a) where + type Suitable (Map a) b = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Functor ((,) a) where + type Suitable ((,) a) b = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Monoid a => Applicative ((,) a) where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Monoid a => Monad ((,) a) where + (>>=) = (Prelude.>>=) + +instance Traversable ((,) a) where + traverse f (x,y) = fmap ((,) x) (f y) + +instance Functor IntMap where + type Suitable IntMap a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Functor Seq where + type Suitable Seq a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative Seq where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Alternative Seq where + empty = Control.Applicative.empty + (<|>) = (Control.Applicative.<|>) + +instance Monad Seq where + (>>=) = (Prelude.>>=) + +instance Functor Tree where + type Suitable Tree a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative Tree where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Monad Tree where + (>>=) = (Prelude.>>=) + +instance Functor ((->) a) where + type Suitable ((->) a) b = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative ((->) a) where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Monad ((->) a) where + (>>=) = (Prelude.>>=) + +instance Functor (ContT r m) where + type Suitable (ContT r m) a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative (ContT r m) where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Monad (ContT r m) where + (>>=) = (Prelude.>>=) + +instance Functor Control.Applicative.ZipList where + type Suitable Control.Applicative.ZipList a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative Control.Applicative.ZipList where + liftA = liftAP + (<*>) = (Prelude.<*>) + (*>) = (Prelude.*>) + (<*) = (Prelude.<*) + pure = Prelude.pure + +instance Functor m => Functor (Strict.StateT s m) where + type Suitable (Strict.StateT s m) a = Suitable m (a, s) + fmap f m = Strict.StateT $ \ s -> + (\ (!a, !s') -> (f a, s')) <$> Strict.runStateT m s + {-# INLINE fmap #-} + x <$ xs = Strict.StateT ((fmap.first) (const x) . Strict.runStateT xs) + +instance Monad m => + Applicative (Strict.StateT s m) where + pure a = + Strict.StateT $ + \(!s) -> + pure (a, s) + {-# INLINE pure #-} + Strict.StateT mf <*> Strict.StateT mx = + Strict.StateT $ + \s -> do + (f,s') <- mf s + (x,s'') <- mx s' + pure (f x, s'') + Strict.StateT xs *> Strict.StateT ys = + Strict.StateT $ + \(!s) -> do + (_,s') <- xs s + ys s' + Strict.StateT xs <* Strict.StateT ys = + Strict.StateT $ + \(!s) -> do + (x,s') <- xs s + (_,s'') <- ys s' + pure (x,s'') + liftA = liftAM + +instance (Monad m, Alternative m) => Alternative (Strict.StateT s m) where + empty = Strict.StateT (const empty) + {-# INLINE empty #-} + Strict.StateT m <|> Strict.StateT n = Strict.StateT $ \ s -> m s <|> n s + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (Strict.StateT s m) where + m >>= k = Strict.StateT $ \ s -> do + (a, s') <- Strict.runStateT m s + Strict.runStateT (k a) s' + {-# INLINE (>>=) #-} + +instance Functor m => Functor (StateT s m) where + type Suitable (StateT s m) a = Suitable m (a, s) + fmap f m = StateT $ \ s -> + (\ ~(a, s') -> (f a, s')) <$> runStateT m s + {-# INLINE fmap #-} + x <$ StateT xs = StateT ((fmap.first) (const x) . xs) + +instance (Monad m) => + Applicative (StateT s m) where + pure a = + StateT $ + \s -> + pure (a, s) + {-# INLINE pure #-} + StateT mf <*> StateT mx = + StateT $ + \s -> do + ~(f,s') <- mf s + ~(x,s'') <- mx s' + pure (f x, s'') + StateT xs *> StateT ys = + StateT $ + \s -> do + ~(_,s') <- xs s + ys s' + StateT xs <* StateT ys = + StateT $ + \s -> do + ~(x,s') <- xs s + ~(_,s'') <- ys s' + pure (x,s'') + liftA = liftAM + +instance (Monad m, Alternative m) => Alternative (StateT s m) where + empty = StateT (const empty) + {-# INLINE empty #-} + StateT m <|> StateT n = StateT $ \ s -> m s <|> n s + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (StateT s m) where + m >>= k = StateT $ \ s -> do + ~(a, s') <- runStateT m s + runStateT (k a) s' + {-# INLINE (>>=) #-} + +instance (Functor m) => Functor (ReaderT r m) where + type Suitable (ReaderT r m) a = Suitable m a + fmap f = mapReaderT (fmap f) + {-# INLINE fmap #-} + x <$ ReaderT xs = ReaderT (\r -> x <$ xs r) + +instance (Applicative m) => Applicative (ReaderT r m) where + pure = liftReaderT . pure + {-# INLINE pure #-} + f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r + {-# INLINE (<*>) #-} + liftA f ys = ReaderT $ \r -> liftA f (tr r ys) where + tr :: Functor m => r -> AppVect (ReaderT r m) xs -> AppVect m xs + tr _ NilA = NilA + tr r (xs :* NilA) = runReaderT xs r :* NilA + tr r (x :* xs) = runReaderT x r :* tr r xs + ReaderT xs *> ReaderT ys = ReaderT (\c -> xs c *> ys c) + ReaderT xs <* ReaderT ys = ReaderT (\c -> xs c <* ys c) + +instance (Alternative m) => Alternative (ReaderT r m) where + empty = liftReaderT empty + {-# INLINE empty #-} + m <|> n = ReaderT $ \ r -> runReaderT m r <|> runReaderT n r + {-# INLINE (<|>) #-} + +instance (Monad m) => Monad (ReaderT r m) where + m >>= k = ReaderT $ \ r -> do + a <- runReaderT m r + runReaderT (k a) r + {-# INLINE (>>=) #-} + +liftReaderT :: m a -> ReaderT r m a +liftReaderT m = ReaderT (const m) +{-# INLINE liftReaderT #-} + +instance Functor m => Functor (MaybeT m) where + type Suitable (MaybeT m) a = (Suitable m (Maybe a), Suitable m a) + fmap f (MaybeT xs) = MaybeT ((fmap.fmap) f xs) + x <$ MaybeT xs = MaybeT (fmap (x<$) xs) + +instance Monad m => Applicative (MaybeT m) where + pure x = MaybeT (pure (Just x)) + MaybeT fs <*> MaybeT xs = MaybeT (liftA2 (<*>) fs xs) + liftA = liftAM + MaybeT xs *> MaybeT ys = MaybeT (xs *> ys) + MaybeT xs <* MaybeT ys = MaybeT (xs <* ys) + +instance Monad m => Monad (MaybeT m) where + MaybeT x >>= f = MaybeT (x >>= maybe (pure Nothing) (runMaybeT . f)) + +instance Monad m => + Alternative (MaybeT m) where + empty = MaybeT (pure Nothing) + MaybeT x <|> MaybeT y = MaybeT (x >>= maybe y (pure . Just)) + +instance Functor m => + Functor (ExceptT e m) where + type Suitable (ExceptT e m) a = Suitable m (Either e a) + fmap f (ExceptT xs) = ExceptT ((fmap . fmap) f xs) + x <$ ExceptT xs = ExceptT (fmap (x <$) xs) + +instance Monad m => + Applicative (ExceptT e m) where + pure x = ExceptT (pure (Right x)) + ExceptT fs <*> ExceptT xs = ExceptT (liftA2 (<*>) fs xs) + liftA = liftAM + ExceptT xs *> ExceptT ys = ExceptT (xs *> ys) + ExceptT xs <* ExceptT ys = ExceptT (xs <* ys) + +instance Monad m => Monad (ExceptT e m) where + ExceptT xs >>= f = ExceptT (xs >>= either (pure . Left) (runExceptT . f)) + +instance (Monad m, Monoid e) => Alternative (ExceptT e m) where + empty = ExceptT (pure (Left mempty)) + ExceptT xs <|> ExceptT ys = ExceptT (xs >>= either (const ys) (pure . Right)) + +instance Functor m => + Functor (IdentityT m) where + type Suitable (IdentityT m) a = Suitable m a + fmap = + (coerce :: ((a -> b) -> f a -> f b) -> (a -> b) -> IdentityT f a -> IdentityT f b) + fmap + (<$) = + (coerce :: (a -> f b -> f a) -> a -> IdentityT f b -> IdentityT f a) + (<$) + +instance Applicative m => + Applicative (IdentityT m) where + pure = (coerce :: (a -> f a) -> a -> IdentityT f a) pure + (<*>) = + (coerce :: (f (a -> b) -> f a -> f b) -> IdentityT f (a -> b) -> IdentityT f a -> IdentityT f b) + (<*>) + liftA f = + (coerce :: (AppVect f xs -> f b) -> (AppVect (IdentityT f) xs -> IdentityT f b)) + (liftA f) + IdentityT xs *> IdentityT ys = IdentityT (xs *> ys) + IdentityT xs <* IdentityT ys = IdentityT (xs <* ys) + +instance Monad m => + Monad (IdentityT m) where + (>>=) = + (coerce :: (f a -> (a -> f b) -> f b) -> IdentityT f a -> (a -> IdentityT f b) -> IdentityT f b) + (>>=) diff --git a/src/Control/Monad/Constrained/Cont.hs b/src/Control/Monad/Constrained/Cont.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained/Cont.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE RebindableSyntax #-} + +-- | This module is a duplication of the Control.Monad.Cont module, from the\ +-- mtl. +module Control.Monad.Constrained.Cont + (MonadCont(..) + ,ContT(..) + ,cont + ,mapContT + ,withContT + ,runCont + ,mapCont + ,withCont)where + +import Control.Monad.Constrained + +import qualified Control.Monad.Trans.Cont as Cont +import Control.Monad.Trans.Cont hiding (callCC) + +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State.Lazy as State.Lazy +import qualified Control.Monad.Trans.State.Strict as State.Strict +import qualified Control.Monad.Trans.Identity as Identity +import qualified Control.Monad.Trans.Maybe as Maybe +import qualified Control.Monad.Trans.Except as Except + +-- | A class for monads which can embed continuations. +class Monad m => MonadCont m where + {- | @callCC@ (call-with-current-continuation) + calls a function with the current continuation as its argument. + Provides an escape continuation mechanism for use with Continuation monads. + Escape continuations allow to abort the current computation and return + a value immediately. + They achieve a similar effect to 'Control.Monad.Error.throwError' + and 'Control.Monad.Error.catchError' + within an 'Control.Monad.Error.Error' monad. + Advantage of this function over calling @return@ is that it makes + the continuation explicit, + allowing more flexibility and better control + (see examples in "Control.Monad.Cont"). + + The standard idiom used with @callCC@ is to provide a lambda-expression + to name the continuation. Then calling the named continuation anywhere + within its scope will escape from the computation, + even if it is many layers deep within nested computations. + -} + callCC :: ((a -> m b) -> m a) -> m a + +instance MonadCont (ContT r m) where + callCC = Cont.callCC + +instance MonadCont m => MonadCont (Maybe.MaybeT m) where + callCC = Maybe.liftCallCC callCC + +instance MonadCont m => MonadCont (Reader.ReaderT r m) where + callCC = Reader.liftCallCC callCC + +instance MonadCont m => MonadCont (State.Lazy.StateT s m) where + callCC = State.Lazy.liftCallCC callCC + +instance MonadCont m => MonadCont (State.Strict.StateT s m) where + callCC = State.Strict.liftCallCC callCC + +instance MonadCont m => MonadCont (Identity.IdentityT m) where + callCC = Identity.liftCallCC callCC + +instance MonadCont m => MonadCont (Except.ExceptT e m) where + callCC = Except.liftCallCC callCC diff --git a/src/Control/Monad/Constrained/Error.hs b/src/Control/Monad/Constrained/Error.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained/Error.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module is a duplication of the Control.Monad.Error module from the +-- mtl, for constrained monads. +module Control.Monad.Constrained.Error + (MonadError(..) + ,ExceptT(..) + ,Except) + where + +import GHC.Exts + +import Control.Monad.Constrained +import Control.Monad.Constrained.Trans + +import Control.Monad.Trans.Except hiding (catchE) + +import qualified Control.Monad.Trans.Identity as Identity +import qualified Control.Monad.Trans.Maybe as Maybe +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.State.Lazy as State.Lazy +import qualified Control.Monad.Trans.State.Strict as State.Strict + +-- | A class for monads which can error out. +class Monad m => + MonadError e m | m -> e where + type SuitableError m a :: Constraint + -- | Raise an error. + throwError :: SuitableError m a => e -> m a + {- | + A handler function to handle previous errors and return to normal execution. + A common idiom is: + + > do { action1; action2; action3 } `catchError` handler + + where the @action@ functions can call 'throwError'. + Note that @handler@ and the do-block must have the same return type. + -} + catchError :: SuitableError m a => m a -> (e -> m a) -> m a + +instance MonadError e (Either e) where + type SuitableError (Either e) a = () + throwError = Left + catchError (Left x) f = f x + catchError r _ = r + +instance Monad m => MonadError e (ExceptT e m) where + type SuitableError (ExceptT e m) a = Suitable m (Either e a) + throwError = ExceptT . pure . Left + catchError = catchE + +catchE + :: (Monad m, Suitable m (Either e' a)) + => ExceptT e m a + -> (e -> ExceptT e' m a) + -> ExceptT e' m a +catchE m h = + ExceptT $ + do a <- runExceptT m + case a of + Left l -> runExceptT (h l) + Right r -> return (Right r) +{-# INLINE catchE #-} + +instance MonadError e m => MonadError e (Identity.IdentityT m) where + type SuitableError (Identity.IdentityT m) a = SuitableError m a + throwError = lift . throwError + catchError = Identity.liftCatch catchError + +instance MonadError e m => + MonadError e (Maybe.MaybeT m) where + type SuitableError (Maybe.MaybeT m) a + = (SuitableError m a + ,SuitableError m (Maybe a) + ,Suitable m (Maybe a)) + throwError = lift . throwError + catchError = Maybe.liftCatch catchError + +instance MonadError e m => + MonadError e (Reader.ReaderT r m) where + type SuitableError (Reader.ReaderT r m) a = SuitableError m a + throwError = lift . throwError + catchError = Reader.liftCatch catchError + +instance MonadError e m => MonadError e (State.Lazy.StateT s m) where + type SuitableError (State.Lazy.StateT s m) a + = (Suitable m (a,s), SuitableError m (a,s), SuitableError m a) + throwError = lift . throwError + catchError = State.Lazy.liftCatch catchError + +instance MonadError e m => MonadError e (State.Strict.StateT s m) where + type SuitableError (State.Strict.StateT s m) a + = (Suitable m (a,s), SuitableError m (a,s), SuitableError m a) + throwError = lift . throwError + catchError = State.Strict.liftCatch catchError diff --git a/src/Control/Monad/Constrained/IO.hs b/src/Control/Monad/Constrained/IO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained/IO.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module is a duplication of the "Control.Monad.IO.Class" module, for +-- constrained monads. +module Control.Monad.Constrained.IO + (MonadIO(..)) + where + +import Control.Monad.Constrained +import Control.Monad.Constrained.Trans + +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict +import qualified Control.Monad.Trans.State.Lazy as Lazy + +import GHC.Exts + +-- | A class for monads which can have IO actions lifted into them. +class Monad m => + MonadIO m where + type SuitableIO m a :: Constraint + liftIO :: SuitableIO m a => IO a -> m a + +instance MonadIO IO where + type SuitableIO IO a = () + liftIO = id + +instance MonadIO m => + MonadIO (IdentityT m) where + type SuitableIO (IdentityT m) a = SuitableIO m a + liftIO = lift . liftIO + +instance MonadIO m => + MonadIO (MaybeT m) where + type SuitableIO (MaybeT m) a = (Suitable m (Maybe a), SuitableIO m a) + liftIO = lift . liftIO + +instance MonadIO m => + MonadIO (ContT r m) where + type SuitableIO (ContT r m) a = (Suitable m r, SuitableIO m a) + liftIO = lift . liftIO + +instance MonadIO m => + MonadIO (ReaderT r m) where + type SuitableIO (ReaderT r m) a = SuitableIO m a + liftIO = lift . liftIO + +instance MonadIO m => + MonadIO (StateT s m) where + type SuitableIO (StateT s m) a = (SuitableIO m a, Suitable m (a, s)) + liftIO = lift . liftIO + +instance MonadIO m => + MonadIO (Lazy.StateT s m) where + type SuitableIO (Lazy.StateT s m) a = (SuitableIO m a, Suitable m (a, s)) + liftIO = lift . liftIO diff --git a/src/Control/Monad/Constrained/IntSet.hs b/src/Control/Monad/Constrained/IntSet.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained/IntSet.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module creates an 'IntSet' type with a phantom type variable, allowing +-- it to conform to 'Functor', 'Foldable', etc. Other than that, it's a +-- duplication of the "Data.IntSet" module. +module Control.Monad.Constrained.IntSet + (IntSet + ,(\\) + ,lookupLT + ,lookupLE + ,lookupGT + ,lookupGE + ,insert + ,delete + ,difference + ,intersection + ,filter + ,partition + ,split + ,maxView + ,minView) + where + +import Control.Monad.Constrained hiding (filter) + +import qualified Data.IntSet as IntSet + +import Data.Foldable (Foldable (..)) +import Data.Functor.Classes +import Data.Semigroup + +import Control.Arrow (first) +import GHC.Exts + +-- | This type is a wrapper around 'Data.IntSet.IntSet', with a phantom type +-- variable which must always be 'Int'. This allows it to conform to 'Functor', +-- 'Foldable', 'Applicative', 'Monad', etc. +data IntSet a where + IntSet :: IntSet.IntSet -> IntSet Int + +instance Foldable IntSet where + foldr f b (IntSet xs) = IntSet.foldr f b xs + foldl f b (IntSet xs) = IntSet.foldl f b xs + foldr' f b (IntSet xs) = IntSet.foldr' f b xs + foldl' f b (IntSet xs) = IntSet.foldl' f b xs + null (IntSet xs) = IntSet.null xs + length (IntSet xs) = IntSet.size xs + minimum (IntSet xs) = IntSet.findMin xs + maximum (IntSet xs) = IntSet.findMax xs + elem x (IntSet xs) = IntSet.member x xs + +instance Functor IntSet where + type Suitable IntSet a = a ~ Int + fmap f (IntSet xs) = IntSet (IntSet.map f xs) + x <$ IntSet xs = + IntSet + (if IntSet.null xs + then IntSet.empty + else IntSet.singleton x) + +instance Semigroup (IntSet a) where + IntSet xs <> IntSet ys = IntSet (IntSet.union xs ys) + +instance a ~ Int => Monoid (IntSet a) where + mempty = IntSet IntSet.empty + mappend = (<>) + +instance Applicative IntSet where + pure x = IntSet (IntSet.singleton x) + xs *> ys = + if null xs + then mempty + else ys + xs <* ys = + if null ys + then mempty + else xs + liftA = liftAM + +instance Alternative IntSet where + empty = mempty + (<|>) = mappend + +instance Monad IntSet where + (>>=) = flip foldMap + +instance a ~ Int => IsList (IntSet a) where + type Item (IntSet a) = a + fromList = IntSet . IntSet.fromList + toList = foldr (:) [] + +infixl 9 \\ +-- | /O(n+m)/. See 'difference'. +(\\) :: IntSet a -> IntSet a -> IntSet a +IntSet xs \\ IntSet ys = IntSet (xs IntSet.\\ ys) + +-- | /O(log n)/. Find largest element smaller than the given one. +-- +-- > lookupLT 3 (fromList [3, 5]) == Nothing +-- > lookupLT 5 (fromList [3, 5]) == Just 3 +lookupLT :: a -> IntSet a -> Maybe a +lookupLT x (IntSet xs) = IntSet.lookupLT x xs + +-- | /O(log n)/. Find smallest element greater than the given one. +-- +-- > lookupGT 4 (fromList [3, 5]) == Just 5 +-- > lookupGT 5 (fromList [3, 5]) == Nothing +lookupGT :: a -> IntSet a -> Maybe a +lookupGT x (IntSet xs) = IntSet.lookupGT x xs + +-- | /O(log n)/. Find largest element smaller or equal to the given one. +-- +-- > lookupLE 2 (fromList [3, 5]) == Nothing +-- > lookupLE 4 (fromList [3, 5]) == Just 3 +-- > lookupLE 5 (fromList [3, 5]) == Just 5 +lookupLE :: a -> IntSet a -> Maybe a +lookupLE x (IntSet xs) = IntSet.lookupLE x xs + +-- | /O(log n)/. Find smallest element greater or equal to the given one. +-- +-- > lookupGE 3 (fromList [3, 5]) == Just 3 +-- > lookupGE 4 (fromList [3, 5]) == Just 5 +-- > lookupGE 6 (fromList [3, 5]) == Nothing +lookupGE :: a -> IntSet a -> Maybe a +lookupGE x (IntSet xs) = IntSet.lookupGE x xs + +-- | /O(min(n,W))/. Add a value to the set. There is no left- or right bias for +-- IntSets. +insert :: a -> IntSet a -> IntSet a +insert x (IntSet xs) = IntSet (IntSet.insert x xs) + +-- | /O(min(n,W))/. Delete a value in the set. Returns the +-- original set when the value was not present. +delete :: a -> IntSet a -> IntSet a +delete x (IntSet xs) = IntSet (IntSet.delete x xs) + +-- | /O(n+m)/. Difference between two sets. +difference :: IntSet a -> IntSet a -> IntSet a +difference (IntSet xs) (IntSet ys) = IntSet (IntSet.difference xs ys) + +-- | /O(n+m)/. The intersection of two sets. +intersection :: IntSet a -> IntSet a -> IntSet a +intersection (IntSet xs) (IntSet ys) = IntSet (IntSet.intersection xs ys) + +-- | /O(n)/. Filter all elements that satisfy some predicate. +filter :: (a -> Bool) -> IntSet a -> IntSet a +filter p (IntSet xs) = IntSet (IntSet.filter p xs) + +-- | /O(n)/. partition the set according to some predicate. +partition :: (a -> Bool) -> IntSet a -> (IntSet a, IntSet a) +partition p (IntSet xs) = + let (ys,zs) = IntSet.partition p xs + in (IntSet ys, IntSet zs) + +-- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@ +-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ +-- comprises the elements of @set@ greater than @x@. +-- +-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5]) +split :: a -> IntSet a -> (IntSet a, IntSet a) +split x (IntSet xs) = + let (ys,zs) = IntSet.split x xs + in (IntSet ys, IntSet zs) + +-- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set +-- stripped of that element, or 'Nothing' if passed an empty set. +maxView :: IntSet a -> Maybe (a, IntSet a) +maxView (IntSet xs) = (fmap.fmap) IntSet (IntSet.maxView xs) + +-- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set +-- stripped of that element, or 'Nothing' if passed an empty set. +minView :: IntSet a -> Maybe (a, IntSet a) +minView (IntSet xs) = (fmap.fmap) IntSet (IntSet.minView xs) + +instance Show1 IntSet where + liftShowsPrec _ _ d (IntSet xs) = showsPrec d xs + +instance Show a => + Show (IntSet a) where + showsPrec = showsPrec1 + +instance a ~ Int => + Read (IntSet a) where + readsPrec n = (fmap . first) IntSet . readsPrec n + +instance Eq1 IntSet where + liftEq _ (IntSet xs) (IntSet ys) = xs == ys + +instance Eq a => + Eq (IntSet a) where + (==) = eq1 + +instance Ord1 IntSet where + liftCompare _ (IntSet xs) (IntSet ys) = compare xs ys + +instance Ord a => + Ord (IntSet a) where + compare = compare1 diff --git a/src/Control/Monad/Constrained/Reader.hs b/src/Control/Monad/Constrained/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained/Reader.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module duplicates the Control.Monad.Reader module from the mtl, for +-- constrained monads. +module Control.Monad.Constrained.Reader + (MonadReader(..) + ,ReaderT(..) + ,Reader + )where + +import GHC.Exts + +import Control.Monad.Constrained +import Control.Monad.Constrained.Trans + +import Control.Monad.Trans.Reader hiding (reader, ask, local) + +import qualified Control.Monad.Trans.State.Lazy as State.Lazy +import qualified Control.Monad.Trans.State.Strict as State.Strict +import qualified Control.Monad.Trans.Cont as Cont +import qualified Control.Monad.Trans.Identity as Identity +import qualified Control.Monad.Trans.Maybe as Maybe +import qualified Control.Monad.Trans.Except as Except + +-- | A class for reader monads. +class Monad m => + MonadReader r m | m -> r where + type ReaderSuitable m a :: Constraint + {-# MINIMAL reader , local #-} + -- | Retrieves the environment + ask + :: (ReaderSuitable m r) + => m r + ask = reader id + -- | Executes a computation in a modified environment. + local + :: (ReaderSuitable m a, ReaderSuitable m r) + => (r -> r) -- ^ The function to modify the environment. + -> m a -- ^ @Reader@ to run in the modified environment. + -> m a + + -- | Retrieves a function of the current environment. + reader + :: (ReaderSuitable m r, ReaderSuitable m a) + => (r -> a) -- ^ The selector function to apply to the environment. + -> m a + +instance MonadReader r ((->) r) where + type ReaderSuitable ((->) r) a = () + ask = id + local f m = m . f + reader = id + +instance Monad m => MonadReader r (ReaderT r m) where + type ReaderSuitable (ReaderT r m) a = Suitable m a + ask = ReaderT pure + local = local + reader f = ReaderT (pure . f) + +instance MonadReader r' m => + MonadReader r' (Cont.ContT r m) where + type ReaderSuitable (Cont.ContT r m) a + = (ReaderSuitable m a, Suitable m r, ReaderSuitable m r) + ask = lift ask + local = liftLocal ask local + reader = lift . reader + +liftLocal + :: (Monad m, Suitable m r) + => m r' + -> ((r' -> r') -> m r -> m r) + -> (r' -> r') + -> Cont.ContT r m a + -> Cont.ContT r m a +liftLocal ask' local' f m = + Cont.ContT $ + \c -> do + r <- ask' + local' f (Cont.runContT m (local' (const r) . c)) + +instance MonadReader r m => MonadReader r (Except.ExceptT e m) where + type ReaderSuitable (Except.ExceptT e m) a + = (ReaderSuitable m a + ,Suitable m (Either e a) + ,ReaderSuitable m (Either e a)) + ask = lift ask + local = Except.mapExceptT . local + reader = lift . reader + +instance MonadReader r m => MonadReader r (Identity.IdentityT m) where + type ReaderSuitable (Identity.IdentityT m) a = ReaderSuitable m a + ask = lift ask + local = Identity.mapIdentityT . local + reader = lift . reader + +instance MonadReader r m => + MonadReader r (Maybe.MaybeT m) where + type ReaderSuitable (Maybe.MaybeT m) a + = (ReaderSuitable m a + ,ReaderSuitable m (Maybe a) + ,Suitable m (Maybe a)) + ask = lift ask + local = Maybe.mapMaybeT . local + reader = lift . reader + +instance MonadReader r m => + MonadReader r (State.Lazy.StateT s m) where + type ReaderSuitable (State.Lazy.StateT s m) a + = (ReaderSuitable m a + ,ReaderSuitable m (a,s) + ,Suitable m (a,s)) + ask = lift ask + local = State.Lazy.mapStateT . local + reader = lift . reader + +instance MonadReader r m => + MonadReader r (State.Strict.StateT s m) where + type ReaderSuitable (State.Strict.StateT s m) a + = (ReaderSuitable m a + ,ReaderSuitable m (a,s) + ,Suitable m (a,s)) + ask = lift ask + local = State.Strict.mapStateT . local + reader = lift . reader diff --git a/src/Control/Monad/Constrained/State.hs b/src/Control/Monad/Constrained/State.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained/State.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module duplicates the Control.Monad.State module from mtl for monads +-- with constraints. +module Control.Monad.Constrained.State + (MonadState(..) + ,StateT(..) + ,gets + ,modify + ,modify' + )where + +import GHC.Exts + +import Control.Monad.Constrained +import Control.Monad.Constrained.Trans + +import qualified Control.Monad.Trans.State.Lazy as State.Lazy +import Control.Monad.Trans.State.Strict hiding (state, get, modify, gets, modify') + +import qualified Control.Monad.Trans.Cont as Cont +import qualified Control.Monad.Trans.Identity as Identity +import qualified Control.Monad.Trans.Maybe as Maybe +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.Except as Except + +-- | A class for monads with state. +class Monad m => + MonadState s m | m -> s where + {-# MINIMAL state #-} + type StateSuitable m a :: Constraint + -- | Return the state from the internals of the monad. + get + :: (StateSuitable m s) + => m s + get = + state + (\s -> + (s, s)) + -- | Replace the state inside the monad. + put + :: (StateSuitable m (), StateSuitable m s) + => s -> m () + put s = state (const ((), s)) + -- | Embed a simple state action in the monad. + state + :: (StateSuitable m a, StateSuitable m s) + => (s -> (a, s)) -> m a + +-- | Get the state, while applying a transformation function. +gets + :: (StateSuitable m s, MonadState s m, Suitable m b) + => (s -> b) -> m b +gets f = fmap f get + +-- | Modify the state. +modify + :: (StateSuitable m (), StateSuitable m s, MonadState s m) + => (s -> s) -> m () +modify f = + state + (\s -> + ((), f s)) + +-- | Modify the state, strictly in the new state. +modify' + :: (StateSuitable m (), StateSuitable m s, MonadState s m) + => (s -> s) -> m () +modify' f = + state + (\s -> + let s' = f s + in s' `seq` ((), s')) + +instance Monad m => MonadState s (StateT s m) where + type StateSuitable (StateT s m) a = Suitable m (a, s) + state f = StateT (pure . f) + +instance Monad m => MonadState s (State.Lazy.StateT s m) where + type StateSuitable (State.Lazy.StateT s m) a = Suitable m (a, s) + state f = State.Lazy.StateT (pure . f) + +instance (MonadState s m, Suitable m r) => MonadState s (Cont.ContT r m) where + type StateSuitable (Cont.ContT r m) a = StateSuitable m a + state = lift . state + +instance MonadState s m => + MonadState s (Maybe.MaybeT m) where + type StateSuitable (Maybe.MaybeT m) a + = (Suitable m (Maybe a), StateSuitable m a) + state = lift . state + +instance MonadState s m => + MonadState s (Identity.IdentityT m) where + type StateSuitable (Identity.IdentityT m) a = StateSuitable m a + state = lift . state + +instance MonadState s m => + MonadState s (Reader.ReaderT r m) where + type StateSuitable (Reader.ReaderT r m) a = StateSuitable m a + state = lift . state + +instance MonadState s m => + MonadState s (Except.ExceptT e m) where + type StateSuitable (Except.ExceptT e m) a + = (Suitable m (Either e a), StateSuitable m a) + state = lift . state diff --git a/src/Control/Monad/Constrained/Trans.hs b/src/Control/Monad/Constrained/Trans.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained/Trans.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module duplicates the "Control.Monad.Trans.Class" module for +-- constrained monads. +module Control.Monad.Constrained.Trans + (MonadTrans(..)) + where + +import Control.Monad.Constrained + +import Control.Monad.Trans.Cont (ContT (..)) +import Control.Monad.Trans.Except (ExceptT (..)) +import Control.Monad.Trans.Identity (IdentityT (..)) +import Control.Monad.Trans.Maybe (MaybeT (..)) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Trans.State.Lazy as Lazy (StateT (..)) +import Control.Monad.Trans.State.Strict as Strict (StateT (..)) + +import GHC.Exts + +-- | A class for monad transformers with constraints. See +-- "Control.Monad.Trans.Class" for full documentation on the class without +-- constraints. +class MonadTrans t where + -- | A type for monads that are liftable into the outer monad. For instance, + -- since 'StateT' is defined like so: + -- + -- @newtype 'StateT' s m a = 'StateT' { 'runStateT' :: s -> m (a, s) }@ + -- + -- the underlying monad needs not to be able to hold @a@, but @(a, s)@. + type SuitableLift (t :: (* -> *) -> * -> *) (m :: * -> *) (a :: *) :: Constraint + -- | Lift a monad into an outer monad. + lift + :: (Monad m, SuitableLift t m a) + => m a -> t m a + +instance MonadTrans (ContT r) where + type SuitableLift (ContT r) m a = Suitable m r + lift m = ContT (m >>=) + {-# INLINE lift #-} + +instance MonadTrans (ReaderT r) where + type SuitableLift (ReaderT r) m a = () + lift m = ReaderT (const m) + {-# INLINE lift #-} + +instance MonadTrans (Strict.StateT r) where + type SuitableLift (Strict.StateT r) m a = Suitable m (a,r) + lift m = Strict.StateT (\s -> fmap (flip (,) s) m) + {-# INLINE lift #-} + +instance MonadTrans (Lazy.StateT r) where + type SuitableLift (Lazy.StateT r) m a = Suitable m (a,r) + lift m = Lazy.StateT (\s -> fmap (flip (,) s) m) + {-# INLINE lift #-} + +instance MonadTrans IdentityT where + type SuitableLift IdentityT m a = () + lift = IdentityT + {-# INLINE lift #-} + +instance MonadTrans MaybeT where + type SuitableLift MaybeT m a = Suitable m (Maybe a) + lift = MaybeT . fmap Just + {-# INLINE lift #-} + +instance MonadTrans (ExceptT e) where + type SuitableLift (ExceptT e) m a = Suitable m (Either e a) + lift = ExceptT . fmap Right + {-# INLINE lift #-} diff --git a/src/Control/Monad/Constrained/Writer.hs b/src/Control/Monad/Constrained/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Constrained/Writer.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This module duplicates the Control.Monad.Writer module from the mtl, for +-- constrained monads. It also provides a non-leaky writer monad. +module Control.Monad.Constrained.Writer + (MonadWriter(..) + ,WriterT + ,pattern WriterT + ,Writer + ,runWriterT + ,execWriterT + ,execWriter + ,runWriter + ,listen + ,pass + ,evalWriterT + ,evalWriter + )where + +import GHC.Exts + +import Control.Monad.Constrained +import Control.Monad.Constrained.Trans + +import qualified Control.Monad.Trans.State.Lazy as State.Lazy +import qualified Control.Monad.Trans.State.Strict as State.Strict +import qualified Control.Monad.Trans.Identity as Identity +import qualified Control.Monad.Trans.Maybe as Maybe +import qualified Control.Monad.Trans.Reader as Reader +import qualified Control.Monad.Trans.Except as Except + +import Control.Monad.Constrained.State +import Control.Monad.Constrained.Error +import Control.Monad.Constrained.Reader + +import Data.Functor.Identity +import Data.Functor.Classes + +-- | A class for monads with logging ability. +class (Monoid w, Monad m) => MonadWriter w m | m -> w where + type WriterSuitable m a :: Constraint + -- | Embed a simple writer action. + writer :: WriterSuitable m a => (a,w) -> m a + -- | Log some output. + tell :: WriterSuitable m () => w -> m () + -- | This is equivalent to the 'Control.Monad.Trans.Writer.Lazy.listen' + -- function, except it is church encoded, to make the constraints a little + -- easier to manage. + listenC :: WriterSuitable m b => (a -> w -> b) -> m a -> m b + -- | This is equivalent to the 'Control.Monad.Trans.Writer.Lazy.pass' + -- function, except it is church encoded, to make the constraints a little + -- easier to manage. + passC :: WriterSuitable m a => (a -> w -> w) -> m a -> m a + +instance MonadWriter w m => + MonadWriter w (Except.ExceptT e m) where + type WriterSuitable (Except.ExceptT e m) a + = (WriterSuitable m a + ,WriterSuitable m (Either e a) + ,Suitable m (Either e a)) + writer = lift . writer + tell = lift . tell + listenC f = (Except.mapExceptT . listenC . flip) (fmap . flip f) + passC = Except.mapExceptT . passC . either (const id) + +-- | @'listen' m@ is an action that executes the action @m@ and adds +-- its output to the value of the computation. +listen + :: (MonadWriter w m, WriterSuitable m (a, w)) + => m a -> m (a, w) +listen = listenC (,) + +-- | @'pass' m@ is an action that executes the action @m@, which +-- returns a value and a function, and returns the value, applying +-- the function to the output. +pass + :: (MonadWriter w m, Suitable m a, WriterSuitable m (a, w -> w)) + => m (a, w -> w) -> m a +pass = fmap fst . passC snd + +instance MonadWriter w m => + MonadWriter w (State.Lazy.StateT s m) where + type WriterSuitable (State.Lazy.StateT s m) a + = (WriterSuitable m a + ,WriterSuitable m (a, s) + ,Suitable m (a, s)) + writer = lift . writer + tell = lift . tell + listenC f m = + State.Lazy.StateT + (listenC + (\ ~(a,s') w -> + (f a w, s')) . + State.Lazy.runStateT m) + passC c m = State.Lazy.StateT (passC (c . fst) . State.Lazy.runStateT m) + +instance MonadWriter w m => + MonadWriter w (State.Strict.StateT s m) where + type WriterSuitable (State.Strict.StateT s m) a + = (WriterSuitable m a + ,WriterSuitable m (a, s) + ,Suitable m (a, s)) + writer = lift . writer + tell = lift . tell + listenC f m = + State.Strict.StateT + (listenC + (\ (a,s') w -> + (f a w, s')) . + State.Strict.runStateT m) + passC c m = State.Strict.StateT (passC (c . fst) . State.Strict.runStateT m) + +instance MonadWriter w m => + MonadWriter w (Identity.IdentityT m) where + type WriterSuitable (Identity.IdentityT m) a = WriterSuitable m a + writer = lift . writer + tell = lift . tell + listenC f = Identity.mapIdentityT (listenC f) + passC f = Identity.mapIdentityT (passC f) + +instance MonadWriter w m => MonadWriter w (Maybe.MaybeT m) where + type WriterSuitable (Maybe.MaybeT m) a + = (WriterSuitable m a + ,WriterSuitable m (Maybe a) + ,Suitable m (Maybe a)) + writer = lift . writer + tell = lift . tell + listenC f = (Maybe.mapMaybeT . listenC . flip) (fmap . flip f) + passC = Maybe.mapMaybeT . passC . maybe id + +instance MonadWriter w m => MonadWriter w (Reader.ReaderT r m) where + type WriterSuitable (Reader.ReaderT r m) a = WriterSuitable m a + writer = lift . writer + tell = lift . tell + listenC f = Reader.mapReaderT (listenC f) + passC f = Reader.mapReaderT (passC f) + +-- | A monad transformer similar to 'Control.Monad.Writer.Strict.WriterT', except +-- that it does not leak space. It is implemented using a state monad, so that +-- `mappend` is tail recursive. See +-- +-- email to the Haskell libraries committee for more information. +-- +-- Wherever possible, coercions are used to eliminate any overhead from the +-- newtype wrapper. +newtype WriterT s m a = + WriterT_ { unWriterT :: State.Strict.StateT s m a } + +instance Functor m => Functor (WriterT s m) where + type Suitable (WriterT s m) a = Suitable m (a,s) + fmap f (WriterT_ x) = WriterT_ (fmap f x) + x <$ WriterT_ xs = WriterT_ (x <$ xs) + +instance Monad m => + Applicative (WriterT s m) where + pure x = WriterT_ (pure x) + WriterT_ fs <*> WriterT_ xs = WriterT_ (fs <*> xs) + WriterT_ xs *> WriterT_ ys = WriterT_ (xs *> ys) + WriterT_ xs <* WriterT_ ys = WriterT_ (xs <* ys) + liftA = liftAM + +instance Monad m => Monad (WriterT s m) where + WriterT_ xs >>= f = WriterT_ (xs >>= (unWriterT . f)) + +-- first_ :: (Functor f, Suitable f (b, c)) => (a -> f b) -> (a, c) -> f (b, c) +-- first_ f (x,y) = fmap (flip (,) y) (f x) + +-- | Run a writer computation in the underlying monad. +runWriterT + :: Monoid s + => WriterT s m a -> m (a, s) +runWriterT = + (coerce :: (State.Strict.StateT s m a -> m (a, s)) -> WriterT s m a -> m (a, s)) + (`State.Strict.runStateT` mempty) + +-- | This pattern gives the newtype wrapper around 'StateT' the same interface +-- as 'Control.Monad.Writer.Strict.WriterT'. Unfortunately, GHC currently warns +-- that a function is incomplete wherever this pattern is used. This issue +-- should be solved in a future version of GHC, when the +-- pragma is +-- implemented. +pattern WriterT :: (Functor m, Monoid s, Suitable m (a, s)) => + m (a, s) -> WriterT s m a + +pattern WriterT x <- (runWriterT -> x) + where WriterT y + = WriterT_ (State.Strict.StateT (\ s -> (fmap.fmap) (mappend s) y)) + +-- | A type synonym for the plain (non-transformer) version of 'WriterT'. This +-- can be used as if it were defined as: +-- +-- > newtype Writer w a = Writer { runWriter :: (a, w) } +type Writer s = WriterT s Identity + +-- | Run a writer computation. +-- +-- >>> runWriter $ traverse (\x -> writer (show x, [x])) [1..5] +-- (["1","2","3","4","5"],[1,2,3,4,5]) +runWriter + :: Monoid s + => Writer s a -> (a, s) +runWriter = + (coerce + :: (WriterT s Identity a -> Identity (a, s)) + -> (WriterT s Identity a -> (a, s)) + ) runWriterT + +{-# INLINE runWriter #-} + +instance (Monoid s, Monad m) => + MonadWriter s (WriterT s m) where + type WriterSuitable (WriterT s m) a = Suitable m (a, s) + tell s = WriterT (pure ((), s)) + writer (x,s) = WriterT (pure (x, s)) + {-# INLINE writer #-} + listenC f (WriterT_ xs) = + WriterT_ + (State.Strict.StateT + (fmap + (\(x,s') -> + (f x s', s')) . + State.Strict.runStateT xs)) + {-# INLINE listenC #-} + passC f (WriterT_ xs) = + WriterT_ + (State.Strict.StateT + (fmap + (\(x,s') -> + (x, f x s')) . State.Strict.runStateT xs)) + {-# INLINE passC #-} + +instance MonadTrans (WriterT w) where + type SuitableLift (WriterT w) m a = Suitable m (a, w) + lift xs = WriterT_ . State.Strict.StateT $ (\s -> fmap (flip (,) s) xs) + +instance MonadState s m => + MonadState s (WriterT w m) where + type StateSuitable (WriterT w m) a = (StateSuitable m a, Suitable m (a, w)) + get = lift get + put = lift . put + state = lift . state + +instance MonadError e m => + MonadError e (WriterT w m) where + type SuitableError (WriterT w m) a = SuitableError m (a, w) + throwError e = WriterT_ . State.Strict.StateT $ const (throwError e) + catchError (WriterT_ xs) f = + WriterT_ (State.Strict.liftCatch catchError xs (unWriterT . f)) + +instance MonadReader r m => + MonadReader r (WriterT w m) where + type ReaderSuitable (WriterT w m) a + = (ReaderSuitable m a + ,Suitable m (a, w) + ,ReaderSuitable m (a, w)) + ask = WriterT_ ask + reader x = WriterT_ (reader x) + local f (WriterT_ xs) = WriterT_ (local f xs) + +-- | Run a writer computation in the underlying monad, and return its result. +evalWriterT + :: (Monad m, Monoid s, Suitable m a) + => WriterT s m a -> m a +evalWriterT = fmap fst . runWriterT + +{-# INLINE evalWriterT #-} + +-- | Run a writer computation in the underlying monad, and collect its output. +execWriterT + :: (Monad m, Monoid s, Suitable m s) + => WriterT s m a -> m s +execWriterT = fmap snd . runWriterT + +{-# INLINE execWriterT #-} + +-- | Run a writer computation, and return its result. +evalWriter + :: Monoid s + => Writer s a -> a +evalWriter = fst . runWriter + +{-# INLINE evalWriter #-} + +-- | Run a writer computation, and collect its output. +execWriter + :: Monoid s + => Writer s a -> s +execWriter = snd . runWriter + +{-# INLINE execWriter #-} + +instance (Foldable m, Monoid w) => + Foldable (WriterT w m) where + foldMap f = + foldMap + (\(x,_) -> + f x) . + runWriterT + +-- instance (Traversable m, Monoid w) => +-- Traversable (WriterT w m) where +-- traverse f x = WriterT <$> (traverse . first_) f (runWriterT x) + +instance (Eq1 m, Eq w, Monoid w) => + Eq1 (WriterT w m) where + liftEq eq x y = + liftEq + (\(xx,xy) (yx,yy) -> + eq xx yx && xy == yy) + (runWriterT x) + (runWriterT y) + +instance (Ord1 m, Ord w, Monoid w) => + Ord1 (WriterT w m) where + liftCompare cmp x y = + liftCompare + (\(xx,xy) (yx,yy) -> + cmp xx yx `mappend` compare xy yy) + (runWriterT x) + (runWriterT y) + +-- instance (Read w, Read1 m, Monoid w, Functor m) => +-- Read1 (WriterT w m) where +-- liftReadsPrec rp rl = +-- readsData $ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" WriterT_ +-- where +-- rp' = liftReadsPrec2 rp rl readsPrec readList +-- rl' = liftReadList2 rp rl readsPrec readList + +instance (Show w, Show1 m, Monoid w) => + Show1 (WriterT w m) where + liftShowsPrec sp sl d m = + showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d (runWriterT m) + where + sp' = liftShowsPrec2 sp sl showsPrec showList + sl' = liftShowList2 sp sl showsPrec showList + +instance (Eq w, Eq1 m, Eq a, Monoid w) => + Eq (WriterT w m a) where + (==) = eq1 + +instance (Ord w, Ord1 m, Ord a, Monoid w) => + Ord (WriterT w m a) where + compare = compare1 + +-- instance (Read w, Read1 m, Read a, Monoid w, Functor m) => +-- Read (WriterT w m a) where +-- readsPrec = readsPrec1 + +instance (Show w, Show1 m, Show a, Monoid w) => + Show (WriterT w m a) where + showsPrec = showsPrec1 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main (main) where + +import Control.Monad.Constrained +import qualified Prelude + +import Test.DocTest +import Test.QuickCheck + +import Data.Proxy + +import qualified Control.Applicative + +import Data.Set (Set) +import Control.Monad.Constrained.IntSet (IntSet) + +import GHC.Exts (fromList) +import Data.Functor.Classes + +import Control.Monad.Trans.Reader (ReaderT(..), Reader) +import Control.Monad.Trans.State.Strict (StateT(..), State) +import Data.Functor.Identity + +instance Functor Gen where + type Suitable Gen a = () + fmap = Prelude.fmap + (<$) = (Prelude.<$) + +instance Applicative Gen where + liftA = liftAP + +instance Monad Gen where + (>>=) = (Prelude.>>=) + +instance a ~ Int => Arbitrary (IntSet a) where + arbitrary = fmap fromList arbitrary + +fmapIsSame + :: (Functor f, Prelude.Functor f, Suitable f b, Eq (f b), Show (f b)) + => Blind (a -> b) -> f a -> Property +fmapIsSame (Blind f) x = label "fmap is same" $ fmap f x === Prelude.fmap f x + +replaceIsSame + :: (Functor f, Prelude.Functor f, Suitable f a, Eq (f a), Show (f a)) + => f b -> a -> Property +replaceIsSame xs x = label "replace is same" $ (x <$ xs) === (x Prelude.<$ xs) + +pureIsSame + :: (Applicative f + ,Prelude.Applicative f + ,Suitable f a + ,Eq (f a) + ,Show (f a)) + => Proxy f -> a -> Property +pureIsSame (_ :: Proxy f) (x :: a) = label "pure is same" $ (pure x :: f a) === Prelude.pure x + +seqRightIsSame + :: (Applicative f + ,Prelude.Applicative f + ,Suitable f b + ,Eq (f b) + ,Show (f b)) + => f a -> f b -> Property +seqRightIsSame xs ys = label "*> is same" $ (xs *> ys) === (xs Prelude.*> ys) + +seqLeftIsSame + :: (Applicative f + ,Prelude.Applicative f + ,Suitable f b + ,Eq (f b) + ,Show (f b)) + => f b -> f a -> Property +seqLeftIsSame xs ys = label "<* is same" $ (xs <* ys) === (xs Prelude.<* ys) + +applyIsSame + :: (Applicative f + ,Prelude.Applicative f + ,Suitable f b + ,Eq (f b) + ,Show (f b)) + => Blind (f (a -> b)) -> f a -> Property +applyIsSame (Blind fs) xs = label "<*> is same" $ (fs <*> xs) === (fs Prelude.<*> xs) + +liftA2IsSame + :: (Applicative f + ,Prelude.Applicative f + ,Suitable f c + ,Eq (f c) + ,Show (f c)) + => Blind (a -> b -> c) -> f a -> f b -> Property +liftA2IsSame (Blind f) xs ys = + label "liftA2 is same" $ + liftA2 f xs ys === Control.Applicative.liftA2 f xs ys + +bindIsSame + :: (Monad f, Prelude.Monad f, Suitable f b, Show (f b), Eq (f b)) + => f a -> Blind (a -> f b) -> Property +bindIsSame xs (Blind f) = + label ">>= is same" $ (xs >>= f) === (xs Prelude.>>= f) + +checkSame + :: (Monad f + ,Prelude.Monad f + ,Show (f b) + ,Show (f c) + ,CoArbitrary c + ,Arbitrary (f c) + ,Arbitrary (f a) + ,Arbitrary (f (b -> a)) + ,CoArbitrary b + ,Arbitrary a + ,Arbitrary (f b) + ,Suitable f a + ,Eq (f a) + ,Show (f a) + ,Show a) + => Proxy f -> Proxy a -> Proxy b -> Proxy c -> IO () +checkSame (_ :: Proxy f) (_ :: Proxy a) (_ :: Proxy b) (_ :: Proxy c) = do + quickCheck (fmapIsSame @ f @ a @ b) + quickCheck (replaceIsSame @ f @ a @ b) + quickCheck (pureIsSame (Proxy :: Proxy f) :: a -> Property) + quickCheck (seqRightIsSame @ f @ a @ b) + quickCheck (seqLeftIsSame @ f @ a @ b) + quickCheck (applyIsSame @ f @ a @ b) + quickCheck (liftA2IsSame @ f @ a @ b @ c) + quickCheck (bindIsSame @ f @ a @ b) + +checkConstrained + :: (Show (f a) + ,Arbitrary (f a) + ,Suitable f a + ,Eq (f a) + ,Show (f c) + ,CoArbitrary c + ,CoArbitrary b + ,Arbitrary a + ,Arbitrary (f c) + ,Suitable f b + ,Show (f b) + ,Arbitrary (f b) + ,Show a + ,CoArbitrary a + ,Eq (f b) + ,Monad f + ,Arbitrary b) + => Proxy f -> Proxy a -> Proxy b -> Proxy c -> IO () +checkConstrained (_ :: Proxy f) (_ :: Proxy a) (_ :: Proxy b) (_ :: Proxy c) = do + quickCheck (fmapLaw @ f @ a) + quickCheck (fmapCompLaw @ f @ a @ b @ c) + quickCheck (seqRightLaw @ f @ a @ b) + quickCheck (seqLeftLaw @ f @ a @ b) + quickCheck (monadLawOne @ f @ a @ b) + quickCheck (monadLawTwo @ f @ a) + quickCheck (monadLawThree @ f @ a @ b @ c) + +checkUnConstrained + :: (Show (f a) + ,Arbitrary (f a) + ,Suitable f a + ,Suitable f ((a -> b) -> (c -> a) -> c -> b) + ,Arbitrary (f (a -> b)) + ,Arbitrary (f (c -> a)) + ,Suitable f ((c -> a) -> c -> b) + ,Suitable f (c -> b) + ,Suitable f (a -> b) + ,Suitable f ((a -> b) -> b) + ,Eq (f a) + ,Show (f c) + ,CoArbitrary c + ,CoArbitrary b + ,Arbitrary a + ,Arbitrary (f c) + ,Suitable f b + ,Show (f b) + ,Arbitrary (f b) + ,Show a + ,CoArbitrary a + ,Eq (f b) + ,Monad f + ,Suitable f (a -> a) + ,Arbitrary b) + => Proxy f -> Proxy a -> Proxy b -> Proxy c -> IO () +checkUnConstrained (pf :: Proxy f) (pa :: Proxy a) (pb :: Proxy b) (pc :: Proxy c) = do + checkConstrained pf pa pb pc + quickCheck (appIdLaw @ f @ a) + quickCheck (appCompLaw @ f @ a @ b @ c) + quickCheck (homomorphismLaw (Proxy :: Proxy f) :: Blind (a -> b) -> a -> Property) + quickCheck (interchangeLaw @ f @ a @ b) + + +{-# ANN fmapLaw "HLint: ignore Functor law" #-} +fmapLaw + :: (Functor f, Suitable f a, Eq (f a), Show (f a)) + => f a -> Property +fmapLaw xs = label "fmap law" $ fmap id xs === xs + +{-# ANN fmapCompLaw "HLint: ignore Functor law" #-} +fmapCompLaw + :: (Functor f, Suitable f c, Eq (f c), Show (f c), Suitable f b) + => Blind (b -> c) -> Blind (a -> b) -> f a -> Property +fmapCompLaw (Blind f) (Blind g) xs = + label "fmap comp law" $ fmap (f . g) xs === (fmap f . fmap g) xs + +seqRightLaw + :: (Applicative f, Suitable f b, Eq (f b), Show (f b)) + => f a -> f b -> Property +seqRightLaw xs ys = label "*> law" $ (xs *> ys) === (liftA2 (const id) xs ys) + +seqLeftLaw + :: (Applicative f, Suitable f a, Eq (f a), Show (f a)) + => f a -> f b -> Property +seqLeftLaw xs ys = label "<* law" $ (xs <* ys) === (liftA2 const xs ys) + +appIdLaw + :: (Applicative f, Suitable f a, Suitable f (a -> a), Eq (f a), Show (f a)) + => f a -> Property +appIdLaw xs = label "app id law" $ (pure id <*> xs) === xs + +appCompLaw + :: (Applicative f + ,Suitable f ((b -> c) -> (a -> b) -> a -> c) + ,Suitable f ((a -> b) -> a -> c) + ,Suitable f (a -> c) + ,Suitable f c + ,Suitable f b + ,Eq (f c) + ,Show (f c)) + => Blind (f (b -> c)) -> Blind (f (a -> b)) -> f a -> Property +appCompLaw (Blind u) (Blind v) w + = label "app comp law" $ (pure (.) <*> u <*> v <*> w) === (u <*> (v <*> w)) + +homomorphismLaw + :: (Suitable f (a -> b) + ,Suitable f b + ,Suitable f a + ,Applicative f + ,Eq (f b) + ,Show (f b)) + => Proxy f -> Blind (a -> b) -> a -> Property +homomorphismLaw (_ :: Proxy f) (Blind (f :: a -> b)) x + = label "homomorphism law" $ (pure f <*> pure x) === (pure (f x) :: f b) + +interchangeLaw + :: (Applicative f + ,Suitable f a + ,Suitable f b + ,Suitable f ((a -> b) -> b) + ,Eq (f b) + ,Show (f b)) + => Blind (f (a -> b)) -> a -> Property +interchangeLaw (Blind u) y = label "interchange law" $ (u <*> pure y) === (pure ($y) <*> u) + +monadLawOne + :: (Monad f, Suitable f a, Suitable f b, Show (f b), Eq (f b)) + => Blind (a -> f b) -> a -> Property +monadLawOne (Blind k) a = label "monad law one" $ (pure a >>= k) === k a + +monadLawTwo + :: (Monad f, Suitable f a, Eq (f a), Show (f a)) + => f a -> Property +monadLawTwo xs = label "monad law two" $ (xs >>= pure) === xs + +monadLawThree + :: (Monad f, Suitable f c, Eq (f c), Suitable f b, Show (f c)) + => f a -> Blind (a -> f b) -> Blind (b -> f c) -> Property +monadLawThree m (Blind k) (Blind h) = + label "monad law three" $ (m >>= (k >=> h)) === ((m >>= k) >>= h) + +instance (Enum a, Bounded a, Eq1 m, Eq b) => Eq (ReaderT a m b) where + ReaderT fs == ReaderT gs = all (\x -> eq1 (fs x) (gs x)) [minBound..maxBound] + +instance (CoArbitrary a, Arbitrary (m b)) => Arbitrary (ReaderT a m b) where + arbitrary = fmap ReaderT arbitrary + +instance (CoArbitrary a, Arbitrary (m (b,a))) => Arbitrary (StateT a m b) where + arbitrary = fmap StateT arbitrary + +instance (Enum a, Bounded a, Eq (m (b,a))) => Eq (StateT a m b) where + StateT fs == StateT gs = all (\x -> (fs x) == (gs x)) [minBound..maxBound] + +instance (Enum a, Show a, Show (m b), Bounded a) => Show (ReaderT a m b) where + show (ReaderT xs) = show (map ((,) <*> xs) [minBound..maxBound]) + +instance (Enum a, Show a, Show (m (b,a)), Bounded a) => Show (StateT a m b) where + show (StateT xs) = show (map ((,) <*> xs) [minBound..maxBound]) + +instance Arbitrary a => Arbitrary (Identity a) where + arbitrary = fmap Identity arbitrary + +main :: IO () +main = do + putStrLn "[]" + checkSame (Proxy @ [] ) (Proxy @ Integer) (Proxy @ Word) (Proxy @ Int) + checkUnConstrained (Proxy @ [] ) (Proxy @ Integer) (Proxy @ Word) (Proxy @ Int) + putStrLn "Set" + checkConstrained (Proxy @ Set) (Proxy @ Integer) (Proxy @ Word) (Proxy @ Int) + putStrLn "IntSet" + checkConstrained (Proxy @ IntSet) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + putStrLn "Reader Bool" + checkUnConstrained (Proxy @ (Reader Bool)) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + checkSame (Proxy @ (Reader Bool)) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + putStrLn "ReaderT Bool Maybe" + checkUnConstrained (Proxy @ (ReaderT Bool Maybe)) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + checkSame (Proxy @ (ReaderT Bool Maybe)) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + putStrLn "State Bool" + checkUnConstrained (Proxy @ (State Bool)) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + checkSame (Proxy @ (State Bool)) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + putStrLn "StateT Bool Maybe" + checkUnConstrained (Proxy @ (StateT Bool Maybe)) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + checkSame (Proxy @ (StateT Bool Maybe)) (Proxy @ Int ) (Proxy @ Int ) (Proxy @ Int) + + doctest [ "-isrc", "src/" ]