monad-lgbt 0.0.1 → 0.0.2

raw patch · 4 files changed

+179/−30 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• monad-lgbt.cabal +5/−3
• src/Control/Monad/Backtrack.hs +69/−0
• src/Control/Monad/State/LGBT.hs +92/−16
• test/Main.hs +13/−11

@@ -3,19 +3,19 @@ -- see: https://github.com/sol/hpack  name:           monad-lgbt-version:        0.0.1+version:        0.0.2 synopsis:       Monad transformers for combining local and global state. description:    This is library providing a nice typeclass interface for monads with two different states: local and global. Local state is backtraced whenever intervening monad transformer backtracks. Global state is preserved across all backtracing. It provides nice, classy interface for monads with backtracking/backjumping/continuations. category:       Control stability:      beta homepage:       https://github.com/mgajda/monad-lgbt#readme bug-reports:    https://github.com/mgajda/monad-lgbt/issues-build-type:     Simple-cabal-version:  >= 1.10 author:         Michal J. Gajda <mjgajda@gmail.com> maintainer:     Michal J. Gajda <mjgajda@gmail.com> license:        BSD2 license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10  source-repository head   type: git@@ -34,6 +34,7 @@     , mtl   exposed-modules:       Control.Monad.State.LGBT+      Control.Monad.Backtrack   other-modules:       Paths_monad_lgbt   default-language: Haskell2010@@ -53,5 +54,6 @@     , containers     , mtl   other-modules:+      Control.Monad.Backtrack       Control.Monad.State.LGBT   default-language: Haskell2010

