diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013-2017, Merijn Verstraaten + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Merijn Verstraaten nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/ParamTree.hs b/ParamTree.hs new file mode 100644 --- /dev/null +++ b/ParamTree.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +------------------------------------------------------------------------------- +-- | +-- Module : ParamTree +-- Copyright : (C) 2017 Merijn Verstraaten +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Merijn Verstraaten +-- Stability : experimental +-- Portability : haha +-- +-- Easily generate a labelled tree of tests/benchmarks from a generation +-- function and sets of parameters to use for each of that functions arguments. +-- Example usecases include criterion benchmark trees or tasty test trees. +------------------------------------------------------------------------------- +module ParamTree + ( Params + , ParamFun + , growTree + , simpleParam + , derivedParam + , displayParam + , customParam + , paramSets + ) where + +import Data.Map (Map) +import qualified Data.Map as M +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid (mconcat) +#endif +import Data.Monoid (Endo(..)) + +-- | Type family that converts a type level list into a function type: +-- +-- @'ParamFun' ['Char', 'Int', 'Bool'] r@ = @'Char' -> 'Int' -> 'Bool' -> 'String' -> r@ +#if MIN_VERSION_base(4,7,0) +type family ParamFun (l :: [*]) r where + ParamFun '[] r = String -> r + ParamFun (h ': t) r = h -> ParamFun t r +#else +type family ParamFun (l :: [*]) r +type instance ParamFun '[] r = String -> r +type instance ParamFun (h ': t) r = h -> ParamFun t r +#endif + +-- | Sets of parameters to generate the tree from. +data Params :: [*] -> * where + Nil :: Params '[] + Sets :: [Params l] -> Params l + Param :: Eq r + => (a -> String) -- Display parameter + -> (a -> r) -- Derive value from parameter + -> String -- Parameter name + -> [a] -- Parameter values + -> Params l + -> Params (r ': l) + +data Tree :: [*] -> * where + None :: Tree '[] + Empty :: Tree l + Grouped :: Eq r + => Map (String, String) [(r, Tree l)] + -> Tree (r ': l) + +-- | A simple parameter set. The tree label is a combination of 'show'ing the +-- value and the parameter name. +simpleParam + :: (Eq a, Show a) + => String -- ^ Name of the parameter + -> [a] -- ^ Set of values to use + -> Params l + -> Params (a ': l) +simpleParam = Param show id + +-- | A derived parameter set. Useful when the input expected by your function +-- can't be conveniently rendered as a string label. For example: +-- +-- @derivedParam ('enumFromTo' 0) \"My Parameter\" [1,2,5]@ +-- +-- The above passed @'enumFromTo' 0 1@, @'enumFromTo' 0 2@, etc. to your +-- function, while labelling them as \"1 My Parameter\" and \"2 My Parameter\" +-- respectively. +derivedParam + :: (Eq r, Show a) + => (a -> r) -- ^ Parameter derivation function + -> String -- ^ Name of the parameter + -> [a] -- ^ Set of values to derive from + -> Params l + -> Params (r ': l) +derivedParam f = Param show f + +-- | A simple parameter set with a more flexible way of showing values, +-- 'simpleParam' is equivalent to @displayParam show@. +displayParam + :: Eq a + => (a -> String) + -> String + -> [a] + -> Params l + -> Params (a ': l) +displayParam display = Param display id + +-- | A completely customisable parameter set, allows specification of how to +-- display values and how to derive values. Equivalencies: +-- +-- 'simpleParam' = @customParam show id@ +-- +-- 'derivedParam' = @customParam show@ +-- +-- 'displayParam' = @\\f -> customParam f id@ +customParam + :: Eq r + => (a -> String) + -> (a -> r) + -> String + -> [a] + -> Params l + -> Params (r ': l) +customParam = Param + +-- | Combine multiple sets of parameters into one. Allows a limited amount of +-- control over which combinations appear. For example: +-- +-- @ +-- paramSets +-- [ simpleParam "Bool" [True] . simpleParam "Char" "xy" +-- , simpleParam "Bool" [True,False] . simpleParam "Char" "a" +-- ] +-- @ +-- +-- The result is \"axy\" being used in groups where the \"Bool\" parameter is +-- @True@, if the \"Bool\" parameter is @False@ only \"a\" is used. +paramSets :: [Params r -> Params l] -> Params r -> Params l +paramSets prefixes rest = Sets $ map ($rest) prefixes + +trim :: [Tree l] -> Tree l +trim [] = Empty +trim (None:_) = None +trim (Empty:l) = trim l +trim l@(Grouped{}:_) = Grouped . M.unionsWith fuse $ map explode l + where + explode :: Tree (h ': t) -> Map (String, String) [(h, Tree t)] + explode Empty = M.empty + explode (Grouped m) = m + +sprout :: Params l -> Tree l +sprout Nil = None +sprout (Sets l) = trim $ map sprout l +sprout (Param display derive name values remainder) = + Grouped . M.fromListWith fuse . map convert $ values + where + convert x = ((display x, name), [(derive x, sprout remainder)]) + +fuse :: Eq x => [(x, Tree l)] -> [(x, Tree l)] -> [(x, Tree l)] +fuse = appEndo . mconcat . map (Endo . insert) + where + insert (x, params) [] = [(x, params)] + insert new@(x1, params1) ((x2, params2):l) + | x1 == x2 = (x1, trim [params1, params2]):l + | otherwise = (x2, params2) : insert new l + +-- | Generate a tree from a function that produces a leaf and sets of +-- parameters. Useful for generating tasty TestTrees or criterion benchmark +-- trees from a function and a set of parameter. For example: +-- +-- @ +-- import Test.Tasty +-- import Test.Tasty.HUnit +-- +-- genTestCase :: Int -> Bool -> Char -> String -> TestTree +-- +-- params = 'simpleParam' \"Int\" [1,2] +-- . 'simpleParam' \"Bool\" [True] +-- . 'simpleParam' \"Char\" "xyz" +-- +-- main :: IO () +-- main = defaultMain $ testTree genTestCase params +-- where +-- testTree = growTree (Just "/") testGroup "my tests" +-- @ +-- +-- This generates a tasty TestTree with all combinations of values passed to +-- @genTestCase@. If the 'Maybe' 'String' argument is provided like in the +-- above example, groups with a single entry, such as \"Bool\" get collapsed +-- into their parent groups. So instead of a \"1 Int\" group containing a +-- \"True Bool\" group they get collapsed into a single \"1 Int/True Bool\" +-- group, where the \"/\" separator is the one specified by @'Just' \"\/\"@ +growTree + :: forall a l + . Maybe String -- ^ Groups containing a single entry are skipped and their + -- label is appended to their child, separated by this + -- 'String' if not 'Nothing'. + -> (String -> [a] -> a) -- ^ Tree labelling function, e.g. tasty's + -- @testGroup@ or criterion's @bgroup@ + -> String -- ^ Label for the root of the tree + -> ParamFun l a -- ^ Function that produces leafs, such as tasty tests or + -- criterion benchmarks + -> (Params '[] -> Params l) -- ^ Parameter sets to grow tree from + -> a +growTree collapse labelFun label fun params = + go (sprout $ params Nil) fun label + where + go :: Tree k -> ParamFun k a -> String -> a + go None result lbl = result lbl + go Empty _ lbl = labelFun lbl [] + go (Grouped l) f lbl = case concatMap flatten (M.toList l) of + [x] | Just sep <- collapse -> buildBranch f (\n -> lbl ++ sep ++ n) x + branches -> labelFun lbl $ map (buildBranch f id) branches + + flatten :: ((String, String), [(h, Tree t)]) -> [(String, h, Tree t)] + flatten ((param, name), rest) = map (\(v, r) -> (nextLabel, v, r)) rest + where + nextLabel = param ++ " " ++ name + + buildBranch + :: ParamFun (h ': t) a + -> (String -> String) + -> (String, h, Tree t) + -> a + buildBranch f namer (name, val, rest) = go rest (f val) (namer name) diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +ParamTree +========= +[![BSD3](https://img.shields.io/badge/License-BSD-blue.svg)](https://en.wikipedia.org/wiki/BSD_License) +[![Hackage](https://img.shields.io/hackage/v/paramtree.svg)](https://hackage.haskell.org/package/paramtree) +[![Build Status](https://travis-ci.org/merijn/paramtree.svg)](https://travis-ci.org/merijn/paramtree) + +**ParamTree** library for generating labelled test/benchmark trees from sets of +parameters. Example usecases include criterion benchmark trees or tasty test +trees. + +Example +------- + +```haskell +import Test.Tasty +import Test.Tasty.HUnit + +genTestCase :: Int -> Bool -> Char -> String -> TestTree +genTestCase i b c name = testCase name $ {- your code here -} + +params = 'simpleParam' \"Int\" [1,2] + . 'simpleParam' \"Bool\" [True] + . 'simpleParam' \"Char\" "xyz" + +main :: IO () +main = defaultMain $ testTree genTestCase params + where + testTree = growTree (Just "/") testGroup "my tests" +``` + +This generates a tasty TestTree with all combinations of values passed to +`genTestCase`. If the `Maybe String` argument is provided like in the above +example, groups with a single entry, such as "Bool" get collapsed into their +parent groups. So instead of a "1 Int" group containing a "True Bool" group +they get collapsed into a single "1 Int/True Bool" group, where the "/" +separator is the one specified by `Just "/"`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/paramtree.cabal b/paramtree.cabal new file mode 100644 --- /dev/null +++ b/paramtree.cabal @@ -0,0 +1,68 @@ +Name: paramtree +Version: 0.1.0 + +Homepage: https://github.com/merijn/paramtree +Bug-Reports: https://github.com/merijn/paramtree/issues + +Author: Merijn Verstraaten +Maintainer: Merijn Verstraaten +Copyright: Copyright © 2017 Merijn Verstraaten + +License: BSD3 +License-File: LICENSE + +Category: Development, Benchmarking, Testing +Cabal-Version: >= 1.10 +Build-Type: Simple +Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, + GHC == 8.2.1, GHC == 8.3.* + +Extra-Source-Files: README.md tests/*.golden + +Synopsis: Generate labelled test/benchmark trees from sets of parameters + +Description: + Easily generate a labelled tree of tests/benchmarks from a generation + function and sets of parameters to use for each of that functions + arguments. Example usecases include criterion benchmark trees or tasty test + trees. + +Library + Default-Language: Haskell2010 + GHC-Options: -Wall -fno-warn-unused-do-bind + + Exposed-Modules: ParamTree + Other-Extensions: CPP + DataKinds + GADTs + KindSignatures + ScopedTypeVariables + TypeFamilies + TypeOperators + + Build-Depends: base >= 4.6 && < 5 + , containers >= 0.4 && < 0.6 + +Test-Suite test + Default-Language: Haskell2010 + Type: exitcode-stdio-1.0 + Main-Is: Test.hs + Hs-Source-Dirs: tests + GHC-Options: -Wall -fno-warn-unused-do-bind + Other-Extensions: CPP + DataKinds + Build-Depends: base + , paramtree + , bytestring >= 0.10 && < 0.11 + , tasty >= 0.11 && < 0.13 + , tasty-golden >= 2.0 && < 2.4 + , tasty-hunit == 0.9.* + , temporary == 1.2.* + +Source-Repository head + Type: git + Location: ssh://github.com:merijn/paramtree.git + +Source-Repository head + Type: mercurial + Location: https://bitbucket.org/merijnv/paramtree diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>),(<*)) +#endif +import Control.Exception (SomeException, bracket, try) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Char (ord) +import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import System.IO (Handle, SeekMode(..), hFlush, hSeek, stdout) +import System.IO.Temp (withSystemTempFile) +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit +import ParamTree + +genTestCase :: Int -> Bool -> Char -> Int -> String -> TestTree +genTestCase _ _ _ _ name = testCase name $ return () + +paramTreeTests :: IO () +paramTreeTests = defaultMain $ testTree genTestCase params + where + testTree = growTree (Just "/") testGroup "paramtree" + + params :: Params '[] -> Params [Int, Bool, Char, Int] + params = simpleParam "Int #1" [1,2] + . paramSets + [ simpleParam "Bool" [True] . simpleParam "Char" "xy" + , simpleParam "Bool" [True,False] . simpleParam "Char" "a" + ] + . simpleParam "Int #2" [42,1337] + +withCapturedIO :: IO () -> IO BS.ByteString +withCapturedIO act = withSystemTempFile "golden.test" $ \_ hnd -> do + let redirect :: IO Handle + redirect = do + hFlush stdout + hDuplicate stdout <* hDuplicateTo hnd stdout + + undo :: Handle -> IO () + undo h = hFlush stdout >> hDuplicateTo h stdout + + bracket redirect undo $ \_ -> try act :: IO (Either SomeException ()) + + hSeek hnd AbsoluteSeek 0 + BS.hGetContents hnd + +runGolden :: String -> BS.ByteString -> TestTree +runGolden name rawOutput = goldenVsString name goldenFile (return lazyOutput) + where + goldenFile = "tests/" ++ name ++ ".golden" + output = BS.take (BS.length rawOutput - 9) rawOutput + lazyOutput = LBS.fromStrict $ output `BS.snoc` fromIntegral (ord '\n') + +main :: IO () +main = do + tests <- map (uncurry runGolden) <$> mapM run testPairs + defaultMain . testGroup "Tests" $ tests + where + run (x, act) = (,) x <$> withCapturedIO act + testPairs = [ ("paramtree", paramTreeTests) ] diff --git a/tests/paramtree.golden b/tests/paramtree.golden new file mode 100644 --- /dev/null +++ b/tests/paramtree.golden @@ -0,0 +1,31 @@ +paramtree + 1 Int #1 + False Bool/'a' Char + 1337 Int #2: OK + 42 Int #2: OK + True Bool + 'a' Char + 1337 Int #2: OK + 42 Int #2: OK + 'x' Char + 1337 Int #2: OK + 42 Int #2: OK + 'y' Char + 1337 Int #2: OK + 42 Int #2: OK + 2 Int #1 + False Bool/'a' Char + 1337 Int #2: OK + 42 Int #2: OK + True Bool + 'a' Char + 1337 Int #2: OK + 42 Int #2: OK + 'x' Char + 1337 Int #2: OK + 42 Int #2: OK + 'y' Char + 1337 Int #2: OK + 42 Int #2: OK + +All 16 tests passed