logict-state 0.1.0.2 → 0.1.0.4

raw patch · 3 files changed

+32/−227 lines, 3 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• logict-state.cabal +2/−2
• src/Control/Monad/LogicState.hs +17/−223
• src/Control/Monad/TransLogicState/Class.hs +13/−2

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                logict-state-version:             0.1.0.2+version:             0.1.0.4 synopsis:            Library for logic programming based on haskell package logict description:         Logic programming built on top of part of logict library, in particular for dealing with backtrackable state homepage:            https://github.com/atzedijkstra/logict-state@@ -26,7 +26,7 @@                        Control.Monad.TransLogicState.Class   other-modules:       Control.Monad.LogicState.Logic   default-extensions:  MultiParamTypeClasses-  build-depends:       base >=4.8 && < 4.10,+  build-depends:       base >=4.8 && < 5,                        mtl >= 2.1,                        transformers >= 0.4.2,                        logict >= 0.6.0.2

@@ -29,15 +29,6 @@     module Control.Monad.TransLogicState.Class,     -- * The LogicState monad     LogicState,-    {--    logicVar,-    runLogicVar,-    -- * The LogicStateT monad transformer-    -}-    -- LogicVarT(..),-    {--    runLogicVarT,-    -}     LogicStateT(..),   ) where @@ -112,34 +103,10 @@ instance (MonadIO m) => MonadIO (LogicStateT gs bs m) where     liftIO = lift . liftIO -{--instance {-# OVERLAPPABLE #-} MonadState s m => MonadState s (LogicStateT gs bs m) where-    get = lift get-    put = lift . put--}- instance MonadReader r m => MonadReader r (LogicStateT gs bs m) where     ask = lift ask     local f m = LogicStateT $ \sk fk -> StateT $ runStateT $ unLogicStateT m (\a fk -> StateT $ local f . runStateT (sk a fk)) (StateT $ local f . runStateT fk) -{--instance MonadError e m => MonadError e (LogicStateT gs bs m) where-  throwError = lift . throwError-  catchError m h = LogicStateT $ \sk fk -> StateT $ \s -> let-      handle r = r `catchError` \e -> put s >> unLogicStateT (h e) sk fk-    in handle $ put s >> unLogicStateT m (\a fk' -> sk a (handle . fk')) fk--}--{--instance MonadError e m => MonadError e (LogicStateT gs bs m) where-  throwError = lift . throwError-  catchError m h = LogicStateT $ \sk fk -> StateT $ \s -> let-      handle r = r `catchError` \e -> StateT $ \_ -> runStateT (unLogicStateT (h e) sk fk) s-    in handle $ StateT $ \_ -> runStateT (unLogicStateT m (\a fk' -> sk a (handle . fk')) fk) s--}--{---} instance (Monad m) => MonadLogic (LogicStateT gs bs m) where     msplit m =        liftWithState $ runStateT $ unLogicStateT m@@ -149,12 +116,27 @@ instance TransLogicState (gs,bs) (LogicStateT gs bs) where   observeT s lt = evalStateT (unLogicStateT lt (\a _ -> return a) (fail "No answer.")) s   -  observeAllT s m = evalStateT (unLogicStateT m+  -- observeAllT s m = evalStateT (unLogicStateT m+  --   (\a fk -> fk >>= \as -> return (a:as))+  --   (return []))+  --   s+  +  observeStateAllT s m = runStateT (unLogicStateT m     (\a fk -> fk >>= \as -> return (a:as))     (return []))     s   -  observeManyT s n m = evalStateT (obs n m) s+  -- observeManyT s n m = evalStateT (obs n m) s+  --  where+  --    obs n m+  --       | n <= 0 = return []+  --       | n == 1 = unLogicStateT m (\a _ -> return [a]) (return [])+  --       | otherwise = unLogicStateT (msplit m) sk (return [])+  --    +  --    sk Nothing _ = return []+  --    sk (Just (a, m')) _ = StateT $ \s -> (\as -> (a:as,s)) `liftM` observeManyT s (n-1) m'++  observeStateManyT s n m = runStateT (obs n m) s    where      obs n m         | n <= 0 = return []@@ -179,192 +161,4 @@ -- | The basic LogicVar monad, for performing backtracking computations -- returning values of type 'a' type LogicState gs bs = LogicStateT gs bs Identity--{------------------------------------------------------------------------------ | A monad transformer for performing backtracking computations--- layered over another monad 'm', with propagation of global and backtracking state, e.g. resp. for freshness/uniqueness and maintaining variable mappings.-newtype LogicVarT gs bs m a =-    LogicVarT { unLogicVarT ::-      forall r. {- (Typeable r) => -} LogicCont gs bs r m a-    }---- | Convenience types-type LogicStateT gs bs r m = (gs,bs) -> m (r,(gs,bs)) -- StateT (gs,bs) m r -- (gs,bs) -> m (r,(gs,bs))-type LogicCont gs bs r m a =-           (   a                                -- ^ result-            -> LogicState gs bs r m             -- ^ failure continuation-            -> LogicState gs bs r m-           )                                    -- ^ success continuation-        -> LogicState gs bs r m                 -- ^ failure continuation-        -> LogicState gs bs r m                 -- ^ global + backtracking state--instance Functor (LogicVarT gs bs f) where-    fmap f lt = LogicVarT $ \sk -> unLogicVarT lt (sk . f)--instance Applicative (LogicVarT gs bs f) where-    pure a = LogicVarT $ \sk -> sk a-    f <*> a = LogicVarT $ \sk -> unLogicVarT f (\g -> unLogicVarT a (sk . g))--instance Monad (LogicVarT gs bs m) where-    return a = LogicVarT $ \sk -> sk a-    m >>= f = LogicVarT $ \sk -> unLogicVarT m (\a -> unLogicVarT (f a) sk)-    fail _ = LogicVarT $ \_ fk -> fk--instance Alternative (LogicVarT gs bs f) where-    empty = LogicVarT $ \_ fk -> fk-    f1 <|> f2 = LogicVarT $ \sk fk s@(_,bs) -> unLogicVarT f1 sk (\(gs',_) -> unLogicVarT f2 sk fk (gs',bs)) s--instance MonadPlus (LogicVarT gs bs m) where-  mzero = empty-  {-# INLINE mzero #-}-  mplus = (<|>)-  {-# INLINE mplus #-}--instance MonadTrans (LogicVarT gs bs) where-    lift m = LogicVarT $ \sk fk s -> m >>= \a -> sk a fk s--instance (MonadIO m) => MonadIO (LogicVarT gs bs m) where-    liftIO = lift . liftIO--}--{--data ResultLV gs bs r m a where-    DoneR :: ResultLV gs bs r m a-    NextR :: a -> LogicCont gs bs r m a -> ResultLV gs bs r m a--}--{--instance (Monad m, F.Foldable m) => F.Foldable (LogicVarT m) where-    foldMap f m = F.fold $ unLogicVarT m (liftM . mappend . f) (return mempty)--instance T.Traversable (LogicVarT Identity) where-    traverse g l = runLogicVar l (\a ft -> cons <$> g a <*> ft) (pure mzero)-     where cons a l' = return a `mplus` l'--}--{---- Needs undecidable instances-instance MonadReader r m => MonadReader r (LogicVarT gs bs m) where-    ask = lift ask-    local f m = LogicVarT $ \sk fk -> unLogicVarT m (\a fk -> local f . sk a fk) (local f . fk)-    -- ((local f .) . sk) (local f fk)-    -- (\a -> (local f .) $ \fk -> sk a fk) (local f fk)---- Needs undecidable instances-instance MonadState s m => MonadState s (LogicVarT gs bs m) where-    get = lift get-    put = lift . put---- Needs undecidable instances-instance MonadError e m => MonadError e (LogicVarT gs bs m) where-  throwError = lift . throwError-  catchError m h = LogicVarT $ \sk fk s -> let-      handle r = r `catchError` \e -> unLogicVarT (h e) sk fk s-    in handle $ unLogicVarT m (\a fk' -> sk a (handle . fk')) fk s--}-{--  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--}--{--instance (Monad m) => MonadLogic (LogicVarT gs bs m) where-    msplit m =-       liftWithState $ unLogicVarT m-         (\a fk s -> return (Just (a, liftWithState fk >>= reflect), s))-         (\s -> return (Nothing,s))--}-{--    msplit m =-       liftWithState $ \s -> unLogicVarT m s-         (\a s2@(gs2,bs2) fk -> return-           ( Just ( a-                  , do ma <- liftWithState fk -- $ \s3@(gs3,bs3::bs) -> fk s3 -- >>= \(a,s@(gs,bs)) -> return (a,s))-                       reflect ma-                  )-           , s2-           ))-         (\s -> return (Nothing,s))--}-{--    interleave m1 m2 = msplit m1 >>=-                        maybe m2 (\(a, m1') -> return a `mplus` interleave m2 m1')--    m >>- f = do (a, m') <- maybe mzero return =<< msplit m-                 interleave (f a) (m' >>- f)--    ifte t th el = msplit t >>= maybe el (\(a,m) -> th a `mplus` (m >>= th))--    once m = do (a, _) <- maybe mzero return =<< msplit m-                return a--}--{--instance (Monad m) => MonadLogicState (gs,bs) (LogicVarT gs bs m) where-    lvGet = LogicVarT $ \sk fk s -> sk s fk s-    lvModifyGet f = LogicVarT $ \sk fk s -> let (x,s') = f s in sk x fk s'--instance TransLogicState (gs,bs) (LogicVarT gs bs) where-  --------------------------------------------------------------------------  -- | Extracts the first result from a LogicVarT computation,-  -- failing otherwise.-  observeT s lt = fmap fst $ unLogicVarT lt (\a _ s -> return (a,s)) (\_ -> fail "No answer.") s-  -  --------------------------------------------------------------------------  -- | Extracts all results from a LogicVarT computation.-  observeAllT s m = fmap fst $ unLogicVarT m-    (\a fk s -> fk s >>= \(as,s') -> return (a:as, s'))-    (\s -> return ([],s))-    s-  -  --------------------------------------------------------------------------  -- | Extracts up to a given number of results from a LogicVarT computation.-  observeManyT s n m = fmap fst $ obs s n m-   where-     obs s n m-        | n <= 0 = return ([],s)-        | n == 1 = unLogicVarT m (\a _ s -> return ([a],s)) (\s -> return ([],s)) s-        | otherwise = unLogicVarT (msplit m) sk (\s -> return ([],s)) s-     -     sk Nothing _ s = return ([],s)-     sk (Just (a, m')) _ s = (\as -> (a:as,s)) `liftM` observeManyT s (n-1) m'--  -- |-  liftWithState m = LogicVarT $ \sk fk s -> m s >>= \(a,s) -> sk a fk s--}--{--  ----------------------------------------------------------------------------- | Runs a LogicVarT computation with the specified initial success and--- failure continuations.-runLogicVarT :: LogicVarT m a -> (a -> m r -> m r) -> m r -> m r-runLogicVarT = unLogicVarT--}--{------------------------------------------------------------------------------ | The basic LogicVar monad, for performing backtracking computations--- returning values of type 'a'-type LogicVar gs bs = LogicVarT gs bs Identity------------------------------------------------------------------------------ | A smart constructor for LogicVar computations.-logicVar :: (forall r. (a -> r -> r) -> r -> r) -> LogicVar a-logicVar f = LogicVarT $ \k -> Identity .-                         f (\a -> runIdentity . k a . Identity) .-                         runIdentity------------------------------------------------------------------------------ | Runs a LogicVar computation with the specified initial success and--- failure continuations.-runLogicVar :: LogicVar a -> (a -> r -> r) -> r -> r-runLogicVar l s f = runIdentity $ unLogicVarT l si fi- where- si = fmap . s- fi = Identity f---} 

@@ -11,6 +11,7 @@  -- import Data.Typeable +import Control.Arrow import Control.Monad.Identity -- import Control.Monad.Trans @@ -25,12 +26,22 @@   -------------------------------------------------------------------------   -- | Extracts all results from a 't m' computation.   observeAllT :: (Monad m) => s -> t m a -> m [a]-  observeAllT e = observeManyT e maxBound+  observeAllT e = fmap fst . observeStateAllT e      -------------------------------------------------------------------------+  -- | Extracts all results from a 't m' computation.+  observeStateAllT :: (Monad m) => s -> t m a -> m ([a],s)+  observeStateAllT e = observeStateManyT e maxBound+  +  -------------------------------------------------------------------------   -- | Extracts up to a given number of results from a 't m' computation.   observeManyT :: forall m a . (Monad m) => s -> Int -> t m a -> m [a]-  observeManyT e n m = fmap (take n) $ observeAllT e m+  observeManyT e n m = fmap fst $ observeStateManyT e n m++  -------------------------------------------------------------------------+  -- | Extracts up to a given number of results from a 't m' computation.+  observeStateManyT :: forall m a . (Monad m) => s -> Int -> t m a -> m ([a],s)+  observeStateManyT e n m = fmap (first $ take n) $ observeStateAllT e m    -- | Lift a monad by threading the state available in the transformed monad through it   liftWithState :: Monad m => (s -> m (a,s)) -> t m a