packages feed

tasty-kat (empty) → 0.0.1

raw patch · 8 files changed

+519/−0 lines, 8 filesdep +basedep +bytestringdep +mtlsetup-changed

Dependencies added: base, bytestring, mtl, tasty, tasty-hunit, tasty-kat, tasty-quickcheck

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2015 Vincent Hanquez <vincent@snarc.org>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
@@ -0,0 +1,76 @@+tasty-kat+=========++[![Build Status](https://travis-ci.org/vincenthz/tasty-kat.png?branch=master)](https://travis-ci.org/vincenthz/tasty-kat)+[![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses)+[![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org)++[Tasty-kat](http://hackage.haskell.org/package/tasty-kat) provides support for+KAT (Known Answer Tests) testing.  KAT files provides input and output tests+for some functions for example, for testing the following function:++    r == a + b++A KAT file could be:++```ini+[2 digits addition]++a = 10+b = 20+r = 30++a = 11+b = 21+r = 32+```++This is somewhat similar to the [tasty-golden](http://hackage.haskell.org/package/tasty-golden)+package, but instead of generating files and comparing output file to a golden file,+tasty-kat loads input and output in test vectors and run specific function on it.++Documentation: [tasty-kat on hackage](http://hackage.haskell.org/package/tasty-kat)++```haskell+import Test.Tasty+import Test.Tasty.KAT+main = do+    kat <- testKatLoad "path/to/KAT" katLoaderSimple+    defaultMain [ testKatDetailed "kat-name" kat testKat ]+  where testAddition group kvs =+            case sequence $ map (flip lookup kvs) ["a","b","r"] of+                Nothing      -> error "invalid vector"+                Just [a,b,r] -> let a = read as :: Int+                                    b = read bs :: Int+                                    r = read rs :: Int+                                 in return (a + b == r)+```++The detail output with 'testKatDetailed' looks like:++```shell+    add+      1:    OK+      2:    OK+    sub+      1:    OK+    add+      1:    OK+    base64+      1:    OK+      2:    OK+```++The grouped output with 'testKatGrouped' looks like:++```shell+    add:    OK+      2 tests succeed+    sub:    OK+      1 tests succeed+    add:    OK+      1 tests succeed+    base64: OK+      2 tests succeed+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test/Tasty/KAT.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Test.Tasty.KAT+-- License     : MIT+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+-- Tasty support for KAT (Known Answer Tests)+--+module Test.Tasty.KAT+    (+    -- * Run tests+      testKatDetailed+    , testKatGrouped+    -- * Load KAT resources+    , testKatLoad+    , Resource(..)+    , katLoaderSimple+    , mapTestUnits+    ) where++import Control.Applicative+import Control.Exception+import Data.Typeable+import Test.Tasty (testGroup)+import Test.Tasty.Providers+import Test.Tasty.KAT.FileLoader++newtype Resource a = Resource [(String, [a])]++data TestKatSingle = TestKatSingle (IO Bool)+    deriving Typeable++data TestKatGroup = TestKatGroup [(Int, IO Bool)]+    deriving Typeable++data KatResult = KatFailed String | KatSuccess+    deriving (Show,Eq)++tryResult :: IO Bool -> IO KatResult+tryResult f = do+    er <- try f+    case er of+        Left (e :: SomeException)+            | show e == "<<timeout>>" -> throwIO e+            | otherwise               -> return $ KatFailed (show e)+        Right r                       -> return $ if r then KatSuccess else KatFailed "test failed"++instance IsTest TestKatSingle where+    run _ (TestKatSingle tst) _ = do+        r <- tryResult tst+        case r of+            KatSuccess  -> return $ testPassed ""+            KatFailed s -> return $ testFailed s+    testOptions = return []+instance IsTest TestKatGroup where+    run _ (TestKatGroup groupTests) _ = do+        (success, failed) <- summarize <$> mapM runGroup groupTests+        return $+            (if failed == 0 then testPassed else testFailed)+            (if failed > 0 then (show failed) ++ " tests failed on " ++ show (failed + success)+                           else (show success) ++ " tests succeed")+      where summarize :: [KatResult] -> (Int, Int)+            summarize = foldl (\(s,f) k -> if k == KatSuccess then (s+1,f) else (s,f+1)) (0,0)++            runGroup :: (Int, IO Bool) -> IO KatResult+            runGroup (_, tst) = tryResult tst+            --nbGroups = fromIntegral $ length groupTests+            --yieldProgress $ Progress { progressText = groupName, progressPercent = fromIntegral tstNb / nbGroups  }++    testOptions = return []++-- | run one tasty test per vectors in each groups+--+-- This is useful to have detailed output on what failed+-- and what succeeded. For a more concise output, use+-- 'testKatGrouped'+testKatDetailed :: TestName+                -> Resource a+                -> (String -> a -> IO Bool)+                -> TestTree+testKatDetailed name (Resource groups) test = -- singleTest name $ mkTestKat resource test+    testGroup name $ map groupToTests groups+  where groupToTests (groupName, vectors) =+            testGroup groupName $ map (\(i, v) -> singleTest (show (i :: Int)) (TestKatSingle $ test groupName v)) (zip [1..] vectors)++-- | run one tasty test per group+testKatGrouped :: TestName+               -> Resource a+               -> (String -> a -> IO Bool)+               -> TestTree+testKatGrouped name (Resource groups) test = -- singleTest name $ mkTestKat resource test+    testGroup name $ map groupToTests groups+  where groupToTests (groupName, vectors) =+            singleTest groupName $ TestKatGroup $ map (\(i, v) -> (i, test groupName v)) (zip [1..] vectors)++-- | Read a KAT file into values that will be used for KATs tests+testKatLoad :: FilePath+            -> ([String] -> [(String, [a])])+            -> IO (Resource a)+testKatLoad filepath transform = Resource . transform . lines <$> readFile filepath
+ Test/Tasty/KAT/FileLoader.hs view
@@ -0,0 +1,204 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Test.Tasty.KAT.FileLoader+-- License     : MIT+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+-- extra loaders helpers+--+module Test.Tasty.KAT.FileLoader+    ( katLoader+    , katLoaderSimple+    -- * generic helpers on TestResource+    , mapTestUnitValues+    , mapTestUnits+    -- * common helpers on TestResource+    , mapTestUnitValuesBase64+    , mapTestUnitValuesBase16+    -- * common value decoding helpers+    , valueUnbase16+    , valueUnbase64+    , valueInteger+    , valueHexInteger+    -- * associated hierarchy of KAT types +    , TestResource+    , TestGroup+    , TestUnit+    ) where++import Control.Arrow (second)+import Data.Bits+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B+import Data.ByteString (ByteString)+import Data.ByteString.Char8 () -- for Bytestring OverloadedString instance on old ghc+import Data.List+import Data.Word+import Foreign.Storable+import Foreign.Ptr++import Test.Tasty.KAT.Internal++type TestResource a = [(String, TestGroup a)]+type TestGroup a = [TestUnit a]+type TestUnit a = [a]++-- | From a simple KAT file, extract +--+-- * lines starting by #, are assumed to be comment+--+-- format should be the following:+-- +-- > skipped ..+-- > skipped ..+-- > [group1]+-- >+-- > f1= v1+-- > f2= v2+-- > ...+-- > +-- > f1= v3+-- > f2= v4+-- > ...+-- >+-- > [group2]+-- > ...+katLoaderSimple :: [String] -> TestResource (String, String)+katLoaderSimple = katLoader '=' "#"++katLoader :: Char     -- ^ key value separator, e.g. '='+          -> String   -- ^ line comment, e.g. "--" "#"+          -> [String] -- ^ input lines+          -> TestResource (String, String)+katLoader kvSep lineComment =+      map (second (map (map kv)))+    . removeEmpty+    . map (second (splitWhen null)) -- split a group of lines into a group of tests+    . groupify "" []+    . map noTrailing+    . filter (not . isComment)+  where isComment = isPrefixOf lineComment++        removeEmpty = filter ((/= []) . snd)++        groupify :: String -> [String] -> [String] -> [(String, [String])]+        groupify gname acc []     = [(gname, reverse acc)]+        groupify gname acc (x:xs) =+            case getGroupHeader x of+                Just hdr -> (gname, reverse acc) : groupify hdr [] xs+                Nothing  -> groupify gname (x:acc) xs++        kv :: String -> (String, String)+        kv s = case break (== kvSep) s of+                    (k, c:v)+                        | c == kvSep -> (stripSpaces k, stripSpaces v)+                        | otherwise  -> (stripSpaces k, stripSpaces v)+                    (_, _)     -> (s, "") -- no error handling ..++        getGroupHeader :: String -> Maybe String+        getGroupHeader s+            | isPrefixOf "[" s && isSuffixOf "]" s = Just . drop 1 . reverse . drop 1 . reverse $ s+            | otherwise                            = Nothing++        noTrailing = reverse . dropWhile (== ' ') . reverse++        splitWhen :: (a -> Bool) -> [a] -> [[a]]+        splitWhen p s = case dropWhile p s of+                             [] -> []+                             s' -> w : splitWhen p s''+                                   where (w, s'') = break p s'+        stripSpaces = dropWhile (== ' ') . reverse . dropWhile (== ' ') . reverse++mapTestUnitValues :: (String -> a) -> TestResource (String, String) -> TestResource (String,a)+mapTestUnitValues f = map (second (map (map (\(k,v) -> (k, f v)))))++mapTestUnits :: (TestUnit (String,a) -> TestUnit b)+             -> TestResource (String,a)+             -> TestResource b+mapTestUnits f = map (second (map f))++mapTestUnitValuesBase64 :: TestResource (String, String) -> TestResource (String, ByteString)+mapTestUnitValuesBase64 =  mapTestUnitValues valueUnbase64++mapTestUnitValuesBase16 :: TestResource (String, String) -> TestResource (String, ByteString)+mapTestUnitValuesBase16 = mapTestUnitValues valueUnbase16++-- expect an ascii string.+valueUnbase64 :: String -> ByteString+valueUnbase64 s+    | (length s `mod` 4) /= 0 = error ("decodiong base64 not proper length: " ++ s)+    | otherwise               = unsafeCreateUptoN maxSz $ \ptr -> do+                                    szRemove <- loop s ptr+                                    return (maxSz - szRemove)+  where maxSz = (length s `div` 4) * 3+        loop []               _   = return 0+        loop (w:x:'=':'=':[]) ptr = do+            let w' = rset w+                x' = rset x+            poke ptr ((w' `shiftL` 2) .|. (x' `shiftR` 4))+            return 2+        loop (w:x:y:'=':[])   ptr = do+            let w' = rset w+                x' = rset x+                y' = rset y+            poke ptr               ((w' `shiftL` 2) .|. (x' `shiftR` 4))+            poke (ptr `plusPtr` 1) ((x' `shiftL` 4) .|. (y' `shiftR` 2))+            return 1+        loop (w:x:y:z:r)      ptr = do+            let w' = rset w+                x' = rset x+                y' = rset y+                z' = rset z+            poke ptr               ((w' `shiftL` 2) .|. (x' `shiftR` 4))+            poke (ptr `plusPtr` 1) ((x' `shiftL` 4) .|. (y' `shiftR` 2))+            poke (ptr `plusPtr` 2) ((y' `shiftL` 6) .|. z')+            loop r (ptr `plusPtr` 3)+        loop _                _   = error ("internal error in base64 decoding")+        +        rset :: Char -> Word8+        rset c+            | cval <= 0xff = B.unsafeIndex rsetTable cval+            | otherwise    = 0xff+          where cval = fromEnum c+        -- dict = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"+        rsetTable = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\xff\xff\xff\x3f\+                    \\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\xff\xff\xff\xff\xff\xff\+                    \\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\+                    \\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xff\xff\xff\xff\xff\+                    \\xff\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\+                    \\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+                    \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"++-- expect an ascii string.+valueUnbase16 :: String -> ByteString+valueUnbase16 s+    | odd (length s) = error ("decoding base16 not proper length: " ++ s)+    | otherwise = B.unsafeCreate (length s `div` 2) (loop s)+  where loop []         _   = return ()+        loop (x1:x2:xs) ptr = do+            poke ptr ((unhex x1 `shiftL` 4) .|. unhex x2)+            loop xs (ptr `plusPtr` 2)+        loop _          _   = error "internal error in base16 decoding"+        unhex :: Char -> Word8+        unhex c+            | c >= '0' && c <= '9' = fromIntegral (fromEnum c - fromEnum '0')+            | c >= 'a' && c <= 'f' = 10 + fromIntegral (fromEnum c - fromEnum 'a')+            | c >= 'A' && c <= 'F' = 10 + fromIntegral (fromEnum c - fromEnum 'A')+            | otherwise            = error ("invalid base16 character " ++ show c ++ " in " ++ show s)++valueInteger :: String -> Integer+valueInteger s = read s++valueHexInteger :: String -> Integer+valueHexInteger s = read ("0x" ++ s)
+ Test/Tasty/KAT/Internal.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+-- |+-- Module      : Test.Tasty.KAT.Internal+-- License     : MIT+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+-- compat+--+module Test.Tasty.KAT.Internal+    ( unsafeCreateUptoN+    ) where++import qualified Data.ByteString.Internal as B+import Data.ByteString (ByteString)+import Foreign.Ptr+import Data.Word++#if !(MIN_VERSION_bytestring(0,10,4))+import Foreign.ForeignPtr+import System.IO.Unsafe (unsafePerformIO)+#endif++unsafeCreateUptoN :: Int -> (Ptr Word8 -> IO Int) -> ByteString+#if MIN_VERSION_bytestring(0,10,4)+unsafeCreateUptoN = B.unsafeCreateUptoN+#else+unsafeCreateUptoN len f = unsafePerformIO $ do+    fp <- B.mallocByteString len+    l' <- withForeignPtr fp f+    return $! B.PS fp 0 l'+#endif
+ tasty-kat.cabal view
@@ -0,0 +1,45 @@+Name:                tasty-kat+Version:             0.0.1+Synopsis:            Known Answer Tests (KAT) framework for tasty+Description:+    Tests running from simple KATs file (different formats/helper supported)+License:             MIT+License-file:        LICENSE+Copyright:           Vincent Hanquez <vincent@snarc.org>+Author:              Vincent Hanquez <vincent@snarc.org>+Maintainer:          vincent@snarc.org+Category:            tasty-kat+Stability:           experimental+Build-Type:          Simple+Homepage:            https://github.com/vincenthz/tasty-kat+Bug-Reports:         https://github.com/vincenthz/tasty-kat/issues+Cabal-Version:       >=1.10+extra-source-files:  README.md++source-repository head+  type: git+  location: https://github.com/vincenthz/tasty-kat++Library+  Exposed-modules:   Test.Tasty.KAT+                   , Test.Tasty.KAT.FileLoader+  Other-modules:     Test.Tasty.KAT.Internal+  Build-depends:     base >= 4 && < 5+                   , bytestring+                   , tasty+  ghc-options:       -Wall -fwarn-tabs+  default-language:  Haskell2010++Test-Suite test-tasty-kat+  type:              exitcode-stdio-1.0+  hs-source-dirs:    tests+  Main-is:           Tests.hs+  Build-Depends:     base >= 3 && < 5+                   , bytestring+                   , mtl+                   , tasty+                   , tasty-quickcheck+                   , tasty-hunit+                   , tasty-kat+  ghc-options:       -Wall -fno-warn-orphans -fno-warn-missing-signatures+  default-language:  Haskell2010
+ tests/Tests.hs view
@@ -0,0 +1,37 @@+module Main where++import Test.Tasty+import Test.Tasty.KAT+import Test.Tasty.KAT.FileLoader++import qualified Data.ByteString.Char8 as BC++main = do+    kat <- testKatLoad "tests/KAT" katLoaderSimple+    defaultMain $ testGroup "tasty-kat"+        [ testKatDetailed "kat-detailed" kat myTest+        , testKatGrouped "kat-grouped" kat myTest+        ]+  where myTest group kvs =+            case group of+                "add" -> case sequence $ map (flip lookup kvs) ["a","b","r"] of+                            Just [as,bs,rs] ->+                                let a = read as :: Int+                                    b = read bs :: Int+                                    r = read rs :: Int+                                 in return (a + b == r)+                            _ -> error ("invalid vector " ++ show kvs)+                "sub" -> case sequence $ map (flip lookup kvs) ["a","b","r"] of+                            Just [as,bs,rs] ->+                                let a = read as :: Int+                                    b = read bs :: Int+                                    r = read rs :: Int+                                 in return (a - b == r)+                            _ -> error "invalid vector"+                "base64" ->+                    case sequence $ map (flip lookup kvs) ["a","r"] of+                            Just [as,rs] ->+                                return ((valueUnbase64 as) == (BC.pack rs))+                            _ -> error "invalid vector"+                +                _ -> error ("unknown group: " ++ group)