test-framework-th-prime 0.0.0 → 0.0.1
raw patch · 3 files changed
+124/−51 lines, 3 filesdep +cpphsdep −language-haskell-extractdep −regex-posix
Dependencies added: cpphs
Dependencies removed: language-haskell-extract, regex-posix
Files
- Test/Framework/TH/Prime.hs +41/−49
- Test/Framework/TH/Prime/Parser.hs +79/−0
- test-framework-th-prime.cabal +4/−2
Test/Framework/TH/Prime.hs view
@@ -2,7 +2,7 @@ {-| Template Haskell to generate defaultMain with a list of "Test" from- \"doc_test\", \"case_<somthing>\", and \"prop_<somthing>\".+ \"doc_test\", \"case_\<somthing\>\", and \"prop_\<somthing\>\". An example of source code (Data/MySet.hs): @@ -23,6 +23,7 @@ An example of test code in the src directory (test/Test.hs): + > { -# LANGUAGE TemplateHaskell #- } > module Main where > > import Test.Framework.TH.Prime@@ -54,10 +55,21 @@ > test% runghc -i.. Test.hs - This code is based on Test.Framework.TH by Oscar Finnsson and Emil Nordling- and the author integrated doctest.+ "defaultMainGenerator" generates the following: - Examples in haddock document is only used as unit tests at this+ > main = do+ > TestGroup _ doctests <- docTest ["../Data/MySet.hs"] ["-i.."]+ > defaultMain [+ > testGroup "Doc tests" doctests+ > , testGroup "Unit tests" [+ > testCase "case_ticket4242" case_ticket4242+ > ]+ > , testGroup "Property tests" [+ > testProperty "prop_toList" prop_toList+ > ]+ > ]++ Note: examples in haddock document is only used as unit tests at this moment. I hope that properties of QuickCheck2 can also be specified in haddock document in the future. I guess it's Haskell way of Behavior Driven Development.@@ -65,15 +77,16 @@ -} module Test.Framework.TH.Prime (- defaultMainGenerator,- DocTests-) where+ defaultMainGenerator+ , DocTests+ ) where -import Language.Haskell.Extract-import Language.Haskell.TH-import Language.Haskell.TH.Syntax+import Control.Applicative+import Language.Haskell.TH hiding (Match)+import Language.Haskell.TH.Syntax hiding (Match) import Test.Framework (defaultMain) import Test.Framework.Providers.API+import Test.Framework.TH.Prime.Parser ---------------------------------------------------------------- @@ -89,50 +102,29 @@ defaultMainGenerator :: ExpQ defaultMainGenerator = do defined <- isDefined docTestKeyword- if defined- then [| do TestGroup _ doctests <- $(docListGenerator)- defaultMain [ testGroup $(locationModule) $ doctests ++ $(caseListGenerator) ++ $(propListGenerator) ] |]- else [| defaultMain [ testGroup $(locationModule) $ $(caseListGenerator) ++ $(propListGenerator) ] |]--------------------------------------------------------------------- code from Test.Framework.TH of test-framework-th--- by Oscar Finnsson & Emil Nordling--listGenerator :: String -> String -> ExpQ-listGenerator beginning funcName =- functionExtractorMap beginning (applyNameFix funcName)--propListGenerator :: ExpQ-propListGenerator = listGenerator "^prop_" "testProperty"--caseListGenerator :: ExpQ-caseListGenerator = listGenerator "^case_" "testCase"---------------------------------------------------------------------- | The same as--- e.g. \n f -> testProperty (fixName n) f-applyNameFix :: String -> ExpQ-applyNameFix n =- do fn <- [|fixName|]- return $ LamE [VarP (mkName "n")] (AppE (VarE (mkName n)) (AppE (fn) (VarE (mkName "n"))))--fixName :: String -> String-fixName name = replace '_' ' ' $ drop 5 name--replace :: Eq a => a -> a -> [a] -> [a]-replace b v = map (\i -> if b == i then v else i)+ if defined then [|+ do TestGroup _ doctests <- $(docTests)+ let (unittests, proptests) = $(unitPropTests)+ defaultMain [ testGroup "Doc tests" doctests+ , testGroup "Unit tests" unittests+ , testGroup "Property tests" proptests+ ]+ |] else [|+ do let (unittests, proptests) = $(unitPropTests)+ defaultMain [ testGroup "Unit tests" unittests+ , testGroup "Property tests" proptests+ ]+ |] ---------------------------------------------------------------- -- code from Hiromi Ishii isDefined :: String -> Q Bool-isDefined n = do- return False `recover` do+isDefined n = return False `recover` do VarI (Name _ flavour) _ _ _ <- reify (mkName n)- loc <- location+ modul <- loc_module <$> location case flavour of- NameG ns _ mdl -> return (ns == VarName && modString mdl == loc_module loc)+ NameG ns _ mdl -> return (ns == VarName && modString mdl == modul) _ -> return False ----------------------------------------------------------------@@ -140,5 +132,5 @@ docTestKeyword :: String docTestKeyword = "doc_test" -docListGenerator :: ExpQ-docListGenerator = varE $ mkName docTestKeyword+docTests :: ExpQ+docTests = return $ symbol docTestKeyword
+ Test/Framework/TH/Prime/Parser.hs view
@@ -0,0 +1,79 @@+module Test.Framework.TH.Prime.Parser (+ unitPropTests+ , symbol, string+ ) where++import Control.Applicative+import Data.List+import Language.Haskell.Exts.Extension+import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Syntax hiding (VarName, Exp)+import Language.Haskell.TH hiding (Match)+import Language.Preprocessor.Cpphs++----------------------------------------------------------------++symbol :: String -> Exp+symbol = VarE . mkName++string :: String -> Exp+string = LitE . StringL++----------------------------------------------------------------++unitPropTests :: ExpQ+unitPropTests = do+ file <- loc_filename <$> location+ (cases, props) <- runIO $ getTests file+ return $ TupE [ListE (map toCase cases), ListE (map toProp props)]++----------------------------------------------------------------++toCase :: String -> Exp+toCase = toTest "testCase"++toProp :: String -> Exp+toProp = toTest "testProperty"++toTest :: String -> String -> Exp+toTest tag nm = AppE (AppE (symbol tag ) (string nm)) (symbol nm)++----------------------------------------------------------------++getTests :: FilePath -> IO ([String], [String])+getTests file = do+ ParseOk (Module _ _ _ _ _ _ decls) <- parseTest file+ let funs = map fromFunBind $ filter isFunBind decls+ pats = map fromPatBind $ filter isPatBind decls+ names = funs ++ pats+ return (filter isCase names, filter isProp names)+ where+ isProp = ("prop_" `isPrefixOf`)+ isCase = ("case_" `isPrefixOf`)++parseTest :: FilePath -> IO (ParseResult Module)+parseTest file = do+ raw <- readFile file+ parseModuleWithMode opt . pack <$> go raw+ where+ pack = unlines . tail . map snd+ go = cppIfdef "dummy" [] [] defaultBoolOptions+ opt = defaultParseMode {extensions = [TemplateHaskell]}++----------------------------------------------------------------++isFunBind :: Decl -> Bool+isFunBind (FunBind _) = True+isFunBind _ = False++isPatBind :: Decl -> Bool+isPatBind (PatBind _ _ _ _ _) = True+isPatBind _ = False++fromPatBind :: Decl -> String+fromPatBind (PatBind _ (PVar (Ident name)) _ _ _) = name+fromPatBind _ = error "fromPatBind"++fromFunBind :: Decl -> String+fromFunBind (FunBind (Match _ (Ident name) _ _ _ _:_)) = name+fromFunBind _ = error "fromFunBind"
test-framework-th-prime.cabal view
@@ -1,5 +1,5 @@ Name: test-framework-th-prime-Version: 0.0.0+Version: 0.0.1 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -16,7 +16,9 @@ else GHC-Options: -Wall Exposed-Modules: Test.Framework.TH.Prime- Build-Depends: base >= 4 && < 5, test-framework, language-haskell-extract >= 0.2.1, haskell-src-exts, regex-posix, template-haskell+ Other-Modules: Test.Framework.TH.Prime.Parser+ Build-Depends: base >= 4 && < 5, test-framework,+ cpphs >= 0.2.1, haskell-src-exts, template-haskell Source-Repository head Type: git