diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,16 @@ +4.10.0.1 +------ +* Fix for very old `cabal` versions where the `MIN_VERSION_foo` macros aren't negation friendly. + +4.10 +---- +* Redefine `Alternative` and `MonadPlus` instances of `IterT` so that they apply to any underlying `Monad`. + `mplus` or `<|>` is Capretta's `race` combinator; `mzero` or `empty` is a non-terminating computation. +* Redefine `fail s` for `IterT` as `mzero`, for any string `s`. +* Added `Control.Monad.Trans.Iter.untilJust`, which repeatedly retries a `m (Maybe a)` computation until + it produces `Just` a value. +* Fix things so that we can build with GHC 7.10, which also uses the name `Alt` in `Data.Monoid`, and which exports `Monoid` from `Prelude`. + 4.9 --- * Remove `either` support. Why? It dragged in a large number of dependencies we otherwise don't support, and so is probably best inverted. diff --git a/examples/Cabbage.lhs b/examples/Cabbage.lhs new file mode 100644 --- /dev/null +++ b/examples/Cabbage.lhs @@ -0,0 +1,208 @@ +> {-# LANGUAGE ViewPatterns #-} +> module Cabbage where + +> import Control.Applicative +> import Control.Monad +> import Control.Monad.State +> import Control.Monad.Trans.Iter +> import Control.Monad.Writer +> import Data.Functor.Identity +> import Data.Maybe +> import Data.Tuple +> import Data.List + +Consider the following problem: + +A farmer must cross a river with a wolf, a sheep and a cabbage. +He owns a boat, which can only carry himself and one other item. +The sheep must not be left alone with the wolf, or with the cabbage: +if that happened, one of them would eat the other. + +> data Item = Wolf | Sheep | Cabbage | Farmer deriving (Ord, Show, Eq) +> +> eats :: Item -> Item -> Bool +> Sheep `eats` Cabbage = True +> Wolf `eats` Sheep = True +> _ `eats` _ = False + +The problem can be represented as the set of items on each side of the river. + +> type Situation = ([Item],[Item]) + +> initial :: Situation +> initial = ([Farmer, Wolf, Sheep, Cabbage], []) + +First, some helper functions to extract single elements from lists, leaving the +rest intact: + +> plusTailOf :: [a] -> [a] -> (Maybe a, [a]) +> a `plusTailOf` b = (listToMaybe b, a ++ drop 1 b) + +> singleOut1 :: (a -> Bool) -> [a] -> (Maybe a,[a]) +> singleOut1 sel = uncurry plusTailOf . break sel + +@ +*Cabbage> singleOut1 (== Sheep) [Wolf, Sheep, Cabbage] +[(Just Wolf,[Sheep,Cabbage]),(Just Sheep,[Wolf,Cabbage]),(Just Cabbage,[Wolf,Sheep]),(Nothing,[Wolf,Sheep,Cabbage])] +@ + +> singleOutAll :: [a] -> [(Maybe a,[a])] +> singleOutAll = zipWith plusTailOf <$> inits <*> tails + +@ +*Cabbage> singleOutAll [Wolf, Sheep, Cabbage] +[(Just Wolf,[Sheep,Cabbage]),(Just Sheep,[Wolf,Cabbage]),(Just Cabbage,[Wolf,Sheep]),(Nothing,[Wolf,Sheep,Cabbage])] +@ + +In every move, the farmer goes from one side of the river to the other, +together with (optionally) one item. + +The remaining items must not eat each other for the move to be valid. + +> move :: Situation -> [Situation] +> move = move2 +> where +> move2 (singleOut1 (== Farmer) -> (Just Farmer,as), bs) = move1 as bs +> move2 (bs, singleOut1 (== Farmer) -> (Just Farmer,as)) = map swap $ move1 as bs +> move2 _ = [] +> +> move1 as bs = [(as', [Farmer] ++ maybeToList b ++ bs) | +> (b, as') <- singleOutAll as, +> and [not $ x `eats` y | x <- as', y <- as']] + +@ +*Cabbage> move initial +[([Wolf,Cabbage],[Farmer,Sheep])] +@ + +When the starting side becomes empty, the farmer succeeds. + +> success :: Situation -> Bool +> success ([],_) = True +> success _ = False + +A straightforward implementation to solve the problem could use the +list monad, trying all possible solutions and + +> solution1 :: Situation +> solution1 = head $ solutions' initial +> where +> solutions' a = if success a +> then return a +> else move a >>= solutions' + +However, when it's run, it will get stuck in an infinite loop, as the sheep +is shuffled back and forth. The solution is being searched in depth. + +To guarantee termination, we can use the 'Iter' monad with its MonadPlus instance. +As long as one of the possible execution paths finds a solution, the program +will terminate: the solution is looked for _in breadth_. + +> solution2 :: Iter Situation +> solution2 = solution' initial +> where +> solution' a = +> if success a +> then return a +> else delay $ msum $ map solution' (move a) + +Each of the alternative sequences of movements will be evaluated +concurrently; and the shortest one will be the result. In case of ties, +the leftmost solution takes priority. + +@ + *Cabbage> solution2 + IterT (Identity (Right ( … + (IterT (Identity (Right + (IterT (Identity (Left + ([],[Farmer,Sheep,Cabbage,Wolf])))))))))))))))))))))))) +@ + +For a cleaner display, use 'retract' to escape 'Iter' monad: + +@ + *Cabbage> retract solution2 + Identity ([],[Farmer,Sheep,Cabbage,Wolf]) +@ + +'unsafeIter' will also get rid of the 'Identity' wrapper: + +> unsafeIter :: Iter a -> a +> unsafeIter = runIdentity . retract + +@ + *Cabbage> unsafeIter solution2 + ([],[Farmer,Sheep,Cabbage,Wolf]) +@ + +Suppose that we not only want the solution, but also the steps that we +took to arrive there. Enter the Writer monad transformer: + +> solution3 :: Iter (Situation, [Situation]) +> solution3 = runWriterT $ solution' initial +> where +> solution' :: Situation -> WriterT [Situation] Iter Situation +> solution' a = do +> tell [a] +> if success a +> then return a +> else mapWriterT delay $ msum $ map solution' (move a) + +The second component contains the complete path to the solution: + +@ + *Cabbage> snd $ unsafeIter solution3 + [([Farmer,Wolf,Sheep,Cabbage],[]), + ([Wolf,Cabbage],[Farmer,Sheep]), + ([Farmer,Wolf,Cabbage],[Sheep]), + ([Cabbage],[Farmer,Wolf,Sheep]), + ([Farmer,Sheep,Cabbage],[Wolf]), + ([Sheep],[Farmer,Cabbage,Wolf]), + ([Farmer,Sheep],[Cabbage,Wolf]), + ([],[Farmer,Sheep,Cabbage,Wolf])] +@ + +When the transformer is applied _over_ the Iter monad, it acts locally for each solution. +If we apply the IterT transformer over another monad, +the behaviour for that monad will be shared among all threads. + +For example, let's keep track of how many moves we perform. We could +do so with the writer monad again (numbers form a monoid under addition), but +we'll use the state monad this time. + +> solution4 :: Iter (Situation, Integer) +> solution4 = flip runStateT 0 $ solution' initial +> where +> solution' :: Situation -> StateT Integer Iter Situation +> solution' a = +> if success a +> then return a +> else do +> modify (+1) +> mapStateT delay $ msum $ map solution' (move a) + +This gives us seven moves (one for each transition between two states). + +@ + *Cabbage> unsafeIter solution4 + (([],[Farmer,Sheep,Cabbage,Wolf]),7) +@ + +On the other hand, if move the state inside Iter, we get a global count of +explored nodes until the solution was found. + +> solution5 :: State Integer Situation +> solution5 = retract $ solution' initial +> where +> solution' :: Situation -> IterT (State Integer) Situation +> solution' a = +> if success a +> then return a +> else do +> modify (+1) +> delay $ msum $ map solution' (move a) + +@ + *Cabbage> runState solution5 0 + (([],[Farmer,Sheep,Cabbage,Wolf]),113) +@ diff --git a/free.cabal b/free.cabal --- a/free.cabal +++ b/free.cabal @@ -1,6 +1,6 @@ name: free category: Control, Monads -version: 4.9 +version: 4.10.0.1 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE diff --git a/src/Control/Applicative/Free.hs b/src/Control/Applicative/Free.hs --- a/src/Control/Applicative/Free.hs +++ b/src/Control/Applicative/Free.hs @@ -23,7 +23,7 @@ -- flexible to inspect and interpret, as the number of ways in which -- the values can be nested is more limited. -- - -- See , + -- See , -- by Paolo Capriotti and Ambrus Kaposi, for some applications. Ap(..) diff --git a/src/Control/Applicative/Trans/Free.hs b/src/Control/Applicative/Trans/Free.hs --- a/src/Control/Applicative/Trans/Free.hs +++ b/src/Control/Applicative/Trans/Free.hs @@ -50,7 +50,9 @@ import Data.Functor.Apply import Data.Functor.Identity import Data.Typeable -import Data.Monoid +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (Monoid) +#endif import qualified Data.Foldable as F -- | The free 'Applicative' for a 'Functor' @f@. diff --git a/src/Control/Comonad/Cofree.hs b/src/Control/Comonad/Cofree.hs --- a/src/Control/Comonad/Cofree.hs +++ b/src/Control/Comonad/Cofree.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} @@ -25,6 +26,7 @@ , section , coiter , unfold + , hoistCofree -- * Lenses into cofree comonads , _extract , _unwrap @@ -111,6 +113,9 @@ unfold :: Functor f => (b -> (a, f b)) -> b -> Cofree f a unfold f c = case f c of (x, d) -> x :< fmap (unfold f) d + +hoistCofree :: Functor f => (forall x . f x -> g x) -> Cofree f a -> Cofree g a +hoistCofree f (x :< y) = x :< f (hoistCofree f <$> y) instance Functor f => ComonadCofree f (Cofree f) where unwrap (_ :< as) = as diff --git a/src/Control/Comonad/Trans/Cofree.hs b/src/Control/Comonad/Trans/Cofree.hs --- a/src/Control/Comonad/Trans/Cofree.hs +++ b/src/Control/Comonad/Trans/Cofree.hs @@ -139,7 +139,7 @@ unwrap = tailF . extract . runCofreeT instance Show (w (CofreeF f a (CofreeT f w a))) => Show (CofreeT f w a) where - showsPrec d w = showParen (d > 10) $ + showsPrec d (CofreeT w) = showParen (d > 10) $ showString "CofreeT " . showsPrec 11 w instance Read (w (CofreeF f a (CofreeT f w a))) => Read (CofreeT f w a) where diff --git a/src/Control/Monad/Free/Church.hs b/src/Control/Monad/Free/Church.hs --- a/src/Control/Monad/Free/Church.hs +++ b/src/Control/Monad/Free/Church.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} @@ -118,8 +119,7 @@ {-# INLINE foldr #-} #if MIN_VERSION_base(4,6,0) - foldl' f z xs = runF xs (flip f) (foldr (!>>>) id) z - where (!>>>) h g = \r -> g $! h r + foldl' f z xs = runF xs (\a !r -> f r a) (flip $ foldl' $ \r g -> g r) z {-# INLINE foldl' #-} #endif diff --git a/src/Control/Monad/Trans/Free/Church.hs b/src/Control/Monad/Trans/Free/Church.hs --- a/src/Control/Monad/Trans/Free/Church.hs +++ b/src/Control/Monad/Trans/Free/Church.hs @@ -42,9 +42,11 @@ , iterM -- * Free Monads With Class , MonadFree(..) + , liftF ) where import Control.Applicative +import Control.Category ((<<<), (>>>)) import Control.Monad import Control.Monad.Identity import Control.Monad.Trans.Class @@ -61,7 +63,6 @@ import qualified Data.Foldable as F import Data.Traversable (Traversable) import qualified Data.Traversable as T -import Data.Monoid import Data.Functor.Bind hiding (join) import Data.Function @@ -82,7 +83,7 @@ instance Applicative (FT f m) where pure a = FT $ \k _ -> k a - FT fk <*> FT ak = FT $ \b fr -> ak (\d -> fk (\e -> b (e d)) fr) fr + FT fk <*> FT ak = FT $ \b fr -> fk (\e -> ak (\d -> b (e d)) fr) fr instance Bind (FT f m) where (>>-) = (>>=) @@ -106,7 +107,18 @@ mplus (FT k1) (FT k2) = FT $ \a fr -> k1 a fr `mplus` k2 a fr instance (Foldable f, Foldable m, Monad m) => Foldable (FT f m) where - foldMap f (FT k) = F.fold $ k (return . f) (F.foldr (liftM2 mappend) (return mempty)) + foldr f r xs = F.foldr (<<<) id inner r + where + inner = runFT xs (return . f) (F.foldr (liftM2 (<<<)) (return id)) + {-# INLINE foldr #-} + +#if MIN_VERSION_base(4,6,0) + foldl' f z xs = F.foldl' (!>>>) id inner z + where + (!>>>) h g = \r -> g $! h r + inner = runFT xs (return . flip f) (F.foldr (liftM2 (>>>)) (return id)) + {-# INLINE foldl' #-} +#endif instance (Monad m, Traversable m, Traversable f) => Traversable (FT f m) where traverse f (FT k) = fmap (join . lift) . T.sequenceA $ k traversePure traverseFree diff --git a/src/Control/Monad/Trans/Iter.hs b/src/Control/Monad/Trans/Iter.hs --- a/src/Control/Monad/Trans/Iter.hs +++ b/src/Control/Monad/Trans/Iter.hs @@ -40,6 +40,15 @@ -- monad encapsulates errors, the 'Iter' monad encapsulates -- non-termination. The 'IterT' transformer generalizes non-termination to any monadic -- computation. + -- + -- Computations in 'IterT' (or 'Iter') can be composed in two ways: + -- + -- * /Sequential:/ Using the 'Monad' instance, the result of a computation + -- can be fed into the next. + -- + -- * /Parallel:/ Using the 'MonadPlus' instance, several computations can be + -- executed concurrently, and the first to finish will prevail. + -- See also the . -- * The iterative monad transformer IterT(..) @@ -51,6 +60,7 @@ , liftIter , cutoff , never + , untilJust , interleave, interleave_ -- * Consuming iterative monads , retract @@ -158,7 +168,7 @@ {-# INLINE return #-} IterT m >>= k = IterT $ m >>= either (runIterT . k) (return . Right . (>>= k)) {-# INLINE (>>=) #-} - fail = IterT . fail + fail _ = never {-# INLINE fail #-} instance Monad m => Apply (IterT m) where @@ -173,16 +183,19 @@ mfix f = IterT $ mfix $ runIterT . f . either id (error "mfix (IterT m): Right") {-# INLINE mfix #-} -instance MonadPlus m => Alternative (IterT m) where - empty = IterT mzero +instance Monad m => Alternative (IterT m) where + empty = mzero {-# INLINE empty #-} - IterT a <|> IterT b = IterT (mplus a b) + (<|>) = mplus {-# INLINE (<|>) #-} -instance MonadPlus m => MonadPlus (IterT m) where - mzero = IterT mzero +-- | Capretta's 'race' combinator. Satisfies left catch. +instance Monad m => MonadPlus (IterT m) where + mzero = never {-# INLINE mzero #-} - IterT a `mplus` IterT b = IterT (mplus a b) + (IterT x) `mplus` (IterT y) = IterT $ x >>= either + (return . Left) + (flip liftM y . second . mplus) {-# INLINE mplus #-} instance MonadTrans IterT where @@ -297,6 +310,20 @@ never :: (Monad f, MonadFree f m) => m a never = delay never +-- | Repeatedly run a computation until it produces a 'Just' value. +-- This can be useful when paired with a monad that has side effects. +-- +-- For example, we may have @genId :: IO (Maybe Id)@ that uses a random +-- number generator to allocate ids, but fails if it finds a collision. +-- We can repeatedly run this with +-- +-- @ +-- 'retract' ('untilJust' genId) :: IO Id +-- @ +untilJust :: (Monad m) => m (Maybe a) -> IterT m a +untilJust f = maybe (delay (untilJust f)) return =<< lift f +{-# INLINE untilJust #-} + -- | Cuts off an iterative computation after a given number of -- steps. If the number of steps is 0 or less, no computation nor -- monadic effects will take place. @@ -416,6 +443,8 @@ {- $examples - +* + +* -}