Why must we use state monad instead of passing state directly?

Question

Can someone show a simple example where state monad can be better than passing state directly?

bar1 (Foo x) = Foo (x + 1)

vs

b         


        

Answer 1

In my experience, the point of many Monads doesn't really click until you get into larger examples, so here is an example use of State (well, StateT ... IO) to parse an incoming request to a web service.

The pattern is that this web service can be called with a bunch of options of different types, though all except for one of the options have decent defaults. If I get a incoming JSON request with an unknown key value, I should abort with an appropriate message. I use the state to keep track of what the current config is, and what the remainder of the JSON request is, along with a bunch of accessor methods.

(Based on code currently in production, with the names of everything changed and the details of what this service actually does obscured)

{-# LANGUAGE OverloadedStrings #-}

module XmpConfig where

import Data.IORef
import Control.Arrow (first)
import Control.Monad
import qualified Data.Text as T
import Data.Aeson hiding ((.=))
import qualified Data.HashMap.Strict as MS
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.State (execStateT, StateT, gets, modify)
import qualified Data.Foldable as DF
import Data.Maybe (fromJust, isJust)

data Taggy = UseTags Bool | NoTags
newtype Locale = Locale String

data MyServiceConfig = MyServiceConfig {
    _mscTagStatus :: Taggy
  , _mscFlipResult :: Bool
  , _mscWasteTime :: Bool
  , _mscLocale :: Locale
  , _mscFormatVersion :: Int
  , _mscJobs :: [String]
  }

baseWebConfig :: IO (IORef [String], IORef [String], MyServiceConfig)
baseWebConfig = do
  infoRef <- newIORef []
  warningRef <- newIORef []
  let cfg = MyServiceConfig {
        _mscTagStatus = NoTags
        , _mscFlipResult = False
        , _mscWasteTime = False
        , _mscLocale = Locale "en-US"
        , _mscFormatVersion = 1
        , _mscJobs = []
        }
  return (infoRef, warningRef, cfg)

parseLocale :: T.Text -> Maybe Locale
parseLocale = Just . Locale . T.unpack  -- The real thing does more

parseJSONReq :: MS.HashMap T.Text Value ->
                IO (IORef [String], IORef [String], MyServiceConfig)
parseJSONReq m = liftM snd
                 (baseWebConfig >>= (\c -> execStateT parse' (m, c)))
  where
    parse' :: StateT (MS.HashMap T.Text Value,
                      (IORef [String], IORef [String], MyServiceConfig))
              IO ()
    parse' = do
      let addWarning s = do let snd3 (_, b, _) = b
                            r <- gets (snd3 . snd)
                            liftIO $ modifyIORef r (++ [s])
          -- These two functions suck a key/value off the input map and
          -- pass the value on to the handler "h"
          onKey      k h = onKeyMaybe k $ DF.mapM_ h
          onKeyMaybe k h = do myb <- gets fst
                              modify $ first $ MS.delete k
                              h (MS.lookup k myb)
          -- Access the "lns" field of the configuration
          config setter = modify (\(a, (b, c, d)) -> (a, (b, c, setter d)))

      onKey "tags" $ \x -> case x of
        Bool True ->       config $ \c -> c {_mscTagStatus = UseTags False}
        String "true" ->   config $ \c -> c {_mscTagStatus = UseTags False}
        Bool False ->      config $ \c -> c {_mscTagStatus = NoTags}
        String "false" ->  config $ \c -> c {_mscTagStatus = NoTags}
        String "inline" -> config $ \c -> c {_mscTagStatus = UseTags True}
        q -> addWarning ("Bad value ignored for tags: " ++ show q)
      onKey "reverse" $ \x -> case x of
        Bool r -> config $ \c -> c {_mscFlipResult = r}
        q -> addWarning ("Bad value ignored for reverse: " ++ show q)
      onKey "spin" $ \x -> case x of
        Bool r -> config $ \c -> c {_mscWasteTime = r}
        q -> addWarning ("Bad value ignored for spin: " ++ show q)
      onKey "language" $ \x -> case x of
        String s | isJust (parseLocale s) ->
          config $ \c -> c {_mscLocale = fromJust $ parseLocale s}
        q -> addWarning ("Bad value ignored for language: " ++ show q)
      onKey "format" $ \x -> case x of
        Number 1 -> config $ \c -> c {_mscFormatVersion = 1}
        Number 2 -> config $ \c -> c {_mscFormatVersion = 2}
        q -> addWarning ("Bad value ignored for format: " ++ show q)
      onKeyMaybe "jobs" $ \p -> case p of
        Just (Array x) -> do q <- parseJobs x
                             config $ \c -> c {_mscJobs = q}
        Just (String "test") ->
          config $ \c -> c {_mscJobs = ["test1", "test2"]}
        Just other -> fail $ "Bad value for jobs: " ++ show other
        Nothing    -> fail "Missing value for jobs"
      m' <- gets fst
      unless (MS.null m') (fail $ "Unrecognized key(s): " ++ show (MS.keys m'))

    parseJobs :: (Monad m, DF.Foldable b) => b Value -> m [String]
    parseJobs = DF.foldrM (\a b -> liftM (:b) (parseJob a)) []
    parseJob :: (Monad m) => Value -> m String
    parseJob (String s) = return (T.unpack s)
    parseJob q = fail $ "Bad job value: " ++ show q