{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      :  Mcmc.Algorithm.Metropolis
-- Description :  Metropolis-Hastings-Green algorithm
-- Copyright   :  (c) Dominik Schrempf 2020
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Tue May  5 20:11:30 2020.
--
-- The Metropolis-Hastings-Green ('MHG') algorithm.
--
-- For example, see Geyer, C. J., Introduction to Markov chain Monte Carlo, In
-- Handbook of Markov Chain Monte Carlo (pp. 45) (2011). CRC press.
module Mcmc.Algorithm.Metropolis
  ( MHG (..),
    mhg,
    mhgSave,
    mhgLoad,
    mhgAccept,
  )
where

import Codec.Compression.GZip
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Time
import Mcmc.Algorithm
import Mcmc.Chain.Chain
import Mcmc.Chain.Link
import Mcmc.Chain.Save
import Mcmc.Chain.Trace
import Mcmc.Monitor
import Mcmc.Proposal
import Mcmc.Settings
import Numeric.Log
import System.Random.MWC
import Text.Printf
import Prelude hiding (cycle)

-- | The MHG algorithm.
newtype MHG a = MHG {MHG a -> Chain a
fromMHG :: Chain a}

instance ToJSON a => Algorithm (MHG a) where
  aName :: MHG a -> String
aName = String -> MHG a -> String
forall a b. a -> b -> a
const String
"Metropolis-Hastings-Green (MHG)"
  aIteration :: MHG a -> Int
aIteration = Chain a -> Int
forall a. Chain a -> Int
iteration (Chain a -> Int) -> (MHG a -> Chain a) -> MHG a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MHG a -> Chain a
forall a. MHG a -> Chain a
fromMHG
  aIterate :: ParallelizationMode -> MHG a -> IO (MHG a)
aIterate = ParallelizationMode -> MHG a -> IO (MHG a)
forall a. ParallelizationMode -> MHG a -> IO (MHG a)
mhgIterate
  aAutoTune :: MHG a -> MHG a
aAutoTune = MHG a -> MHG a
forall a. MHG a -> MHG a
mhgAutoTune
  aResetAcceptance :: MHG a -> MHG a
aResetAcceptance = MHG a -> MHG a
forall a. MHG a -> MHG a
mhgResetAcceptance
  aSummarizeCycle :: MHG a -> ByteString
aSummarizeCycle = MHG a -> ByteString
forall a. MHG a -> ByteString
mhgSummarizeCycle
  aOpenMonitors :: AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
aOpenMonitors = AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
forall a. AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
mhgOpenMonitors
  aExecuteMonitors :: Verbosity -> UTCTime -> Int -> MHG a -> IO (Maybe ByteString)
aExecuteMonitors = Verbosity -> UTCTime -> Int -> MHG a -> IO (Maybe ByteString)
forall a.
Verbosity -> UTCTime -> Int -> MHG a -> IO (Maybe ByteString)
mhgExecuteMonitors
  aStdMonitorHeader :: MHG a -> ByteString
aStdMonitorHeader = MHG a -> ByteString
forall a. MHG a -> ByteString
mhgStdMonitorHeader
  aCloseMonitors :: MHG a -> IO (MHG a)
aCloseMonitors = MHG a -> IO (MHG a)
forall a. MHG a -> IO (MHG a)
mhgCloseMonitors
  aSave :: AnalysisName -> MHG a -> IO ()
aSave = AnalysisName -> MHG a -> IO ()
forall a. ToJSON a => AnalysisName -> MHG a -> IO ()
mhgSave

-- NOTE: IO is required because the trace is mutable.

-- | Initialize an MHG algorithm.
mhg ::
  PriorFunction a ->
  LikelihoodFunction a ->
  Cycle a ->
  Monitor a ->
  -- | The initial state in the state space @a@.
  a ->
  -- | A source of randomness. For reproducible runs, make sure to use
  -- generators with the same seed.
  GenIO ->
  IO (MHG a)
mhg :: PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> a
-> GenIO
-> IO (MHG a)
mhg PriorFunction a
pr PriorFunction a
lh Cycle a
cc Monitor a
mn a
i0 GenIO
g = do
  -- The trace is a mutable vector and the mutable state needs to be handled by
  -- a monad.
  Trace a
tr <- Int -> Link a -> IO (Trace a)
forall a. Int -> Link a -> IO (Trace a)
replicateT Int
traceLength Link a
l0
  MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Int
-> Link a
-> Int
-> Trace a
-> Acceptance (Proposal a)
-> GenIO
-> Int
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> Chain a
forall a.
Int
-> Link a
-> Int
-> Trace a
-> Acceptance (Proposal a)
-> GenIO
-> Int
-> PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> Chain a
Chain Int
0 Link a
l0 Int
0 Trace a
tr Acceptance (Proposal a)
ac GenIO
g Int
0 PriorFunction a
pr PriorFunction a
lh Cycle a
cc Monitor a
mn
  where
    l0 :: Link a
l0 = a -> Log Double -> Log Double -> Link a
forall a. a -> Log Double -> Log Double -> Link a
Link a
i0 (PriorFunction a
pr a
i0) (PriorFunction a
lh a
i0)
    ac :: Acceptance (Proposal a)
ac = [Proposal a] -> Acceptance (Proposal a)
forall k. Ord k => [k] -> Acceptance k
emptyA ([Proposal a] -> Acceptance (Proposal a))
-> [Proposal a] -> Acceptance (Proposal a)
forall a b. (a -> b) -> a -> b
$ Cycle a -> [Proposal a]
forall a. Cycle a -> [Proposal a]
ccProposals Cycle a
cc
    batchMonitorSizes :: [Int]
batchMonitorSizes = (MonitorBatch a -> Int) -> [MonitorBatch a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map MonitorBatch a -> Int
forall a. MonitorBatch a -> Int
getMonitorBatchSize ([MonitorBatch a] -> [Int]) -> [MonitorBatch a] -> [Int]
forall a b. (a -> b) -> a -> b
$ Monitor a -> [MonitorBatch a]
forall a. Monitor a -> [MonitorBatch a]
mBatches Monitor a
mn
    traceLength :: Int
traceLength = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
1 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
batchMonitorSizes

mhgFn :: AnalysisName -> FilePath
mhgFn :: AnalysisName -> String
mhgFn (AnalysisName String
nm) = String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".mhg"

-- | Save an MHG algorithm.
mhgSave ::
  ToJSON a =>
  AnalysisName ->
  MHG a ->
  IO ()
mhgSave :: AnalysisName -> MHG a -> IO ()
mhgSave AnalysisName
nm (MHG Chain a
c) = do
  SavedChain a
savedChain <- Chain a -> IO (SavedChain a)
forall a. Chain a -> IO (SavedChain a)
toSavedChain Chain a
c
  String -> ByteString -> IO ()
BL.writeFile (AnalysisName -> String
mhgFn AnalysisName
nm) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ SavedChain a -> ByteString
forall a. ToJSON a => a -> ByteString
encode SavedChain a
savedChain

-- | Load an MHG algorithm.
--
-- See 'Mcmc.Mcmc.mcmcContinue'.
mhgLoad ::
  FromJSON a =>
  PriorFunction a ->
  LikelihoodFunction a ->
  Cycle a ->
  Monitor a ->
  AnalysisName ->
  IO (MHG a)
mhgLoad :: PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> AnalysisName
-> IO (MHG a)
mhgLoad PriorFunction a
pr PriorFunction a
lh Cycle a
cc Monitor a
mn AnalysisName
nm = do
  Either String (SavedChain a)
savedChain <- ByteString -> Either String (SavedChain a)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String (SavedChain a))
-> (ByteString -> ByteString)
-> ByteString
-> Either String (SavedChain a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
decompress (ByteString -> Either String (SavedChain a))
-> IO ByteString -> IO (Either String (SavedChain a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BL.readFile (AnalysisName -> String
mhgFn AnalysisName
nm)
  Chain a
chain <- (String -> IO (Chain a))
-> (SavedChain a -> IO (Chain a))
-> Either String (SavedChain a)
-> IO (Chain a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (Chain a)
forall a. HasCallStack => String -> a
error (PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a)
forall a.
PriorFunction a
-> PriorFunction a
-> Cycle a
-> Monitor a
-> SavedChain a
-> IO (Chain a)
fromSavedChain PriorFunction a
pr PriorFunction a
lh Cycle a
cc Monitor a
mn) Either String (SavedChain a)
savedChain
  MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG Chain a
chain

-- The MHG ratio.
--
-- 'Infinity' if fX is zero. In this case, the proposal is always accepted.
--
-- 'NaN' if (fY or q) and fX are zero. In this case, the proposal is always
-- rejected.

-- There is a discrepancy between authors saying that one should (a) always
-- accept the new state when the current posterior is zero (Chapter 4 of the
-- Handbook of Markov Chain Monte Carlo), or (b) almost surely reject the
-- proposal when either fY or q are zero (Chapter 1). Since I trust the author
-- of Chapter 1 (Charles Geyer) I choose to follow option (b).
mhgRatio :: Log Double -> Log Double -> Log Double -> Log Double -> Log Double
-- q = qYX / qXY * jXY; see 'ProposalSimple'.
-- j = Jacobian.
mhgRatio :: Log Double -> Log Double -> Log Double -> Log Double -> Log Double
mhgRatio Log Double
fX Log Double
fY Log Double
q Log Double
j = Log Double
fY Log Double -> Log Double -> Log Double
forall a. Fractional a => a -> a -> a
/ Log Double
fX Log Double -> Log Double -> Log Double
forall a. Num a => a -> a -> a
* Log Double
q Log Double -> Log Double -> Log Double
forall a. Num a => a -> a -> a
* Log Double
j
{-# INLINE mhgRatio #-}

-- | Accept or reject a proposal with given MHG ratio?
mhgAccept :: Log Double -> GenIO -> IO Bool
mhgAccept :: Log Double -> GenIO -> IO Bool
mhgAccept Log Double
r GenIO
g
  | Log Double -> Double
forall a. Log a -> a
ln Log Double
r Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
0.0 = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  | Bool
otherwise = do
    Double
b <- GenIO -> IO Double
forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
uniform GenIO
g
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Double
b Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double -> Double
forall a. Floating a => a -> a
exp (Log Double -> Double
forall a. Log a -> a
ln Log Double
r)

mhgPropose :: MHG a -> Proposal a -> IO (MHG a)
mhgPropose :: MHG a -> Proposal a -> IO (MHG a)
mhgPropose (MHG Chain a
c) Proposal a
p = do
  -- 1. Sample new state.
  (!a
y, !Log Double
q, !Log Double
j) <- IO (a, Log Double, Log Double) -> IO (a, Log Double, Log Double)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, Log Double, Log Double) -> IO (a, Log Double, Log Double))
-> IO (a, Log Double, Log Double) -> IO (a, Log Double, Log Double)
forall a b. (a -> b) -> a -> b
$ a -> Gen RealWorld -> IO (a, Log Double, Log Double)
s a
x Gen RealWorld
g
  -- 2. Calculate Metropolis-Hastings-Green ratio.
  let !pY :: Log Double
pY = PriorFunction a
pF a
y
      !lY :: Log Double
lY = PriorFunction a
lF a
y
      !r :: Log Double
r = Log Double -> Log Double -> Log Double -> Log Double -> Log Double
mhgRatio (Log Double
pX Log Double -> Log Double -> Log Double
forall a. Num a => a -> a -> a
* Log Double
lX) (Log Double
pY Log Double -> Log Double -> Log Double
forall a. Num a => a -> a -> a
* Log Double
lY) Log Double
q Log Double
j
  -- 3. Accept or reject.
  -- if ln r >= 0.0
  --   then do
  --     let !ac' = pushA p True ac
  --     return $ MHG $ c {link = Link y pY lY, acceptance = ac'}
  --   else do
  --     b <- uniform g
  --     if b < exp (ln r)
  --       then do
  --         let !ac' = pushA p True ac
  --         return $ MHG $ c {link = Link y pY lY, acceptance = ac'}
  --       else do
  --         let !ac' = pushA p False ac
  --         return $ MHG $ c {acceptance = pushA p False ac'}
  Bool
accept <- Log Double -> GenIO -> IO Bool
mhgAccept Log Double
r Gen RealWorld
GenIO
g
  if Bool
accept
    then do
      let !ac' :: Acceptance (Proposal a)
ac' = Proposal a
-> Bool -> Acceptance (Proposal a) -> Acceptance (Proposal a)
forall k. Ord k => k -> Bool -> Acceptance k -> Acceptance k
pushA Proposal a
p Bool
True Acceptance (Proposal a)
ac
      MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {link :: Link a
link = a -> Log Double -> Log Double -> Link a
forall a. a -> Log Double -> Log Double -> Link a
Link a
y Log Double
pY Log Double
lY, acceptance :: Acceptance (Proposal a)
acceptance = Acceptance (Proposal a)
ac'}
    else do
      let !ac' :: Acceptance (Proposal a)
ac' = Proposal a
-> Bool -> Acceptance (Proposal a) -> Acceptance (Proposal a)
forall k. Ord k => k -> Bool -> Acceptance k -> Acceptance k
pushA Proposal a
p Bool
False Acceptance (Proposal a)
ac
      MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {acceptance :: Acceptance (Proposal a)
acceptance = Proposal a
-> Bool -> Acceptance (Proposal a) -> Acceptance (Proposal a)
forall k. Ord k => k -> Bool -> Acceptance k -> Acceptance k
pushA Proposal a
p Bool
False Acceptance (Proposal a)
ac'}
  where
    s :: ProposalSimple a
s = Proposal a -> ProposalSimple a
forall a. Proposal a -> ProposalSimple a
pSimple Proposal a
p
    (Link a
x Log Double
pX Log Double
lX) = Chain a -> Link a
forall a. Chain a -> Link a
link Chain a
c
    pF :: PriorFunction a
pF = Chain a -> PriorFunction a
forall a. Chain a -> PriorFunction a
priorFunction Chain a
c
    lF :: PriorFunction a
lF = Chain a -> PriorFunction a
forall a. Chain a -> PriorFunction a
likelihoodFunction Chain a
c
    ac :: Acceptance (Proposal a)
ac = Chain a -> Acceptance (Proposal a)
forall a. Chain a -> Acceptance (Proposal a)
acceptance Chain a
c
    g :: GenIO
g = Chain a -> GenIO
forall a. Chain a -> GenIO
generator Chain a
c

mhgPush :: MHG a -> IO (MHG a)
mhgPush :: MHG a -> IO (MHG a)
mhgPush (MHG Chain a
c) = do
  Trace a
t' <- Link a -> Trace a -> IO (Trace a)
forall a. Link a -> Trace a -> IO (Trace a)
pushT Link a
i Trace a
t
  MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG Chain a
c {trace :: Trace a
trace = Trace a
t', iteration :: Int
iteration = Int -> Int
forall a. Enum a => a -> a
succ Int
n}
  where
    i :: Link a
i = Chain a -> Link a
forall a. Chain a -> Link a
link Chain a
c
    t :: Trace a
t = Chain a -> Trace a
forall a. Chain a -> Trace a
trace Chain a
c
    n :: Int
n = Chain a -> Int
forall a. Chain a -> Int
iteration Chain a
c

-- Ignore the number of capabilities. I have tried a lot of stuff, but the MHG
-- algorithm is just inherently sequential. Parallelization can be achieved by
-- having parallel prior and/or likelihood functions, or by using algorithms
-- running parallel chains such as 'MC3'.
mhgIterate :: ParallelizationMode -> MHG a -> IO (MHG a)
mhgIterate :: ParallelizationMode -> MHG a -> IO (MHG a)
mhgIterate ParallelizationMode
_ MHG a
a = do
  [Proposal a]
ps <- Cycle a -> GenIO -> IO [Proposal a]
forall a. Cycle a -> GenIO -> IO [Proposal a]
orderProposals Cycle a
cc Gen RealWorld
GenIO
g
  MHG a
a' <- (MHG a -> Proposal a -> IO (MHG a))
-> MHG a -> [Proposal a] -> IO (MHG a)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM MHG a -> Proposal a -> IO (MHG a)
forall a. MHG a -> Proposal a -> IO (MHG a)
mhgPropose MHG a
a [Proposal a]
ps
  MHG a -> IO (MHG a)
forall a. MHG a -> IO (MHG a)
mhgPush MHG a
a'
  where
    c :: Chain a
c = MHG a -> Chain a
forall a. MHG a -> Chain a
fromMHG MHG a
a
    cc :: Cycle a
cc = Chain a -> Cycle a
forall a. Chain a -> Cycle a
cycle Chain a
c
    g :: GenIO
g = Chain a -> GenIO
forall a. Chain a -> GenIO
generator Chain a
c

mhgAutoTune :: MHG a -> MHG a
mhgAutoTune :: MHG a -> MHG a
mhgAutoTune (MHG Chain a
c) = Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {cycle :: Cycle a
cycle = Acceptance (Proposal a) -> Cycle a -> Cycle a
forall a. Acceptance (Proposal a) -> Cycle a -> Cycle a
autoTuneCycle Acceptance (Proposal a)
ac Cycle a
cc}
  where
    ac :: Acceptance (Proposal a)
ac = Chain a -> Acceptance (Proposal a)
forall a. Chain a -> Acceptance (Proposal a)
acceptance Chain a
c
    cc :: Cycle a
cc = Chain a -> Cycle a
forall a. Chain a -> Cycle a
cycle Chain a
c

mhgResetAcceptance :: MHG a -> MHG a
mhgResetAcceptance :: MHG a -> MHG a
mhgResetAcceptance (MHG Chain a
c) = Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {acceptance :: Acceptance (Proposal a)
acceptance = Acceptance (Proposal a) -> Acceptance (Proposal a)
forall k. Ord k => Acceptance k -> Acceptance k
resetA Acceptance (Proposal a)
ac}
  where
    ac :: Acceptance (Proposal a)
ac = Chain a -> Acceptance (Proposal a)
forall a. Chain a -> Acceptance (Proposal a)
acceptance Chain a
c

mhgSummarizeCycle :: MHG a -> BL.ByteString
mhgSummarizeCycle :: MHG a -> ByteString
mhgSummarizeCycle (MHG Chain a
c) = Acceptance (Proposal a) -> Cycle a -> ByteString
forall a. Acceptance (Proposal a) -> Cycle a -> ByteString
summarizeCycle Acceptance (Proposal a)
ac Cycle a
cc
  where
    cc :: Cycle a
cc = Chain a -> Cycle a
forall a. Chain a -> Cycle a
cycle Chain a
c
    ac :: Acceptance (Proposal a)
ac = Chain a -> Acceptance (Proposal a)
forall a. Chain a -> Acceptance (Proposal a)
acceptance Chain a
c

mhgOpenMonitors :: AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
mhgOpenMonitors :: AnalysisName -> ExecutionMode -> MHG a -> IO (MHG a)
mhgOpenMonitors AnalysisName
nm ExecutionMode
em (MHG Chain a
c) = do
  Monitor a
m' <- String -> String -> ExecutionMode -> Monitor a -> IO (Monitor a)
forall a.
String -> String -> ExecutionMode -> Monitor a -> IO (Monitor a)
mOpen String
pre String
suf ExecutionMode
em Monitor a
m
  MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG Chain a
c {monitor :: Monitor a
monitor = Monitor a
m'}
  where
    m :: Monitor a
m = Chain a -> Monitor a
forall a. Chain a -> Monitor a
monitor Chain a
c
    pre :: String
pre = AnalysisName -> String
fromAnalysisName AnalysisName
nm
    suf :: String
suf = String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%02d" (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Chain a -> Int
forall a. Chain a -> Int
chainId Chain a
c

mhgExecuteMonitors ::
  Verbosity ->
  -- Starting time.
  UTCTime ->
  -- Total number of iterations.
  Int ->
  MHG a ->
  IO (Maybe BL.ByteString)
mhgExecuteMonitors :: Verbosity -> UTCTime -> Int -> MHG a -> IO (Maybe ByteString)
mhgExecuteMonitors Verbosity
vb UTCTime
t0 Int
iTotal (MHG Chain a
c) = Verbosity
-> Int
-> Int
-> UTCTime
-> Trace a
-> Int
-> Monitor a
-> IO (Maybe ByteString)
forall a.
Verbosity
-> Int
-> Int
-> UTCTime
-> Trace a
-> Int
-> Monitor a
-> IO (Maybe ByteString)
mExec Verbosity
vb Int
i Int
i0 UTCTime
t0 Trace a
tr Int
iTotal Monitor a
m
  where
    i :: Int
i = Chain a -> Int
forall a. Chain a -> Int
iteration Chain a
c
    i0 :: Int
i0 = Chain a -> Int
forall a. Chain a -> Int
start Chain a
c
    tr :: Trace a
tr = Chain a -> Trace a
forall a. Chain a -> Trace a
trace Chain a
c
    m :: Monitor a
m = Chain a -> Monitor a
forall a. Chain a -> Monitor a
monitor Chain a
c

mhgStdMonitorHeader :: MHG a -> BL.ByteString
mhgStdMonitorHeader :: MHG a -> ByteString
mhgStdMonitorHeader (MHG Chain a
c) = MonitorStdOut a -> ByteString
forall a. MonitorStdOut a -> ByteString
msHeader (Monitor a -> MonitorStdOut a
forall a. Monitor a -> MonitorStdOut a
mStdOut (Monitor a -> MonitorStdOut a) -> Monitor a -> MonitorStdOut a
forall a b. (a -> b) -> a -> b
$ Chain a -> Monitor a
forall a. Chain a -> Monitor a
monitor Chain a
c)

mhgCloseMonitors :: MHG a -> IO (MHG a)
mhgCloseMonitors :: MHG a -> IO (MHG a)
mhgCloseMonitors (MHG Chain a
c) = do
  Monitor a
m' <- Monitor a -> IO (Monitor a)
forall a. Monitor a -> IO (Monitor a)
mClose Monitor a
m
  MHG a -> IO (MHG a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MHG a -> IO (MHG a)) -> MHG a -> IO (MHG a)
forall a b. (a -> b) -> a -> b
$ Chain a -> MHG a
forall a. Chain a -> MHG a
MHG (Chain a -> MHG a) -> Chain a -> MHG a
forall a b. (a -> b) -> a -> b
$ Chain a
c {monitor :: Monitor a
monitor = Monitor a
m'}
  where
    m :: Monitor a
m = Chain a -> Monitor a
forall a. Chain a -> Monitor a
monitor Chain a
c