{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BangPatterns #-}

-- | Framework for seeing how much a function allocates.
--
-- WARNING: weigh is incompatible with profiling. It reports much more
-- allocations with profiling turned on.
--
-- Example:
--
-- @
-- import Weigh
-- main =
--   mainWith (do func "integers count 0" count 0
--                func "integers count 1" count 1
--                func "integers count 2" count 2
--                func "integers count 3" count 3
--                func "integers count 10" count 10
--                func "integers count 100" count 100)
--   where count :: Integer -> ()
--         count 0 = ()
--         count a = count (a - 1)
-- @
--
-- Use 'wgroup' to group sets of tests.

module Weigh
  (-- * Main entry points
   mainWith
  ,weighResults
  -- * Configuration
  ,setColumns
  ,Column(..)
  ,setFormat
  ,Format (..)
  ,setConfig
  ,Config (..)
  ,defaultConfig
  -- * Simple combinators
  ,func
  ,func'
  ,io
  ,value
  ,action
  ,wgroup
  -- * Validating combinators
  ,validateAction
  ,validateFunc
  -- * Validators
  ,maxAllocs
  -- * Types
  ,Weigh
  ,Weight(..)
  -- * Handy utilities
  ,commas
  ,reportGroup
  -- * Internals
  ,weighDispatch
  ,weighFunc
  ,weighFuncResult
  ,weighAction
  ,weighActionResult
  ,Grouped(..)
  )
  where

import Control.Applicative
import Control.Arrow
import Control.DeepSeq
#if MIN_VERSION_base(4,18,0)
import Control.Monad (unless)
#endif
import Control.Monad.State
import Criterion.Measurement
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import Data.List.Split
import Data.Maybe
import qualified Data.Traversable as Traversable
import Data.Word
import GHC.Generics
import Prelude
import System.Environment
import System.Exit
import System.IO
import System.IO.Temp
import System.Mem
import System.Process
import Text.Printf
import qualified Weigh.GHCStats as GHCStats

--------------------------------------------------------------------------------
-- Types

-- | Table column.
data Column
  = Case      -- ^ Case name for the column
  | Allocated -- ^ Total bytes allocated
  | GCs       -- ^ Total number of GCs
  | Live      -- ^ Total amount of live data in the heap
  | Check     -- ^ Table column indicating about the test status
  | Max       -- ^ Maximum residency memory in use
  | MaxOS     -- ^ Maximum memory in use by the RTS. Valid only for
              -- GHC >= 8.2.2. For unsupported GHC, this is reported
              -- as 0.
  | WallTime  -- ^ Rough execution time. For general indication, not a benchmark tool.
  deriving (Int -> Column -> ShowS
[Column] -> ShowS
Column -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Column] -> ShowS
$cshowList :: [Column] -> ShowS
show :: Column -> String
$cshow :: Column -> String
showsPrec :: Int -> Column -> ShowS
$cshowsPrec :: Int -> Column -> ShowS
Show, Column -> Column -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Column -> Column -> Bool
$c/= :: Column -> Column -> Bool
== :: Column -> Column -> Bool
$c== :: Column -> Column -> Bool
Eq, Int -> Column
Column -> Int
Column -> [Column]
Column -> Column
Column -> Column -> [Column]
Column -> Column -> Column -> [Column]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Column -> Column -> Column -> [Column]
$cenumFromThenTo :: Column -> Column -> Column -> [Column]
enumFromTo :: Column -> Column -> [Column]
$cenumFromTo :: Column -> Column -> [Column]
enumFromThen :: Column -> Column -> [Column]
$cenumFromThen :: Column -> Column -> [Column]
enumFrom :: Column -> [Column]
$cenumFrom :: Column -> [Column]
fromEnum :: Column -> Int
$cfromEnum :: Column -> Int
toEnum :: Int -> Column
$ctoEnum :: Int -> Column
pred :: Column -> Column
$cpred :: Column -> Column
succ :: Column -> Column
$csucc :: Column -> Column
Enum)

-- | Weigh configuration.
data Config = Config
  { Config -> [Column]
configColumns :: [Column]
  , Config -> String
configPrefix :: String
  , Config -> Format
configFormat :: !Format
  } deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

data Format = Plain | Markdown
  deriving (Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Format] -> ShowS
$cshowList :: [Format] -> ShowS
show :: Format -> String
$cshow :: Format -> String
showsPrec :: Int -> Format -> ShowS
$cshowsPrec :: Int -> Format -> ShowS
Show)

