{-# LANGUAGE AllowAmbiguousTypes #-}
module Control.Monad.Freer.Profiling
(profileEffect
,Named
,SingleEffectStats(..)
,EffectStats(..)
,forEachStat
,drawEffectStats
)
where
import Control.Monad
import Control.Monad.Freer
import Control.Monad.Freer.Writer
import Data.Map (Map)
import qualified Data.Map as M
import Data.Tree (Forest)
import qualified Data.Tree as T
import Data.Monoid
import Data.Time.Clock.POSIX
import Text.Printf
data SingleEffectStats = SingleEffectStats
{ effectStatCount :: Int
, effectStatTime :: Double
} deriving (Show)
instance Semigroup SingleEffectStats where
(SingleEffectStats a x) <> (SingleEffectStats b y) = SingleEffectStats (a + b) (x + y)
instance Monoid SingleEffectStats where
mempty = SingleEffectStats 0 0
newtype EffectStats = EffectStats (Map String (Map String SingleEffectStats)) deriving Show
instance Semigroup EffectStats where
(EffectStats l) <> (EffectStats r) = EffectStats $ M.unionWith (M.unionWith mappend) l r
instance Monoid EffectStats where
mempty = EffectStats M.empty
class Named f where
getDataTypeName :: f a -> String
getConstructorName :: f a -> String
forEachStat :: Monad m
=> EffectStats
-> (String -> String -> SingleEffectStats -> m ())
-> m ()
forEachStat (EffectStats stats) f = void $
flip M.traverseWithKey stats $ \effect actions ->
M.traverseWithKey (f effect) actions
toTree :: EffectStats -> Forest String
toTree (EffectStats m) = (\(a, b) -> T.Node a $ toSubtree b) <$> M.assocs m
where
toSubtree :: Map String SingleEffectStats -> Forest String
toSubtree s = (\(a, b) -> T.Node (printed a b) []) <$> M.assocs s
printed :: String -> SingleEffectStats -> String
printed action (SingleEffectStats n t) = printf "%s: Ran %d time, taking %0.3f seconds" action n t
drawEffectStats :: EffectStats -> String
drawEffectStats = T.drawForest . toTree
profileEffect :: forall q r v
. (Member (Writer EffectStats) r, Member IO r, Member q r, Named q)
=> Eff r v -> Eff r v
profileEffect eff = interpose handleEff eff
where
handleEff :: q a -> Eff r a
handleEff action = do
!start <- realToFrac <$> send getPOSIXTime
v <- send action
!end <- realToFrac <$> send getPOSIXTime
let !diff = end - start
effectName = getDataTypeName action
actionName = getConstructorName action
tell $ EffectStats (M.singleton effectName $ M.singleton actionName (SingleEffectStats 1 diff))
return v