diff --git a/Test/Framework/TH/Prime.hs b/Test/Framework/TH/Prime.hs --- a/Test/Framework/TH/Prime.hs +++ b/Test/Framework/TH/Prime.hs @@ -2,7 +2,7 @@ {-| Template Haskell to generate defaultMain with a list of "Test" from - \"doc_test\", \"case_\", and \"prop_\". + \"doc_test\", \"case_\\", and \"prop_\\". 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 diff --git a/Test/Framework/TH/Prime/Parser.hs b/Test/Framework/TH/Prime/Parser.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/TH/Prime/Parser.hs @@ -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" diff --git a/test-framework-th-prime.cabal b/test-framework-th-prime.cabal --- a/test-framework-th-prime.cabal +++ b/test-framework-th-prime.cabal @@ -1,5 +1,5 @@ Name: test-framework-th-prime -Version: 0.0.0 +Version: 0.0.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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