diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,7 @@ +0.0.3: + * Added more docs to haddocks + * Export more internal combinators + 0.0.2: * Remove magic numbers from weighing code, better accuracy * Add additional `io` combinator diff --git a/src/Weigh.hs b/src/Weigh.hs --- a/src/Weigh.hs +++ b/src/Weigh.hs @@ -5,13 +5,27 @@ {-# LANGUAGE BangPatterns #-} -- | Framework for seeing how much a function allocates. +-- +-- 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) +-- @ module Weigh - (-- * Main entry point. + (-- * Main entry points mainWith - -- * Types - ,Weigh - ,Weight(..) + ,weighResults -- * Simple combinators ,func ,io @@ -22,8 +36,16 @@ ,validateFunc -- * Validators ,maxAllocs + -- * Types + ,Weigh + ,Weight(..) -- * Handy utilities - ,commas) + ,commas + -- * Internals + ,weighDispatch + ,weighFunc + ,weighAction + ) where import Control.Applicative @@ -67,35 +89,39 @@ -------------------------------------------------------------------------------- -- Main-runners --- | Just run the measuring and print a report. +-- | Just run the measuring and print a report. Uses 'weighResults'. mainWith :: Weigh a -> IO () mainWith m = + do results <- weighResults m + unless (null results) + (do putStrLn "" + putStrLn (report results)) + case mapMaybe (\(w,r) -> + do msg <- r + return (w,msg)) + results of + [] -> return () + errors -> + do putStrLn "\nCheck problems:" + mapM_ (\(w,r) -> putStrLn (" " ++ weightLabel w ++ "\n " ++ r)) errors + exitWith (ExitFailure (-1)) + +-- | 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 <- weigh args cases + result <- weighDispatch args cases case result of - Nothing -> return () + Nothing -> return [] Just weights -> - do let results = - map (\w -> - case lookup (weightLabel w) cases of - Nothing -> (w,Nothing) - Just a -> (w,actionCheck a w)) - weights - putStrLn "" - putStrLn (report results) - case mapMaybe (\(w,r) -> - do msg <- r - return (w,msg)) - results of - [] -> return () - errors -> - do putStrLn "\nCheck problems:" - mapM_ (\(w,r) -> - putStrLn (" " ++ weightLabel w ++ "\n " ++ r)) - errors - exitWith (ExitFailure (-1)) - + return (map (\w -> + case lookup (weightLabel w) cases of + Nothing -> (w,Nothing) + Just a -> (w,actionCheck a w)) + weights) -------------------------------------------------------------------------------- -- User DSL @@ -103,30 +129,44 @@ -- | Weigh a function applied to an argument. -- -- Implemented in terms of 'validateFunc'. -func :: (NFData a) => String -> (b -> a) -> b -> Weigh () +func :: (NFData a) + => String -- ^ Name of the case. + -> (b -> a) -- ^ Function that does some action to measure. + -> b -- ^ Argument to that function. + -> Weigh () func name !f !x = validateFunc name f x (const Nothing) --- | Weigh a function applied to an argument. +-- | Weigh an action applied to an argument. -- --- Implemented in terms of 'validateFunc'. -io :: (NFData a) => String -> (b -> IO a) -> b -> Weigh () +-- 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 name !f !x = validateAction name f x (const Nothing) -- | Weigh a value. -- -- Implemented in terms of 'action'. -value :: NFData a => String -> a -> Weigh () +value :: NFData a + => String -- ^ Name for the value. + -> a -- ^ The value to measure. + -> Weigh () value name !v = func name id v -- | Weigh an IO action. -- -- Implemented in terms of 'validateAction'. action :: NFData a - => String -> IO a -> Weigh () + => String -- ^ Name for the value. + -> IO a -- ^ The action to measure. + -> Weigh () action name !m = io name (const m) () -- | Make a validator that set sthe maximum allocations. -maxAllocs :: Int64 -> (Weight -> Maybe String) +maxAllocs :: Int64 -- ^ The upper bound. + -> (Weight -> Maybe String) maxAllocs n = \w -> if weightAllocatedBytes w > n @@ -135,16 +175,22 @@ else Nothing -- | Weigh an IO action, validating the result. -validateAction - :: (NFData a) - => String -> (b -> IO a) -> b -> (Weight -> Maybe String) -> Weigh () +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 name !m !arg !validate = Weigh (tell [(name,Action (Left m) arg validate)]) -- | Weigh a function, validating the result -validateFunc - :: (NFData a) - => String -> (b -> a) -> b -> (Weight -> Maybe String) -> Weigh () +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 name !f !x !validate = Weigh (tell [(name,Action (Right f) x validate)]) @@ -153,8 +199,10 @@ -- | Weigh a set of actions. The value of the actions are forced -- completely to ensure they are fully allocated. -weigh :: [String] -> [(String,Action)] -> IO (Maybe [Weight]) -weigh args cases = +weighDispatch :: [String] -- ^ Program arguments. + -> [(String,Action)] -- ^ Weigh name:action mapping. + -> IO (Maybe [Weight]) +weighDispatch args cases = case args of ("--case":label:_) -> case lookup label (deepseq (map fst cases) cases) of @@ -185,10 +233,16 @@ ["--case",label,"+RTS","-T","-RTS"] "" case exit of - ExitFailure{} -> error ("Error in case (" ++ show label ++ "):\n " ++ err) + ExitFailure{} -> + error ("Error in case (" ++ show label ++ "):\n " ++ err) ExitSuccess -> - let !r = read out - in return r + 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."]) -- | Weigh a pure function. This function is heavily documented inside. weighFunc diff --git a/weigh.cabal b/weigh.cabal --- a/weigh.cabal +++ b/weigh.cabal @@ -1,5 +1,5 @@ name: weigh -version: 0.0.2 +version: 0.0.3 synopsis: Measure allocations of a Haskell functions/values description: Please see README.md homepage: https://github.com/fpco/weigh#readme