freer-simple-profiling (empty) → 0.1.0.0

raw patch · 7 files changed

+192/−0 lines, 7 filesdep +basedep +containersdep +freer-simplesetup-changed

Dependencies added: base, containers, freer-simple, freer-simple-profiling, hspec, time

Files

ChangeLog.md +3/−0
LICENSE +21/−0
README.md +1/−0
Setup.hs +2/−0
freer-simple-profiling.cabal +58/−0
src/Control/Monad/Freer/Profiling.hs +105/−0
test/Spec.hs +2/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for freer-simple-profiling++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 Co—Star Astrology, Ben Weitzman++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

+ README.md view

@@ -0,0 +1,1 @@+# freer-simple-profiling

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ freer-simple-profiling.cabal view

@@ -0,0 +1,58 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 8e02280851791e0ab62db7b1821da498d030b754d37d86fa6937f21a9ee5cd8f++name:           freer-simple-profiling+version:        0.1.0.0+synopsis:       Automatic profling of freer-simple programs+description:    Please see the README on GitHub at <https://gitlab.com/costar-astrology/freer-simple-contrib/tree/master/freer-simple-http>+category:       Control, Benchmarking, Profiling+author:         Ben Weitzman+maintainer:     ben@costarastrology.com+copyright:      2018 Ben Weitzman+license:        MIT+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://gitlab.com/costar-astrology/freer-simple-contrib/tree/master/freer-simple-http++library+  exposed-modules:+      Control.Monad.Freer.Profiling+  other-modules:+      Paths_freer_simple_profiling+  hs-source-dirs:+      src+  default-extensions: GADTs FlexibleContexts TypeOperators DataKinds StandaloneDeriving DeriveDataTypeable MultiParamTypeClasses FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables TypeFamilies RankNTypes DeriveAnyClass OverloadedStrings FunctionalDependencies ConstraintKinds EmptyCase BangPatterns+  build-depends:+      base >=4.7 && <5+    , containers >=0.5 && <0.6+    , freer-simple >=1.1 && <1.2+    , time >=1.8 && <1.9+  default-language: Haskell2010++test-suite freer-simple-profiling-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_freer_simple_profiling+  hs-source-dirs:+      test+  default-extensions: GADTs FlexibleContexts TypeOperators DataKinds StandaloneDeriving DeriveDataTypeable MultiParamTypeClasses FlexibleInstances UndecidableInstances TypeApplications ScopedTypeVariables TypeFamilies RankNTypes DeriveAnyClass OverloadedStrings FunctionalDependencies ConstraintKinds EmptyCase BangPatterns+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.7 && <5+    , containers >=0.5 && <0.6+    , freer-simple >=1.1 && <1.2+    , freer-simple-profiling+    , hspec+    , time >=1.8 && <1.9+  default-language: Haskell2010

+ src/Control/Monad/Freer/Profiling.hs view

@@ -0,0 +1,105 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++{-|+Module      : Control.Monad.Freer.Profiling+Description : Automatic profiling of freer-simple effects+Copyright   : (c) Ben Weitzman 2018+License     : MIT+Maintainer  : ben@costarastrolgoy.com+Stability   : experimental+Portability : POSIX+-}++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++-- | The stats relating to a single effect. Includes the number of times run and the+-- total amount of time spent running.+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++-- | The stats for a whole bunch of effects+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++-- | 'Named' is a typeclass that defines the type names and constructor names for effects.+-- Effects are defined as GADTs, and unfortunately, GADTs don't work well with 'GHC.Generics'+-- or 'Data.Data', so this is a small typeclass that can be implemented manually to provide+-- the info the profiler needs.+class Named f where+    getDataTypeName :: f a -> String+    getConstructorName :: f a -> String++-- | Iterate through each indivudal stat +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++-- | Pretty print the effect stats+drawEffectStats :: EffectStats -> String+drawEffectStats = T.drawForest . toTree    +++-- | Automatically time and count each individual effectful compoutation. An effect that+-- is interpreted to another effect will count towards both effects, flame graph style. +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

+ test/Spec.hs view

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"