logict 0.8.1.0 → 0.8.2.0
raw patch · 6 files changed
+231/−126 lines, 6 filesdep +exceptionsdep −faildep ~base
Dependencies added: exceptions
Dependencies removed: fail
Dependency ranges changed: base
Files
- Control/Monad/Logic.hs +130/−60
- Control/Monad/Logic/Class.hs +36/−6
- changelog.md +6/−0
- example/grandparents.hs +0/−6
- logict.cabal +8/−15
- test/Test.hs +51/−39
Control/Monad/Logic.hs view
@@ -13,23 +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 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 -- <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 '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
Control/Monad/Logic/Class.hs view
@@ -13,29 +13,34 @@ -- <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 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
changelog.md view
@@ -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)`.
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.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
test/Test.hs view
@@ -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