weigh 0.0.3 → 0.0.4

raw patch · 2 files changed

+139/−67 lines, 2 filesdep +temporaryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: temporary

API changes (from Hackage documentation)

Files

• src/Weigh.hs +137/−66
• weigh.cabal +2/−1

@@ -26,6 +26,9 @@   (-- * Main entry points    mainWith   ,weighResults+  -- * Configuration+  ,setColumns+  ,Column(..)   -- * Simple combinators   ,func   ,io@@ -49,8 +52,9 @@   where  import Control.Applicative+import Control.Arrow import Control.DeepSeq-import Control.Monad.Writer+import Control.Monad.State import Data.List import Data.List.Split import Data.Maybe@@ -59,6 +63,8 @@ import Prelude import System.Environment import System.Exit+import System.IO+import System.IO.Temp import System.Mem import System.Process import Text.Printf@@ -67,16 +73,27 @@ -------------------------------------------------------------------------------- -- Types +-- | Table column.+data Column = Case | Allocated | GCs| Live | Check | Max+  deriving (Show, Eq, Enum)++-- | Weigh configuration.+data Config = Config {configColumns :: [Column]}+  deriving (Show)+ -- | Weigh specification monad. newtype Weigh a =-  Weigh {runWeigh :: Writer [(String,Action)] a}+  Weigh {runWeigh :: State (Config, [(String,Action)]) a}   deriving (Monad,Functor,Applicative)  -- | How much a computation weighed in at. data Weight =   Weight {weightLabel :: !String          ,weightAllocatedBytes :: !Int64-         ,weightGCs :: !Int64}+         ,weightGCs :: !Int64+         ,weightLiveBytes :: !Int64+         ,weightMaxBytes :: !Int64+         }   deriving (Read,Show)  -- | An action to run.@@ -92,10 +109,10 @@ -- | Just run the measuring and print a report. Uses 'weighResults'. mainWith :: Weigh a -> IO () mainWith m =-  do results <- weighResults m+  do (results, config) <- weighResults m      unless (null results)             (do putStrLn ""-                putStrLn (report results))+                putStrLn (report config results))      case mapMaybe (\(w,r) ->                       do msg <- r                          return (w,msg))@@ -109,23 +126,39 @@ -- | Run the measuring and return all the results, each one may have -- an error. weighResults-  :: Weigh a -> IO [(Weight,Maybe String)]-weighResults m =-  do args <- getArgs-     let cases = execWriter (runWeigh m)-     result <- weighDispatch args cases-     case result of-       Nothing -> return []-       Just weights ->-         return (map (\w ->-                        case lookup (weightLabel w) cases of-                          Nothing -> (w,Nothing)-                          Just a -> (w,actionCheck a w))-                     weights)+  :: Weigh a -> IO ([(Weight,Maybe String)], Config)+weighResults m = do+  args <- getArgs+  let (config, cases) =+        execState (runWeigh m) (defaultConfig, [])+  result <- weighDispatch args cases+  case result of+    Nothing -> return ([], config)+    Just weights ->+      return+        ( map+            (\w ->+               case lookup (weightLabel w) cases of+                 Nothing -> (w, Nothing)+                 Just a -> (w, actionCheck a w))+            weights+        , config)  -------------------------------------------------------------------------------- -- User DSL +-- | Default columns to display.+defaultColumns :: [Column]+defaultColumns = [Case, Allocated, GCs]++-- | Default config.+defaultConfig :: Config+defaultConfig = Config {configColumns = defaultColumns}++-- | Set the config. Default is: 'defaultConfig'.+setColumns :: [Column] -> Weigh ()+setColumns cs = Weigh (modify (first (\c -> c {configColumns = cs})))+ -- | Weigh a function applied to an argument. -- -- Implemented in terms of 'validateFunc'.@@ -182,7 +215,7 @@                -> (Weight -> Maybe String) -- ^ A validating function, returns maybe an error.                -> Weigh () validateAction name !m !arg !validate =-  Weigh (tell [(name,Action (Left m) arg validate)])+  tellAction [(name,Action (Left m) arg validate)]  -- | Weigh a function, validating the result validateFunc :: (NFData a)@@ -192,8 +225,12 @@              -> (Weight -> Maybe String) -- ^ A validating function, returns maybe an error.              -> Weigh () validateFunc name !f !x !validate =-  Weigh (tell [(name,Action (Right f) x validate)])+  tellAction [(name,Action (Right f) x validate)] +-- | Write out an action.+tellAction :: [(String, Action)] -> Weigh ()+tellAction x = Weigh (modify (second ( ++ x)))+ -------------------------------------------------------------------------------- -- Internal measuring actions @@ -204,19 +241,27 @@               -> IO (Maybe [Weight]) weighDispatch args cases =   case args of-    ("--case":label:_) ->-      case lookup label (deepseq (map fst cases) cases) of-        Nothing -> error "No such case!"-        Just act ->-          do case act of-               Action !run arg _ ->-                 do (bytes,gcs) <--                      case run of-                        Right f -> weighFunc f arg-                        Left m -> weighAction m arg-                    print (Weight {weightLabel = label-                                  ,weightAllocatedBytes = bytes-                                  ,weightGCs = gcs})+    ("--case":label:fp:_) ->+      let !_ = force fp+      in case lookup label (deepseq (map fst cases) cases) of+           Nothing -> error "No such case!"+           Just act -> do+             case act of+               Action !run arg _ -> do+                 (bytes, gcs, liveBytes, maxByte) <-+                   case run of+                     Right f -> weighFunc f arg+                     Left m -> weighAction m arg+                 writeFile+                   fp+                   (show+                      (Weight+                       { weightLabel = label+                       , weightAllocatedBytes = bytes+                       , weightGCs = gcs+                       , weightLiveBytes = liveBytes+                       , weightMaxBytes = maxByte+                       }))              return Nothing     _       | names == nub names -> fmap Just (mapM (fork . fst) cases)@@ -227,29 +272,37 @@ fork :: String -- ^ Label for the case.      -> IO Weight fork label =-  do me <- getExecutablePath-     (exit,out,err) <--       readProcessWithExitCode me-                               ["--case",label,"+RTS","-T","-RTS"]-                               ""-     case exit of-       ExitFailure{} ->-         error ("Error in case (" ++ show label ++ "):\n  " ++ err)-       ExitSuccess ->-         case reads out of-           [(!r,_)] -> return r-           _ ->-             error (concat ["Malformed output from subprocess. Weigh"-                           ," (currently) communicates with its sub-"-                           ,"processes via stdout. Remove any other "-                           ,"output from your process."])+  withSystemTempFile+    "weigh"+    (\fp h -> do+       hClose h+       me <- getExecutablePath+       (exit, _, err) <-+         readProcessWithExitCode+           me+           ["--case", label, fp, "+RTS", "-T", "-RTS"]+           ""+       case exit of+         ExitFailure {} ->+           error ("Error in case (" ++ show label ++ "):\n  " ++ err)+         ExitSuccess ->+           do out <- readFile fp+              case reads out of+                [(!r, _)] -> return r+                _ ->+                  error+                    (concat+                       [ "Malformed output from subprocess. Weigh"+                       , " (currently) communicates with its sub-"+                       , "processes via a temporary file."+                       ]))  -- | Weigh a pure function. This function 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 (Int64,Int64) -- ^ Bytes allocated and garbage collections.+  -> IO (Int64,Int64,Int64,Int64) -- ^ Bytes allocated and garbage collections. weighFunc run !arg =   do performGC      -- The above forces getGCStats data to be generated NOW.@@ -272,14 +325,17 @@          -- return zero. It's not perfect, but this library is for          -- measuring large quantities anyway.          actualBytes = max 0 actionBytes-     return (actualBytes,actionGCs)+         liveBytes = max 0 (currentBytesUsed actionStats -+                            currentBytesUsed bootupStats)+         maxBytes = max 0 (maxBytesUsed actionStats - maxBytesUsed bootupStats)+     return (actualBytes,actionGCs,liveBytes, maxBytes)  -- | Weigh a pure function. This function 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 (Int64,Int64) -- ^ Bytes allocated and garbage collections.+  -> IO (Int64,Int64,Int64,Int64) -- ^ Bytes allocated and garbage collections. weighAction run !arg =   do performGC      -- The above forces getGCStats data to be generated NOW.@@ -302,32 +358,47 @@          -- return zero. It's not perfect, but this library is for          -- measuring large quantities anyway.          actualBytes = max 0 actionBytes-     return (actualBytes,actionGCs)+         liveBytes = max 0 (currentBytesUsed actionStats -+                            currentBytesUsed bootupStats)+         maxBytes = max 0 (maxBytesUsed actionStats - maxBytesUsed bootupStats)+     return (actualBytes,actionGCs,liveBytes, maxBytes)  -------------------------------------------------------------------------------- -- Formatting functions  -- | Make a report of the weights.-report :: [(Weight,Maybe String)] -> String-report =-  tablize .-  ([(True,"Case"),(False,"Bytes"),(False,"GCs"),(True,"Check")] :) . map toRow-  where toRow (w,err) =-          [(True,weightLabel w)-          ,(False,commas (weightAllocatedBytes w))-          ,(False,commas (weightGCs w))-          ,(True-           ,case err of+report :: Config -> [(Weight,Maybe String)] -> String+report config = tablize . (select headings :) . map (select . toRow)+  where+    select row = mapMaybe (\name -> lookup name row) (configColumns config)+    headings =+      [ (Case, (True, "Case"))+      , (Allocated, (False, "Allocated"))+      , (GCs, (False, "GCs"))+      , (Live, (False, "Live"))+      , (Check, (True, "Check"))+      , (Max, (False, "Max"))+      ]+    toRow (w, err) =+      [ (Case, (True, weightLabel w))+      , (Allocated, (False, commas (weightAllocatedBytes w)))+      , (GCs, (False, commas (weightGCs w)))+      , (Live, (False, commas (weightLiveBytes w)))+      , (Max, (False, commas (weightMaxBytes w)))+      , ( Check+        , ( True+          , case err of               Nothing -> "OK"-              Just{} -> "INVALID")]+              Just {} -> "INVALID"))+      ]  -- | Make a table out of a list of rows. tablize :: [[(Bool,String)]] -> String tablize xs =   intercalate "\n"               (map (intercalate "  " . map fill . zip [0 ..]) xs)-  where fill (x',(left,text')) = printf ("%" ++ direction ++ show width ++ "s") text'-          where direction = if left+  where fill (x',(left',text')) = printf ("%" ++ direction ++ show width ++ "s") text'+          where direction = if left'                                then "-"                                else ""                 width = maximum (map (length . snd . (!! x')) xs)

@@ -1,5 +1,5 @@ name:                weigh-version:             0.0.3+version:             0.0.4 synopsis:            Measure allocations of a Haskell functions/values description:         Please see README.md homepage:            https://github.com/fpco/weigh#readme@@ -30,6 +30,7 @@                      , mtl                      , split                      , template-haskell+                     , temporary   default-language:    Haskell2010  test-suite weigh-test