{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# 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
import Control.Monad (unless)
import Control.Monad.State (State, execState, get, gets, modify)
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
(Int -> Column -> ShowS)
-> (Column -> String) -> ([Column] -> ShowS) -> Show Column
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Column -> ShowS
showsPrec :: Int -> Column -> ShowS
$cshow :: Column -> String
show :: Column -> String
$cshowList :: [Column] -> ShowS
showList :: [Column] -> ShowS
Show, Column -> Column -> Bool
(Column -> Column -> Bool)
-> (Column -> Column -> Bool) -> Eq Column
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Column -> Column -> Bool
== :: Column -> Column -> Bool
$c/= :: Column -> Column -> Bool
/= :: Column -> Column -> Bool
Eq, Int -> Column
Column -> Int
Column -> [Column]
Column -> Column
Column -> Column -> [Column]
Column -> Column -> Column -> [Column]
(Column -> Column)
-> (Column -> Column)
-> (Int -> Column)
-> (Column -> Int)
-> (Column -> [Column])
-> (Column -> Column -> [Column])
-> (Column -> Column -> [Column])
-> (Column -> Column -> Column -> [Column])
-> Enum 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
$csucc :: Column -> Column
succ :: Column -> Column
$cpred :: Column -> Column
pred :: Column -> Column
$ctoEnum :: Int -> Column
toEnum :: Int -> Column
$cfromEnum :: Column -> Int
fromEnum :: Column -> Int
$cenumFrom :: Column -> [Column]
enumFrom :: Column -> [Column]
$cenumFromThen :: Column -> Column -> [Column]
enumFromThen :: Column -> Column -> [Column]
$cenumFromTo :: Column -> Column -> [Column]
enumFromTo :: Column -> Column -> [Column]
$cenumFromThenTo :: Column -> Column -> Column -> [Column]
enumFromThenTo :: Column -> Column -> 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
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show)

data Format = Plain | Markdown
  deriving (Int -> Format -> ShowS
[Format] -> ShowS
Format -> String
(Int -> Format -> ShowS)
-> (Format -> String) -> ([Format] -> ShowS) -> Show Format
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Format -> ShowS
showsPrec :: Int -> Format -> ShowS
$cshow :: Format -> String
show :: Format -> String
$cshowList :: [Format] -> ShowS
showList :: [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
Applicative Weigh =>
(forall a b. Weigh a -> (a -> Weigh b) -> Weigh b)
-> (forall a b. Weigh a -> Weigh b -> Weigh b)
-> (forall a. a -> Weigh a)
-> Monad 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
$c>>= :: forall a b. Weigh a -> (a -> Weigh b) -> Weigh b
>>= :: forall a b. Weigh a -> (a -> Weigh b) -> Weigh b
$c>> :: forall a b. Weigh a -> Weigh b -> Weigh b
>> :: forall a b. Weigh a -> Weigh b -> Weigh b
$creturn :: forall a. a -> Weigh a
return :: forall a. a -> Weigh a
Monad,(forall a b. (a -> b) -> Weigh a -> Weigh b)
-> (forall a b. a -> Weigh b -> Weigh a) -> Functor Weigh
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
$cfmap :: forall a b. (a -> b) -> Weigh a -> Weigh b
fmap :: forall a b. (a -> b) -> Weigh a -> Weigh b
$c<$ :: forall a b. a -> Weigh b -> Weigh a
<$ :: forall a b. a -> Weigh b -> Weigh a
Functor,Functor Weigh
Functor Weigh =>
(forall a. a -> Weigh a)
-> (forall a b. Weigh (a -> b) -> Weigh a -> Weigh b)
-> (forall a b c. (a -> b -> c) -> Weigh a -> Weigh b -> Weigh c)
-> (forall a b. Weigh a -> Weigh b -> Weigh b)
-> (forall a b. Weigh a -> Weigh b -> Weigh a)
-> Applicative 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
$cpure :: forall a. a -> Weigh a
pure :: forall a. a -> Weigh a
$c<*> :: forall a b. Weigh (a -> b) -> Weigh a -> Weigh b
<*> :: forall a b. Weigh (a -> b) -> Weigh a -> Weigh b
$cliftA2 :: forall a b c. (a -> b -> c) -> Weigh a -> Weigh b -> Weigh c
liftA2 :: forall a b c. (a -> b -> c) -> Weigh a -> Weigh b -> Weigh c
$c*> :: forall a b. Weigh a -> Weigh b -> Weigh b
*> :: forall a b. Weigh a -> Weigh b -> Weigh b
$c<* :: forall a b. Weigh a -> Weigh b -> Weigh a
<* :: forall a b. Weigh a -> Weigh b -> 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]
(Int -> ReadS Weight)
-> ReadS [Weight]
-> ReadPrec Weight
-> ReadPrec [Weight]
-> Read Weight
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Weight
readsPrec :: Int -> ReadS Weight
$creadList :: ReadS [Weight]
readList :: ReadS [Weight]
$creadPrec :: ReadPrec Weight
readPrec :: ReadPrec Weight
$creadListPrec :: ReadPrec [Weight]
readListPrec :: ReadPrec [Weight]
Read,Int -> Weight -> ShowS
[Weight] -> ShowS
Weight -> String
(Int -> Weight -> ShowS)
-> (Weight -> String) -> ([Weight] -> ShowS) -> Show Weight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Weight -> ShowS
showsPrec :: Int -> Weight -> ShowS
$cshow :: Weight -> String
show :: Weight -> String
$cshowList :: [Weight] -> ShowS
showList :: [Weight] -> ShowS
Show)

