diff --git a/Control/Monad/Logic.hs b/Control/Monad/Logic.hs --- a/Control/Monad/Logic.hs +++ b/Control/Monad/Logic.hs @@ -13,23 +13,23 @@ -- -- 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 DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# 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, @@ -54,36 +54,45 @@ import Prelude (error, (-)) -import Control.Applicative (Alternative(..), Applicative, liftA2, pure, (<*>)) -import Control.Monad (join, MonadPlus(..), liftM, Monad(..), fail) +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(..)) -#if MIN_VERSION_base(4,8,0) -import Control.Monad.Zip (MonadZip (..)) -#endif - import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) -import Control.Monad.Error.Class (MonadError(..)) - -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup (Semigroup (..)) -#endif +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.Zip (MonadZip (..)) -import Data.Bool (otherwise) -import Data.Eq ((==)) +import Data.Bool (Bool (..), otherwise) +import Data.Eq (Eq, (==)) import qualified Data.Foldable as F -import Data.Function (($), (.), const) +import Data.Function (($), (.), const, on) import Data.Functor (Functor(..), (<$>)) import Data.Int import qualified Data.List as L -import Data.Maybe (Maybe(..)) +import Data.Maybe (Maybe(..), maybe) import Data.Monoid (Monoid (..)) -import Data.Ord ((<=)) +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 + +#if MIN_VERSION_base(4,18,0) +import qualified Data.Foldable1 as F1 +#endif + import Control.Monad.Logic.Class ------------------------------------------------------------------------- @@ -94,6 +103,22 @@ -- (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 } @@ -147,9 +172,9 @@ | 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 @@ -191,17 +216,12 @@ -- @ -- import ListT (ListT) -- --- 'show' $ fromLogicT @ListT l +-- 'Text.Show.show' $ fromLogicT @ListT l -- @ -- -- @since 0.8.0.0 -#if MIN_VERSION_base(4,8,0) fromLogicT :: (Alternative (t m), MonadTrans t, Monad m, Monad (t m)) => LogicT m a -> t m a -#else -fromLogicT :: (Alternative (t m), MonadTrans t, Applicative m, Monad m, Monad (t m)) - => LogicT m a -> t m a -#endif fromLogicT = fromLogicTWith lift -- | Convert from @'LogicT' m@ to an arbitrary logic-like monad, @@ -254,11 +274,17 @@ -- | 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 -- -- of lists. Speaking plainly, its type is identical (up to 'Identity' wrappers) --- to 'foldr' applied to a given list. And this list itself can be reconstructed +-- to 'Data.List.foldr' applied to a given list. And this list itself can be reconstructed -- by supplying @(:)@ and @[]@. -- -- > import Data.Functor.Identity @@ -326,7 +352,7 @@ -- >>> observe empty -- *** Exception: No answer. -- --- Since 'Logic' is isomorphic to a list, 'observe' is analogous to 'head'. +-- Since 'Logic' is isomorphic to a list, 'observe' is analogous to 'Data.List.head'. -- -- @since 0.2 observe :: Logic a -> a @@ -352,7 +378,7 @@ -- >>> observeMany 5 nats -- [0,1,2,3,4] -- --- Since 'Logic' is isomorphic to a list, 'observeMany' is analogous to 'take'. +-- Since 'Logic' is isomorphic to a list, 'observeMany' is analogous to 'Data.List.take'. -- -- @since 0.2 observeMany :: Int -> Logic a -> [a] @@ -387,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 @@ -395,6 +422,7 @@ 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 @@ -407,21 +435,19 @@ mzero = empty mplus = (<|>) -#if MIN_VERSION_base(4,9,0) -- | @since 0.7.0.3 instance Semigroup (LogicT m a) where (<>) = 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 -#if MIN_VERSION_base(4,9,0) mappend = (<>) -#else - mappend = (<|>) -#endif mconcat = F.asum instance MonadTrans LogicT where @@ -430,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) @@ -439,23 +465,37 @@ 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) --- | @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) + 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)) --- | @since 0.5.0 -instance {-# OVERLAPPING #-} F.Foldable (LogicT Identity) where - foldr f z m = runLogic m f z +data MyException = MyException + deriving (Show) -#else +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 (Applicative m, F.Foldable m) => F.Foldable (LogicT m) where +instance {-# OVERLAPPABLE #-} (Applicative m, F.Foldable m) => F.Foldable (LogicT m) where foldMap f m = F.fold $ unLogicT m (fmap . mappend . f) (pure mempty) -#endif +-- | @since 0.5.0 +instance {-# INCOHERENT #-} F.Foldable Logic where + foldr f z m = runLogic m f z -- 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 @@ -488,11 +528,10 @@ 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 >>= \r -> case r of +fromML (ML m) = lift m >>= \case EmptyML -> empty ConsML a xs -> pure a <|> fromML xs -#if MIN_VERSION_base(4,8,0) -- | @since 0.5.0 instance {-# OVERLAPPING #-} T.Traversable (LogicT Identity) where traverse g l = runLogic l (\a ft -> cons <$> g a <*> ft) (pure empty) @@ -502,13 +541,7 @@ -- | @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 -#else --- | @since 0.8.0.0 -instance (Monad m, Applicative m, T.Traversable m) => T.Traversable (LogicT m) where - traverse f = fmap fromML . T.traverse f . toML -#endif -#if MIN_VERSION_base(4,8,0) zipWithML :: MonadZip m => (a -> b -> c) -> ML m a -> ML m b -> ML m c zipWithML f = go where @@ -541,7 +574,6 @@ mzipWith f xs ys = fromML $ zipWithML f (toML xs) (toML ys) munzip xys = case unzipML (toML xys) of (xs, ys) -> (fromML xs, fromML ys) -#endif instance MonadReader r m => MonadReader r (LogicT m) where ask = lift ask @@ -559,3 +591,41 @@ 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 diff --git a/Control/Monad/Logic/Class.hs b/Control/Monad/Logic/Class.hs --- a/Control/Monad/Logic/Class.hs +++ b/Control/Monad/Logic/Class.hs @@ -13,29 +13,34 @@ -- -- 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 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 @@ -215,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 >>- @@ -303,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 @@ -355,6 +371,20 @@ instance MonadLogic [] where 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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +# 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)`. diff --git a/example/grandparents.hs b/example/grandparents.hs --- a/example/grandparents.hs +++ b/example/grandparents.hs @@ -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") diff --git a/logict.cabal b/logict.cabal --- a/logict.cabal +++ b/logict.cabal @@ -1,5 +1,5 @@ name: logict -version: 0.8.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.7 GHC ==9.0.2 GHC ==9.2.7 GHC ==9.4.5 GHC ==9.6.1 +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 @@ -34,18 +34,13 @@ Control.Monad.Logic.Class default-language: Haskell2010 - ghc-options: -O2 -Wall - if impl(ghc >= 8.0) - ghc-options: -Wcompat + ghc-options: -O2 -Wall -Wcompat build-depends: - base >=4.3 && <5, + base >=4.9 && <5, mtl >=2.0 && <2.4, - transformers <0.7 - - if impl(ghc <8.0) - build-depends: - fail < 4.10 + transformers <0.7, + exceptions <0.11 executable grandparents buildable: False @@ -61,9 +56,7 @@ main-is: Test.hs default-language: Haskell2010 - ghc-options: -Wall - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wno-incomplete-uni-patterns + ghc-options: -Wall -Wcompat -Wno-incomplete-uni-patterns build-depends: base, @@ -71,7 +64,7 @@ logict, mtl, transformers, - tasty <1.5, + tasty <1.6, tasty-hunit <0.11 hs-source-dirs: test diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,12 +1,12 @@ {-# 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 @@ -16,20 +16,23 @@ 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) && !MIN_VERSION_base(4,11,0) -import Data.Semigroup (Semigroup (..)) +#if MIN_VERSION_base(4,17,0) +import GHC.IsList (IsList(..)) +#else +import GHC.Exts (IsList(..)) #endif --- required by base < 4.9 OR CPS Writer test -#if !MIN_VERSION_base(4,9,0) || MIN_VERSION_mtl(2,3,0) -import Data.Monoid +#if !MIN_VERSION_base(4,11,0) +import Data.Semigroup (Semigroup (..)) #endif #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 @@ -63,13 +66,9 @@ evalWriterT = fmap fst . CpsW.runWriterT #endif -#if MIN_VERSION_base(4,8,0) nats = pure 0 `mplus` ((1 +) <$> nats) -#else -nats = return 0 `mplus` liftM (1 +) nats -#endif -odds = return 1 `mplus` liftM (2+) odds +odds = return 1 `mplus` fmap (2+) odds oddsOrTwoUnfair = odds `mplus` return 2 oddsOrTwoFair = odds `interleave` return 2 @@ -87,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 @@ -104,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 @@ -115,7 +112,7 @@ , testCase "observeManyT can be used with Either" $ (Right [0..4] :: Either Char [Integer]) @=? - (observeManyT 5 nats) + observeManyT 5 nats ] -------------------------------------------------- @@ -124,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) @@ -144,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] ] -------------------------------------------------- @@ -172,7 +175,7 @@ , 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 @@ -192,6 +195,11 @@ 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 @@ -210,20 +218,20 @@ , 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] @@ -263,26 +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` liftM (2+) oddsW + 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 @@ -347,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 @@ -370,7 +378,7 @@ ) , 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 @@ -380,7 +388,7 @@ , testCase "fair conjunction :: CPS WriterT" $ [2,4,6,8] @=? (take 4 $ evalWriterT $ (let oddsW :: CpsW.WriterT [Char] [] Integer - oddsW = return (1 :: Integer) `mplus` liftM (2+) oddsW + 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 @@ -388,14 +396,14 @@ #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 @@ -451,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) @@ -460,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) @@ -472,7 +480,7 @@ #if MIN_VERSION_mtl(2,3,0) , let iota n = msum (map return [1..n]) - oddsW = return (1 :: Integer) `mplus` liftM (2+) oddsW + oddsW = return (1 :: Integer) `mplus` fmap (2+) oddsW oc :: CpsW.WriterT [Char] [] Integer oc = do n <- oddsW guard (n > 1) @@ -485,7 +493,7 @@ #endif , 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) @@ -496,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) @@ -578,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