state-plus (empty) → 0.1

raw patch · 5 files changed

+183/−0 lines, 5 filesdep +QuickCheckdep +basedep +checkerssetup-changed

Dependencies added: QuickCheck, base, checkers, mtl, state-plus

Files

COPYING +25/−0
Control/Monad/Trans/State/Plus.hs +70/−0
Setup.hs +5/−0
state-plus.cabal +25/−0
tests/Main.hs +58/−0

+ COPYING view

@@ -0,0 +1,25 @@+Copyright (c) 2012 Boris Sukholitko+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. The names of the authors may not be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.+

+ Control/Monad/Trans/State/Plus.hs view

@@ -0,0 +1,70 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-}+----------------------------------------------------------------------+-- |+-- Module      :  Control.Monad.Trans.State.Plus+-- Copyright   :  (c) Boris Sukholitko 2012+-- License     :  BSD3+-- +-- Maintainer  :  boriss@gmail.com+-- Stability   :  experimental+-- +-- MonadPlus with left catch (MonadOr) for StateT.+----------------------------------------------------------------------+module Control.Monad.Trans.State.Plus (+    -- * The StatePlusT monad transformer+    StatePlusT, runStatePlusT, execStatePlusT, evalStatePlusT) where++import Control.Monad.State++-- | StatePlusT behaves similar to StateT monad transformer+newtype StatePlusT s m a = MkSPT { unSPT :: StateT (Bool, s) m a }+                                deriving (Functor, MonadTrans, MonadIO)++mzeroError :: a+mzeroError = error "StatePlusT mzero value"++instance Monad m => Monad (StatePlusT s m) where+    return = lift . return+    x >>= f = (MkSPT . StateT) go+        where go s = do+                    (a, s') <- runStateT (unSPT x) s+                    if fst s'+                            then runStateT (unSPT $ f a) s'+                            else return $ (mzeroError, s')++instance Monad m => MonadState s (StatePlusT s m) where+    get = (MkSPT . StateT) $ \s -> return (snd s, s)+    put v = (MkSPT . StateT) $ \s -> return ((), (fst s, v))++plusStates :: (a, (Bool, s)) -> (a, (Bool, s)) -> (a, (Bool, s))+plusStates (_, (False, _)) b = b+plusStates a _ = a++instance Monad m => MonadPlus (StatePlusT s m) where+    mzero = (MkSPT . StateT) $ \s -> return (mzeroError, (False, snd s))+    mplus a b = (MkSPT . StateT) go where+        go s = do+            as <- runStateT (unSPT a) s+            bs <- runStateT (unSPT b) s+            let (rr, rs) = plusStates as bs+            runStateT (return rr) rs++-- | Evaluate StatePlusT monad. In difference from runStateT it returns+-- @Nothing@ if @mzero@ has been encountered. @Just a@ otherwise.+runStatePlusT :: Monad m => StatePlusT s m a -> s -> m (Maybe a, s)+runStatePlusT sm s = do+    (v, (isOK, ss)) <- runStateT (unSPT sm) (True, s)+    return (if isOK then Just v else Nothing, ss)++-- | Execute StatePlusT monad returning resulting state+execStatePlusT :: Monad m => StatePlusT s m a -> s -> m s+execStatePlusT sm s = do+    (_, ss) <- runStatePlusT sm s+    return ss++-- | Evaluate StatePlusT monad returning resulting value. See above+-- for the semantics.+evalStatePlusT :: Monad m => StatePlusT s m a -> s -> m (Maybe a)+evalStatePlusT sm s = do+    (mb, _) <- runStatePlusT sm s+    return mb

+ Setup.hs view

@@ -0,0 +1,5 @@+module Main where++import Distribution.Simple++main = defaultMain

+ state-plus.cabal view

@@ -0,0 +1,25 @@+Name:                state-plus+Version:             0.1+License:             BSD3+License-File:        COPYING+Copyright:           Boris Sukholitko, 2012+Author:              Boris Sukholitko+Maintainer:          boriss@gmail.com+Cabal-version:       >= 1.8+Build-type:          Simple+Synopsis:            MonadPlus for StateT+Description:         Implements MonadPlus with left catch (MonadOr) for StateT.+Category:            Control++library +  build-depends:  base < 5, mtl+  ghc-options:      -Wall+  exposed-modules:  Control.Monad.Trans.State.Plus++test-suite Main+  type:            exitcode-stdio-1.0+  build-depends:   base < 5, QuickCheck, mtl, state-plus, checkers+  ghc-options:     -Wall+  hs-source-dirs:  tests+  main-is:         Main.hs+

+ tests/Main.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}+import Control.Monad.Trans.State.Plus+import Test.QuickCheck (Arbitrary, arbitrary, CoArbitrary, stdArgs+                            , Args(maxSuccess), quickCheckWithResult)+import Test.QuickCheck.Function+import Control.Monad.Identity+import Control.Monad.State+import Test.QuickCheck.Classes+import Test.QuickCheck.Checkers+import Test.QuickCheck.Test (isSuccess)+import Test.QuickCheck.Property (property)+import Data.List (foldl')+import System.Exit (exitFailure)++newtype P = P Bool deriving (Eq, Arbitrary, Function, Show, CoArbitrary)+newtype SI = SI [Int] deriving (Eq, Arbitrary, Function, Show, CoArbitrary)+instance Show (StatePlusT SI Identity P) where+    show m = "StatePlus: " ++ show (runIdentity $ runStatePlusT m (SI [0]))++arbSP :: SI -> P -> Bool -> StatePlusT SI Identity P+arbSP si p b = do+    put si+    when b $ mzero+    return p++instance Arbitrary (StatePlusT SI Identity P) where+    arbitrary = do+        s <- arbitrary+        p <- arbitrary+        b <- arbitrary+        return $ arbSP s p b++extract :: StatePlusT SI Identity P -> Maybe (P, SI)+extract m = case fst res of+    Nothing -> Nothing+    Just v -> Just (v, snd res)+    where res = runIdentity $ runStatePlusT m (SI [0])++instance EqProp (StatePlusT SI Identity P) where+    a =-= b = property $ (extract a) == (extract b)++-- shamelessly copied from Checkers+checkB :: TestBatch -> IO ()+checkB (name,tests) =+  do putStrLn $ "\n" ++ name ++ ":"+     mapM_ pr tests+ where+   pr (s,p) = do putStr (padTo (width + 4) ("  "++s ++ ":"))+                 r <- quickCheckWithResult stdArgs { maxSuccess = 500 } p+                 when (not $ isSuccess r) $ exitFailure+   width    = foldl' max 0 (map (length.fst) tests)+   padTo n = take n . (++ repeat ' ')++main :: IO ()+main = do+    checkB (monad (undefined :: StatePlusT SI Identity (P, P, P)))+    checkB (monadOr (undefined :: StatePlusT SI Identity (P, P)))+