-- | Weigh specification monad.
newtype Weigh a =
  Weigh {forall a. Weigh a -> State (Config, [Grouped Action]) a
runWeigh :: State (Config, [Grouped Action]) a}
  deriving (Applicative Weigh
forall a. a -> Weigh a
forall a b. Weigh a -> Weigh b -> Weigh b
forall a b. Weigh a -> (a -> Weigh b) -> Weigh b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Weigh a
$creturn :: forall a. a -> Weigh a
>> :: forall a b. Weigh a -> Weigh b -> Weigh b
$c>> :: forall a b. Weigh a -> Weigh b -> Weigh b
>>= :: forall a b. Weigh a -> (a -> Weigh b) -> Weigh b
$c>>= :: forall a b. Weigh a -> (a -> Weigh b) -> Weigh b
Monad,forall a b. a -> Weigh b -> Weigh a
forall a b. (a -> b) -> Weigh a -> Weigh b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Weigh b -> Weigh a
$c<$ :: forall a b. a -> Weigh b -> Weigh a
fmap :: forall a b. (a -> b) -> Weigh a -> Weigh b
$cfmap :: forall a b. (a -> b) -> Weigh a -> Weigh b
Functor,Functor Weigh
forall a. a -> Weigh a
forall a b. Weigh a -> Weigh b -> Weigh a
forall a b. Weigh a -> Weigh b -> Weigh b
forall a b. Weigh (a -> b) -> Weigh a -> Weigh b
forall a b c. (a -> b -> c) -> Weigh a -> Weigh b -> Weigh c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Weigh a -> Weigh b -> Weigh a
$c<* :: forall a b. Weigh a -> Weigh b -> Weigh a
*> :: forall a b. Weigh a -> Weigh b -> Weigh b
$c*> :: forall a b. Weigh a -> Weigh b -> Weigh b
liftA2 :: forall a b c. (a -> b -> c) -> Weigh a -> Weigh b -> Weigh c
$cliftA2 :: forall a b c. (a -> b -> c) -> Weigh a -> Weigh b -> Weigh c
<*> :: forall a b. Weigh (a -> b) -> Weigh a -> Weigh b
$c<*> :: forall a b. Weigh (a -> b) -> Weigh a -> Weigh b
pure :: forall a. a -> Weigh a
$cpure :: forall a. a -> Weigh a
Applicative)

-- | How much a computation weighed in at.
data Weight =
  Weight {Weight -> String
weightLabel :: !String
         ,Weight -> Word64
weightAllocatedBytes :: !Word64
         ,Weight -> Word32
weightGCs :: !Word32
         ,Weight -> Word64
weightLiveBytes :: !Word64
         ,Weight -> Word64
weightMaxBytes :: !Word64
         ,Weight -> Word64
weightMaxOSBytes :: !Word64
         ,Weight -> Double
weightWallTime :: !Double
         }
  deriving (ReadPrec [Weight]
ReadPrec Weight
Int -> ReadS Weight
ReadS [Weight]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Weight]
$creadListPrec :: ReadPrec [Weight]
readPrec :: ReadPrec Weight
$creadPrec :: ReadPrec Weight
readList :: ReadS [Weight]
$creadList :: ReadS [Weight]
readsPrec :: Int -> ReadS Weight
$creadsPrec :: Int -> ReadS Weight
Read,Int -> Weight -> ShowS
[Weight] -> ShowS
Weight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Weight] -> ShowS
$cshowList :: [Weight] -> ShowS
show :: Weight -> String
$cshow :: Weight -> String
showsPrec :: Int -> Weight -> ShowS
$cshowsPrec :: Int -> Weight -> ShowS
Show)

