{-# language OverloadedStrings #-}
{-# language DeriveFunctor, GeneralizedNewtypeDeriving #-}
{-# language FlexibleContexts #-}
module System.Random.MWC.Probability.Transition (
Transition
, mkTransition
, runTransition
, withSeverity
) where
import Control.Monad
import Control.Monad.Primitive
import qualified Control.Monad.State as S
import Control.Monad.Trans.Class (MonadTrans(..), lift)
import Control.Monad.Trans.State.Strict (StateT(..), evalStateT, execStateT, runStateT)
import Control.Monad.Log (MonadLog(..), Handler, WithSeverity(..), Severity(..), LoggingT(..), runLoggingT, withFDHandler, defaultBatchingOptions, logMessage)
import Data.Char
import System.Random.MWC.Probability
newtype Transition message s m a = Transition (
Gen (PrimState m) -> StateT s (LoggingT message m) a
) deriving (Functor)
instance Show (Transition msg s m a) where
show _ = "<Transition>"
mkTransition :: Monad m =>
(s -> Prob m t)
-> (s -> t -> (a, s))
-> (a -> s -> message)
-> Transition message s m a
mkTransition fm fs flog = Transition $ \gen -> do
s <- S.get
w <- lift . lift $ sample (fm s) gen
let (a, s') = fs s w
lift $ logMessage $ flog a s'
S.put s'
return a
runTransition :: Monad m =>
Handler m message
-> Transition message s m a
-> Int
-> s
-> Gen (PrimState m)
-> m ([a], s)
runTransition logf (Transition fm) n s0 g =
runLoggingT (runStateT (replicateM n (fm g)) s0) logf
bracketsUpp :: Show a => a -> String
bracketsUpp p = unwords ["[", map toUpper (show p), "]"]
withSeverity :: (t -> String) -> WithSeverity t -> String
withSeverity k (WithSeverity u a ) = unwords [bracketsUpp u, k a]