@@ -0,0 +1,69 @@+{-# LANGUAGE RankNTypes #-}+-- | Simple monad that allows _depth-first_ backtracking+--   instead of fair conjunction/disjunction behaviour+--   as in @LogicT@.+module Control.Monad.Backtrack(+    BacktrackT+  , runBacktrackT+  ) where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans++newtype BacktrackT r m a = BacktrackT { runBacktrackT :: (String -> m r)  -- ^ failure+                                                      -> (a      -> m r) -- ^ success+                                                      ->            m r  -- ^ result+                                      }++instance Functor (BacktrackT r m) where+    fmap f m = BacktrackT $ \cf cs -> runBacktrackT m cf $ cs . f+    {-# INLINE fmap #-}++instance Applicative (BacktrackT r m) where+    pure x  = BacktrackT  (\_cf cs -> cs x)+    {-# INLINE pure #-}+    f <*> v = BacktrackT $ \cf cs -> runBacktrackT f cf+                         $ \r     -> runBacktrackT v cf (cs . r)+    {-# INLINE (<*>) #-}++instance Monad (BacktrackT r m) where+    m >>= k  = BacktrackT $ \cf cs -> runBacktrackT m cf (\v -> runBacktrackT (k v) cf cs)+    fail s   = BacktrackT $ \cf _cs -> cf s++instance MonadTrans (BacktrackT r) where+    lift m = BacktrackT $ \_cf cs -> m >>= cs+    {-# INLINE lift #-}++instance (MonadIO m) => MonadIO (BacktrackT r m) where+    liftIO = lift . liftIO+    {-# INLINE liftIO #-}++instance Alternative (BacktrackT r m) where+  empty   = BacktrackT $ \cf _cs -> cf "<empty alternative>"+  {-# INLINE empty #-}+  a <|> b = BacktrackT $ \cf  cs -> runBacktrackT a (\_s -> runBacktrackT b cf cs) cs+  {-# INLINE (<|>) #-}+  many = munch []+  {-# INLINE many #-}+  some p = p >>= (\a -> munch [a] p)+  {-# INLINE some #-}++-- | Munch as many as possible, depth-first.+--   Note that it always succeeds - possibly with empty result.+--   That allows it to backjump efficiently, instead of using @Alternative@.+munch :: [a] -> BacktrackT r m a -> BacktrackT r m [a]+munch initialAcc p = BacktrackT $ \_cf cs -> go cs initialAcc+  where+    go cs acc = runBacktrackT p onFailure onSuccess +      where+        onSuccess a = go cs $ a:acc+        onFailure _ = cs $ reverse acc+{-# INLINE munch #-}++instance MonadPlus (BacktrackT r m) where+  mzero = empty+  {-# INLINE mzero #-}+  mplus = (<|>)+  {-# INLINE mplus #-}+

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE FunctionalDependencies     #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE NamedFieldPuns             #-} {-# LANGUAGE PartialTypeSignatures      #-}@@ -8,9 +9,11 @@ {-# LANGUAGE TupleSections              #-} {-# LANGUAGE TypeSynonymInstances       #-} {-# LANGUAGE UndecidableInstances       #-}-module Control.Monad.State.LGBT( LGLT+module Control.Monad.State.LGBT( LGBT+                               , LGLT                                , LGCT                                , MonadLGBT (..)+                               , runLGBT                                , runLGLT                                , runLGCT                                , withGlobal, withLocal@@ -19,12 +22,47 @@  import Control.Applicative import Control.Monad.Cont---import Control.Monad.Except import Control.Monad.Logic---import Control.Monad.Trans(lift) --import Control.Monad.Reader import Control.Monad.State.Strict+import Control.Monad.Backtrack +-- | LGBT monad is sandwiching state with eager @BacktrackT@ transformer.+newtype LGBT localState globalState m a = LGBT { _unLGBT :: forall result.+    StateT                             localState+   (BacktrackT (Either String (result, localState))+   (StateT                                         globalState m)) a }++instance Functor (LGBT localState globalState m) where+  fmap f (LGBT act) = LGBT $ fmap f act++instance Applicative (LGBT localState globalState m) where+  LGBT f <*> LGBT a = LGBT $ f <*> a+  pure v            = LGBT $ pure v++instance Applicative m+      => Alternative (LGBT localState globalState m) where+  empty             = LGBT empty+  LGBT a <|> LGBT b = LGBT $ a <|> b+  some (LGBT act)   = LGBT $ some act+  many (LGBT act)   = LGBT $ many act++instance Monad                              m+      => Monad (LGBT localState globalState m) where+  return v     = LGBT $ return v+  LGBT a >>= b = LGBT $ a >>= (_unLGBT . b)+  fail   s     = LGBT $ fail s++instance MonadPlus                              m+      => MonadPlus (LGBT localState globalState m) where+  mzero = LGBT mzero+  LGBT a `mplus` LGBT b = LGBT $ a `mplus` b++instance MonadIO                              m+      => MonadIO (LGBT localState globalState m) where+  liftIO act = LGBT $ liftIO act++-- | LGBT monad is sandwiching state with fair @LogicT@ transformer. newtype LGLT localState globalState m a =     LGLT { _unLGLT ::              StateT localState (LogicT (StateT globalState m)) a }@@ -51,6 +89,9 @@     StateT localState (ContT (result, localState) (StateT globalState m)) a }   deriving (Functor, Applicative, Monad, MonadIO, MonadCont) +instance MonadTrans (LGBT localState globalState) where+  lift act = LGBT $ lift $ lift $ lift act+ instance MonadTrans (LGLT localState globalState) where   lift = LGLT . lift . lift . lift @@ -90,6 +131,16 @@ getsGlobal f = f <$> getGlobal  instance Monad m+      => MonadLGBT (LGBT localState globalState m)+                         localState globalState    where+  getLocal       = LGBT                 get+  getGlobal      = LGBT $ lift $ lift   get+  putLocal     l = LGBT $               put l+  putGlobal    g = LGBT $ lift . lift $ put g+  modifyLocal  m = LGBT $               modify m+  modifyGlobal m = LGBT $ lift . lift $ modify m++instance Monad m       => MonadLGBT (LGLT localState globalState m)                    localState globalState    where   getLocal     = LGLT                 get@@ -99,24 +150,49 @@   modifyLocal  = LGLT .               modify   modifyGlobal = LGLT . lift . lift . modify --- * These are not instance methods, since liftings need to be explicitly determined.-withLocal  :: Monad m-           => (localState -> m localState)-           -> LGLT localState globalState m ()+-- * These are not instance methods, since choice of transformer needs+--   to be explicitly determined.+withLocal :: forall (t :: (* -> *) -> * -> *) -- ^ Any transformer that makes MonadLGBT+                          (m ::       * -> *) -- ^ Any underlying monad, below the @t@+                             localState+                                        globalState.+            (Monad        m,+             MonadTrans t  ,+             MonadLGBT (t m) localState      globalState)+          =>                (localState -> m localState )+          -> t m () withLocal f = getLocal >>= (lift . f) >>= putLocal -withGlobal  :: Monad m-            =>     (globalState -> m globalState)-            -> LGLT globalState globalState m ()+withGlobal :: forall (t :: (* -> *) -> * -> *) -- ^ Any transformer that makes MonadLGBT+                     (m ::  * -> *           ) -- ^ Any underlying monad, below the @t@+                              localState+                                         globalState.+             (Monad        m,+              MonadTrans t  ,+              MonadLGBT (t m) localState globalState)+           =>                           (globalState -> m globalState)+           ->            t m () withGlobal f = getGlobal >>= (lift . f) >>= putGlobal -runLGLT :: forall m localState globalState success result.+runLGBT :: forall m localState globalState result.            Monad  m-        => LGLT        localState    globalState    m success-        ->             localState-        ->                           globalState-        -> (success -> localState -> globalState -> m result  -> m result)-        -> (                         globalState ->              m result)+        => LGBT localState globalState m         result+        ->      localState+        ->                 globalState+        ->                             m (Either String (result, localState), globalState)+runLGBT (LGBT act) localState globalState =+    runStateT (runBacktrackT (runStateT act localState) onFailure onSuccess) globalState+  where+    onFailure = pure . Left+    onSuccess = pure . Right++runLGLT :: forall m  result success localState globalState.+           Monad  m+        => LGLT             localState    globalState    m success+        ->                  localState+        ->                                globalState+        -> (success ->      localState -> globalState -> m result  -> m result)+        -> (                              globalState ->              m result)         ->                                          m result runLGLT (LGLT act) localState globalState onSuccess onFailure =     evalStateT  (runLogicT (runStateT act localState) onSuccess' onFailure') globalState

@@ -6,7 +6,9 @@ {-# LANGUAGE NamedFieldPuns         #-} module Main(main) where +import Control.Applicative import Control.Monad.Identity+import Data.Foldable(asum) import Data.Tree  import Control.Monad.State.LGBT@@ -20,7 +22,7 @@ -- | We define type Path = [String] -type MeerkatM a = LGLT Local Global Identity a+type MeerkatM a = LGBT Local Global Identity a  -- | First maze is relatively easy, but since Merryssa is very liberal, --   she will probably choose the leftist path until proven that it goes nowhere.@@ -54,7 +56,7 @@ withRaisins :: (Raisins -> Raisins) -> Global -> Global withRaisins f (Global x) = Global $ f x -type MazeM = LGLT Local Global Identity [String]+type MazeM = LGBT Local Global Identity [String]  -- | Merryssa the Meerkat tries to find her way inside the forest maze... --   but she has limited amount of food.@@ -63,10 +65,10 @@   current <- getsLocal $ rootLabel . subMaze   modifyLocal $ \Local{..} -> Local { path=current:path, .. }   remainingFood <- getsGlobal food-  when (remainingFood == 0) mzero+  when (remainingFood == 0) $ fail "No more raisins!"   if current == "FINISH"-    then reverse     <$> getsLocal path -- return the path to finish-    else (msum . map stepTo) =<< getsLocal (subForest . subMaze)+    then  reverse            <$> getsLocal  path -- ^ Return the path to finish+    else (asum . map stepTo) =<< getsLocal (subForest . subMaze)   where     stepTo    :: Maze -> MazeM     stepTo new = do@@ -88,14 +90,14 @@  experiment :: Int -> Maze -> Result experiment givenFood theMaze =+    extract     $     runIdentity $-    runLGLT meerkat (Local  { subMaze = theMaze, path = [] })-                    (Global { food    = givenFood          })-                     onSuccess onFailure+    runLGBT  meerkat Local  { subMaze = theMaze,   path = [] }+                     Global         { food      = givenFood  }   where-    onFailure        Global { food=0 }       = return   Bored-    onFailure        Global { food   }       = return $ Asleep food-    onSuccess path _ Global { food   } _next = return $ Escaped food path+    extract (Left         _ , Global { food=0 }) = Bored+    extract (Left         _ , Global { food   }) = Asleep  food+    extract (Right (path, _), Global { food   }) = Escaped food path  test :: Int -> Maze -> IO () test someFood aMaze = do