{-# 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
import Control.Monad.State
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.
  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
showList :: [Column] -> ShowS
$cshowList :: [Column] -> ShowS
show :: Column -> String
$cshow :: Column -> String
showsPrec :: Int -> Column -> ShowS
$cshowsPrec :: Int -> Column -> ShowS
Show, Column -> Column -> Bool
(Column -> Column -> Bool)
-> (Column -> Column -> Bool) -> Eq Column
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]
(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
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
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
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
(Int -> Format -> ShowS)
-> (Format -> String) -> ([Format] -> ShowS) -> Show Format
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 {Weigh a -> State (Config, [Grouped Action]) a
runWeigh :: State (Config, [Grouped Action]) a}
  deriving (Applicative Weigh
a -> Weigh a
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
Weigh a -> (a -> Weigh b) -> Weigh b
Weigh a -> Weigh b -> Weigh b
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 :: a -> Weigh a
$creturn :: forall a. a -> Weigh a
>> :: Weigh a -> Weigh b -> Weigh b
$c>> :: forall a b. Weigh a -> Weigh b -> Weigh b
>>= :: Weigh a -> (a -> Weigh b) -> Weigh b
$c>>= :: forall a b. Weigh a -> (a -> Weigh b) -> Weigh b
$cp1Monad :: Applicative Weigh
Monad,a -> Weigh b -> Weigh a
(a -> b) -> Weigh a -> Weigh b
(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
<$ :: a -> Weigh b -> Weigh a
$c<$ :: forall a b. a -> Weigh b -> Weigh a
fmap :: (a -> b) -> Weigh a -> Weigh b
$cfmap :: forall a b. (a -> b) -> Weigh a -> Weigh b
Functor,Functor Weigh
a -> Weigh a
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
Weigh a -> Weigh b -> Weigh b
Weigh a -> Weigh b -> Weigh a
Weigh (a -> b) -> Weigh a -> Weigh b
(a -> b -> c) -> Weigh a -> Weigh b -> Weigh c
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
<* :: Weigh a -> Weigh b -> Weigh a
$c<* :: forall a b. Weigh a -> Weigh b -> Weigh a
*> :: Weigh a -> Weigh b -> Weigh b
$c*> :: forall a b. Weigh a -> Weigh b -> Weigh b
liftA2 :: (a -> b -> c) -> Weigh a -> Weigh b -> Weigh c
$cliftA2 :: forall a b c. (a -> b -> c) -> Weigh a -> Weigh b -> Weigh c
<*> :: Weigh (a -> b) -> Weigh a -> Weigh b
$c<*> :: forall a b. Weigh (a -> b) -> Weigh a -> Weigh b
pure :: a -> Weigh a
$cpure :: forall a. a -> Weigh a
$cp1Applicative :: Functor Weigh
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
         }
  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
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
(Int -> Weight -> ShowS)
-> (Weight -> String) -> ([Weight] -> ShowS) -> Show Weight
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
(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
/= :: 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
[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
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, a -> Grouped b -> Grouped a
(a -> b) -> Grouped a -> Grouped b
(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
<$ :: a -> Grouped b -> Grouped a
$c<$ :: forall a b. a -> Grouped b -> Grouped a
fmap :: (a -> b) -> Grouped a -> Grouped b
$cfmap :: forall a b. (a -> b) -> Grouped a -> Grouped b
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
(a -> f b) -> Grouped a -> f (Grouped b)
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 :: Grouped (m a) -> m (Grouped a)
$csequence :: forall (m :: * -> *) a. Monad m => Grouped (m a) -> m (Grouped a)
mapM :: (a -> m b) -> Grouped a -> m (Grouped b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Grouped a -> m (Grouped b)
sequenceA :: Grouped (f a) -> f (Grouped a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Grouped (f a) -> f (Grouped a)
traverse :: (a -> f b) -> Grouped a -> f (Grouped b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Grouped a -> f (Grouped b)
$cp2Traversable :: Foldable Grouped
$cp1Traversable :: Functor Grouped
Traversable.Traversable, Grouped a -> Bool
(a -> m) -> Grouped a -> m
(a -> b -> b) -> b -> Grouped a -> b
(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
product :: Grouped a -> a
$cproduct :: forall a. Num a => Grouped a -> a
sum :: Grouped a -> a
$csum :: forall a. Num a => Grouped a -> a
minimum :: Grouped a -> a
$cminimum :: forall a. Ord a => Grouped a -> a
maximum :: Grouped a -> a
$cmaximum :: forall a. Ord a => Grouped a -> a
elem :: a -> Grouped a -> Bool
$celem :: forall a. Eq a => a -> Grouped a -> Bool
length :: Grouped a -> Int
$clength :: forall a. Grouped a -> Int
null :: Grouped a -> Bool
$cnull :: forall a. Grouped a -> Bool
toList :: Grouped a -> [a]
$ctoList :: forall a. Grouped a -> [a]
foldl1 :: (a -> a -> a) -> Grouped a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Grouped a -> a
foldr1 :: (a -> a -> a) -> Grouped a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Grouped a -> a
foldl' :: (b -> a -> b) -> b -> Grouped a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Grouped a -> b
foldl :: (b -> a -> b) -> b -> Grouped a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Grouped a -> b
foldr' :: (a -> b -> b) -> b -> Grouped a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Grouped a -> b
foldr :: (a -> b -> b) -> b -> Grouped a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Grouped a -> b
foldMap' :: (a -> m) -> Grouped a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Grouped a -> m
foldMap :: (a -> m) -> Grouped a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Grouped a -> m
fold :: Grouped m -> m
$cfold :: forall m. Monoid m => Grouped m -> m
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
$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 _ = ()

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

-- | Just run the measuring and print a report. Uses 'weighResults'.
mainWith :: Weigh a -> IO ()
mainWith :: Weigh a -> IO ()
mainWith m :: Weigh a
m = do
  (results :: [Grouped (Weight, Maybe String)]
results, config :: 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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Grouped (Weight, Maybe String)]
results)
    (do String -> IO ()
putStrLn ""
        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
         (\(w :: Weight
w, r :: Maybe String
r) -> do
            String
msg <- Maybe String
r
            (Weight, String) -> Maybe (Weight, String)
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 (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList ([Grouped (Weight, Maybe String)]
-> [Grouped (Weight, Maybe String)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList [Grouped (Weight, Maybe String)]
results)) of
    [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    errors :: [(Weight, String)]
errors -> do
      String -> IO ()
putStrLn "\nCheck problems:"
      ((Weight, String) -> IO ()) -> [(Weight, String)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
        (\(w :: Weight
w, r :: String
r) -> String -> IO ()
putStrLn ("  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Weight -> String
weightLabel Weight
w String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n    " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
r))
        [(Weight, String)]
errors
      ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure (-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 :: Weigh a -> IO ([Grouped (Weight, Maybe String)], Config)
weighResults m :: Weigh a
m = do
  [String]
args <- IO [String]
getArgs
  Maybe String
weighEnv <- String -> IO (Maybe String)
lookupEnv "WEIGH_CASE"
  let (config :: Config
config, cases :: [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
    Nothing -> ([Grouped (Weight, Maybe String)], Config)
-> IO ([Grouped (Weight, Maybe String)], Config)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Config
config)
    Just weights :: [Grouped Weight]
weights ->
      ([Grouped (Weight, Maybe String)], Config)
-> IO ([Grouped (Weight, Maybe String)], Config)
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( (Grouped Weight -> Grouped (Weight, Maybe String))
-> [Grouped Weight] -> [Grouped (Weight, Maybe String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            ((Weight -> (Weight, Maybe String))
-> Grouped Weight -> Grouped (Weight, Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
               (\w :: Weight
w ->
                  case String -> [Grouped Action] -> Maybe Action
glookup (Weight -> String
weightLabel Weight
w) [Grouped Action]
cases of
                    Nothing -> (Weight
w, Maybe String
forall a. Maybe a
Nothing)
                    Just a :: Action
a -> (Weight
w, Action -> Weight -> Maybe String
actionCheck Action
a Weight
w)))
            [Grouped Weight]
weights
        , Config
config
          { configFormat :: Format
configFormat =
              if (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "--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 =
  $WConfig :: [Column] -> String -> Format -> Config
Config
  {configColumns :: [Column]
configColumns = [Column]
defaultColumns, configPrefix :: String
configPrefix = "", configFormat :: Format
configFormat = Format
Plain}

-- | Set the columns to display in the config
setColumns :: [Column] -> Weigh ()
setColumns :: [Column] -> Weigh ()
setColumns cs :: [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 (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\c :: Config
c -> Config
c {configColumns :: [Column]
configColumns = [Column]
cs})))

-- | Set the output format in the config
setFormat :: Format -> Weigh ()
setFormat :: Format -> Weigh ()
setFormat fm :: 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 (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\c :: Config
c -> Config
c {configFormat :: Format
configFormat = Format
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 (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 :: String -> (b -> a) -> b -> Weigh ()
func name :: 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' :: String -> (b -> a) -> b -> Weigh ()
func' name :: 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) -- ^ Aciton that does some IO to measure.
   -> b           -- ^ Argument to that function.
   -> Weigh ()
io :: String -> (b -> IO a) -> b -> Weigh ()
io name :: 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 :: String -> a -> Weigh ()
value name :: 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 :: String -> IO a -> Weigh ()
action name :: 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 n :: Word64
n =
  \w :: 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 ("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 -> 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 :: String -> (b -> IO a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateAction name :: 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 :: String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh ()
validateFunc name :: 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 name :: String
name act :: 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 (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (\x :: [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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name)])))

-- | Make a grouping of tests.
wgroup :: String -> Weigh () -> Weigh ()
wgroup :: String -> Weigh () -> Weigh ()
wgroup str :: String
str wei :: Weigh ()
wei = do
  (orig :: Config
orig, start :: [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 (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 (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\c :: Config
c -> Config
c {configPrefix :: String
configPrefix = Config -> String
configPrefix Config
orig String -> ShowS
forall a. [a] -> [a] -> [a]
++ "/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
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 (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
$ \x :: [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 (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\c :: 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 args :: Maybe String
args cases :: [Grouped Action]
cases =
  case Maybe String
args of
    Just var :: String
var -> do
      let (label :: String
label:fp :: String
fp:_) = 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
        Nothing -> String -> IO (Maybe [Grouped Weight])
forall a. HasCallStack => String -> a
error "No such case!"
        Just act :: Action
act -> do
          case Action
act of
            Action !Either (b -> IO a) (b -> a)
run arg :: b
arg _ _ -> do
              (bytes :: Word64
bytes, gcs :: Word32
gcs, liveBytes :: Word64
liveBytes, maxByte :: Word64
maxByte, maxOSBytes :: Word64
maxOSBytes) <-
                case Either (b -> IO a) (b -> a)
run of
                  Right f :: 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 m :: 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
              String -> String -> IO ()
writeFile
                String
fp
                (Weight -> String
forall a. Show a => a -> String
show
                   ($WWeight :: String -> Word64 -> Word32 -> Word64 -> Word64 -> Word64 -> Weight
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
                    }))
          Maybe [Grouped Weight] -> IO (Maybe [Grouped Weight])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Grouped Weight]
forall a. Maybe a
Nothing
    _ -> ([Grouped Weight] -> Maybe [Grouped Weight])
-> IO [Grouped Weight] -> IO (Maybe [Grouped Weight])
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)
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)
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 label :: 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 (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 (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 act :: Action
act =
  String -> (String -> Handle -> IO Weight) -> IO Weight
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> Handle -> m a) -> m a
withSystemTempFile
    "weigh"
    (\fp :: String
fp h :: Handle
h -> do
       Handle -> IO ()
hClose Handle
h
       String -> String -> IO ()
setEnv "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
       (exit :: ExitCode
exit, _, err :: String
err) <-
         String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode
           String
me
           ([String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["+RTS", "-T", "-RTS"])
           ""
       case ExitCode
exit of
         ExitFailure {} ->
           String -> IO Weight
forall a. HasCallStack => String -> a
error
             ("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]
++ "):\n  " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err)
         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, _)] -> Weight -> IO Weight
forall (m :: * -> *) a. Monad m => a -> m a
return Weight
r
             _ ->
               String -> IO Weight
forall a. HasCallStack => String -> a
error
                 ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    [ "Malformed output from subprocess. Weigh"
                    , " (currently) communicates with its sub-"
                    , "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 :: (b -> a) -> b -> IO (Word64, Word32, Word64, Word64, Word64)
weighFunc run :: 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 :: (b -> a) -> b -> IO (a, (Word64, Word32, Word64, Word64, Word64))
weighFuncResult run :: 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 = 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 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 (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 :: p -> p -> p
subtracting x :: p
x y :: 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 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 :: (b -> IO a) -> b -> IO (Word64, Word32, Word64, Word64, Word64)
weighAction run :: 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 :: (b -> IO a)
-> b -> IO (a, (Word64, Word32, Word64, Word64, Word64))
weighActionResult run :: 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 (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 = 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 0 Word64
actionBytes
      liveBytes :: Word64
liveBytes =
        Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max 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
          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
          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 (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
config gs :: [Grouped (Weight, Maybe String)]
gs =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate
    "\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 (t :: * -> *) a. Foldable t => t a -> Bool
null)
       [ if [(Weight, Maybe String)] -> 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 "\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 v :: (Weight, Maybe String)
v -> (Weight, Maybe String) -> Maybe (Weight, Maybe String)
forall a. a -> Maybe a
Just (Weight, Maybe String)
v
           _ -> 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 title :: String
title vs :: [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)
           _ -> 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
config title :: String
title gs :: [Grouped (Weight, Maybe String)]
gs =
  case Config -> Format
configFormat Config
config of
    Plain -> String
title String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\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)
    Markdown -> "#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
title String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\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
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
         Plain -> [[(Bool, String)]] -> String
tablize
         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 row :: [(Column, b)]
row = (Column -> Maybe b) -> [Column] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\name :: 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, "Case"))
      , (Column
Allocated, (Bool
False, "Allocated"))
      , (Column
GCs, (Bool
False, "GCs"))
      , (Column
Live, (Bool
False, "Live"))
      , (Column
Check, (Bool
True, "Check"))
      , (Column
Max, (Bool
False, "Max"))
      , (Column
MaxOS, (Bool
False, "MaxOS"))
      ]
    toRow :: (Weight, Maybe a) -> [(Column, (Bool, String))]
toRow (w :: Weight
w, err :: 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
Check
        , ( Bool
True
          , case Maybe a
err of
              Nothing -> "OK"
              Just {} -> "INVALID"))
      ]
    takeLastAfterBk :: ShowS
takeLastAfterBk w :: String
w = case Char -> String -> [Int]
forall a. Eq a => a -> [a] -> [Int]
List.elemIndices '/' String
w of
                       [] -> String
w
                       x :: [Int]
x  -> Int -> ShowS
forall a. Int -> [a] -> [a]
drop (1Int -> Int -> Int
forall a. Num a => a -> a -> a
+[Int] -> Int
forall a. [a] -> a
last [Int]
x) String
w

-- | Make a markdown table.
mdtable ::[[(Bool,String)]] -> String
mdtable :: [[(Bool, String)]] -> String
mdtable rows :: [[(Bool, String)]]
rows = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate "\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 (\(_, str :: 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
           (\(shouldAlignLeft :: Bool
shouldAlignLeft, _) ->
              if Bool
shouldAlignLeft
                then ":---"
                else "---:")
           ([(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 "\n" (([(Bool, String)] -> String) -> [[(Bool, String)]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\row :: [(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 1 [[(Bool, String)]]
rows))
    columns :: [String] -> String
columns xs :: [String]
xs = "|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate "|" [String]
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ "|"

-- | Make a table out of a list of rows.
tablize :: [[(Bool,String)]] -> String
tablize :: [[(Bool, String)]] -> String
tablize xs :: [[(Bool, String)]]
xs =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate "\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)
-> ([(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 [0 ..]) [[(Bool, String)]]
xs)
  where
    fill :: (Int, (Bool, t)) -> t
fill (x' :: Int
x', (left' :: Bool
left', text' :: t
text')) =
      String -> t -> t
forall r. PrintfType r => String -> r
printf ("%" 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]
++ "s") t
text'
      where
        direction :: String
direction =
          if Bool
left'
            then "-"
            else ""
        width :: Int
width = [Int] -> Int
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 (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. [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 :: 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) -> (a -> [String]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [String]
forall e. Int -> [e] -> [[e]]
chunksOf 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 "\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 2 ' '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