-- | Some grouped thing.
data Grouped a
  = Grouped String [Grouped a]
  | Singleton a
  deriving (Grouped a -> Grouped a -> Bool
forall a. Eq a => Grouped a -> Grouped a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Grouped a -> Grouped a -> Bool
$c/= :: forall a. Eq a => Grouped a -> Grouped a -> Bool
== :: Grouped a -> Grouped a -> Bool
$c== :: forall a. Eq a => Grouped a -> Grouped a -> Bool
Eq, Int -> Grouped a -> ShowS
forall a. Show a => Int -> Grouped a -> ShowS
forall a. Show a => [Grouped a] -> ShowS
forall a. Show a => Grouped a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Grouped a] -> ShowS
$cshowList :: forall a. Show a => [Grouped a] -> ShowS
show :: Grouped a -> String
$cshow :: forall a. Show a => Grouped a -> String
showsPrec :: Int -> Grouped a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Grouped a -> ShowS
Show, forall a b. a -> Grouped b -> Grouped a
forall a b. (a -> b) -> Grouped a -> Grouped b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Grouped b -> Grouped a
$c<$ :: forall a b. a -> Grouped b -> Grouped a
fmap :: forall a b. (a -> b) -> Grouped a -> Grouped b
$cfmap :: forall a b. (a -> b) -> Grouped a -> Grouped b
Functor, Functor Grouped
Foldable Grouped
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Grouped (m a) -> m (Grouped a)
forall (f :: * -> *) a.
Applicative f =>
Grouped (f a) -> f (Grouped a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Grouped a -> m (Grouped b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Grouped a -> f (Grouped b)
sequence :: forall (m :: * -> *) a. Monad m => Grouped (m a) -> m (Grouped a)
$csequence :: forall (m :: * -> *) a. Monad m => Grouped (m a) -> m (Grouped a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Grouped a -> m (Grouped b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Grouped a -> m (Grouped b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Grouped (f a) -> f (Grouped a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Grouped (f a) -> f (Grouped a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Grouped a -> f (Grouped b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Grouped a -> f (Grouped b)
Traversable.Traversable, forall a. Eq a => a -> Grouped a -> Bool
forall a. Num a => Grouped a -> a
forall a. Ord a => Grouped a -> a
forall m. Monoid m => Grouped m -> m
forall a. Grouped a -> Bool
forall a. Grouped a -> Int
forall a. Grouped a -> [a]
forall a. (a -> a -> a) -> Grouped a -> a
forall m a. Monoid m => (a -> m) -> Grouped a -> m
forall b a. (b -> a -> b) -> b -> Grouped a -> b
forall a b. (a -> b -> b) -> b -> Grouped a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Grouped a -> a
$cproduct :: forall a. Num a => Grouped a -> a
sum :: forall a. Num a => Grouped a -> a
$csum :: forall a. Num a => Grouped a -> a
minimum :: forall a. Ord a => Grouped a -> a
$cminimum :: forall a. Ord a => Grouped a -> a
maximum :: forall a. Ord a => Grouped a -> a
$cmaximum :: forall a. Ord a => Grouped a -> a
elem :: forall a. Eq a => a -> Grouped a -> Bool
$celem :: forall a. Eq a => a -> Grouped a -> Bool
length :: forall a. Grouped a -> Int
$clength :: forall a. Grouped a -> Int
null :: forall a. Grouped a -> Bool
$cnull :: forall a. Grouped a -> Bool
toList :: forall a. Grouped a -> [a]
$ctoList :: forall a. Grouped a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Grouped a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Grouped a -> a
foldr1 :: forall a. (a -> a -> a) -> Grouped a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Grouped a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Grouped a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Grouped a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Grouped a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Grouped a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Grouped a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Grouped a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Grouped a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Grouped a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Grouped a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Grouped a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Grouped a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Grouped a -> m
fold :: forall m. Monoid m => Grouped m -> m
$cfold :: forall m. Monoid m => Grouped m -> m
Foldable.Foldable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Grouped a) x -> Grouped a
forall a x. Grouped a -> Rep (Grouped a) x
$cto :: forall a x. Rep (Grouped a) x -> Grouped a
$cfrom :: forall a x. Grouped a -> Rep (Grouped a) x
Generic)
instance NFData a => NFData (Grouped a)

-- | An action to run.
data Action =
  forall a b. (NFData a) =>
  Action {()
_actionRun :: !(Either (b -> IO a) (b -> a))
         ,()
_actionArg :: !b
         ,Action -> String
actionName :: !String
         ,Action -> Weight -> Maybe String
actionCheck :: Weight -> Maybe String}
instance NFData Action where rnf :: Action -> ()
rnf Action
_ = ()

--------------------------------------------------------------------------------
-- Main-runners

-- | Just run the measuring and print a report. Uses 'weighResults'.
mainWith :: Weigh a -> IO ()
mainWith :: forall a. Weigh a -> IO ()
mainWith Weigh a
m = do
  ([Grouped (Weight, Maybe String)]
results, Config
config) <- forall a. Weigh a -> IO ([Grouped (Weight, Maybe String)], Config)
weighResults Weigh a
m
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Grouped (Weight, Maybe String)]
results)
    (do String -> IO ()
putStrLn String
""
        String -> IO ()
putStrLn (Config -> [Grouped (Weight, Maybe String)] -> String
report Config
config [Grouped (Weight, Maybe String)]
results))
  case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
         (\(Weight
w, Maybe String
r) -> do
            String
msg <- Maybe String
r
            forall (m :: * -> *) a. Monad m => a -> m a
return (Weight
w, String
msg))
         (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList [Grouped (Weight, Maybe String)]
results)) of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(Weight, String)]
errors -> do
      String -> IO ()
putStrLn String
"\nCheck problems:"
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        (\(Weight
w, String
r) -> String -> IO ()
putStrLn (String
"  " forall a. [a] -> [a] -> [a]
++ Weight -> String
weightLabel Weight
w forall a. [a] -> [a] -> [a]
++ String
"\n    " forall a. [a] -> [a] -> [a]
++ String
r))
        [(Weight, String)]
errors
      forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure (-Int
1))

-- | Run the measuring and return all the results, each one may have
-- an error.
weighResults
  :: Weigh a -> IO ([Grouped (Weight,Maybe String)], Config)
weighResults :: forall a. Weigh a -> IO ([Grouped (Weight, Maybe String)], Config)
weighResults Weigh a
m = do
  [String]
args <- IO [String]
getArgs
  Maybe String
weighEnv <- String -> IO (Maybe String)
lookupEnv String
"WEIGH_CASE"
  let (Config
config, [Grouped Action]
cases) = forall s a. State s a -> s -> s
execState (forall a. Weigh a -> State (Config, [Grouped Action]) a
runWeigh Weigh a
m) (Config
defaultConfig, [])
  Maybe [Grouped Weight]
result <- Maybe String -> [Grouped Action] -> IO (Maybe [Grouped Weight])
weighDispatch Maybe String
weighEnv [Grouped Action]
cases
  case Maybe [Grouped Weight]
result of
    Maybe [Grouped Weight]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ([], Config
config)
    Just [Grouped Weight]
weights ->
      forall (m :: * -> *) a. Monad m => a -> m a
return
        ( forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
               (\Weight
w ->
                  case String -> [Grouped Action] -> Maybe Action
glookup (Weight -> String
weightLabel Weight
w) [Grouped Action]
cases of
                    Maybe Action
Nothing -> (Weight
w, forall a. Maybe a
Nothing)
                    Just Action
a -> (Weight
w, Action -> Weight -> Maybe String
actionCheck Action
a Weight
w)))
            [Grouped Weight]
weights
        , Config
config
          { configFormat :: Format
configFormat =
              if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== String
"--markdown") [String]
args
                then Format
Markdown
                else Config -> Format
configFormat Config
config
          })

--------------------------------------------------------------------------------
-- User DSL

-- | Default columns to display.
defaultColumns :: [Column]
defaultColumns :: [Column]
defaultColumns = [Column
Case, Column
Allocated, Column
GCs]

-- | Default config.
defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
  Config
  {configColumns :: [Column]
configColumns = [Column]
defaultColumns, configPrefix :: String
configPrefix = String
"", configFormat :: Format
configFormat = Format
Plain}

-- | Set the columns to display in the config
setColumns :: [Column] -> Weigh ()
setColumns :: [Column] -> Weigh ()
setColumns [Column]
cs = forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\Config
c -> Config
c {configColumns :: [Column]
configColumns = [Column]
cs})))

