I'm somewhat new to monad transformers, and currently trying to use a StateT/Except stack in a project. The difficulty I'm having is that I have a few layers of data composition (types with operations on them, contained within types that have other operations on them), and I can't figure out how to elegantly use monad transformers in that design. Concretely, I'm having trouble writing the following code (simplified example, obviously):
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import Control.Monad.Except
import Control.Monad.State
import Control.Monad.Trans.Except (Except, throwE)
import Control.Monad.Trans.State (StateT)
data ComposedState = ComposedState { state :: Bool }
data MyError = MyError { message :: String }
-- If the passed in state is true, change it to false; otherwise throw.
throwingModification :: ComposedState -> Except MyError ComposedState
throwingModification (ComposedState True) = return $ ComposedState False
throwingModification _ = throwE $ MyError "error!"
-- A state which composes with #ComposedState#,
data MyState = MyState { composed :: ComposedState }
-- and a monad transformer state to allow me to modify it and propagate
-- errors.
newtype MyMonad a = MyMonad { contents :: StateT MyState (Except MyError) a }
deriving ( Functor
, Applicative
, Monad
, MonadState MyState
, MonadError MyError )
anAction :: MyMonad ()
anAction = do -- want to apply throwingModification to the `composed` member,
-- propogating any exception
undefined
where I have a potentially "throwing" operation on ComposedState, and I want to use that operation in a stateful, throwing operation on MyState. I can obviously do that by deconstructing the whole stack and rebuilding it, but the whole point of the monadic structure is that I shouldn't have to. Is there a terse, idiomatic solution?
Apologies for the lengthy code snippet--I did my best to cut it down.
The more natural way of doing this would be to write throwingModification from the start in the MyMonad monad, like so:
throwingModification' :: MyMonad ()
throwingModification' = do ComposedState flag <- gets composed
if not flag then throwError $ MyError "error!"
else modify (\s -> s { composed = (composed s)
{ Main.state = False } })
I'm assuming here that the composed states contain other components that you want to preserve, which makes the modify clause ugly. Using lenses can make this cleaner.
However, if you're stuck with the current form of throwingModification, you'll probably have to write your own combinator, since the usual State combinators don't include mechanisms for switching the state type s, which is what you're effectively trying to do.
The following definition of usingState may help. It transforms a StateT operation from one state to another using a getter and setter. (Again, a lens approach would be cleaner.)
usingState :: (Monad m) => (s -> t) -> (s -> t -> s)
-> StateT t m a -> StateT s m a
usingState getter setter mt = do
s <- get
StateT . const $ do (a, t) <- runStateT mt (getter s)
return (a, setter s t)
I don't think there's an easy way to modify usingState to work between general MonadState monads instead of directly on a StateT, so you'll need to lift it manually and convert it through your MyMonad data type.
With usingState so defined, you can write the following. (Note >=> comes from Control.Monad.)
MyMonad $ usingState getComposed putComposed $
StateT (throwingModification >=> return . ((),))
with helpers:
getComposed = composed
putComposed s c = s { composed = c }
This is still a little ugly, but that's because the type t -> Except e t must be adapted to StateT (t -> Except e ((), t)), then transformed to the s state by the combinator, and then wrapped manually in your MyMonad, as explained above.
With Lenses
I'm not suggesting lenses are a miracle cure or anything, but they do help clean up a few of the uglier parts of the code.
After adding lenses:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
import Control.Lens
import Control.Monad ((>=>))
import Control.Monad.Except (Except, MonadError, throwError)
import Control.Monad.State (get, MonadState, runStateT, StateT(..))
data MyError = MyError { _message :: String }
data MyState = MyState { _composed :: ComposedState }
data ComposedState = ComposedState { _state :: Bool }
makeLenses ''ComposedState
makeLenses ''MyError
makeLenses ''MyState
the definition of throwingModification looks a little cleaner:
throwingModification :: ComposedState -> Except MyError ComposedState
throwingModification s =
if s^.state then return $ s&state .~ False
else throwError $ MyError "error!"
and the MyMonad version I gave above certainly benefits:
throwingModification' :: MyMonad ()
throwingModification' = do
flag <- use (composed.state)
if flag then composed.state .= False
else throwError (MyError "error!")
The definition of usingStateL doesn't look much different:
usingStateL :: (Monad m) => Lens' s t -> StateT t m a -> StateT s m a
usingStateL tPart mt = do
s <- get
StateT . const $ do (a, t) <- runStateT mt (s^.tPart)
return (a, s&tPart .~ t)
but it allows the existing lens composed to be used in place of helper functions:
MyMonad $ usingStateL composed $
StateT (throwingModification >=> return . ((),))
and it would generalize to (composed.underneath.state4) if you had complex nested state.
The best solution would be re-write throwingModification as a MyMonad.
throwingModification :: MyMonad ()
throwingModification = do
s <- get
if state s then
put $ ComposedState False
else
throwError $ MyError "error!"
If you can't re-write your function (because it is used elsewhere), you can wrap it instead.
When there is a function like:
some_type_t* some_type_create(const char* name, char** errptr);
is there a way to get C2HS to generate a Haskell binding with the following signature?
someTypeCreate :: String -> IO (SomeTypeFPtr, String)
Here is what I can get so far:
{#fun some_type_create as ^
{`String', alloca- `Ptr CChar' peek*} -> `SomeTypeFPtr' #}
and it works in a way that I get
someTypeCreate :: String -> IO (SomeTypeFPtr, (Ptr CChar))
but how do I make it return IO (SomeTypeFPtr, String)
(or better IO (Either String SomeTypeFPtr)) since String represents the error)?
I assume that I should use/write a different marshaller to use instead of peek which would convert the result type but I don't quite understand how to do it.
I think I've figured it out, I just wrote the following marshallers:
nullableM :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
nullableM f ptr = if ptr == nullPtr
then return Nothing
else liftM Just $ f ptr
{-# INLINE nullableM #-}
toStringMaybe :: CString -> IO (Maybe String)
toStringMaybe = nullableM peekCString
{-# INLINE toStringMaybe #-}
peekStringMaybe :: Ptr CString -> IO (Maybe String)
peekStringMaybe x = peek x >>= toStringMaybe
{-# INLINE peekStringMaybe #-}
I've read Happstack crashcourse. My web server has almost exact way described in the section Passing multiple AcidState handles around transparently
Problem I have is that, I have value which is non-acidic, but want to access within the Happstack application. Specifically speaking, "PushManager" from push-notify-general library,
What I wanted is:
data Acid = Acid
{ acidCountState :: AcidState CountState
, acidGreetingState :: AcidState GreetingState
, acidPushManager :: AcidState PushManager
}
I couldn't make this work, because 1) PushManager use so many data types internally, and it is not realistic/robust to make underlying data type SafeCopy compatible by calling $(deriveSafeCopy ...). 2) PushManager not only contains simple value, but also function which is SafeCopy compatible.
Other thing I tried is to "Acid" data declaration to carry not only AcidState, but also non-AcidState data. By looking at the definition of runApp, "Acid" is just used for Reading, so I thought that rewriting with State monad may be able to achive my need. - but it turns out that it was not so simple. My tentative code is:
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving,
TemplateHaskell, TypeFamilies, DeriveDataTypeable,
FlexibleContexts, ScopedTypeVariables,
NamedFieldPuns, DeriveFunctor, StandaloneDeriving, OverloadedStrings #-}
import Control.Applicative ( Applicative, Alternative, (<$>))
import Control.Monad ( MonadPlus )
import Control.Monad.State.Strict ( MonadState, StateT, get, put, evalStateT )
import Control.Monad.Trans ( MonadIO )
import Data.Acid
import Data.Data ( Data, Typeable )
import Happstack.Server
newtype Simple a = Simple { unSimple :: a }
deriving (Show)
data CountState = CountState { count :: Integer }
deriving (Eq, Ord, Data, Typeable, Show)
-- This data is equivalent to the one previously called "Acid"
data States = States {
simpleState :: Simple Int
, acidCountState :: AcidState CountState
}
initialStates :: States
initialStates = States { simpleState = Simple 1, acidCountState = undefined }
newtype App a = App { unApp :: ServerPartT (StateT States IO) a }
deriving ( Functor, Alternative, Applicative, Monad
, MonadPlus, MonadIO, HasRqData, ServerMonad
, WebMonad Response, FilterMonad Response
, Happstack, MonadState States )
class HasSimple m st where
getSimple :: m (Simple st)
putSimple :: (Simple st) -> m ()
instance HasSimple App Int where
getSimple = simpleState <$> get
putSimple input = do
whole <- get
put $ whole {simpleState = input}
simpleQuery :: ( Functor m
, HasSimple m a
, MonadIO m
, Show a
) =>
m a
simpleQuery = do
(Simple a) <- getSimple
return a
simpleUpdate :: ( Functor m
, HasSimple m a
, MonadIO m
, Show a
) =>
a
-> m ()
simpleUpdate a = putSimple (Simple a)
runApp :: States -> App a -> ServerPartT IO a
runApp states (App sp) = do
mapServerPartT (flip evalStateT states) sp
rootDir :: App Response
rootDir = do
intVal <- simpleQuery
let newIntVal :: Int
newIntVal = intVal + 1
simpleUpdate newIntVal
ok $ toResponse $ ("hello number:" ++ (show newIntVal))
main :: IO ()
main = do
simpleHTTP nullConf $ runApp initialStates rootDir
It compiled, but every time web page is requested, the page display same number. Looking at my code again, and I felt that evalStateT in runApp is wrong, because it never use updated state value.
Now, I am reading mapServerPartT and ServerPartT, but that is too complex.
Appreciate if anybody can answer the title line: "How to carry non-Acidic value in Happstack?"
The mapServerPartT would not help you either. The issue here is that the handler function you pass to simpleHTTP gets called in a new thread for each request that comes in. And each time it is going to be calling runApp with the initialStates argument. So not only is the value lost at the end of the request, but if multiple threads are handling requests, they will each have their own separate copy of the state.
Once we realize that we want state that is shared between multiple threads, we realize that the answer must rely on one of the tools for doing interthread communication. A good choice would probably be a TVar, http://hackage.haskell.org/package/stm-2.4.3/docs/Control-Concurrent-STM-TVar.html
main :: IO ()
main = do
states <- atomically $ newTVar initialStates
simpleHTTP nullConf $ runApp states rootDir
Note that we create the TVar before we start listening for incoming connections. We pass the TVar to all the request handling threads, and STM takes care of synchronizing the values between threads.
a TVar is a bit like acid-state without the (D)urability. Since the data does not need to be saved, there is no need for SafeCopy instances, etc.
Based on stepcut's Answer, I was able to carry non-acidic value within Happstack using TVar.
If anybody is interested in, here is simplified code:
https://gist.github.com/anonymous/5686161783fd53c4e413
And this is full version which carries both "AcidState CountState" and "TVar CountState".
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving,
TemplateHaskell, TypeFamilies, DeriveDataTypeable,
FlexibleContexts, ScopedTypeVariables,
NamedFieldPuns, DeriveFunctor, StandaloneDeriving, OverloadedStrings,
RecordWildCards #-}
import Happstack.Server
import Control.Applicative ( Applicative, Alternative, (<$>))
import Control.Monad ( MonadPlus, msum )
import Control.Monad.Reader ( MonadReader, ReaderT(..), ask)
import Control.Monad.State (get, put)
import Control.Monad.Trans ( MonadIO, liftIO )
import Control.Monad.Trans.Control ( MonadBaseControl )
import Data.Maybe (fromMaybe)
import Control.Exception
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Data.Acid hiding (update)
import Data.Acid.Advanced (query', update')
import Data.Acid.Local
import Data.SafeCopy
import Data.Data ( Data, Typeable )
import System.FilePath ((</>))
data CountState = CountState { count :: Integer }
deriving (Eq, Ord, Data, Typeable, Show)
$(deriveSafeCopy 0 'base ''CountState)
initialCountState :: CountState
initialCountState = CountState { count = 0 }
-- for AcidState
incCount :: Update CountState Integer
incCount =
do (CountState c) <- get
let c' = succ c
put (CountState c')
return c'
$(makeAcidic ''CountState ['incCount])
-- for TVar
incCountState :: App Integer
incCountState = do
(_, CountState newVal) <- updateTVar incCount'
return newVal
where
incCount' :: CountState -> CountState
incCount' (CountState c) = CountState $ succ c
data Aci = Aci
{ acidCountState :: AcidState CountState
, tvarCountState :: TVar CountState
}
withAci :: Maybe FilePath -> (Aci -> IO a) -> IO a
withAci mBasePath action = do
initialTVarCount <- newTVarIO initialCountState
let basePath = fromMaybe "_state" mBasePath
countPath = Just $ basePath </> "count"
in withLocalState countPath initialCountState $ \c ->
action (Aci c initialTVarCount)
-- for AcidState
class HasAcidState m st where
getAcidState :: m (AcidState st)
query :: forall event m.
( Functor m
, MonadIO m
, QueryEvent event
, HasAcidState m (EventState event)
) =>
event
-> m (EventResult event)
query event =
do as <- getAcidState
query' (as :: AcidState (EventState event)) event
update :: forall event m.
( Functor m
, MonadIO m
, UpdateEvent event
, HasAcidState m (EventState event)
) =>
event
-> m (EventResult event)
update event =
do as <- getAcidState
update' (as :: AcidState (EventState event)) event
-- for TVar
class HasTVarState m st where
getTVarState :: m (TVar st)
instance HasTVarState App CountState where
getTVarState = tvarCountState <$> ask
queryTVar :: ( HasTVarState m a
, MonadIO m
) => m a
queryTVar = do
as <- getTVarState
liftIO $ readTVarIO as
updateTVar :: ( HasTVarState m a
, MonadIO m ) =>
(a -> a) -- ^ function to modify value
-> m (a, a) -- ^ return value - "before change" and "after change"
updateTVar func = do
as <- getTVarState
liftIO $ atomically $ do -- STM
prevVal <- readTVar as
let newVal = func prevVal
writeTVar as newVal
return (prevVal, newVal)
-- | same as updateTVar, except no return
updateTVar_ :: ( HasTVarState m a
, MonadIO m ) =>
(a -> a) -- ^ function to modify value
-> m ()
updateTVar_ func = do
as <- getTVarState
liftIO $ atomically $ modifyTVar as func
withLocalState
:: ( IsAcidic st
, Typeable st
) =>
Maybe FilePath -- ^ path to state directory
-> st -- ^ initial state value
-> (AcidState st -> IO a) -- ^ function which uses the
-- `AcidState` handle
-> IO a
withLocalState mPath initialState =
bracket (liftIO $ open initialState)
(liftIO . createCheckpointAndClose)
where
open = maybe openLocalState openLocalStateFrom mPath
newtype App a = App { unApp :: ServerPartT (ReaderT Aci IO) a }
deriving ( Functor, Alternative, Applicative, Monad
, MonadPlus, MonadIO, HasRqData, ServerMonad
, WebMonad Response, FilterMonad Response
, Happstack, MonadReader Aci )
runApp :: Aci -> App a -> ServerPartT IO a
runApp aci (App sp) = do
mapServerPartT (flip runReaderT aci) sp
instance HasAcidState App CountState where
getAcidState = acidCountState <$> ask
acidCounter :: App Response
acidCounter = do
c <- update IncCount -- ^ a CountState event
ok $ toResponse $ ("hello number acid:" ++ (show c))
tvarCounter :: App Response
tvarCounter = do
c <- incCountState
ok $ toResponse $ ("hello number tvar:" ++ (show c))
rootDir :: App Response
rootDir = do
msum
[ dir "favicon.ico" $ notFound (toResponse ())
, dir "acidCounter" acidCounter
, dir "tvarCounter" tvarCounter
, ok $ toResponse ("access /acidCounter or /tvarCounter" :: String)
]
main :: IO ()
main = do
withAci Nothing $ \aci ->
simpleHTTP nullConf $ runApp aci rootDir
I'm getting "No instance for MonadState BTState BT" and I don't know what I'm doing wrong. I've tried adding constraints in various places, putting MonadState in the deriving() clause, etc.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
import System.Random
import Control.Monad.Error
import Control.Monad.State
-- I want to make a class of monads which contain random generator state.
class Monad m => RandMonad m where
putGen :: StdGen -> m ()
getGen :: m StdGen
-- the following creates a monadic type BT
data BTState = BTState
{ bGoalN :: Int
, bRandState :: StdGen }
newtype BT a = BT { insideBT :: ErrorT String (State BTState) a }
deriving(Monad)
runBT a s = runState (runErrorT $ insideBT a) s
instance RandMonad BT where
getGen = BT $ gets bRandState
putGen g = BT $ do { s <- get; put s {bRandState=g} }
-- trying to use BT
backtrackBT :: BT Int
backtrackBT = do
s <- get
put s {bGoalN=2}
return 3
You need to derive MonadState:
newtype BT a = ...
deriving (Monad, MonadState BTState, MonadError String)
And MonadError while we're at it.
If you had tried just putting deriving (Monad, MonadState, MonadError), you would have gotten a compiler error because you have to have an associated state or error type with your transformer stack, otherwise you'd be able to change the type of the error or the type of the state midway through the computation, which wouldn't typecheck elsewhere.
I am working on this problem and had previously asked related question. Implementation of State Monad To further refine my code i tried to implement it using only one increment function.
module StateExample where
import Control.Monad.State
data GlobState = GlobState { c1 :: Int, c2:: Int, c3:: Int} deriving (Show)
newGlobState:: GlobState
newGlobState = GlobState { c1=0,c2=0,c3=0 }
incr :: String-> State GlobState ()
incr x = do
modify(\g -> g {x =x g + 1})
main:: IO()
main = do
let a1= flip execState newGlobState $ do
incr c1
incr c2
incr c1
print a
But here i am getting an error
`x' is not a (visible) constructor field name
How can i remove this error?
You have hit a weakness in Haskell: records are not first class values!
Indeed, it would be very nice to write as you have done, but it is not possible.
However, you can use different libraries to achieve the desired effect.
This is how it looks if you use
fclabels:
{-# LANGUAGE TemplateHaskell, TypeOperators #-}
module StateExample where
import Control.Monad.State hiding (modify)
import Data.Label (mkLabels)
import Data.Label.Pure ((:->))
import Data.Label.PureM
data GlobState = GlobState { _c1 :: Int , _c2 :: Int , _c3 :: Int } deriving Show
$(mkLabels [''GlobState])
newGlobState:: GlobState
newGlobState = GlobState { _c1 = 0, _c2 = 0, _c3 = 0 }
incr :: (GlobState :-> Int) -> State GlobState ()
incr x = modify x (+1)
main :: IO ()
main = do
let a = flip execState newGlobState $ do
incr c1
incr c2
incr c1
print a
There are some magic parts here. We define the GlobState with the same
record names but prependend with an underscore. Then the function
mkLabels uses TemplateHaskell to define "lenses" for every field
in the record. These lenses will have the same name but without the underscore. The argument (GlobState :-> Int) to incr is such a
lens, and we can use the modify function from Data.Label.PureM
which updates records defined this way inside the state monad. We hide
modify from Control.Monad.State, to avoid collision.
You can look at the other
functions in the
documentation for
PureM
for other functions usable with state monads, as
gets and puts.
If you do not have fclabels installed, but you have the cabal executable from the cabal-install package (which you get if you install the Haskell Platform), you can install fclabels by simply running:
cabal install fclabels
If this is the first time you run cabal, you first need to update the database:
cabal update