paramtree (empty) → 0.1.0
raw patch · 7 files changed
+455/−0 lines, 7 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, paramtree, tasty, tasty-golden, tasty-hunit, temporary
Files
- LICENSE +30/−0
- ParamTree.hs +226/−0
- README.md +36/−0
- Setup.hs +2/−0
- paramtree.cabal +68/−0
- tests/Test.hs +62/−0
- tests/paramtree.golden +31/−0
+ LICENSE view
@@ -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.
+ ParamTree.hs view
@@ -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 <merijn@inconsistent.nl>+-- 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)
+ README.md view
@@ -0,0 +1,36 @@+ParamTree+=========+[](https://en.wikipedia.org/wiki/BSD_License)+[](https://hackage.haskell.org/package/paramtree)+[](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 "/"`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ paramtree.cabal view
@@ -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 <merijn@inconsistent.nl>+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
+ tests/Test.hs view
@@ -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) ]
+ tests/paramtree.golden view
@@ -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