-- | Set the output format in the config
setFormat :: Format -> Weigh ()
setFormat :: Format -> Weigh ()
setFormat Format
fm = forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\Config
c -> Config
c {configFormat :: Format
configFormat = Format
fm})))

-- | Set the config. Default is: 'defaultConfig'.
setConfig :: Config -> Weigh ()
setConfig :: Config -> Weigh ()
setConfig = forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | Weigh a function applied to an argument.
--
-- Implemented in terms of 'validateFunc'.
func :: (NFData a)
     => String   -- ^ Name of the case.
     -> (b -> a) -- ^ Function that does some action to measure.
     -> b        -- ^ Argument to that function.
     -> Weigh ()
func :: forall a b. NFData a => String -> (b -> a) -> b -> Weigh ()
func String
name !b -> a
f !b
x = forall a b.
NFData a =>
String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateFunc String
name b -> a
f b
x (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)

-- | Weigh a function applied to an argument. Unlike 'func', the argument
-- is evaluated to normal form before the function is applied.
func' :: (NFData a, NFData b)
      => String
      -> (b -> a)
      -> b
      -> Weigh ()
func' :: forall a b.
(NFData a, NFData b) =>
String -> (b -> a) -> b -> Weigh ()
func' String
name !b -> a
f (forall a. NFData a => a -> a
force -> !b
x) = forall a b.
NFData a =>
String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateFunc String
name b -> a
f b
x (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)

-- | Weigh an action applied to an argument.
--
-- Implemented in terms of 'validateAction'.
io :: (NFData a)
   => String      -- ^ Name of the case.
   -> (b -> IO a) -- ^ Action that does some IO to measure.
   -> b           -- ^ Argument to that function.
   -> Weigh ()
io :: forall a b. NFData a => String -> (b -> IO a) -> b -> Weigh ()
io String
name !b -> IO a
f !b
x = forall a b.
NFData a =>
String -> (b -> IO a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateAction String
name b -> IO a
f b
x (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)

-- | Weigh a value.
--
-- Implemented in terms of 'action'.
value :: NFData a
      => String -- ^ Name for the value.
      -> a      -- ^ The value to measure.
      -> Weigh ()
value :: forall a. NFData a => String -> a -> Weigh ()
value String
name !a
v = forall a b. NFData a => String -> (b -> a) -> b -> Weigh ()
func String
name forall a. a -> a
id a
v

-- | Weigh an IO action.
--
-- Implemented in terms of 'validateAction'.
action :: NFData a
       => String -- ^ Name for the value.
       -> IO a   -- ^ The action to measure.
       -> Weigh ()
action :: forall a. NFData a => String -> IO a -> Weigh ()
action String
name !IO a
m = forall a b. NFData a => String -> (b -> IO a) -> b -> Weigh ()
io String
name (forall a b. a -> b -> a
const IO a
m) ()

-- | Make a validator that set sthe maximum allocations.
maxAllocs :: Word64 -- ^ The upper bound.
          -> (Weight -> Maybe String)
maxAllocs :: Word64 -> Weight -> Maybe String
maxAllocs Word64
n =
  \Weight
w ->
    if Weight -> Word64
weightAllocatedBytes Weight
w forall a. Ord a => a -> a -> Bool
> Word64
n
       then forall a. a -> Maybe a
Just (String
"Allocated bytes exceeds " forall a. [a] -> [a] -> [a]
++
                  forall a. (Num a, Integral a, Show a) => a -> String
commas Word64
n forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightAllocatedBytes Weight
w))
       else forall a. Maybe a
Nothing

-- | Weigh an IO action, validating the result.
validateAction :: (NFData a)
               => String -- ^ Name of the action.
               -> (b -> IO a) -- ^ The function which performs some IO.
               -> b -- ^ Argument to the function. Doesn't have to be forced.
               -> (Weight -> Maybe String) -- ^ A validating function, returns maybe an error.
               -> Weigh ()
validateAction :: forall a b.
NFData a =>
String -> (b -> IO a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateAction String
name !b -> IO a
m !b
arg !Weight -> Maybe String
validate =
  String -> (String -> Action) -> Weigh ()
tellAction String
name forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b.
NFData a =>
Either (b -> IO a) (b -> a)
-> b -> String -> (Weight -> Maybe String) -> Action
Action (forall a b. a -> Either a b
Left b -> IO a
m) b
arg) Weight -> Maybe String
validate

-- | Weigh a function, validating the result
validateFunc :: (NFData a)
             => String -- ^ Name of the function.
             -> (b -> a) -- ^ The function which calculates something.
             -> b -- ^ Argument to the function. Doesn't have to be forced.
             -> (Weight -> Maybe String) -- ^ A validating function, returns maybe an error.
             -> Weigh ()
validateFunc :: forall a b.
NFData a =>
String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateFunc String
name !b -> a
f !b
x !Weight -> Maybe String
validate =
  String -> (String -> Action) -> Weigh ()
tellAction String
name forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a b.
NFData a =>
Either (b -> IO a) (b -> a)
-> b -> String -> (Weight -> Maybe String) -> Action
Action (forall a b. b -> Either a b
Right b -> a
f) b
x)  Weight -> Maybe String
validate

-- | Write out an action.
tellAction :: String -> (String -> Action) -> Weigh ()
tellAction :: String -> (String -> Action) -> Weigh ()
tellAction String
name String -> Action
act =
  forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (do String
prefix <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Config -> String
configPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (\[Grouped Action]
x -> [Grouped Action]
x forall a. [a] -> [a] -> [a]
++ [forall a. a -> Grouped a
Singleton forall a b. (a -> b) -> a -> b
$ String -> Action
act (String
prefix forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
name)])))

