diff --git a/Control/Monad/Logic.hs b/Control/Monad/Logic.hs --- a/Control/Monad/Logic.hs +++ b/Control/Monad/Logic.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP, UndecidableInstances, Rank2Types, FlexibleInstances, MultiParamTypeClasses #-} - ------------------------------------------------------------------------- -- | -- Module : Control.Monad.Logic @@ -16,9 +14,11 @@ -- /Backtracking, Interleaving, and Terminating -- Monad Transformers/, by -- Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry --- (). +-- (). ------------------------------------------------------------------------- +{-# LANGUAGE CPP, UndecidableInstances, Rank2Types, FlexibleInstances, MultiParamTypeClasses #-} + module Control.Monad.Logic ( module Control.Monad.Logic.Class, -- * The Logic monad @@ -49,7 +49,9 @@ import Control.Monad.State.Class import Control.Monad.Error.Class +#if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(mappend, mempty)) +#endif import qualified Data.Foldable as F import qualified Data.Traversable as T @@ -57,7 +59,7 @@ ------------------------------------------------------------------------- -- | A monad transformer for performing backtracking computations --- layered over another monad 'm' +-- layered over another monad @m@. newtype LogicT m a = LogicT { unLogicT :: forall r. (a -> m r -> m r) -> m r -> m r } @@ -95,7 +97,7 @@ ------------------------------------------------------------------------- -- | The basic Logic monad, for performing backtracking computations --- returning values of type 'a' +-- returning values of type @a@. type Logic = LogicT Identity ------------------------------------------------------------------------- @@ -118,7 +120,9 @@ ------------------------------------------------------------------------- -- | Extracts up to a given number of results from a Logic computation. observeMany :: Int -> Logic a -> [a] -observeMany i = runIdentity . observeManyT i +observeMany i = take i . observeAll +-- Implementing 'observeMany' using 'observeManyT' is quite costly, +-- because it calls 'msplit' multiple times. ------------------------------------------------------------------------- -- | Runs a Logic computation with the specified initial success and @@ -161,13 +165,29 @@ liftIO = lift . liftIO instance (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) 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) -instance (Monad m, F.Foldable m) => F.Foldable (LogicT m) where +#if MIN_VERSION_base(4,8,0) + +instance {-# OVERLAPPABLE #-} (Monad m, F.Foldable m) => F.Foldable (LogicT m) where foldMap f m = F.fold $ unLogicT m (liftM . mappend . f) (return mempty) +instance {-# OVERLAPPING #-} F.Foldable (LogicT Identity) where + foldr f z m = runLogic m f z + +#else + +instance {-# OVERLAPPABLE #-} (Monad m, F.Foldable m) => F.Foldable (LogicT m) where + foldMap f m = F.fold $ unLogicT m (liftM . mappend . f) (return mempty) + +#endif + instance T.Traversable (LogicT Identity) where traverse g l = runLogic l (\a ft -> cons <$> g a <*> ft) (pure mzero) where cons a l' = return a `mplus` l' @@ -175,7 +195,7 @@ -- Needs undecidable instances instance MonadReader r m => MonadReader r (LogicT m) where ask = lift ask - local f m = LogicT $ \sk fk -> unLogicT m ((local f .) . sk) (local f fk) + local f m = LogicT (\sk fk -> local f (unLogicT m sk fk)) -- Needs undecidable instances instance MonadState s m => MonadState s (LogicT m) where 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 @@ -14,20 +14,15 @@ -- /Backtracking, Interleaving, and Terminating -- Monad Transformers/, by -- Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry --- () +-- () ------------------------------------------------------------------------- -module Control.Monad.Logic.Class (MonadLogic(..), reflect, lnot) where +module Control.Monad.Logic.Class (MonadLogic(..), reflect) where +import Control.Monad.Reader import qualified Control.Monad.State.Lazy as LazyST import qualified Control.Monad.State.Strict as StrictST -import Control.Monad.Reader - -import Data.Monoid -import qualified Control.Monad.Writer.Lazy as LazyWT -import qualified Control.Monad.Writer.Strict as StrictWT - ------------------------------------------------------------------------------- -- | Minimal implementation: msplit class (MonadPlus m) => MonadLogic m where @@ -79,6 +74,10 @@ -- such. once :: m a -> m a + -- | Inverts a logic computation. If @m@ succeeds with at least one value, + -- @lnot m@ fails. If @m@ fails, then @lnot m@ succeeds the value @()@. + lnot :: m a -> m () + -- All the class functions besides msplit can be derived from msplit, if -- desired interleave m1 m2 = msplit m1 >>= @@ -92,7 +91,9 @@ once m = do (a, _) <- maybe mzero return =<< msplit m return a + lnot m = ifte (once m) (const mzero) (return ()) + ------------------------------------------------------------------------------- -- | The inverse of msplit. Satisfies the following law: -- @@ -101,33 +102,27 @@ reflect Nothing = mzero reflect (Just (a, m)) = return a `mplus` m --- | Inverts a logic computation. If @m@ succeeds with at least one value, --- @lnot m@ fails. If @m@ fails, then @lnot m@ succeeds the value @()@. -lnot :: MonadLogic m => m a -> m () -lnot m = ifte (once m) (const mzero) (return ()) - -- An instance of MonadLogic for lists instance MonadLogic [] where msplit [] = return Nothing msplit (x:xs) = return $ Just (x, xs) --- Some of these may be questionable instances. Splitting a transformer does --- not allow you to provide different input to the monadic object returned. --- So, for instance, in: +-- | Note that splitting a transformer does +-- not allow you to provide different input +-- to the monadic object returned. +-- For instance, in: -- --- let Just (_, rm') = runReaderT (msplit rm) r --- in runReaderT rm' r' +-- > let Just (_, rm') = runReaderT (msplit rm) r in runReaderT rm' r' -- --- The "r'" parameter will be ignored, as "r" was already threaded through the --- computation. The results are similar for StateT. However, this is likely not --- an issue as most uses of msplit (all the ones in this library, at least) would --- not allow for that anyway. +-- @r'@ will be ignored, because @r@ was already threaded through the +-- computation. instance MonadLogic m => MonadLogic (ReaderT e m) where msplit rm = ReaderT $ \e -> do r <- msplit $ runReaderT rm e case r of Nothing -> return Nothing Just (a, m) -> return (Just (a, lift m)) +-- | See note on splitting above. instance MonadLogic m => MonadLogic (StrictST.StateT s m) where msplit sm = StrictST.StateT $ \s -> do r <- msplit (StrictST.runStateT sm s) @@ -148,6 +143,7 @@ once ma = StrictST.StateT $ \s -> once (StrictST.runStateT ma s) +-- | See note on splitting above. instance MonadLogic m => MonadLogic (LazyST.StateT s m) where msplit sm = LazyST.StateT $ \s -> do r <- msplit (LazyST.runStateT sm s) @@ -167,47 +163,3 @@ (LazyST.runStateT el s) once ma = LazyST.StateT $ \s -> once (LazyST.runStateT ma s) - -instance (MonadLogic m, Monoid w) => MonadLogic (StrictWT.WriterT w m) where - msplit wm = StrictWT.WriterT $ - do r <- msplit (StrictWT.runWriterT wm) - case r of - Nothing -> return (Nothing, mempty) - Just ((a,w), m) -> - return (Just (a, StrictWT.WriterT m), w) - - interleave ma mb = StrictWT.WriterT $ - StrictWT.runWriterT ma `interleave` StrictWT.runWriterT mb - - ma >>- f = StrictWT.WriterT $ - StrictWT.runWriterT ma >>- \(a,w) -> - StrictWT.runWriterT (StrictWT.tell w >> f a) - - ifte t th el = StrictWT.WriterT $ - ifte (StrictWT.runWriterT t) - (\(a,w) -> StrictWT.runWriterT (StrictWT.tell w >> th a)) - (StrictWT.runWriterT el) - - once ma = StrictWT.WriterT $ once (StrictWT.runWriterT ma) - -instance (MonadLogic m, Monoid w) => MonadLogic (LazyWT.WriterT w m) where - msplit wm = LazyWT.WriterT $ - do r <- msplit (LazyWT.runWriterT wm) - case r of - Nothing -> return (Nothing, mempty) - Just ((a,w), m) -> - return (Just (a, LazyWT.WriterT m), w) - - interleave ma mb = LazyWT.WriterT $ - LazyWT.runWriterT ma `interleave` LazyWT.runWriterT mb - - ma >>- f = LazyWT.WriterT $ - LazyWT.runWriterT ma >>- \(a,w) -> - LazyWT.runWriterT (LazyWT.tell w >> f a) - - ifte t th el = LazyWT.WriterT $ - ifte (LazyWT.runWriterT t) - (\(a,w) -> LazyWT.runWriterT (LazyWT.tell w >> th a)) - (LazyWT.runWriterT el) - - once ma = LazyWT.WriterT $ once (LazyWT.runWriterT ma) diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +# 0.7.0.0 + +* Remove unlawful `MonadLogic (Writer T w m)` instances. +* Fix `MonadReader r (LogicT m)` instance. +* Move `lnot` into `MonadLogic` class. + # 0.6.0.3 * Comply with MonadFail proposal. diff --git a/logict.cabal b/logict.cabal --- a/logict.cabal +++ b/logict.cabal @@ -1,5 +1,5 @@ name: logict -version: 0.6.0.3 +version: 0.7.0.0 description: A continuation-based, backtracking, logic programming monad. An adaptation of the two-continuation implementation found in the paper "Backtracking, Interleaving, and Terminating