{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell #-} -- | -- Template Haskell to generate defaultMain with a list of "Test" from -- \"doc_test\", \"case_\<somthing\>\", and \"prop_\<somthing\>\". -- -- 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_\<somthing\>\", and \"prop_\<somthing\>\". -} defaultMainGenerator :: ExpQ defaultMainGenerator :: ExpQ defaultMainGenerator = do Bool defined <- String -> Q Bool isDefined String docTestKeyword if Bool 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 :: String -> Q Bool isDefined n :: String n = Bool -> Q Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool False Q Bool -> Q Bool -> Q Bool forall a. Q a -> Q a -> Q a `recover` do #if MIN_VERSION_template_haskell(2, 11, 0) VarI (Name _ flavour :: NameFlavour flavour) _ _ <- Name -> Q Info reify (String -> Name mkName String n) #else VarI (Name _ flavour) _ _ _ <- reify (mkName n) #endif String modul <- Loc -> String loc_module (Loc -> String) -> Q Loc -> Q String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Q Loc location case NameFlavour flavour of NameG ns :: NameSpace ns _ mdl :: ModName mdl -> Bool -> Q Bool forall (m :: * -> *) a. Monad m => a -> m a return (NameSpace ns NameSpace -> NameSpace -> Bool forall a. Eq a => a -> a -> Bool == NameSpace VarName Bool -> Bool -> Bool && ModName -> String modString ModName mdl String -> String -> Bool forall a. Eq a => a -> a -> Bool == String modul) _ -> Bool -> Q Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool False ---------------------------------------------------------------- docTestKeyword :: String docTestKeyword :: String docTestKeyword = "doc_test" docTests :: ExpQ docTests :: ExpQ docTests = Exp -> ExpQ forall (m :: * -> *) a. Monad m => a -> m a return (Exp -> ExpQ) -> Exp -> ExpQ forall a b. (a -> b) -> a -> b $ String -> Exp symbol String docTestKeyword