-- | Some grouped thing.
data Grouped a
  = Grouped String [Grouped a]
  | Singleton a
  deriving (Grouped a -> Grouped a -> Bool
(Grouped a -> Grouped a -> Bool)
-> (Grouped a -> Grouped a -> Bool) -> Eq (Grouped a)
forall a. Eq a => Grouped a -> Grouped a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: Grouped a -> Grouped a -> Bool
Eq, Int -> Grouped a -> ShowS
[Grouped a] -> ShowS
Grouped a -> String
(Int -> Grouped a -> ShowS)
-> (Grouped a -> String)
-> ([Grouped a] -> ShowS)
-> Show (Grouped a)
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
$cshowsPrec :: forall a. Show a => Int -> Grouped a -> ShowS
showsPrec :: Int -> Grouped a -> ShowS
$cshow :: forall a. Show a => Grouped a -> String
show :: Grouped a -> String
$cshowList :: forall a. Show a => [Grouped a] -> ShowS
showList :: [Grouped a] -> ShowS
Show, (forall a b. (a -> b) -> Grouped a -> Grouped b)
-> (forall a b. a -> Grouped b -> Grouped a) -> Functor Grouped
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
$cfmap :: forall a b. (a -> b) -> Grouped a -> Grouped b
fmap :: forall a b. (a -> b) -> Grouped a -> Grouped b
$c<$ :: forall a b. a -> Grouped b -> Grouped a
<$ :: forall a b. a -> Grouped b -> Grouped a
Functor, Functor Grouped
Foldable Grouped
(Functor Grouped, Foldable Grouped) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Grouped a -> f (Grouped b))
-> (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 (m :: * -> *) a.
    Monad m =>
    Grouped (m a) -> m (Grouped a))
