logict 0.7.1.0 → 0.8.2.0
raw patch · 6 files changed
Files
- Control/Monad/Logic.hs +362/−38
- Control/Monad/Logic/Class.hs +78/−16
- changelog.md +24/−1
- example/grandparents.hs +0/−6
- logict.cabal +16/−13
- test/Test.hs +114/−35
Control/Monad/Logic.hs view
@@ -13,20 +13,23 @@ -- <http://okmij.org/ftp/papers/LogicT.pdf Backtracking, Interleaving, and Terminating Monad Transformers> -- by Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry. -- Note that the paper uses 'MonadPlus' vocabulary--- ('mzero' and 'mplus'),+-- ('Control.Monad.mzero' and 'Control.Monad.mplus'), -- while examples below prefer 'empty' and '<|>' -- from 'Alternative'. ------------------------------------------------------------------------- {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE UndecidableInstances #-} -#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#endif+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid restricted function" #-} module Control.Monad.Logic ( module Control.Monad.Logic.Class,@@ -43,49 +46,92 @@ observeT, observeManyT, observeAllT,- module Control.Monad,- module Trans+ fromLogicT,+ fromLogicTWith,+ hoistLogicT,+ embedLogicT ) where -import Control.Applicative+import Prelude (error, (-)) -import Control.Monad+import Control.Applicative (Alternative(..), Applicative, liftA2, pure, (<*>), (*>))+import Control.Exception (Exception, evaluate, throw)+import Control.Monad (join, MonadPlus(..), Monad(..), fail)+import Control.Monad.Catch (MonadThrow, MonadCatch, throwM, catch)+import Control.Monad.Error.Class (MonadError(..)) import qualified Control.Monad.Fail as Fail import Control.Monad.Identity (Identity(..)) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Trans (MonadTrans(..))-import qualified Control.Monad.Trans as Trans- import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..))-import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.Zip (MonadZip (..)) -#if !MIN_VERSION_base(4,8,0)+import Data.Bool (Bool (..), otherwise)+import Data.Eq (Eq, (==))+import qualified Data.Foldable as F+import Data.Function (($), (.), const, on)+import Data.Functor (Functor(..), (<$>))+import Data.Int+import qualified Data.List as L+import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid (..))-#endif--#if MIN_VERSION_base(4,9,0)+import Data.Ord (Ord, (<=), (>), compare) import Data.Semigroup (Semigroup (..))+import qualified Data.Traversable as T+import System.IO.Unsafe (unsafePerformIO)+import Text.Show (Show, showsPrec, showParen, showString, shows)+import Text.Read (Read, readPrec, Lexeme (Ident), parens, lexP, prec, readListPrec, readListPrecDefault)++#if MIN_VERSION_base(4,17,0)+import GHC.IsList (IsList(..))+#else+import GHC.Exts (IsList(..)) #endif -import qualified Data.Foldable as F-import qualified Data.Traversable as T+#if MIN_VERSION_base(4,18,0)+import qualified Data.Foldable1 as F1+#endif import Control.Monad.Logic.Class ------------------------------------------------------------------------- -- | A monad transformer for performing backtracking computations -- layered over another monad @m@.+--+-- When @m@ is 'Identity', 'LogicT' @m@ becomes isomorphic to a list+-- (see 'Logic'). Thus 'LogicT' @m@ for non-trivial @m@ can be imagined+-- as a list, pattern matching on which causes monadic effects.+--+-- It's important to remember that 'LogicT' on its own is just+-- a lawful list monad transformer, adding a nondeterministic effect,+-- and its 'Monad' instance behaves just as @instance@ 'Monad' @[]@:+--+-- >>> :set -XOverloadedLists+-- >>> observeMany 9 $ do {x <- [100,200] :: Logic Int; fmap (+x) [1..]}+-- [101,102,103,104,105,106,107,108,109]+-- >>> observeMany 9 $ do {[100,200] >>= \x -> fmap (+x) [1..] :: Logic Int}+-- [101,102,103,104,105,106,107,108,109]+--+-- One should explicitly use methods of 'MonadLogic' such as '(>>-)' and 'interleave'+-- to get fair conjunction / disjunction:+--+-- >>> observeMany 9 $ do {[100,200] >>- \x -> fmap (+x) [1..] :: Logic Int}+-- [101,201,102,202,103,203,104,204,105]+--+-- @since 0.2 newtype LogicT m a = LogicT { unLogicT :: forall r. (a -> m r -> m r) -> m r -> m r } ------------------------------------------------------------------------- -- | Extracts the first result from a 'LogicT' computation, -- failing if there are no results at all.+--+-- @since 0.2 #if !MIN_VERSION_base(4,13,0) observeT :: Monad m => LogicT m a -> m a #else-observeT :: MonadFail m => LogicT m a -> m a+observeT :: Fail.MonadFail m => LogicT m a -> m a #endif observeT lt = unLogicT lt (const . return) (fail "No answer.") @@ -112,19 +158,23 @@ -- In general, if the underlying monad manages control flow then -- 'observeAllT' may be unproductive under infinite branching, -- and 'observeManyT' should be used instead.+--+-- @since 0.2 observeAllT :: Applicative m => LogicT m a -> m [a] observeAllT m = unLogicT m (fmap . (:)) (pure []) ------------------------------------------------------------------------- -- | Extracts up to a given number of results from a 'LogicT' computation.+--+-- @since 0.2 observeManyT :: Monad m => Int -> LogicT m a -> m [a] observeManyT n m | n <= 0 = return [] | n == 1 = unLogicT m (\a _ -> return [a]) (return []) | otherwise = unLogicT (msplit m) sk (return [])- where- sk Nothing _ = return []- sk (Just (a, m')) _ = (a:) `liftM` observeManyT (n-1) m'+ where+ sk Nothing _ = return []+ sk (Just (a, m')) _ = (a:) <$> observeManyT (n-1) m' ------------------------------------------------------------------------- -- | Runs a 'LogicT' computation with the specified initial success and@@ -151,16 +201,142 @@ -- >>> runLogicT (yieldWords ["foo", "bar"]) showFirst (putStrLn "none!") -- foo --+-- @since 0.2 runLogicT :: LogicT m a -> (a -> m r -> m r) -> m r -> m r runLogicT (LogicT r) = r +-- | Convert from 'LogicT' to an arbitrary logic-like monad transformer,+-- such as <https://hackage.haskell.org/package/list-t list-t>+-- or <https://hackage.haskell.org/package/logict-sequence logict-sequence>+--+-- For example, to show a representation of the structure of a `LogicT`+-- computation, @l@, over a data-like `Monad` (such as @[]@,+-- @Data.Sequence.Seq@, etc.), you could write+--+-- @+-- import ListT (ListT)+--+-- 'Text.Show.show' $ fromLogicT @ListT l+-- @+--+-- @since 0.8.0.0+fromLogicT :: (Alternative (t m), MonadTrans t, Monad m, Monad (t m))+ => LogicT m a -> t m a+fromLogicT = fromLogicTWith lift++-- | Convert from @'LogicT' m@ to an arbitrary logic-like monad,+-- such as @[]@.+--+-- Examples:+--+-- @+-- 'fromLogicT' = fromLogicTWith d+-- 'hoistLogicT' f = fromLogicTWith ('lift' . f)+-- 'embedLogicT' f = 'fromLogicTWith' f+-- @+--+-- The first argument should be a+-- <https://hackage.haskell.org/package/mmorph/docs/Control-Monad-Morph.html monad morphism>.+-- to produce sensible results.+--+-- @since 0.8.0.0+fromLogicTWith :: (Applicative m, Monad n, Alternative n)+ => (forall x. m x -> n x) -> LogicT m a -> n a+fromLogicTWith p (LogicT f) = join . p $+ f (\a v -> pure (pure a <|> join (p v))) (pure empty)++-- | Convert a 'LogicT' computation from one underlying monad to another.+-- For example,+--+-- @+-- hoistLogicT lift :: LogicT m a -> LogicT (StateT m) a+-- @+--+-- The first argument should be a+-- <https://hackage.haskell.org/package/mmorph/docs/Control-Monad-Morph.html monad morphism>.+-- to produce sensible results.+--+-- @since 0.8.0.0+hoistLogicT :: (Applicative m, Monad n) => (forall x. m x -> n x) -> LogicT m a -> LogicT n a+hoistLogicT f = fromLogicTWith (lift . f)++-- | Convert a 'LogicT' computation from one underlying monad to another.+--+-- The first argument should be a+-- <https://hackage.haskell.org/package/mmorph/docs/Control-Monad-Morph.html monad morphism>.+-- to produce sensible results.+--+-- @since 0.8.0.0+embedLogicT :: Applicative m => (forall a. m a -> LogicT n a) -> LogicT m b -> LogicT n b+embedLogicT f = fromLogicTWith f+ ------------------------------------------------------------------------- -- | The basic 'Logic' monad, for performing backtracking computations -- returning values (e.g. 'Logic' @a@ will return values of type @a@).+--+-- It's important to remember that 'Logic' on its own is just+-- a lawful list monad, behaving exactly as @instance@ 'Monad' @[]@.+-- One should explicitly use methods of 'MonadLogic' such as '(>>-)' and 'interleave'+-- to get fair conjunction / disjunction. Note that usual+-- lists have an instance of 'MonadLogic', so maybe you don't need 'Logic' at all.+--+-- __Technical perspective.__+-- 'Logic' is a+-- <http://okmij.org/ftp/tagless-final/course/Boehm-Berarducci.html Boehm-Berarducci encoding>+-- of lists. Speaking plainly, its type is identical (up to 'Identity' wrappers)+-- to 'Data.List.foldr' applied to a given list. And this list itself can be reconstructed+-- by supplying @(:)@ and @[]@.+--+-- > import Data.Functor.Identity+-- >+-- > fromList :: [a] -> Logic a+-- > fromList xs = LogicT $ \cons nil -> foldr cons nil xs+-- >+-- > toList :: Logic a -> [a]+-- > toList (LogicT fld) = runIdentity $ fld (\x (Identity xs) -> Identity (x : xs)) (Identity [])+--+-- Here is a systematic derivation of the isomorphism. We start with observing+-- that @[a]@ is isomorphic to a fix point of a non-recursive+-- base algebra @Fix@ (@ListF@ @a@):+--+-- > newtype Fix f = Fix (f (Fix f))+-- > data ListF a r = ConsF a r | NilF deriving (Functor)+-- >+-- > cata :: Functor f => (f r -> r) -> Fix f -> r+-- > cata f = go where go (Fix x) = f (fmap go x)+-- >+-- > from :: [a] -> Fix (ListF a)+-- > from = foldr (\a acc -> Fix (ConsF a acc)) (Fix NilF)+-- >+-- > to :: Fix (ListF a) -> [a]+-- > to = cata (\case ConsF a r -> a : r; NilF -> [])+--+-- Further, @Fix@ (@ListF@ @a@) is isomorphic to Boehm-Berarducci encoding @ListC@ @a@:+--+-- > newtype ListC a = ListC (forall r. (ListF a r -> r) -> r)+-- >+-- > from :: Fix (ListF a) -> ListC a+-- > from xs = ListC (\f -> cata f xs)+-- >+-- > to :: ListC a -> Fix (ListF a)+-- > to (ListC f) = f Fix+--+-- Finally, @ListF@ @a@ @r@ → @r@ is isomorphic to a pair (@a@ → @r@ → @r@, @r@),+-- so @ListC@ is isomorphic to the 'Logic' type modulo 'Identity' wrappers:+--+-- > newtype Logic a = Logic (forall r. (a -> r -> r) -> r -> r)+--+-- And wrapping every occurence of @r@ into @m@ gives us 'LogicT':+--+-- > newtype LogicT m a = Logic (forall r. (a -> m r -> m r) -> m r -> m r)+--+-- @since 0.5.0 type Logic = LogicT Identity ------------------------------------------------------------------------- -- | A smart constructor for 'Logic' computations.+--+-- @since 0.5.0 logic :: (forall r. (a -> r -> r) -> r -> r) -> Logic a logic f = LogicT $ \k -> Identity . f (\a -> runIdentity . k a . Identity) .@@ -176,15 +352,22 @@ -- >>> observe empty -- *** Exception: No answer. --+-- Since 'Logic' is isomorphic to a list, 'observe' is analogous to 'Data.List.head'.+--+-- @since 0.2 observe :: Logic a -> a observe lt = runIdentity $ unLogicT lt (const . pure) (error "No answer.") ------------------------------------------------------------------------- -- | Extracts all results from a 'Logic' computation. ----- >>> observe (pure 5 <|> empty <|> empty <|> pure 3 <|> empty)+-- >>> observeAll (pure 5 <|> empty <|> empty <|> pure 3 <|> empty) -- [5,3] --+-- 'observeAll' reveals a half of the isomorphism between 'Logic'+-- and lists. See description of 'runLogic' for the other half.+--+-- @since 0.2 observeAll :: Logic a -> [a] observeAll = runIdentity . observeAllT @@ -195,8 +378,11 @@ -- >>> observeMany 5 nats -- [0,1,2,3,4] --+-- Since 'Logic' is isomorphic to a list, 'observeMany' is analogous to 'Data.List.take'.+--+-- @since 0.2 observeMany :: Int -> Logic a -> [a]-observeMany i = take i . observeAll+observeMany i = L.take i . observeAll -- Implementing 'observeMany' using 'observeManyT' is quite costly, -- because it calls 'msplit' multiple times. @@ -210,6 +396,11 @@ -- >>> runLogic (pure 5 <|> pure 3 <|> empty) (+) 0 -- 8 --+-- When invoked with @(:)@ and @[]@ as arguments, reveals+-- a half of the isomorphism between 'Logic' and lists.+-- See description of 'observeAll' for the other half.+--+-- @since 0.2 runLogic :: Logic a -> (a -> r -> r) -> r -> r runLogic l s f = runIdentity $ unLogicT l si fi where@@ -222,6 +413,7 @@ instance Applicative (LogicT f) where pure a = LogicT $ \sk fk -> sk a fk f <*> a = LogicT $ \sk fk -> unLogicT f (\g fk' -> unLogicT a (sk . g) fk') fk+ m *> k = LogicT $ \sk fk -> unLogicT m (const $ unLogicT k sk) fk instance Alternative (LogicT f) where empty = LogicT $ \_ fk -> fk@@ -230,10 +422,12 @@ instance Monad (LogicT m) where return = pure m >>= f = LogicT $ \sk fk -> unLogicT m (\a fk' -> unLogicT (f a) sk fk') fk+ (>>) = (*>) #if !MIN_VERSION_base(4,13,0) fail = Fail.fail #endif +-- | @since 0.6.0.3 instance Fail.MonadFail (LogicT m) where fail _ = LogicT $ \_ fk -> fk @@ -241,15 +435,19 @@ mzero = empty mplus = (<|>) -#if MIN_VERSION_base(4,9,0)+-- | @since 0.7.0.3 instance Semigroup (LogicT m a) where (<>) = mplus- sconcat = foldr1 mplus+#if MIN_VERSION_base(4,18,0)+ sconcat = F1.foldr1 mplus+#else+ sconcat = F.foldr1 mplus #endif +-- | @since 0.7.0.3 instance Monoid (LogicT m a) where mempty = empty- mappend = (<|>)+ mappend = (<>) mconcat = F.asum instance MonadTrans LogicT where@@ -258,7 +456,7 @@ instance (MonadIO m) => MonadIO (LogicT m) where liftIO = lift . liftIO -instance (Monad m) => MonadLogic (LogicT m) where+instance {-# OVERLAPPABLE #-} (Monad m) => MonadLogic (LogicT m) where -- 'msplit' is quite costly even if the base 'Monad' is 'Identity'. -- Try to avoid it. msplit m = lift $ unLogicT m ssk (return Nothing)@@ -267,41 +465,167 @@ once m = LogicT $ \sk fk -> unLogicT m (\a _ -> sk a fk) fk lnot m = LogicT $ \sk fk -> unLogicT m (\_ _ -> fk) (sk () fk) -#if MIN_VERSION_base(4,8,0)+-- | @since 0.8.2.0+instance {-# INCOHERENT #-} MonadLogic Logic where+ -- Same as in the generic instance above+ msplit m = lift $ unLogicT m ssk (return Nothing)+ where+ ssk a fk = return $ Just (a, lift fk >>= reflect)+ once m = LogicT $ \sk fk -> unLogicT m (\a _ -> sk a fk) fk+ lnot m = LogicT $ \sk fk -> unLogicT m (\_ _ -> fk) (sk () fk) + m >>- f+ | isConstantFailure f = empty+ -- Otherwise apply the default definition from Control.Monad.Logic.Class+ | otherwise = msplit m >>= maybe empty (\(a, m') -> interleave (f a) (m' >>- f))++data MyException = MyException+ deriving (Show)++instance Exception MyException++isConstantFailure :: (a -> Logic b) -> Bool+isConstantFailure f = unsafePerformIO $ do+ let eval foo = runIdentity (unLogicT foo (const $ const $ Identity False) (Identity True))+ evaluate (eval (f (throw MyException))) `catch` (\MyException -> pure False)++-- | @since 0.5.0 instance {-# OVERLAPPABLE #-} (Applicative m, F.Foldable m) => F.Foldable (LogicT m) where foldMap f m = F.fold $ unLogicT m (fmap . mappend . f) (pure mempty) -instance {-# OVERLAPPING #-} F.Foldable (LogicT Identity) where+-- | @since 0.5.0+instance {-# INCOHERENT #-} F.Foldable Logic where foldr f z m = runLogic m f z -#else+-- A much simpler logic monad representation used to define the Traversable and+-- MonadZip instances. This is essentially the same as ListT from the list-t+-- package, but it uses a slightly more efficient representation: MLView m a is+-- more compact than Maybe (a, ML m a), and the additional laziness in the+-- latter appears to be incidental/historical.+newtype ML m a = ML (m (MLView m a))+ deriving (Functor, F.Foldable, T.Traversable) -instance (Applicative m, F.Foldable m) => F.Foldable (LogicT m) where- foldMap f m = F.fold $ unLogicT m (fmap . mappend . f) (pure mempty)+data MLView m a = EmptyML | ConsML a (ML m a)+ deriving (Functor, F.Foldable) -#endif+instance T.Traversable m => T.Traversable (MLView m) where+ traverse _ EmptyML = pure EmptyML+ traverse f (ConsML x (ML m))+ = liftA2 (\y ym -> ConsML y (ML ym)) (f x) (T.traverse (T.traverse f) m)+ {- The derived instance would write the second case as+ -+ - traverse f (ConsML x xs) = liftA2 ConsML (f x) (traverse @(ML m) f xs)+ -+ - Inlining the inner traverse gives+ -+ - traverse f (ConsML x (ML m)) = liftA2 ConsML (f x) (ML <$> traverse (traverse f) m)+ -+ - revealing fmap under liftA2. We fuse those into a single application of liftA2,+ - in case fmap isn't free.+ -} -instance T.Traversable (LogicT Identity) where+toML :: Applicative m => LogicT m a -> ML m a+toML (LogicT q) = ML $ q (\a m -> pure $ ConsML a (ML m)) (pure EmptyML)++fromML :: Monad m => ML m a -> LogicT m a+fromML (ML m) = lift m >>= \case+ EmptyML -> empty+ ConsML a xs -> pure a <|> fromML xs++-- | @since 0.5.0+instance {-# OVERLAPPING #-} T.Traversable (LogicT Identity) where traverse g l = runLogic l (\a ft -> cons <$> g a <*> ft) (pure empty) where cons a l' = pure a <|> l' --- Needs undecidable instances+-- | @since 0.8.0.0+instance {-# OVERLAPPABLE #-} (Monad m, T.Traversable m) => T.Traversable (LogicT m) where+ traverse f = fmap fromML . T.traverse f . toML++zipWithML :: MonadZip m => (a -> b -> c) -> ML m a -> ML m b -> ML m c+zipWithML f = go+ where+ go (ML m1) (ML m2) =+ ML $ mzipWith zv m1 m2+ zv (a `ConsML` as) (b `ConsML` bs) = f a b `ConsML` go as bs+ zv _ _ = EmptyML++unzipML :: MonadZip m => ML m (a, b) -> (ML m a, ML m b)+unzipML (ML m)+ | (l, r) <- munzip (fmap go m)+ = (ML l, ML r)+ where+ go EmptyML = (EmptyML, EmptyML)+ go ((a, b) `ConsML` listab)+ = (a `ConsML` la, b `ConsML` lb)+ where+ -- If the underlying munzip is careful not to leak memory, then we+ -- don't want to defeat it. We need to be sure that la and lb are+ -- realized as selector thunks. Hopefully the CPSish conversion+ -- doesn't muck anything up at another level.+ {-# NOINLINE remains #-}+ {-# NOINLINE la #-}+ {-# NOINLINE lb #-}+ remains = unzipML listab+ (la, lb) = remains++-- | @since 0.8.0.0+instance MonadZip m => MonadZip (LogicT m) where+ mzipWith f xs ys = fromML $ zipWithML f (toML xs) (toML ys)+ munzip xys = case unzipML (toML xys) of+ (xs, ys) -> (fromML xs, fromML ys)+ instance MonadReader r m => MonadReader r (LogicT m) where ask = lift ask local f (LogicT m) = LogicT $ \sk fk -> do env <- ask local f $ m ((local (const env) .) . sk) (local (const env) fk) --- Needs undecidable instances instance MonadState s m => MonadState s (LogicT m) where get = lift get put = lift . put --- Needs undecidable instances+-- | @since 0.4 instance MonadError e m => MonadError e (LogicT m) where throwError = lift . throwError catchError m h = LogicT $ \sk fk -> let handle r = r `catchError` \e -> unLogicT (h e) sk fk in handle $ unLogicT m (\a -> sk a . handle) fk++-- | @since 0.8.2.0+instance MonadThrow m => MonadThrow (LogicT m) where+ throwM = lift . throwM++-- | @since 0.8.2.0+instance MonadCatch m => MonadCatch (LogicT m) where+ catch m h = LogicT $ \sk fk -> let+ handle r = r `catch` \e -> unLogicT (h e) sk fk+ in handle $ unLogicT m (\a -> sk a . handle) fk++-- | @since 0.8.2.0+instance IsList (Logic a) where+ type Item (Logic a) = a+ fromList xs = LogicT $ \cons nil -> L.foldr cons nil xs+ toList = observeAll++-- | @since 0.8.2.0+instance Eq a => Eq (Logic a) where+ (==) = (==) `on` observeAll++-- | @since 0.8.2.0+instance Ord a => Ord (Logic a) where+ compare = compare `on` observeAll++-- | @since 0.8.2.0+instance Show a => Show (Logic a) where+ showsPrec p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)++-- | @since 0.8.2.0+instance Read a => Read (Logic a) where+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault
Control/Monad/Logic/Class.hs view
@@ -13,27 +13,52 @@ -- <http://okmij.org/ftp/papers/LogicT.pdf Backtracking, Interleaving, and Terminating Monad Transformers> -- by Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry. -- Note that the paper uses 'MonadPlus' vocabulary--- ('mzero' and 'mplus'),+-- ('Control.Monad.mzero' and 'Control.Monad.mplus'), -- while examples below prefer 'empty' and '<|>' -- from 'Alternative'. ------------------------------------------------------------------------- {-# LANGUAGE CPP #-}+{-# LANGUAGE Trustworthy #-} -#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Safe #-}-#endif+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Avoid restricted function" #-} module Control.Monad.Logic.Class (MonadLogic(..), reflect) where -import Control.Applicative-import Control.Monad+import Prelude ()++import Control.Applicative (Alternative(..), Applicative(..))+import Control.Exception (Exception, evaluate, catch, throw)+import Control.Monad (MonadPlus, Monad(..)) import Control.Monad.Reader (ReaderT(..)) import Control.Monad.Trans (MonadTrans(..)) import qualified Control.Monad.State.Lazy as LazyST import qualified Control.Monad.State.Strict as StrictST+import Data.Bool (Bool(..), otherwise)+import Data.Function (const, ($))+import Data.List (null)+import Data.Maybe (Maybe(..), maybe)+import System.IO.Unsafe (unsafePerformIO)+import Text.Show (Show) +#if MIN_VERSION_mtl(2,3,0)+import qualified Control.Monad.Writer.CPS as CpsW+import qualified Control.Monad.Trans.Writer.CPS as CpsW (writerT, runWriterT)+import Data.Monoid+#endif+ -- | A backtracking, logic programming monad.+--+-- This package offers one implementation of 'MonadLogic': 'Control.Monad.Logic.LogicT'.+-- Other notable implementations:+--+-- * https://hackage.haskell.org/package/list-t/docs/ListT.html#t:ListT+-- * https://hackage.haskell.org/package/logict-sequence/docs/Control-Monad-Logic-Sequence.html#t:SeqT+-- * https://hackage.haskell.org/package/logict-state/docs/Control-Monad-LogicState.html#t:LogicStateT+-- * https://hackage.haskell.org/package/streamt/docs/Control-Monad-Stream.html#t:StreamT+--+-- @since 0.2 class (Monad m, Alternative m) => MonadLogic m where -- | Attempts to __split__ the computation, giving access to the first -- result. Satisfies the following laws:@@ -195,10 +220,21 @@ -- > (\a -> (oddsPlus a >>- \x -> if even x then pure x else empty)) -- -- Since do notation desugaring results in the latter, the- -- @RebindableSyntax@ language pragma cannot easily be used+ -- @RebindableSyntax@ or @QualifiedDo@ language pragmas cannot easily be used -- either. Instead, it is recommended to carefully use explicit -- '>>-' only when needed. --+ -- Here is an action of '(>>-)' on lists:+ --+ -- >>> take 20 $ [100,200..500] >>- (\x -> map (x +) [1..])+ -- [101,201,102,301,103,202,104,401,105,203,106,302,107,204,108,501,109,205,110,303]+ --+ -- The result is @map (100 +) [1..]@ 'interleave'd+ -- with @[200,300..500] >>- (\x -> map (x +) [1..])@.+ -- You can see that a half of the numbers starts from 1,+ -- a quarter starts from 2, and so on exponentially.+ -- One could argue that `(>>-)` is a very __unfair__ conjunction!+ -- (>>-) :: m a -> (a -> m b) -> m b infixl 1 >>- @@ -266,6 +302,8 @@ -- -- Here if @divisors@ never succeeds, then the 'lnot' will -- succeed and the number will be declared as prime.+ --+ -- @since 0.7.0.0 lnot :: m a -> m () -- | Logical __conditional.__ The equivalent of@@ -281,7 +319,7 @@ -- > ifte (pure a <|> m) th el == th a <|> (m >>= th) -- -- For example, the previous @prime@ function returned nothing- -- if the number was not prime, but if it should return 'False'+ -- if the number was not prime, but if it should return 'Data.Bool.False' -- instead, the following can be used: -- -- > choose = foldr ((<|>) . pure) empty@@ -291,8 +329,8 @@ -- > pure d -- > -- > prime v = once (ifte (divisors v)- -- > (const (pure True))- -- > (pure False))+ -- > (const (pure False))+ -- > (pure True)) -- -- >>> observeAll (prime 20) -- [False]@@ -310,21 +348,21 @@ interleave m1 m2 = msplit m1 >>= maybe m2 (\(a, m1') -> pure a <|> interleave m2 m1') - m >>- f = do (a, m') <- maybe empty pure =<< msplit m- interleave (f a) (m' >>- f)+ m >>- f = msplit m >>= maybe empty+ (\(a, m') -> interleave (f a) (m' >>- f)) ifte t th el = msplit t >>= maybe el (\(a,m) -> th a <|> (m >>= th)) - once m = do (a, _) <- maybe empty pure =<< msplit m- pure a-- lnot m = ifte (once m) (const empty) (pure ())+ once m = msplit m >>= maybe empty (\(a, _) -> pure a) + lnot m = msplit m >>= maybe (pure ()) (const empty) ------------------------------------------------------------------------------- -- | The inverse of 'msplit'. Satisfies the following law: -- -- > msplit m >>= reflect == m+--+-- @since 0.2 reflect :: Alternative m => Maybe (a, m a) -> m a reflect Nothing = empty reflect (Just (a, m)) = pure a <|> m@@ -334,6 +372,20 @@ msplit [] = pure Nothing msplit (x:xs) = pure $ Just (x, xs) + m >>- f+ | isConstantFailure f = []+ -- Otherwise apply the default definition+ | otherwise = msplit m >>= maybe empty (\(a, m') -> interleave (f a) (m' >>- f))++data MyException = MyException+ deriving (Show)++instance Exception MyException++isConstantFailure :: (a -> [b]) -> Bool+isConstantFailure f = unsafePerformIO $+ evaluate (null (f (throw MyException))) `catch` (\MyException -> pure False)+ -- | Note that splitting a transformer does -- not allow you to provide different input -- to the monadic object returned.@@ -348,6 +400,16 @@ case r of Nothing -> pure Nothing Just (a, m) -> pure (Just (a, lift m))++#if MIN_VERSION_mtl(2,3,0)+-- | @since 0.8.1.0+instance (Monoid w, MonadLogic m, MonadPlus m) => MonadLogic (CpsW.WriterT w m) where+ msplit wm = CpsW.writerT $ do+ r <- msplit $ CpsW.runWriterT wm+ case r of+ Nothing -> pure (Nothing, mempty)+ Just ((a, w), m) -> pure (Just (a, CpsW.writerT m), w)+#endif -- | See note on splitting above. instance (MonadLogic m, MonadPlus m) => MonadLogic (StrictST.StateT s m) where
changelog.md view
@@ -1,7 +1,30 @@+# 0.8.2.0++* Add instances for `MonadThrow` and `MonadCatch`.+* Add instances `Eq`, `Ord`, `Show`, `Read`, `IsList` for `Logic a`.+* Speed up `instance MonadLogic Logic` with a trick to determine whether a callback is a constant failure.++# 0.8.1.0++* Add `instance MonadLogic (Control.Monad.Writer.CPS.WriterT w m)`.++# 0.8.0.0++* Breaking change:+ do not re-export `Control.Monad` and `Control.Monad.Trans` from `Control.Monad.Logic`.+* Generalize `instance Traversable (LogicT Identity)`+ to `instance (Traversable m, Monad m) => Traversable (LogicT m)`.+* Add conversion functions `fromLogicT` and `fromLogicTWith` to facilitate+ interoperation with [`list-t`](https://hackage.haskell.org/package/list-t)+ and [`logict-sequence`](https://hackage.haskell.org/package/logict-sequence) packages.+* Add `hoistLogicT` and `embedLogicT` to convert `LogicT` computations+ from one underlying monad to another.+ # 0.7.1.0 * Improve documentation.-* Relax superclasses of `MonadLogic` to `Monad` and `Alternative` instead of `MonadPlus`.+* Breaking change:+ relax superclasses of `MonadLogic` to `Monad` and `Alternative` instead of `MonadPlus`. # 0.7.0.3
example/grandparents.hs view
@@ -2,13 +2,7 @@ import Control.Applicative import Control.Monad.Logic-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid (..))-#endif-#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup (..))-#endif- parents :: [ (String, String) ] parents = [ ("Sarah", "John")
logict.cabal view
@@ -1,5 +1,5 @@ name: logict-version: 0.7.1.0+version: 0.8.2.0 license: BSD3 license-file: LICENSE copyright:@@ -22,7 +22,7 @@ changelog.md README.md cabal-version: >=1.10-tested-with: GHC ==7.0.4 GHC ==7.2.2 GHC ==7.4.2 GHC ==7.6.3 GHC ==7.8.4 GHC ==7.10.3 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.4 GHC ==8.10.3+tested-with: GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 GHC ==8.6.5 GHC ==8.8.4 GHC ==8.10.7 GHC ==9.0.2 GHC ==9.2.8 GHC ==9.4.8 GHC ==9.6.6 GHC ==9.8.2 GHC ==9.10.1 GHC ==9.12.1 source-repository head type: git@@ -33,15 +33,15 @@ Control.Monad.Logic Control.Monad.Logic.Class default-language: Haskell2010- ghc-options: -O2 -Wall- build-depends:- base >=4.3 && <5,- mtl >=2.0 && <2.3 - if impl(ghc <8.0)- build-depends:- fail, transformers+ ghc-options: -O2 -Wall -Wcompat + build-depends:+ base >=4.9 && <5,+ mtl >=2.0 && <2.4,+ transformers <0.7,+ exceptions <0.11+ executable grandparents buildable: False main-is: grandparents.hs@@ -55,13 +55,16 @@ type: exitcode-stdio-1.0 main-is: Test.hs default-language: Haskell2010- ghc-options: -Wall++ ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns+ build-depends: base,- async >=2.0,+ async >=2.0 && <2.3, logict, mtl,- tasty,- tasty-hunit+ transformers,+ tasty <1.6,+ tasty-hunit <0.11 hs-source-dirs: test
test/Test.hs view
@@ -1,32 +1,40 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where import Test.Tasty import Test.Tasty.HUnit -import Control.Arrow ( left ) import Control.Concurrent ( threadDelay ) import Control.Concurrent.Async ( race ) import Control.Exception+import Control.Monad import Control.Monad.Identity import Control.Monad.Logic import Control.Monad.Reader import qualified Control.Monad.State.Lazy as SL import qualified Control.Monad.State.Strict as SS+import Data.List (uncons) import Data.Maybe -#if MIN_VERSION_base(4,9,0)-#if MIN_VERSION_base(4,11,0)+#if MIN_VERSION_base(4,17,0)+import GHC.IsList (IsList(..)) #else+import GHC.Exts (IsList(..))+#endif++#if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup (..)) #endif-#else++#if MIN_VERSION_mtl(2,3,0)+import qualified Control.Monad.Writer.CPS as CpsW (WriterT, execWriterT, tell)+import qualified Control.Monad.Trans.Writer.CPS as CpsW (runWriterT) import Data.Monoid #endif - monadReader1 :: Assertion monadReader1 = assertEqual "should be equal" [5 :: Int] $ runReader (observeAllT (local (+ 5) ask)) 0@@ -52,14 +60,16 @@ oddsOrTwoUnfair, oddsOrTwoFair, odds5down :: Monad m => LogicT m Integer -#if MIN_VERSION_base(4,8,0)-nats = pure 0 `mplus` ((1 +) <$> nats)-#else-nats = return 0 `mplus` liftM (1 +) nats+-- | A `WriterT` version of `evalStateT`.+#if MIN_VERSION_mtl(2,3,0)+evalWriterT :: (Monad m, Monoid w) => CpsW.WriterT w m a -> m a+evalWriterT = fmap fst . CpsW.runWriterT #endif -odds = return 1 `mplus` liftM (2+) odds+nats = pure 0 `mplus` ((1 +) <$> nats) +odds = return 1 `mplus` fmap (2+) odds+ oddsOrTwoUnfair = odds `mplus` return 2 oddsOrTwoFair = odds `interleave` return 2 @@ -76,9 +86,7 @@ main :: IO () main = defaultMain $-#if __GLASGOW_HASKELL__ >= 702 localOption (mkTimeout 3000000) $ -- 3 second deadman timeout-#endif testGroup "All" [ testGroup "Monad Reader + env" [ testCase "Monad Reader 1" monadReader1@@ -93,7 +101,7 @@ testCase "runIdentity all" $ [0..4] @=? (take 5 $ runIdentity $ observeAllT nats) , testCase "runIdentity many" $ [0..4] @=? (runIdentity $ observeManyT 5 nats) , testCase "observeAll" $ [0..4] @=? (take 5 $ observeAll nats)- , testCase "observeMany" $ [0..4] @=? (observeMany 5 nats)+ , testCase "observeMany" $ [0..4] @=? observeMany 5 nats -- Ensure LogicT can be run over other base monads other than -- List. Some are productive (Reader) and some are non-productive@@ -104,7 +112,7 @@ , testCase "observeManyT can be used with Either" $ (Right [0..4] :: Either Char [Integer]) @=?- (observeManyT 5 nats)+ observeManyT 5 nats ] --------------------------------------------------@@ -113,14 +121,14 @@ [ testCase "runLogicT multi" $ ["Hello world !"] @=? let conc w o = fmap ((w `mappend` " ") `mappend`) o in- (runLogicT (yieldWords ["Hello", "world"]) conc (return "!"))+ runLogicT (yieldWords ["Hello", "world"]) conc (return "!") , testCase "runLogicT none" $ ["!"] @=? let conc w o = fmap ((w `mappend` " ") `mappend`) o in- (runLogicT (yieldWords []) conc (return "!"))+ runLogicT (yieldWords []) conc (return "!") , testCase "runLogicT first" $ ["Hello"] @=?- (runLogicT (yieldWords ["Hello", "world"]) (\w -> const $ return w) (return "!"))+ runLogicT (yieldWords ["Hello", "world"]) (\w -> const $ return w) (return "!") , testCase "runLogic multi" $ 20 @=? runLogic odds5down (+) 11 , testCase "runLogic none" $ 11 @=? runLogic mzero (+) (11 :: Integer)@@ -133,6 +141,12 @@ , testCase "observeMany multi" $ [5,3] @=? observeMany 2 odds5down , testCase "observeMany none" $ ([] :: [Integer]) @=? observeMany 2 mzero++ , testCase "(>>-) Logic" $ do+ let sample = fromList [1, 2, 3] :: Logic Integer+ (sample >>- const (mempty :: Logic Integer)) @?= mempty+ (sample >>- (\x -> fmap (+ x) (fromList [100, 200, 300]))) @?= fromList [101,102,201,103,301,202,203,302,303]+ (sample >>- (\x -> if odd x then fmap (+ x) (fromList [100, 200, 300]) else mempty)) @?= fromList [101,103,201,203,301,303] ] --------------------------------------------------@@ -151,10 +165,17 @@ z = mzero in assertBool "ReaderT" $ null $ catMaybes $ runReaderT (msplit z) 0 +#if MIN_VERSION_mtl(2,3,0)+ , testCase "msplit mzero :: CPS WriterT" $+ let z :: CpsW.WriterT (Sum Int) [] String+ z = mzero+ in assertBool "CPS WriterT" $ null $ catMaybes (evalWriterT (msplit z))+#endif+ , testCase "msplit mzero :: LogicT" $ let z :: LogicT [] String z = mzero- in assertBool "LogicT" $ null $ catMaybes $ concat $ observeAllT (msplit z)+ in assertBool "LogicT" $ all (null . catMaybes) $ observeAllT (msplit z) , testCase "msplit mzero :: strict StateT" $ let z :: SS.StateT Int [] String z = mzero@@ -174,29 +195,43 @@ extract (msplit op) @?= [Just 1] extract (msplit op >>= (\(Just (_,nxt)) -> msplit nxt)) @?= [Just 2] + , testCase "(>>-) []" $ do+ (sample >>- const ([] :: [Integer])) @?= []+ (sample >>- (\x -> fmap (+ x) [100, 200, 300])) @?= [101,102,201,103,301,202,203,302,303]+ (sample >>- (\x -> if odd x then fmap (+ x) [100, 200, 300] else [])) @?= [101,103,201,203,301,303]+ , testCase "msplit ReaderT" $ do let op = ask extract = fmap fst . catMaybes . flip runReaderT sample extract (msplit op) @?= [sample] extract (msplit op >>= (\(Just (_,nxt)) -> msplit nxt)) @?= [] +#if MIN_VERSION_mtl(2,3,0)+ , testCase "msplit CPS WriterT" $ do+ let op :: CpsW.WriterT (Sum Integer) [] ()+ op = CpsW.tell 1 `mplus` op+ extract = CpsW.execWriterT+ extract (msplit op) @?= [1]+ extract (msplit op >>= \(Just (_,nxt)) -> msplit nxt) @?= [2]+#endif+ , testCase "msplit LogicT" $ do let op :: LogicT [] Integer op = foldr (mplus . return) mzero sample- extract = fmap fst . catMaybes . concat . observeAllT+ extract = fmap fst . concatMap catMaybes . observeAllT extract (msplit op) @?= [1] extract (msplit op >>= (\(Just (_,nxt)) -> msplit nxt)) @?= [2] , testCase "msplit strict StateT" $ do let op :: SS.StateT Integer [] Integer- op = (SS.modify (+1) >> SS.get `mplus` op)+ op = SS.modify (+1) >> SS.get `mplus` op extract = fmap fst . catMaybes . flip SS.evalStateT 0 extract (msplit op) @?= [1] extract (msplit op >>= \(Just (_,nxt)) -> msplit nxt) @?= [2] , testCase "msplit lazy StateT" $ do let op :: SL.StateT Integer [] Integer- op = (SL.modify (+1) >> SL.get `mplus` op)+ op = SL.modify (+1) >> SL.get `mplus` op extract = fmap fst . catMaybes . flip SL.evalStateT 0 extract (msplit op) @?= [1] extract (msplit op >>= \(Just (_,nxt)) -> msplit nxt) @?= [2]@@ -236,19 +271,26 @@ in oddsOrTwoLFair) , testCase "fair disjunction :: ReaderT" $ [1,2,3,5] @=?- (take 4 $ runReaderT (let oddsR = return 1 `mplus` liftM (2+) oddsR+ (take 4 $ runReaderT (let oddsR = return 1 `mplus` fmap (2+) oddsR in oddsR `interleave` return (2 :: Integer)) "go") +#if MIN_VERSION_mtl(2,3,0)+ , testCase "fair disjunction :: CPS WriterT" $ [1,2,3,5] @=?+ (take 4 $ evalWriterT (let oddsW :: CpsW.WriterT [Char] [] Integer+ oddsW = return 1 `mplus` fmap (2+) oddsW+ in oddsW `interleave` return (2 :: Integer)))+#endif+ , testCase "fair disjunction :: strict StateT" $ [1,2,3,5] @=?- (take 4 $ SS.evalStateT (let oddsS = return 1 `mplus` liftM (2+) oddsS+ (take 4 $ SS.evalStateT (let oddsS = return 1 `mplus` fmap (2+) oddsS in oddsS `interleave` return (2 :: Integer)) "go") , testCase "fair disjunction :: lazy StateT" $ [1,2,3,5] @=?- (take 4 $ SL.evalStateT (let oddsS = return 1 `mplus` liftM (2+) oddsS+ (take 4 $ SL.evalStateT (let oddsS = return 1 `mplus` fmap (2+) oddsS in oddsS `interleave` return (2 :: Integer)) "go") ] - , testGroup "fair conjunction" $+ , testGroup "fair conjunction" [ -- Using the fair conjunction operator (>>-) the test produces values @@ -313,9 +355,9 @@ (nonTerminating $ observeManyT 4 (let oddsPlus n = odds >>= \a -> return (a + n) in (return 0 `mplus` return 1) >>-- \a -> oddsPlus a >>=+ (oddsPlus >=> (\x -> if even x then return x else mzero)- ))+ ))) -- unfair conjunction does not terminate or produce any -- values: this will fail (expectedly) due to a timeout@@ -336,21 +378,32 @@ ) , testCase "fair conjunction :: ReaderT" $ [2,4,6,8] @=?- (take 4 $ runReaderT (let oddsR = return (1 :: Integer) `mplus` liftM (2+) oddsR+ (take 4 $ runReaderT (let oddsR = return (1 :: Integer) `mplus` fmap (2+) oddsR oddsPlus n = oddsR >>= \a -> return (a + n) in do x <- (return 0 `mplus` return 1) >>- oddsPlus if even x then return x else mzero ) "env") +#if MIN_VERSION_mtl(2,3,0)+ , testCase "fair conjunction :: CPS WriterT" $ [2,4,6,8] @=?+ (take 4 $ evalWriterT $+ (let oddsW :: CpsW.WriterT [Char] [] Integer+ oddsW = return (1 :: Integer) `mplus` fmap (2+) oddsW+ oddsPlus n = oddsW >>= \a -> return (a + n)+ in do x <- (return 0 `mplus` return 1) >>- oddsPlus+ if even x then return x else mzero+ ))+#endif+ , testCase "fair conjunction :: strict StateT" $ [2,4,6,8] @=?- (take 4 $ SS.evalStateT (let oddsS = return (1 :: Integer) `mplus` liftM (2+) oddsS+ (take 4 $ SS.evalStateT (let oddsS = return (1 :: Integer) `mplus` fmap (2+) oddsS oddsPlus n = oddsS >>= \a -> return (a + n) in do x <- (return 0 `mplus` return 1) >>- oddsPlus if even x then return x else mzero ) "state") , testCase "fair conjunction :: lazy StateT" $ [2,4,6,8] @=?- (take 4 $ SL.evalStateT (let oddsS = return (1 :: Integer) `mplus` liftM (2+) oddsS+ (take 4 $ SL.evalStateT (let oddsS = return (1 :: Integer) `mplus` fmap (2+) oddsS oddsPlus n = oddsS >>= \a -> return (a + n) in do x <- (return 0 `mplus` return 1) >>- oddsPlus if even x then return x else mzero@@ -406,7 +459,7 @@ oddsL = [ 1 :: Integer ] `mplus` [ o | o <- [3..], odd o ] oc = [ n | n <- oddsL- , (n > 1)+ , n > 1 ] >>= \n -> ifte (do d <- iota (n - 1) guard (d > 1 && n `mod` d == 0)) (const mzero)@@ -415,7 +468,7 @@ take 10 oc , let iota n = msum (map return [1..n])- oddsR = return (1 :: Integer) `mplus` liftM (2+) oddsR+ oddsR = return (1 :: Integer) `mplus` fmap (2+) oddsR oc = do n <- oddsR guard (n > 1) ifte (do d <- iota (n - 1)@@ -425,8 +478,22 @@ in testCase "indivisible odds :: ReaderT" $ [3,5,7,11,13,17,19,23,29,31] @=? (take 10 $ runReaderT oc "env") +#if MIN_VERSION_mtl(2,3,0) , let iota n = msum (map return [1..n])- oddsS = return (1 :: Integer) `mplus` liftM (2+) oddsS+ oddsW = return (1 :: Integer) `mplus` fmap (2+) oddsW+ oc :: CpsW.WriterT [Char] [] Integer+ oc = do n <- oddsW+ guard (n > 1)+ ifte (do d <- iota (n - 1)+ guard (d > 1 && n `mod` d == 0))+ (const mzero)+ (return n)+ in testCase "indivisible odds :: CPS WriterT" $ [3,5,7,11,13,17,19,23,29,31] @=?+ (take 10 $ (fmap fst . CpsW.runWriterT) oc)+#endif++ , let iota n = msum (map return [1..n])+ oddsS = return (1 :: Integer) `mplus` fmap (2+) oddsS oc = do n <- oddsS guard (n > 1) ifte (do d <- iota (n - 1)@@ -437,7 +504,7 @@ (take 10 $ SS.evalStateT oc "state") , let iota n = msum (map return [1..n])- oddsS = return (1 :: Integer) `mplus` liftM (2+) oddsS+ oddsS = return (1 :: Integer) `mplus` fmap (2+) oddsS oc = do n <- oddsS guard (n > 1) ifte (do d <- iota (n - 1)@@ -498,6 +565,14 @@ lnot (isEven v) return v) "env") +#if MIN_VERSION_mtl(2,3,0)+ , testCase "inversion :: CPS WriterT" $ [1,3,5,7,9] @=?+ (take 5 $ (evalWriterT :: CpsW.WriterT [Char] [] Integer -> [Integer])+ (do v <- foldr (mplus . return) mzero [(1::Integer)..]+ lnot (isEven v)+ return v))+#endif+ , testCase "inversion :: strict StateT" $ [1,3,5,7,9] @=? (take 5 $ SS.evalStateT (do v <- foldr (mplus . return) mzero [(1::Integer)..] lnot (isEven v)@@ -511,7 +586,11 @@ ] safely :: IO Integer -> IO (Either String Integer)-safely o = fmap (left (head . lines . show)) (try o :: IO (Either SomeException Integer))+safely o = do+ p <- try o+ pure $ case p of+ Left (err :: SomeException) -> Left $ maybe "" fst $ uncons $ lines $ show err+ Right n -> Right n -- | This is used to test logic operations that don't typically -- terminate by running a parallel race between the operation and a