-- | Make a grouping of tests.
wgroup :: String -> Weigh () -> Weigh ()
wgroup :: String -> Weigh () -> Weigh ()
wgroup String
str Weigh ()
wei = do
  (Config
orig, [Grouped Action]
start) <- forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh forall s (m :: * -> *). MonadState s m => m s
get
  let startL :: Int
startL = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ [Grouped Action]
start
  forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\Config
c -> Config
c {configPrefix :: String
configPrefix = Config -> String
configPrefix Config
orig forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
str})))
  Weigh ()
wei
  forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh forall a b. (a -> b) -> a -> b
$ do
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. (a -> b) -> a -> b
$ \[Grouped Action]
x -> forall a. Int -> [a] -> [a]
take Int
startL [Grouped Action]
x forall a. [a] -> [a] -> [a]
++ [forall a. String -> [Grouped a] -> Grouped a
Grouped String
str forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
startL [Grouped Action]
x]
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\Config
c -> Config
c {configPrefix :: String
configPrefix = Config -> String
configPrefix Config
orig}))

--------------------------------------------------------------------------------
-- Internal measuring actions

-- | Weigh a set of actions. The value of the actions are forced
-- completely to ensure they are fully allocated.
weighDispatch :: Maybe String -- ^ The content of then env variable WEIGH_CASE.
              -> [Grouped Action] -- ^ Weigh name:action mapping.
              -> IO (Maybe [(Grouped Weight)])
weighDispatch :: Maybe String -> [Grouped Action] -> IO (Maybe [Grouped Weight])
weighDispatch Maybe String
args [Grouped Action]
cases =
  case Maybe String
args of
    Just String
var -> do
      let (String
label:String
fp:[String]
_) = forall a. Read a => String -> a
read String
var
      let !String
_ = forall a. NFData a => a -> a
force String
fp
      case String -> [Grouped Action] -> Maybe Action
glookup String
label (forall a. NFData a => a -> a
force [Grouped Action]
cases) of
        Maybe Action
Nothing -> forall a. HasCallStack => String -> a
error String
"No such case!"
        Just Action
act -> do
          case Action
act of
            Action !Either (b -> IO a) (b -> a)
run b
arg String
_ Weight -> Maybe String
_ -> do
              IO ()
initializeTime
              Double
start <- IO Double
getTime
              (Word64
bytes, Word32
gcs, Word64
liveBytes, Word64
maxByte, Word64
maxOSBytes) <-
                case Either (b -> IO a) (b -> a)
run of
                  Right b -> a
f -> forall a b.
NFData a =>
(b -> a) -> b -> IO (Word64, Word32, Word64, Word64, Word64)
weighFunc b -> a
f b
arg
                  Left b -> IO a
m -> forall a b.
NFData a =>
(b -> IO a) -> b -> IO (Word64, Word32, Word64, Word64, Word64)
weighAction b -> IO a
m b
arg
              Double
end <- IO Double
getTime
              String -> String -> IO ()
writeFile
                String
fp
                (forall a. Show a => a -> String
show
                   (Weight
                    { weightLabel :: String
weightLabel = String
label
                    , weightAllocatedBytes :: Word64
weightAllocatedBytes = Word64
bytes
                    , weightGCs :: Word32
weightGCs = Word32
gcs
                    , weightLiveBytes :: Word64
weightLiveBytes = Word64
liveBytes
                    , weightMaxBytes :: Word64
weightMaxBytes = Word64
maxByte
                    , weightMaxOSBytes :: Word64
weightMaxOSBytes = Word64
maxOSBytes
                    , weightWallTime :: Double
weightWallTime = Double
end forall a. Num a => a -> a -> a
- Double
start
                    }))
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Maybe String
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Traversable.traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Traversable.traverse Action -> IO Weight
fork) [Grouped Action]
cases)

-- | Lookup an action.
glookup :: String -> [Grouped Action] -> Maybe Action
glookup :: String -> [Grouped Action] -> Maybe Action
glookup String
label =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Foldable.find ((forall a. Eq a => a -> a -> Bool
== String
label) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> String
actionName) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList

-- | Fork a case and run it.
fork :: Action -- ^ Label for the case.
     -> IO Weight
fork :: Action -> IO Weight
fork Action
act =
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile
    String
"weigh"
    (\String
fp Handle
h -> do
       Handle -> IO ()
hClose Handle
h
       String -> String -> IO ()
setEnv String
"WEIGH_CASE" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ [Action -> String
actionName Action
act,String
fp]
       String
me <- IO String
getExecutablePath
       [String]
args <- IO [String]
getArgs
       (ExitCode
exit, String
_, String
err) <-
         String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode
           String
me
           ([String]
args forall a. [a] -> [a] -> [a]
++ [String
"+RTS", String
"-T", String
"-RTS"])
           String
""
       case ExitCode
exit of
         ExitFailure {} ->
           forall a. HasCallStack => String -> a
error
             (String
"Error in case (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Action -> String
actionName Action
act) forall a. [a] -> [a] -> [a]
++ String
"):\n  " forall a. [a] -> [a] -> [a]
++ String
err)
         ExitCode
ExitSuccess -> do
           String
out <- String -> IO String
readFile String
fp
           case forall a. Read a => ReadS a
reads String
out of
             [(!Weight
r, String
_)] -> forall (m :: * -> *) a. Monad m => a -> m a
return Weight
r
             [(Weight, String)]
_ ->
               forall a. HasCallStack => String -> a