-> Traversable 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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Grouped a -> f (Grouped b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Grouped a -> f (Grouped b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Grouped (f a) -> f (Grouped a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Grouped (f a) -> f (Grouped a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Grouped a -> m (Grouped b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Grouped a -> m (Grouped b)
$csequence :: forall (m :: * -> *) a. Monad m => Grouped (m a) -> m (Grouped a)
sequence :: forall (m :: * -> *) a. Monad m => Grouped (m a) -> m (Grouped a)
Traversable.Traversable, (forall m. Monoid m => Grouped m -> m)
-> (forall m a. Monoid m => (a -> m) -> Grouped a -> m)
-> (forall m a. Monoid m => (a -> m) -> Grouped a -> m)
-> (forall a b. (a -> b -> b) -> b -> Grouped a -> b)
-> (forall a b. (a -> b -> b) -> b -> Grouped a -> b)
-> (forall b a. (b -> a -> b) -> b -> Grouped a -> b)
-> (forall b a. (b -> a -> b) -> b -> Grouped a -> b)
-> (forall a. (a -> a -> a) -> Grouped a -> a)
-> (forall a. (a -> a -> a) -> Grouped a -> a)
-> (forall a. Grouped a -> [a])
-> (forall a. Grouped a -> Bool)
-> (forall a. Grouped a -> Int)
-> (forall a. Eq a => a -> Grouped a -> Bool)
-> (forall a. Ord a => Grouped a -> a)
-> (forall a. Ord a => Grouped a -> a)
-> (forall a. Num a => Grouped a -> a)
-> (forall a. Num a => Grouped a -> a)
-> Foldable Grouped
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
$cfold :: forall m. Monoid m => Grouped m -> m
fold :: forall m. Monoid m => Grouped m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> Grouped a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> Grouped a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Grouped a -> a
foldr1 :: forall a. (a -> a -> a) -> Grouped a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Grouped a -> a
foldl1 :: forall a. (a -> a -> a) -> Grouped a -> a
$ctoList :: forall a. Grouped a -> [a]
toList :: forall a. Grouped a -> [a]
$cnull :: forall a. Grouped a -> Bool
null :: forall a. Grouped a -> Bool
$clength :: forall a. Grouped a -> Int
length :: forall a. Grouped a -> Int
$celem :: forall a. Eq a => a -> Grouped a -> Bool
elem :: forall a. Eq a => a -> Grouped a -> Bool
$cmaximum :: forall a. Ord a => Grouped a -> a
maximum :: forall a. Ord a => Grouped a -> a
$cminimum :: forall a. Ord a => Grouped a -> a
minimum :: forall a. Ord a => Grouped a -> a
$csum :: forall a. Num a => Grouped a -> a
sum :: forall a. Num a => Grouped a -> a
$cproduct :: forall a. Num a => Grouped a -> a
product :: forall a. Num a => Grouped a -> a
Foldable.Foldable, (forall x. Grouped a -> Rep (Grouped a) x)
-> (forall x. Rep (Grouped a) x -> Grouped a)
-> Generic (Grouped a)
forall x. Rep (Grouped a) x -> Grouped a
forall x. Grouped a -> Rep (Grouped a) x
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
$cfrom :: forall a x. Grouped a -> Rep (Grouped a) x
from :: forall x. Grouped a -> Rep (Grouped a) x
$cto :: forall a x. Rep (Grouped a) x -> Grouped a
to :: forall x. Rep (Grouped a) x -> Grouped a
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) <- Weigh a -> IO ([Grouped (Weight, Maybe String)], Config)
forall a. Weigh a -> IO ([Grouped (Weight, Maybe String)], Config)
weighResults Weigh a
m
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    ([Grouped (Weight, Maybe String)] -> Bool
forall a. [a] -> Bool
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 ((Weight, Maybe String) -> Maybe (Weight, String))
-> [(Weight, Maybe String)] -> [(Weight, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
         (\(Weight
w, Maybe String
r) -> do
            String
msg <- Maybe String
r
            (Weight, String) -> Maybe (Weight, String)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Weight
w, String
msg))
         ((Grouped (Weight, Maybe String) -> [(Weight, Maybe String)])
-> [Grouped (Weight, Maybe String)] -> [(Weight, Maybe String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Grouped (Weight, Maybe String) -> [(Weight, Maybe String)]
forall a. Grouped a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList ([Grouped (Weight, Maybe String)]
-> [Grouped (Weight, Maybe String)]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList [Grouped (Weight, Maybe String)]
results)) of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(Weight, String)]
errors -> do
      String -> IO ()
putStrLn String
"\nCheck problems:"
      ((Weight, String) -> IO ()) -> [(Weight, String)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        (\(Weight
w, String
r) -> String -> IO ()
putStrLn (String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Weight -> String
weightLabel Weight
w String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n    " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
r))
        [(Weight, String)]
errors
      ExitCode -> IO ()
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) = State (Config, [Grouped Action]) a
-> (Config, [Grouped Action]) -> (Config, [Grouped Action])
forall s a. State s a -> s -> s
execState (Weigh a -> State (Config, [Grouped Action]) a
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 -> ([Grouped (Weight, Maybe String)], Config)
-> IO ([Grouped (Weight, Maybe String)], Config)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Config
config)
    Just [Grouped Weight]
weights ->
      ([Grouped (Weight, Maybe String)], Config)
-> IO ([Grouped (Weight, Maybe String)], Config)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( (Grouped Weight -> Grouped (Weight, Maybe String))
-> [Grouped Weight] -> [Grouped (Weight, Maybe String)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ((Weight -> (Weight, Maybe String))
-> Grouped Weight -> Grouped (Weight, Maybe String)
forall a b. (a -> b) -> Grouped a -> Grouped b
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, Maybe String
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 =
              if any (== "--markdown") args
                then Markdown
                else configFormat 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 = State (Config, [Grouped Action]) () -> Weigh ()
forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (((Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> State (Config, [Grouped Action]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Config -> Config)
-> (Config, [Grouped Action]) -> (Config, [Grouped Action])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\Config
c -> Config
c {configColumns = cs})))

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

-- | Set the config. Default is: 'defaultConfig'.
setConfig :: Config -> Weigh ()
setConfig :: Config -> Weigh ()
setConfig = State (Config, [Grouped Action]) () -> Weigh ()
forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (State (Config, [Grouped Action]) () -> Weigh ())
-> (Config -> State (Config, [Grouped Action]) ())
-> Config
-> Weigh ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> State (Config, [Grouped Action]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Config, [Grouped Action]) -> (Config, [Grouped Action]))
 -> State (Config, [Grouped Action]) ())
-> (Config
    -> (Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> Config
-> State (Config, [Grouped Action]) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Config)
-> (Config, [Grouped Action]) -> (Config, [Grouped Action])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Config -> Config)
 -> (Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> (Config -> Config -> Config)
-> Config
-> (Config, [Grouped Action])
-> (Config, [Grouped Action])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Config -> Config
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 = String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
forall a b.
NFData a =>
String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateFunc String
name b -> a
f b
x (Maybe String -> Weight -> Maybe String
forall a b. a -> b -> a
const Maybe String
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 (b -> b
forall a. NFData a => a -> a
force -> !b
x) = String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
forall a b.
NFData a =>
String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateFunc String
name b -> a
f b
x (Maybe String -> Weight -> Maybe String
forall a b. a -> b -> a
const Maybe String
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 = String -> (b -> IO a) -> b -> (Weight -> Maybe String) -> Weigh ()
forall a b.
NFData a =>
String -> (b -> IO a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateAction String
name b -> IO a
f b
x (Maybe String -> Weight -> Maybe String
forall a b. a -> b -> a
const Maybe String
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 = String -> (a -> a) -> a -> Weigh ()
forall a b. NFData a => String -> (b -> a) -> b -> Weigh ()
func String
name a -> a
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 = String -> (() -> IO a) -> () -> Weigh ()
forall a b. NFData a => String -> (b -> IO a) -> b -> Weigh ()
io String
name (IO a -> () -> IO a
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 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
n
       then String -> Maybe String
forall a. a -> Maybe a
Just (String
"Allocated bytes exceeds " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                  Word64 -> String
forall a. (Num a, Integral a, Show a) => a -> String
commas Word64
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightAllocatedBytes Weight
w))
       else Maybe String
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 ((String -> Action) -> Weigh ()) -> (String -> Action) -> Weigh ()
forall a b. (a -> b) -> a -> b
$ (String -> (Weight -> Maybe String) -> Action)
-> (Weight -> Maybe String) -> String -> Action
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either (b -> IO a) (b -> a)
-> b -> String -> (Weight -> Maybe String) -> Action
forall a b.
NFData a =>
Either (b -> IO a) (b -> a)
-> b -> String -> (Weight -> Maybe String) -> Action
Action ((b -> IO a) -> Either (b -> IO a) (b -> a)
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 ((String -> Action) -> Weigh ()) -> (String -> Action) -> Weigh ()
forall a b. (a -> b) -> a -> b
$ (String -> (Weight -> Maybe String) -> Action)
-> (Weight -> Maybe String) -> String -> Action
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Either (b -> IO a) (b -> a)
-> b -> String -> (Weight -> Maybe String) -> Action
forall a b.
NFData a =>
Either (b -> IO a) (b -> a)
-> b -> String -> (Weight -> Maybe String) -> Action
Action ((b -> a) -> Either (b -> IO a) (b -> a)
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 =
  State (Config, [Grouped Action]) () -> Weigh ()
forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (do String
prefix <- ((Config, [Grouped Action]) -> String)
-> StateT (Config, [Grouped Action]) Identity String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Config -> String
configPrefix (Config -> String)
-> ((Config, [Grouped Action]) -> Config)
-> (Config, [Grouped Action])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config, [Grouped Action]) -> Config
forall a b. (a, b) -> a
fst)
            ((Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> State (Config, [Grouped Action]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (([Grouped Action] -> [Grouped Action])
-> (Config, [Grouped Action]) -> (Config, [Grouped Action])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (\[Grouped Action]
x -> [Grouped Action]
x [Grouped Action] -> [Grouped Action] -> [Grouped Action]
forall a. [a] -> [a] -> [a]
++ [Action -> Grouped Action
forall a. a -> Grouped a
Singleton (Action -> Grouped Action) -> Action -> Grouped Action
forall a b. (a -> b) -> a -> b
$ String -> Action
act (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
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) <- State (Config, [Grouped Action]) (Config, [Grouped Action])
-> Weigh (Config, [Grouped Action])
forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh State (Config, [Grouped Action]) (Config, [Grouped Action])
forall s (m :: * -> *). MonadState s m => m s
get
  let startL :: Int
startL = [Grouped Action] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Grouped Action] -> Int) -> [Grouped Action] -> Int
forall a b. (a -> b) -> a -> b
$ [Grouped Action]
start
  State (Config, [Grouped Action]) () -> Weigh ()
forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (((Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> State (Config, [Grouped Action]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Config -> Config)
-> (Config, [Grouped Action]) -> (Config, [Grouped Action])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\Config
c -> Config
c {configPrefix = configPrefix orig ++ "/" ++ str})))
  Weigh ()
wei
  State (Config, [Grouped Action]) () -> Weigh ()
forall a. State (Config, [Grouped Action]) a -> Weigh a
Weigh (State (Config, [Grouped Action]) () -> Weigh ())
-> State (Config, [Grouped Action]) () -> Weigh ()
forall a b. (a -> b) -> a -> b
$ do
    ((Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> State (Config, [Grouped Action]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Config, [Grouped Action]) -> (Config, [Grouped Action]))
 -> State (Config, [Grouped Action]) ())
-> ((Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> State (Config, [Grouped Action]) ()
forall a b. (a -> b) -> a -> b
$ ([Grouped Action] -> [Grouped Action])
-> (Config, [Grouped Action]) -> (Config, [Grouped Action])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([Grouped Action] -> [Grouped Action])
 -> (Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> ([Grouped Action] -> [Grouped Action])
-> (Config, [Grouped Action])
-> (Config, [Grouped Action])
forall a b. (a -> b) -> a -> b
$ \[Grouped Action]
x -> Int -> [Grouped Action] -> [Grouped Action]
forall a. Int -> [a] -> [a]
take Int
startL [Grouped Action]
x [Grouped Action] -> [Grouped Action] -> [Grouped Action]
forall a. [a] -> [a] -> [a]
++ [String -> [Grouped Action] -> Grouped Action
forall a. String -> [Grouped a] -> Grouped a
Grouped String
str ([Grouped Action] -> Grouped Action)
-> [Grouped Action] -> Grouped Action
forall a b. (a -> b) -> a -> b
$ Int -> [Grouped Action] -> [Grouped Action]
forall a. Int -> [a] -> [a]
drop Int
startL [Grouped Action]
x]
    ((Config, [Grouped Action]) -> (Config, [Grouped Action]))
-> State (Config, [Grouped Action]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Config -> Config)
-> (Config, [Grouped Action]) -> (Config, [Grouped Action])
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\Config
c -> Config
c {configPrefix = configPrefix 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]
_) = String -> [String]
forall a. Read a => String -> a
read String
var
      let !String
_ = ShowS
forall a. NFData a => a -> a
force String
fp
      case String -> [Grouped Action] -> Maybe Action
glookup String
label ([Grouped Action] -> [Grouped Action]
forall a. NFData a => a -> a
force [Grouped Action]
cases) of
        Maybe Action
Nothing -> String -> IO (Maybe [Grouped Weight])
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 -> (b -> a) -> b -> IO (Word64, Word32, Word64, Word64, Word64)
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 -> (b -> IO a) -> b -> IO (Word64, Word32, Word64, Word64, Word64)
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
                (Weight -> String
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 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
start
                    }))
          Maybe [Grouped Weight] -> IO (Maybe [Grouped Weight])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Grouped Weight]
forall a. Maybe a
Nothing
    Maybe String
_ -> ([Grouped Weight] -> Maybe [Grouped Weight])
-> IO [Grouped Weight] -> IO (Maybe [Grouped Weight])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Grouped Weight] -> Maybe [Grouped Weight]
forall a. a -> Maybe a
Just ((Grouped Action -> IO (Grouped Weight))
-> [Grouped Action] -> IO [Grouped Weight]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
Traversable.traverse ((Action -> IO Weight) -> Grouped Action -> IO (Grouped Weight)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Grouped a -> f (Grouped 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 =
  (Action -> Bool) -> [Action] -> Maybe Action
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Foldable.find ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
label) (String -> Bool) -> (Action -> String) -> Action -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> String
actionName) ([Action] -> Maybe Action)
-> ([Grouped Action] -> [Action])
-> [Grouped Action]
-> Maybe Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  [[Action]] -> [Action]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Action]] -> [Action])
-> ([Grouped Action] -> [[Action]]) -> [Grouped Action] -> [Action]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Grouped Action -> [Action]) -> [Grouped Action] -> [[Action]]
forall a b. (a -> b) -> [a] -> [b]
map Grouped Action -> [Action]
forall a. Grouped a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList ([Grouped Action] -> [[Action]])
-> ([Grouped Action] -> [Grouped Action])
-> [Grouped Action]
-> [[Action]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Grouped Action] -> [Grouped Action]
forall a. [a] -> [a]
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 =
  String -> (String -> Handle -> IO Weight) -> IO Weight
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" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"+RTS", String
"-T", String
"-RTS"])
           String
""
       case ExitCode
exit of
         ExitFailure {} ->
           String -> IO Weight
forall a. HasCallStack => String -> a
error
             (String
"Error in case (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (Action -> String
actionName Action
act) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"):\n  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)
         ExitCode
ExitSuccess -> do
           String
out <- String -> IO String
readFile String
fp
           case ReadS Weight
forall a. Read a => ReadS a
reads String
out of
             [(!Weight
r, String
_)] -> Weight -> IO Weight
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Weight
r
             [(Weight, String)]
_ ->
               String -> IO Weight
forall a. HasCallStack => String -> a
error
                 ([String] -> String
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 = (a, (Word64, Word32, Word64, Word64, Word64))
-> (Word64, Word32, Word64, Word64, Word64)
forall a b. (a, b) -> b
snd ((a, (Word64, Word32, Word64, Word64, Word64))
 -> (Word64, Word32, Word64, Word64, Word64))
-> IO (a, (Word64, Word32, Word64, Word64, Word64))
-> IO (Word64, Word32, Word64, Word64, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> a) -> b -> IO (a, (Word64, Word32, Word64, Word64, Word64))
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 = a -> a
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 Word64 -> Word64 -> Word64
forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
         RTSStats -> Word64
GHCStats.totalBytesAllocated RTSStats
bootupStats) Word64 -> Word64 -> Word64
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.
        Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ghcStatsSizeInBytes
      actionGCs :: Word32
actionGCs =
        RTSStats -> Word32
GHCStats.gcCount RTSStats
actionStats Word32 -> Word32 -> Word32
forall p. (Ord p, Num p) => p -> p -> p
`subtracting` RTSStats -> Word32
GHCStats.gcCount RTSStats
bootupStats Word32 -> Word32 -> Word32
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 = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
0 Word64
actionBytes
      liveBytes :: Word64
liveBytes =
        (RTSStats -> Word64
GHCStats.liveBytes RTSStats
actionStats Word64 -> Word64 -> Word64
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 Word64 -> Word64 -> Word64
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 Word64 -> Word64 -> Word64
forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
            RTSStats -> Word64
GHCStats.maxOSBytes RTSStats
bootupStats)
  (a, (Word64, Word32, Word64, Word64, Word64))
-> IO (a, (Word64, Word32, Word64, Word64, Word64))
forall a. a -> IO a
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 p -> p -> Bool
forall a. Ord a => a -> a -> Bool
> p
y
    then p
x p -> p -> p
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 = (a, (Word64, Word32, Word64, Word64, Word64))
-> (Word64, Word32, Word64, Word64, Word64)
forall a b. (a, b) -> b
snd ((a, (Word64, Word32, Word64, Word64, Word64))
 -> (Word64, Word32, Word64, Word64, Word64))
-> IO (a, (Word64, Word32, Word64, Word64, Word64))
-> IO (Word64, Word32, Word64, Word64, Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (b -> IO a)
-> b -> IO (a, (Word64, Word32, Word64, Word64, Word64))
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 <- (a -> a) -> IO a -> IO a
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
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 Word64 -> Word64 -> Word64
forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
         RTSStats -> Word64
GHCStats.totalBytesAllocated RTSStats
bootupStats) Word64 -> Word64 -> Word64
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.
        Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
ghcStatsSizeInBytes
      actionGCs :: Word32
actionGCs =
        RTSStats -> Word32
GHCStats.gcCount RTSStats
actionStats Word32 -> Word32 -> Word32
forall p. (Ord p, Num p) => p -> p -> p
`subtracting` RTSStats -> Word32
GHCStats.gcCount RTSStats
bootupStats Word32 -> Word32 -> Word32
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 = Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
0 Word64
actionBytes
      liveBytes :: Word64
liveBytes =
        Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
0 (RTSStats -> Word64
GHCStats.liveBytes RTSStats
actionStats Word64 -> Word64 -> Word64
forall p. (Ord p, Num p) => p -> p -> p
`subtracting` RTSStats -> Word64
GHCStats.liveBytes RTSStats
bootupStats)
      maxBytes :: Word64
maxBytes =
        Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max
          Word64
0
          (RTSStats -> Word64
GHCStats.maxBytesInUse RTSStats
actionStats Word64 -> Word64 -> Word64
forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
           RTSStats -> Word64
GHCStats.maxBytesInUse RTSStats
bootupStats)
      maxOSBytes :: Word64
maxOSBytes =
        Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max
          Word64
0
          (RTSStats -> Word64
GHCStats.maxOSBytes RTSStats
actionStats Word64 -> Word64 -> Word64
forall p. (Ord p, Num p) => p -> p -> p
`subtracting`
           RTSStats -> Word64
GHCStats.maxOSBytes RTSStats
bootupStats)
  (a, (Word64, Word32, Word64, Word64, Word64))
-> IO (a, (Word64, Word32, Word64, Word64, Word64))
forall a. a -> IO a
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 =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate
    String
"\n\n"
    ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter
       (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
       [ if [(Weight, Maybe String)] -> Bool
forall a. [a] -> Bool
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
       , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n\n" (((String, [Grouped (Weight, Maybe String)]) -> String)
-> [(String, [Grouped (Weight, Maybe String)])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> [Grouped (Weight, Maybe String)] -> String)
-> (String, [Grouped (Weight, Maybe String)]) -> String
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 =
      (Grouped (Weight, Maybe String) -> Maybe (Weight, Maybe String))
-> [Grouped (Weight, Maybe String)] -> [(Weight, Maybe String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        (\case
           Singleton (Weight, Maybe String)
v -> (Weight, Maybe String) -> Maybe (Weight, Maybe String)
forall a. a -> Maybe a
Just (Weight, Maybe String)
v
           Grouped (Weight, Maybe String)
_ -> Maybe (Weight, Maybe String)
forall a. Maybe a
Nothing)
        [Grouped (Weight, Maybe String)]
gs
    groups :: [(String, [Grouped (Weight, Maybe String)])]
groups =
      (Grouped (Weight, Maybe String)
 -> Maybe (String, [Grouped (Weight, Maybe String)]))
-> [Grouped (Weight, Maybe String)]
-> [(String, [Grouped (Weight, Maybe String)])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        (\case
           Grouped String
title [Grouped (Weight, Maybe String)]
vs -> (String, [Grouped (Weight, Maybe String)])
-> Maybe (String, [Grouped (Weight, Maybe String)])
forall a. a -> Maybe a
Just (String
title, [Grouped (Weight, Maybe String)]
vs)
           Grouped (Weight, Maybe String)
_ -> Maybe (String, [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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
indent (Config -> [Grouped (Weight, Maybe String)] -> String
report Config
config [Grouped (Weight, Maybe String)]
gs)
    Format
Markdown -> String
"#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
title String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n\n" String -> ShowS
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 = [(Weight, Maybe String)] -> String
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) ([[(Bool, String)]] -> String)
-> ([(Weight, Maybe a)] -> [[(Bool, String)]])
-> [(Weight, Maybe a)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      ([(Column, (Bool, String))] -> [(Bool, String)]
forall {b}. [(Column, b)] -> [b]
select [(Column, (Bool, String))]
headings [(Bool, String)] -> [[(Bool, String)]] -> [[(Bool, String)]]
forall a. a -> [a] -> [a]
:) ([[(Bool, String)]] -> [[(Bool, String)]])
-> ([(Weight, Maybe a)] -> [[(Bool, String)]])
-> [(Weight, Maybe a)]
-> [[(Bool, String)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Weight, Maybe a) -> [(Bool, String)])
-> [(Weight, Maybe a)] -> [[(Bool, String)]]
forall a b. (a -> b) -> [a] -> [b]
map ([(Column, (Bool, String))] -> [(Bool, String)]
forall {b}. [(Column, b)] -> [b]
select ([(Column, (Bool, String))] -> [(Bool, String)])
-> ((Weight, Maybe a) -> [(Column, (Bool, String))])
-> (Weight, Maybe a)
-> [(Bool, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Weight, Maybe a) -> [(Column, (Bool, String))]
forall {a}. (Weight, Maybe a) -> [(Column, (Bool, String))]
toRow)
    select :: [(Column, b)] -> [b]
select [(Column, b)]
row = (Column -> Maybe b) -> [Column] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Column
name -> Column -> [(Column, b)] -> Maybe b
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 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Weight -> String
weightLabel Weight
w))
      , (Column
Allocated, (Bool
False, Word64 -> String
forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightAllocatedBytes Weight
w)))
      , (Column
GCs, (Bool
False, Word32 -> String
forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word32
weightGCs Weight
w)))
      , (Column
Live, (Bool
False, Word64 -> String
forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightLiveBytes Weight
w)))
      , (Column
Max, (Bool
False, Word64 -> String
forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightMaxBytes Weight
w)))
      , (Column
MaxOS, (Bool
False, Word64 -> String
forall a. (Num a, Integral a, Show a) => a -> String
commas (Weight -> Word64
weightMaxOSBytes Weight
w)))
      , (Column
WallTime, (Bool
False, String -> Double -> String
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 Char -> String -> [Int]
forall a. Eq a => a -> [a] -> [Int]
List.elemIndices Char
'/' String
w of
                       [] -> String
w
                       [Int]
x  -> Int -> ShowS
forall a. Int -> [a] -> [a]
drop (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+[Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
x) String
w

-- | Make a markdown table.
mdtable ::[[(Bool,String)]] -> String
mdtable :: [[(Bool, String)]] -> String
mdtable [[(Bool, String)]]
rows = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" [String
heading, String
align, String
body]
  where
    heading :: String
heading = [String] -> String
columns (((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bool
_, String
str) -> String
str) ([(Bool, String)] -> Maybe [(Bool, String)] -> [(Bool, String)]
forall a. a -> Maybe a -> a
fromMaybe [] ([[(Bool, String)]] -> Maybe [(Bool, String)]
forall a. [a] -> Maybe a
listToMaybe [[(Bool, String)]]
rows)))
    align :: String
align =
      [String] -> String
columns
        (((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
           (\(Bool
shouldAlignLeft, String
_) ->
              if Bool
shouldAlignLeft
                then String
":---"
                else String
"---:")
           ([(Bool, String)] -> Maybe [(Bool, String)] -> [(Bool, String)]
forall a. a -> Maybe a -> a
fromMaybe [] ([[(Bool, String)]] -> Maybe [(Bool, String)]
forall a. [a] -> Maybe a
listToMaybe [[(Bool, String)]]
rows)))
    body :: String
body =
      String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (([(Bool, String)] -> String) -> [[(Bool, String)]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\[(Bool, String)]
row -> [String] -> String
columns (((Bool, String) -> String) -> [(Bool, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, String) -> String
forall a b. (a, b) -> b
snd [(Bool, String)]
row)) (Int -> [[(Bool, String)]] -> [[(Bool, String)]]
forall a. Int -> [a] -> [a]
drop Int
1 [[(Bool, String)]]
rows))
    columns :: [String] -> String
columns [String]
xs = String
"|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"|" [String]
xs String -> ShowS
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 =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" (([(Bool, String)] -> String) -> [[(Bool, String)]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"  " ([String] -> String)
-> ([(Bool, String)] -> [String]) -> [(Bool, String)] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, (Bool, String)) -> String)
-> [(Int, (Bool, String))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (Bool, String)) -> String
forall {t} {t}.
(PrintfArg t, PrintfType t) =>
(Int, (Bool, t)) -> t
fill ([(Int, (Bool, String))] -> [String])
-> ([(Bool, String)] -> [(Int, (Bool, String))])
-> [(Bool, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [(Bool, String)] -> [(Int, (Bool, String))]
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')) =
      String -> t -> t
forall r. PrintfType r => String -> r
printf (String
"%" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
direction String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
width String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"s") t
text'
      where
        direction :: String
direction =
          if Bool
left'
            then String
"-"
            else String
""
        width :: Int
width = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (([(Bool, String)] -> Int) -> [[(Bool, String)]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ([(Bool, String)] -> String) -> [(Bool, String)] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, String) -> String
forall a b. (a, b) -> b
snd ((Bool, String) -> String)
-> ([(Bool, String)] -> (Bool, String))
-> [(Bool, String)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Bool, String)] -> Int -> (Bool, String)
forall a. HasCallStack => [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 = ShowS
forall a. [a] -> [a]
reverse ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"," ([String] -> String) -> (a -> [String]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [String]
forall e. Int -> [e] -> [[e]]
chunksOf Int
3 (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

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