logict 0.8.0.0 → 0.8.1.0
raw patch · 5 files changed
+204/−25 lines, 5 filesdep ~asyncdep ~faildep ~tastyPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: async, fail, tasty, tasty-hunit, transformers
API changes (from Hackage documentation)
Files
- Control/Monad/Logic.hs +85/−12
- Control/Monad/Logic/Class.hs +36/−2
- changelog.md +4/−0
- logict.cabal +9/−7
- test/Test.hs +70/−4
Control/Monad/Logic.hs view
@@ -52,9 +52,10 @@ embedLogicT ) where -import Control.Applicative+import Prelude (error, (-)) -import Control.Monad+import Control.Applicative (Alternative(..), Applicative, liftA2, pure, (<*>))+import Control.Monad (join, MonadPlus(..), liftM, Monad(..), fail) import qualified Control.Monad.Fail as Fail import Control.Monad.Identity (Identity(..)) import Control.Monad.IO.Class (MonadIO(..))@@ -67,15 +68,20 @@ import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Error.Class (MonadError(..)) -#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid (..))-#endif- #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup (..)) #endif +import Data.Bool (otherwise)+import Data.Eq ((==)) import qualified Data.Foldable as F+import Data.Function (($), (.), const)+import Data.Functor (Functor(..), (<$>))+import Data.Int+import qualified Data.List as L+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid (..))+import Data.Ord ((<=)) import qualified Data.Traversable as T import Control.Monad.Logic.Class@@ -88,16 +94,19 @@ -- (see 'Logic'). Thus 'LogicT' @m@ for non-trivial @m@ can be imagined -- as a list, pattern matching on which causes monadic effects. --+-- @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.") @@ -124,11 +133,15 @@ -- 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 []@@ -163,6 +176,7 @@ -- >>> 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 @@ -179,6 +193,8 @@ -- -- '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@@ -202,6 +218,8 @@ -- 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 $@@ -217,6 +235,8 @@ -- 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) @@ -225,6 +245,8 @@ -- 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 @@ -247,10 +269,48 @@ -- > 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) .@@ -268,6 +328,7 @@ -- -- Since 'Logic' is isomorphic to a list, 'observe' is analogous to 'head'. --+-- @since 0.2 observe :: Logic a -> a observe lt = runIdentity $ unLogicT lt (const . pure) (error "No answer.") @@ -280,6 +341,7 @@ -- '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 @@ -292,8 +354,9 @@ -- -- Since 'Logic' is isomorphic to a list, 'observeMany' is analogous to '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. @@ -311,6 +374,7 @@ -- 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@@ -335,6 +399,7 @@ fail = Fail.fail #endif +-- | @since 0.6.0.3 instance Fail.MonadFail (LogicT m) where fail _ = LogicT $ \_ fk -> fk @@ -343,11 +408,13 @@ mplus = (<|>) #if MIN_VERSION_base(4,9,0)+-- | @since 0.7.0.3 instance Semigroup (LogicT m a) where (<>) = mplus- sconcat = foldr1 mplus+ 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)@@ -374,14 +441,17 @@ #if MIN_VERSION_base(4,8,0) +-- | @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) +-- | @since 0.5.0 instance {-# OVERLAPPING #-} F.Foldable (LogicT Identity) where foldr f z m = runLogic m f z #else +-- | @since 0.5.0 instance (Applicative m, F.Foldable m) => F.Foldable (LogicT m) where foldMap f m = F.fold $ unLogicT m (fmap . mappend . f) (pure mempty) @@ -423,13 +493,17 @@ 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) where cons a l' = pure a <|> l'++-- | @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@@ -462,25 +536,24 @@ 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) #endif --- Needs undecidable instances 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
Control/Monad/Logic/Class.hs view
@@ -26,14 +26,34 @@ module Control.Monad.Logic.Class (MonadLogic(..), reflect) where -import Control.Applicative-import Control.Monad+import Prelude ()++import Control.Applicative (Alternative(..), Applicative(..))+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.Function (const, ($))+import Data.Maybe (Maybe(..), maybe) +#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:@@ -266,6 +286,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@@ -323,6 +345,8 @@ -- | 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@@ -346,6 +370,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,3 +1,7 @@+# 0.8.1.0++* Add `instance MonadLogic (Control.Monad.Writer.CPS.WriterT w m)`.+ # 0.8.0.0 * Breaking change:
logict.cabal view
@@ -1,5 +1,5 @@ name: logict-version: 0.8.0.0+version: 0.8.1.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.2+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 source-repository head type: git@@ -40,11 +40,12 @@ build-depends: base >=4.3 && <5,- mtl >=2.0 && <2.4+ mtl >=2.0 && <2.4,+ transformers <0.7 if impl(ghc <8.0) build-depends:- fail, transformers+ fail < 4.10 executable grandparents buildable: False@@ -66,10 +67,11 @@ build-depends: base,- async >=2.0,+ async >=2.0 && <2.3, logict, mtl,- tasty,- tasty-hunit+ transformers,+ tasty <1.5,+ tasty-hunit <0.11 hs-source-dirs: test
test/Test.hs view
@@ -18,15 +18,19 @@ import qualified Control.Monad.State.Strict as SS import Data.Maybe -#if MIN_VERSION_base(4,9,0)-#if MIN_VERSION_base(4,11,0)-#else+#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup (..)) #endif-#else++-- 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 #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)+#endif monadReader1 :: Assertion monadReader1 = assertEqual "should be equal" [5 :: Int] $@@ -53,6 +57,12 @@ oddsOrTwoUnfair, oddsOrTwoFair, odds5down :: Monad m => LogicT m Integer +-- | 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+ #if MIN_VERSION_base(4,8,0) nats = pure 0 `mplus` ((1 +) <$> nats) #else@@ -152,6 +162,13 @@ 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@@ -181,6 +198,15 @@ 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@@ -240,6 +266,13 @@ (take 4 $ runReaderT (let oddsR = return 1 `mplus` liftM (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+ 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 in oddsS `interleave` return (2 :: Integer)) "go")@@ -343,6 +376,17 @@ 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` liftM (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 oddsPlus n = oddsS >>= \a -> return (a + n)@@ -426,7 +470,21 @@ 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])+ oddsW = return (1 :: Integer) `mplus` liftM (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` liftM (2+) oddsS oc = do n <- oddsS guard (n > 1)@@ -498,6 +556,14 @@ (take 5 $ runReaderT (do v <- foldr (mplus . return) mzero [(1::Integer)..] 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)..]