error
                 (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ String
"Malformed output from subprocess. Weigh"
                    , String
" (currently) communicates with its sub-"
                    , String
"processes via a temporary file."
                    ]))

-- | Weigh a pure function. This function is built on top of `weighFuncResult`,
--   which is heavily documented inside
weighFunc
  :: (NFData a)
  => (b -> a)         -- ^ A function whose memory use we want to measure.
  -> b                -- ^ Argument to the function. Doesn't have to be forced.
  -> IO (Word64,Word32,Word64,Word64,Word64) -- ^ Bytes allocated and garbage collections.
weighFunc :: forall a b.
NFData a =>
(b -> a) -> b -> IO (Word64, Word32, Word64, Word64, Word64)
weighFunc b -> a
run !b
arg = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
NFData a =>
(b -> a) -> b -> IO (a, (Word64, Word32, Word64, Word64, Word64))
weighFuncResult b -> a
run b
arg

-- | Weigh a pure function and return the result. This function is heavily
--   documented inside.
weighFuncResult
  :: (NFData a)
  => (b -> a)         -- ^ A function whose memory use we want to measure.
  -> b                -- ^ Argument to the function. Doesn't have to be forced.
  -> IO (a, (Word64,Word32,Word64,Word64,Word64)) -- ^ Result, Bytes allocated, GCs.
weighFuncResult :: forall a b.
NFData a =>
(b -> a) -> b -> IO (a, (Word64, Word32, Word64, Word64, Word64))
weighFuncResult b -> a
run !b
arg = do
  Word64
ghcStatsSizeInBytes <- IO Word64
GHCStats.getGhcStatsSizeInBytes
  IO ()
performGC
     -- The above forces getStats data to be generated NOW.
  !RTSStats
bootupStats <- IO RTSStats
GHCStats.getStats
     -- We need the above to subtract "program startup" overhead. This
     -- operation itself adds n bytes for the size of GCStats, but we
     -- subtract again that later.
  let !result :: a
result = forall a. NFData a => a -> a
force (b -> a
run b
arg)
  IO ()
performGC
     -- The above forces getStats data to be generated NOW.
  !RTSStats
actionStats <- IO RTSStats
GHCStats.getStats
  let reflectionGCs :: Word32
reflectionGCs = Word32
1 -- We performed an additional GC.
      actionBytes :: Word64
actionBytes =
        (RTSStats -> Word64
GHCStats.totalBytesAllocated RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
         RTSStats -> Word64
GHCStats.totalBytesAllocated RTSStats
bootupStats) forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
           -- We subtract the size of "bootupStats", which will be
           -- included after we did the performGC.
        forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ghcStatsSizeInBytes
      actionGCs :: Word32
actionGCs =
        RTSStats -> Word32
GHCStats.gcCount RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting` RTSStats -> Word32
GHCStats.gcCount RTSStats
bootupStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
        Word32
reflectionGCs
         -- If overheadBytes is too large, we conservatively just
         -- return zero. It's not perfect, but this library is for
         -- measuring large quantities anyway.
      actualBytes :: Word64
actualBytes = forall a. Ord a => a -> a -> a
max Word64
0 Word64
actionBytes
      liveBytes :: Word64
liveBytes =
        (RTSStats -> Word64
GHCStats.liveBytes RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
         RTSStats -> Word64
GHCStats.liveBytes RTSStats
bootupStats)
      maxBytes :: Word64
maxBytes =
        (RTSStats -> Word64
GHCStats.maxBytesInUse RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
         RTSStats -> Word64
GHCStats.maxBytesInUse RTSStats
bootupStats)
      maxOSBytes :: Word64
maxOSBytes =
        (RTSStats -> Word64
GHCStats.maxOSBytes RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
            RTSStats -> Word64
GHCStats.maxOSBytes RTSStats
bootupStats)
  forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, (Word64
actualBytes, Word32
actionGCs, Word64
liveBytes, Word64
maxBytes, Word64
maxOSBytes))

subtracting :: (Ord p, Num p) => p -> p -> p
subtracting :: forall p. (Ord p, Num p) => p -> p -> p
subtracting p
x p
y =
  if p
x forall a. Ord a => a -> a -> Bool
> p
y
    then p
x forall a. Num a => a -> a -> a
- p
y
    else p
0

-- | Weigh an IO action. This function is based on `weighActionResult`, which is
--   heavily documented inside.
weighAction
  :: (NFData a)
  => (b -> IO a)      -- ^ A function whose memory use we want to measure.
  -> b                -- ^ Argument to the function. Doesn't have to be forced.
  -> IO (Word64,Word32,Word64,Word64,Word64) -- ^ Bytes allocated and garbage collections.
weighAction :: forall a b.
NFData a =>
(b -> IO a) -> b -> IO (Word64, Word32, Word64, Word64, Word64)
weighAction b -> IO a
run !b
arg = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b.
NFData a =>
(b -> IO a)
-> b -> IO (a, (Word64, Word32, Word64, Word64, Word64))
weighActionResult b -> IO a
run b
arg

-- | Weigh an IO action, and return the result. This function is heavily
--   documented inside.
weighActionResult
  :: (NFData a)
  => (b -> IO a)      -- ^ A function whose memory use we want to measure.
  -> b                -- ^ Argument to the function. Doesn't have to be forced.
  -> IO (a, (Word64,Word32,Word64,Word64,Word64)) -- ^ Result, Bytes allocated and GCs.
weighActionResult :: forall a b.
NFData a =>
(b -> IO a)
-> b -> IO (a, (Word64, Word32, Word64, Word64, Word64))
weighActionResult b -> IO a
run !b
arg = do
  Word64
ghcStatsSizeInBytes <- IO Word64
GHCStats.getGhcStatsSizeInBytes
  IO ()
performGC
     -- The above forces getStats data to be generated NOW.
  !RTSStats
bootupStats <- IO RTSStats
GHCStats.getStats
     -- We need the above to subtract "program startup" overhead. This
     -- operation itself adds n bytes for the size of GCStats, but we
     -- subtract again that later.
  !a
result <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. NFData a => a -> a
force (b -> IO a
run b
arg)
  IO ()
performGC
     -- The above forces getStats data to be generated NOW.
  !RTSStats
actionStats <- IO RTSStats
GHCStats.getStats
  let reflectionGCs :: Word32
reflectionGCs = Word32
1 -- We performed an additional GC.
      actionBytes :: Word64
actionBytes =
        (RTSStats -> Word64
GHCStats.totalBytesAllocated RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
         RTSStats -> Word64
GHCStats.totalBytesAllocated RTSStats
bootupStats) forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
           -- We subtract the size of "bootupStats", which will be
           -- included after we did the performGC.
        forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ghcStatsSizeInBytes
      actionGCs :: Word32
actionGCs =
        RTSStats -> Word32
GHCStats.gcCount RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting` RTSStats -> Word32
GHCStats.gcCount RTSStats
bootupStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
        Word32
