monad-lgbt (empty) → 0.0.1
raw patch · 5 files changed
+334/−0 lines, 5 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, deepseq, hspec, logict, mtl
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- monad-lgbt.cabal +57/−0
- src/Control/Monad/State/LGBT.hs +137/−0
- test/Main.hs +114/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2016, Michał J. Gajda+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ monad-lgbt.cabal view
@@ -0,0 +1,57 @@+-- This file has been generated from package.yaml by hpack version 0.14.0.+--+-- see: https://github.com/sol/hpack++name: monad-lgbt+version: 0.0.1+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++source-repository head+ type: git+ location: https://github.com/mgajda/monad-lgbt++library+ hs-source-dirs:+ src+ build-depends:+ logict+ , hspec+ , QuickCheck+ , deepseq+ , base >=4.3 && <4.10+ , containers+ , mtl+ exposed-modules:+ Control.Monad.State.LGBT+ other-modules:+ Paths_monad_lgbt+ default-language: Haskell2010++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs:+ src+ , test+ build-depends:+ logict+ , hspec+ , QuickCheck+ , deepseq+ , base >=4.3 && <4.10+ , containers+ , mtl+ other-modules:+ Control.Monad.State.LGBT+ default-language: Haskell2010
+ src/Control/Monad/State/LGBT.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Control.Monad.State.LGBT( LGLT+ , LGCT+ , MonadLGBT (..)+ , runLGLT+ , runLGCT+ , withGlobal, withLocal+ , getsLocal, getsGlobal+ ) where++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++newtype LGLT localState globalState m a =+ LGLT { _unLGLT ::+ StateT localState (LogicT (StateT globalState m)) a }+ deriving (Functor, Applicative, Alternative,+ Monad, MonadPlus, MonadIO, MonadLogic)++{- TODO: MonadRead and MonadExcept instances:+instance MonadReader r m+ => MonadReader r (LGLT l g m)+ where+ ask = lift . lift . lift $ ask+ --local f m = LGLT $ local f (_unLGLT m ((local f .) . sk (local f fk))+ -- \sk fk -> unLogicT m ((local f .) . sk) (local f fk)++instance MonadError e m+ => MonadError e (LGLT l g m)+ where+ throwError = lift . throwError+ -- catchError+ -}++-- | Local/global state transformer with unlimited continuations @MonadCont@+newtype LGCT localState globalState result m a = LGCT { _unLGCT ::+ StateT localState (ContT (result, localState) (StateT globalState m)) a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadCont)++instance MonadTrans (LGLT localState globalState) where+ lift = LGLT . lift . lift . lift++instance MonadTrans (LGCT localState globalState result) where+ lift = LGCT . lift . lift . lift++-- | Local/global state transformer class abstracts over details of how global+-- and local state are realized.+-- The separation of local and global state only makes sense when we also+-- allow for some backtracking monad in between,+-- hence the name "Local/global backtracking transformer".+class Monad m+ => MonadLGBT m localState globalState+ | m -> localState,+ m -> globalState where+ getLocal :: m localState+ getGlobal :: m globalState++ putLocal :: localState -> m ()+ putGlobal :: globalState -> m ()++ modifyLocal :: (localState -> localState ) -> m ()+ modifyLocal m = putLocal . m =<< getLocal++ modifyGlobal :: (globalState -> globalState) -> m ()+ modifyGlobal m = putGlobal . m =<< getGlobal+ {-# MINIMAL getLocal, getGlobal, putLocal, putGlobal #-}++getsLocal :: forall m localState globalState a.+ MonadLGBT m localState globalState+ => (localState -> a) -> m a+getsLocal f = f <$> getLocal++getsGlobal :: forall m localState globalState a.+ MonadLGBT m localState globalState+ => (globalState -> a) -> m a+getsGlobal f = f <$> getGlobal++instance Monad m+ => MonadLGBT (LGLT localState globalState m)+ localState globalState where+ getLocal = LGLT get+ getGlobal = LGLT $ lift $ lift get+ putLocal = LGLT . put+ putGlobal = LGLT . lift . lift . put+ 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 ()+withLocal f = getLocal >>= (lift . f) >>= putLocal++withGlobal :: Monad m+ => (globalState -> m globalState)+ -> LGLT globalState globalState m ()+withGlobal f = getGlobal >>= (lift . f) >>= putGlobal++runLGLT :: forall m localState globalState success result.+ 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+ where+ onFailure' = lift . onFailure =<< get+ onSuccess' (r, local) next = do+ global <- get+ lift $ onSuccess r local global $ evalStateT next global++runLGCT :: forall m localState globalState result.+ Monad m+ => LGCT localState globalState result m result+ -> localState+ -> globalState+ -> m ((result, localState), globalState)+runLGCT (LGCT act) localState globalState =+ runStateT (runContT (runStateT act localState) return) globalState+
+ test/Main.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+module Main(main) where++import Control.Monad.Identity+import Data.Tree++import Control.Monad.State.LGBT++-- | Laboratory maze will be defined by just @String@ labels in a tree...+type Maze = Tree String++-- | We will need to remember how many motivating @Raisins@ our meerkat still has.+type Raisins = Int++-- | We define+type Path = [String]++type MeerkatM a = LGLT 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.+maze :: Maze+maze = Node "top" [Node "righty" [peanoNode 4+ ,Node "lefty" [Node "Deeper" [Node "FINISH" []]+ ,peanoNode 100]+ ]+ ]++-- | Second maze has no exit, so probably results in the boring end.+maze2 :: Maze+maze2 = Node "top" [Node "righty" [peanoNode 4+ ,Node "lefty" [Node "Deeper" [Node "Eternal" []]+ ,peanoNode 100]+ ]+ ]++-- | Make a deep dead-end tunnel to the ends of Peano-land.+peanoNode :: Int -> Maze+peanoNode 0 = Node "zero" [ ]+peanoNode i = Node "succ" [peanoNode $ i-1]++-- | Global state keeps track of how long the meerkat will still walk...+data Global = Global { food :: Raisins }+-- | Local state keeps track of where Merryssa currently is.+data Local = Local { path :: Path+ , subMaze :: Maze }++-- | Apply a given action on @Global@ variable+withRaisins :: (Raisins -> Raisins) -> Global -> Global+withRaisins f (Global x) = Global $ f x++type MazeM = LGLT Local Global Identity [String]++-- | Merryssa the Meerkat tries to find her way inside the forest maze...+-- but she has limited amount of food.+meerkat :: MazeM+meerkat = do+ current <- getsLocal $ rootLabel . subMaze+ modifyLocal $ \Local{..} -> Local { path=current:path, .. }+ remainingFood <- getsGlobal food+ when (remainingFood == 0) mzero+ if current == "FINISH"+ then reverse <$> getsLocal path -- return the path to finish+ else (msum . map stepTo) =<< getsLocal (subForest . subMaze)+ where+ stepTo :: Maze -> MazeM+ stepTo new = do+ eat+ modifyLocal $ \Local {..} -> Local { subMaze = new, .. }+ meerkat++-- | Eaten breadcrumbs do not renew, so they are part of global state.+eat :: MeerkatM ()+eat = modifyGlobal $ withRaisins (-1+) -- eat food++-- | Final outcome of the search can be either lucky+-- or extremely tragic.+data Result = Bored -- ^ Ran out of food, and phased out of forest maze+ | Asleep Int -- ^ Went through entire maze, and found nothing+ | Escaped Int -- ^ Remaining food+ [String] -- ^ Path+ deriving (Show)++experiment :: Int -> Maze -> Result+experiment givenFood theMaze =+ runIdentity $+ runLGLT meerkat (Local { subMaze = theMaze, path = [] })+ (Global { food = givenFood })+ onSuccess onFailure+ where+ onFailure Global { food=0 } = return Bored+ onFailure Global { food } = return $ Asleep food+ onSuccess path _ Global { food } _next = return $ Escaped food path++test :: Int -> Maze -> IO ()+test someFood aMaze = do+ putStr $ "Testing with " ++ show someFood ++ " " -- ++ "on:\n" ++ drawTree maze+ print $ experiment someFood aMaze++-- | Test the backtracing on two different forest mazes.+main :: IO ()+main = do+ test 1 maze+ test 10 maze+ test 100 maze+ test 1 maze2+ test 10 maze2+ test 200 maze2+