test-framework-th-prime-0.0.10/0000755000000000000000000000000013155424041014452 5ustar0000000000000000test-framework-th-prime-0.0.10/LICENSE0000644000000000000000000000276513155424041015471 0ustar0000000000000000Copyright (c) 2012, IIJ Innovation Institute Inc. 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 the copyright holders nor the names of its 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. test-framework-th-prime-0.0.10/Setup.hs0000644000000000000000000000005613155424041016107 0ustar0000000000000000import Distribution.Simple main = defaultMain test-framework-th-prime-0.0.10/test-framework-th-prime.cabal0000644000000000000000000000207713155424041022141 0ustar0000000000000000Name: test-framework-th-prime Version: 0.0.10 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Synopsis: Template Haskell for test framework Description: Automatically generates a Test list for HUnit, doctest and QuickCheck2. Category: Testing Cabal-Version: >= 1.6 Build-Type: Simple Library if impl(ghc >= 6.12) GHC-Options: -Wall -fno-warn-unused-do-bind else GHC-Options: -Wall Exposed-Modules: Test.Framework.TH.Prime Other-Modules: Test.Framework.TH.Prime.Parser Build-Depends: base >= 4 && < 5 , cpphs >= 0.2.1 , haskell-src-exts , template-haskell , test-framework Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/test-framework-th-prime.git test-framework-th-prime-0.0.10/Test/0000755000000000000000000000000013155424041015371 5ustar0000000000000000test-framework-th-prime-0.0.10/Test/Framework/0000755000000000000000000000000013155424041017326 5ustar0000000000000000test-framework-th-prime-0.0.10/Test/Framework/TH/0000755000000000000000000000000013155424041017641 5ustar0000000000000000test-framework-th-prime-0.0.10/Test/Framework/TH/Prime.hs0000644000000000000000000001010013155424041021241 0ustar0000000000000000{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell #-} -- | -- Template Haskell to generate defaultMain with a list of "Test" from -- \"doc_test\", \"case_\\", and \"prop_\\". -- -- An example of source code (Data/MySet.hs): -- -- > {-| Creating a set from a list. O(N log N) -- > -- > >>> empty == fromList [] -- > True -- > >>> singleton 'a' == fromList ['a'] -- > True -- > >>> fromList [5,3,5] == fromList [5,3] -- > True -- > -} -- > -- > fromList :: Ord a => [a] -> RBTree a -- > fromList = foldl' (flip insert) empty -- -- An example of test code in the src directory (test/Test.hs): -- -- > {-# LANGUAGE TemplateHaskell #-} -- > module Main where -- > -- > import Test.Framework.TH.Prime -- > import Test.Framework.Providers.DocTest -- > import Test.Framework.Providers.HUnit -- > import Test.Framework.Providers.QuickCheck2 -- > import Test.QuickCheck2 -- > import Test.HUnit -- > -- > import Data.MySet -- > -- > main :: IO () -- > main = $(defaultMainGenerator) -- > -- > doc_test :: DocTests -- > doc_test = docTest ["../Data/MySet.hs"] ["-i.."] -- > -- > prop_toList :: [Int] -> Bool -- > prop_toList xs = ordered ys -- > where -- > ys = toList . fromList $ xs -- > ordered (x:y:xys) = x <= y && ordered (y:xys) -- > ordered _ = True -- > -- > case_ticket4242 :: Assertion -- > case_ticket4242 = (valid $ deleteMin $ deleteMin $ fromList [0,2,5,1,6,4,8,9,7,11,10,3]) @?= True -- -- And run: -- -- > test% runghc -i.. Test.hs -- -- "defaultMainGenerator" generates the following: -- -- > 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. module Test.Framework.TH.Prime ( defaultMainGenerator , DocTests ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif 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 ---------------------------------------------------------------- -- | Type for \"doc_test\". type DocTests = IO Test ---------------------------------------------------------------- {-| Generating defaultMain with a list of "Test" from \"doc_test\", \"case_\\", and \"prop_\\". -} defaultMainGenerator :: ExpQ defaultMainGenerator = do defined <- isDefined docTestKeyword 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 = return False `recover` do #if MIN_VERSION_template_haskell(2, 11, 0) VarI (Name _ flavour) _ _ <- reify (mkName n) #else VarI (Name _ flavour) _ _ _ <- reify (mkName n) #endif modul <- loc_module <$> location case flavour of NameG ns _ mdl -> return (ns == VarName && modString mdl == modul) _ -> return False ---------------------------------------------------------------- docTestKeyword :: String docTestKeyword = "doc_test" docTests :: ExpQ docTests = return $ symbol docTestKeyword test-framework-th-prime-0.0.10/Test/Framework/TH/Prime/0000755000000000000000000000000013155424041020715 5ustar0000000000000000test-framework-th-prime-0.0.10/Test/Framework/TH/Prime/Parser.hs0000644000000000000000000000750013155424041022507 0ustar0000000000000000{-# LANGUAGE CPP #-} 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 #if MIN_VERSION_haskell_src_exts(1, 18, 0) import Language.Haskell.Exts.SrcLoc #endif import Language.Haskell.Exts.Syntax hiding (VarName, Exp) import Language.Haskell.TH hiding (Match, Extension (..)) import Language.Preprocessor.Cpphs hiding (Ident) #if MIN_VERSION_haskell_src_exts(1, 18, 0) -- location field for haskell-src-exts-1.18 #define L SrcSpanInfo #define loc _ #else #define L #define loc #endif ---------------------------------------------------------------- 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 #if MIN_VERSION_haskell_src_exts(1, 18, 0) ParseOk (Module _ _ _ _ decls) <- parseTest file #else ParseOk (Module _ _ _ _ _ _ decls) <- parseTest file #endif 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 L)) parseTest file = do raw <- readFile file parseModuleWithMode (opt raw) . pack <$> go raw where pack = unlines . tail . map snd go = cppIfdef "dummy" [] [] defaultBoolOptions exts raw = case getTopPragmas raw of ParseOk pragmas -> [ toExtention name | LanguagePragma _ names <- pragmas, name <- names] ParseFailed _ _ -> [] where #if MIN_VERSION_haskell_src_exts(1, 14, 0) toExtention = parseExtension . toStr #else toExtention = read . toStr #endif toStr (Ident loc str) = str toStr (Symbol loc str) = str opt raw = defaultParseMode { #if MIN_VERSION_haskell_src_exts(1, 14, 0) extensions = nub $ EnableExtension TemplateHaskell : exts raw #else extensions = nub $ TemplateHaskell : exts raw #endif -- to prevent "Ambiguous infix expression" , fixities = Nothing } ---------------------------------------------------------------- isFunBind :: Decl L -> Bool isFunBind (FunBind loc _) = True isFunBind _ = False isPatBind :: Decl L -> Bool isPatBind PatBind{} = True isPatBind _ = False fromPatBind :: Decl L -> String #if MIN_VERSION_haskell_src_exts(1, 16, 0) fromPatBind (PatBind _ (PVar loc (Ident loc name)) _ _) = name fromPatBind (PatBind _ (PVar loc (Symbol loc name)) _ _) = name #else fromPatBind (PatBind _ (PVar (Ident name)) _ _ _) = name fromPatBind (PatBind _ (PVar (Symbol name)) _ _ _) = name #endif fromPatBind _ = error "fromPatBind" fromFunBind :: Decl L -> String #if MIN_VERSION_haskell_src_exts(1, 18, 0) fromFunBind (FunBind _floc (Match _ (Ident _iloc name) _ _ _:_)) = name fromFunBind (FunBind _floc (Match _ (Symbol _sloc name) _ _ _:_)) = name #else fromFunBind (FunBind (Match _ (Ident name) _ _ _ _:_)) = name fromFunBind (FunBind (Match _ (Symbol name) _ _ _ _:_)) = name #endif fromFunBind _ = error "fromFunBind"