reflectionGCs
         -- If overheadBytes is too large, we conservatively just
         -- return zero. It's not perfect, but this library is for
         -- measuring large quantities anyway.
      actualBytes :: Word64
actualBytes = forall a. Ord a => a -> a -> a
max Word64
0 Word64
actionBytes
      liveBytes :: Word64
liveBytes =
        forall a. Ord a => a -> a -> a
max Word64
0 (RTSStats -> Word64
GHCStats.liveBytes RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting` RTSStats -> Word64
GHCStats.liveBytes RTSStats
bootupStats)
      maxBytes :: Word64
maxBytes =
        forall a. Ord a => a -> a -> a
max
          Word64
0
          (RTSStats -> Word64
GHCStats.maxBytesInUse RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
           RTSStats -> Word64
GHCStats.maxBytesInUse RTSStats
bootupStats)
      maxOSBytes :: Word64
maxOSBytes =
        forall a. Ord a => a -> a -> a
max
          Word64
0
          (RTSStats -> Word64
GHCStats.maxOSBytes RTSStats
actionStats forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
           RTSStats -> Word64
GHCStats.maxOSBytes RTSStats
bootupStats)
  forall (m :: * -> *) a. Monad m => a -> m a
return (a
result,
    (  Word64
actualBytes
    ,  Word32
actionGCs
    ,  Word64
liveBytes
    ,  Word64
maxBytes
    ,  Word64
maxOSBytes
    ))

--------------------------------------------------------------------------------
-- Formatting functions

report :: Config -> [Grouped (Weight,Maybe String)] -> String
report :: Config -> [Grouped (Weight, Maybe String)] -> String
report Config
config [Grouped (Weight, Maybe String)]
gs =
  forall a. [a] -> [[a]] -> [a]
List.intercalate
    String
"\n\n"
    (forall a. (a -> Bool) -> [a] -> [a]
filter
       (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
       [ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Weight, Maybe String)]
singletons
           then []
           else Config -> [(Weight, Maybe String)] -> String
reportTabular Config
config [(Weight, Maybe String)]
singletons
       , forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n\n" (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Config -> String -> [Grouped (Weight, Maybe String)] -> String
reportGroup Config
config)) [(String, [Grouped (Weight, Maybe String)])]
groups)
       ])
  where
    singletons :: [(Weight, Maybe String)]
singletons =
      forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        (\case
           Singleton (Weight, Maybe String)
v -> forall a. a -> Maybe a
Just (Weight, Maybe String)
v
           Grouped (Weight, Maybe String)
_ -> forall a. Maybe a
Nothing)
        [Grouped (Weight, Maybe String)]
gs
    groups :: [(String, [Grouped (Weight, Maybe String)])]
groups =
      forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        (\case
           Grouped String
title [Grouped (Weight, Maybe String)]
vs -> forall a. a -> Maybe a
Just (String
title, [Grouped (Weight, Maybe String)]
vs)
           Grouped (Weight, Maybe String)
_ -> forall a. Maybe a
Nothing)
        [Grouped (Weight, Maybe String)]
gs

reportGroup :: Config -> [Char] -> [Grouped (Weight, Maybe String)] -> [Char]
reportGroup :: Config -> String -> [Grouped (Weight, Maybe String)] -> String
reportGroup Config
config String
title [Grouped (Weight, Maybe String)]
gs =
  case Config -> Format
configFormat Config
config of
    Format
Plain -> String
title forall a. [a] -> [a] -> [a]
++ String
"\n\n" forall a. [a] -> [a] -> [a]
++ ShowS
indent (Config -> [Grouped (Weight, Maybe String)] -> String
report Config
config [Grouped (Weight, Maybe String)]
gs)
    Format
Markdown -> String
"#" forall a. [a] -> [a] -> [a]
++ String
title forall a. [a] -> [a] -> [a]
++ String
"\n\n" forall a. [a] -> [a] -> [a]
++ Config -> [Grouped (Weight, Maybe String)] -> String
report Config
config [Grouped (Weight, Maybe String)]
gs

-- | Make a report of the weights.
reportTabular :: Config -> [(Weight,Maybe String)] -> String
reportTabular :: Config -> [(Weight, Maybe String)] -> String
reportTabular Config
config = forall {a}. [(Weight, Maybe a)] -> String
tabled
  where
    tabled :: [(Weight, Maybe a)] -> String
tabled =
      (case Config -> Format
configFormat Config
config of
         Format
Plain -> [[(Bool, String)]] -> String
tablize
         Format
Markdown -> [[(Bool, String)]] -> String
mdtable) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (forall {b}. [(Column, b)] -> [b]
select [(Column, (Bool, String))]
headings forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall {b}. [(Column, b)] -> [b]
select forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Weight, Maybe a) -> [(Column, (Bool, String))]
toRow)
    select :: [(Column, b)] -> [b]
select [(Column, b)]
row = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Column
name -> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Column
name [(Column, b)]
row) (Config -> [Column]
configColumns Config
config)
    headings :: [(Column, (Bool, String))]
headings =
      [ (Column
Case, (Bool
True, String
"Case"))
      , (Column
Allocated, (Bool
False, String
"Allocated"))
      , (Column
GCs, (Bool
False, String
"GCs"))
      , (Column
Live, (Bool
False, String
"Live"))
      , (Column
Check, (Bool
True, String
"Check"))
      , (Column
Max, (Bool
False, String
"Max"))
      , (Column
MaxOS, (Bool
False, String
"MaxOS"))
      , (Column
WallTime, (Bool
False, String
"Wall Time"))
      ]
    toRow :: (Weight, Maybe a) -> [(Column, (Bool, String))]
toRow (Weight
w, Maybe a
err) =
      [ (Column
Case, (Bool
True, ShowS
takeLastAfterBk forall a b. (a -> b) -> a -> b
$ Weight -> String
weightLabel Weight
w))
      , (Column
Allocated, (Bool
False, forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightAllocatedBytes Weight
w)))
      , (Column
GCs, (Bool
False, forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word32
weightGCs Weight
w)))
      , (Column
Live, (Bool
False, forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightLiveBytes Weight
w)))
      , (Column
Max, (Bool
False, forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightMaxBytes Weight
w)))
      , (Column
MaxOS, (Bool
False, forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightMaxOSBytes Weight
w)))
      , (Column
WallTime, (Bool
False, forall r. PrintfType r => String -> r
printf String
"%.3fs" (Weight -> Double
weightWallTime Weight
w)))
      , ( Column
Check
        , ( Bool
True
          , case Maybe a
err of
              Maybe a
Nothing -> String
"OK"
              Just {} -> String
"INVALID"))
      ]
    takeLastAfterBk :: ShowS
takeLastAfterBk String
w = case forall a. Eq a => a -> [a] -> [Int]
List.elemIndices Char
'/' String
w of
                       [] -> String
w
                       [Int]
x  -> forall a. Int -> [a] -> [a]
drop (Int
1forall a. Num a => a -> a -> a
+forall a. [a] -> a
last [Int]
x) String
w

-- | Make a markdown table.
mdtable ::[[(Bool,String)]] -> String
mdtable :: [[(Bool, String)]] -> String
mdtable [[(Bool, String)]]
rows = forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" [String
heading, String
align, String
body]
  where
    heading :: String
heading = [String] -> String
columns (forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_, String
str) -> String
str) (forall a. a -> Maybe a -> a
fromMaybe [] (forall a. [a] -> Maybe a
listToMaybe [[(Bool, String)]]
rows)))
    align :: String
align =
      [String] -> String
columns
        (forall a b. (a -> b) -> [a] -> [b]
map
           (\(Bool
shouldAlignLeft, String
_) ->
              if Bool
shouldAlignLeft
                then String
":---"
                else String
"---:")
           (forall a. a -> Maybe a -> a
fromMaybe [] (forall a. [a] -> Maybe a
listToMaybe [[(Bool, String)]]
rows)))
    body :: String
body =
      forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map (\[(Bool, String)]
row -> [String] -> String
columns (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Bool, String)]
row)) (forall a. Int -> [a] -> [a]
drop Int
1 [[(Bool, String)]]
rows))
    columns :: [String] -> String
columns [String]
xs = String
"|" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
List.intercalate String
"|" [String]
xs forall a. [a] -> [a] -> [a]
++ String
"|"

-- | Make a table out of a list of rows.
tablize :: [[(Bool,String)]] -> String
tablize :: [[(Bool, String)]] -> String
tablize [[(Bool, String)]]
xs =
  forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [[a]] -> [a]
List.intercalate String
"  " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {t} {t}.
(PrintfArg t, PrintfType t) =>
(Int, (Bool, t)) -> t
fill forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..]) [[(Bool, String)]]
xs)
  where
    fill :: (Int, (Bool, t)) -> t
fill (Int
x', (Bool
left', t
text')) =
      forall r. PrintfType r => String -> r
printf (String
"%" forall a. [a] -> [a] -> [a]
++ String
direction forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
width forall a. [a] -> [a] -> [a]
++ String
"s") t
text'
      where
        direction :: String
direction =
          if Bool
left'
            then String
"-"
            else String
""
        width :: Int
width = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> Int -> a
!! Int
x')) [[(Bool, String)]]
xs)

-- | Formatting an integral number to 1,000,000, etc.
commas :: (Num a,Integral a,Show a) => a -> String
commas :: forall a. (Num a, Integral a, Show a) => a -> String
commas = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [[a]] -> [a]
List.intercalate String
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Int -> [e] -> [[e]]
chunksOf Int
3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Indent all lines in a string.
indent :: [Char] -> [Char]
indent :: ShowS
indent = forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> a -> [a]
replicate Int
2 Char
' 'forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines