-----------------------------------------------------------------------------
--
-- Module      :  MainTestGenerator
-- Copyright   :  
-- License     :  BSD4
--
-- Maintainer  :  Oscar Finnsson
-- Stability   :  
-- Portability :  
--
-- 
-----------------------------------------------------------------------------
{-# OPTIONS_GHC -XTemplateHaskell #-}

module Test.Framework.TH (
  defaultMainGenerator,
  defaultMainGenerator2,
  testGroupGenerator
) where
import Language.Haskell.TH
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Syntax
import Text.Regex.Posix
import Data.Maybe
import Language.Haskell.Exts.Extension
import Language.Haskell.Extract 

import Test.Framework (defaultMain, testGroup)

-- | Generate the usual code and extract the usual functions needed in order to run HUnit/Quickcheck/Quickcheck2.
--   All functions beginning with case_, prop_ or test_ will be extracted.
--  
--   > {-# OPTIONS_GHC -fglasgow-exts -XTemplateHaskell #-}
--   > module MyModuleTest where
--   > import Test.HUnit
--   > import MainTestGenerator
--   > 
--   > main = $(defaultMainGenerator)
--   >
--   > case_Foo = do 4 @=? 4
--   >
--   > case_Bar = do "hej" @=? "hej"
--   > 
--   > prop_Reverse xs = reverse (reverse xs) == xs
--   >   where types = xs :: [Int]
--   >
--   > test_Group =
--   >     [ testCase "1" case_Foo
--   >     , testProperty "2" prop_Reverse
--   >     ]
--   
--   will automagically extract prop_Reverse, case_Foo, case_Bar and test_Group and run them as well as present them as belonging to the testGroup 'MyModuleTest' such as
--
--   > me: runghc MyModuleTest.hs 
--   > MyModuleTest:
--   >   Reverse: [OK, passed 100 tests]
--   >   Foo: [OK]
--   >   Bar: [OK]
--   >   Group:
--   >     1: [OK]
--   >     2: [OK, passed 100 tests]
--   > 
--   >          Properties  Test Cases   Total       
--   >  Passed  2           3            5          
--   >  Failed  0           0            0           
--   >  Total   2           3            5
 
--   
defaultMainGenerator :: ExpQ
defaultMainGenerator :: ExpQ
defaultMainGenerator = 
  [| defaultMain [ testGroup $(locationModule) $ $(propListGenerator) ++ $(caseListGenerator) ++ $(testListGenerator) ] |]

defaultMainGenerator2 :: ExpQ
defaultMainGenerator2 :: ExpQ
defaultMainGenerator2 = 
  [| defaultMain [ testGroup $(locationModule) $ $(caseListGenerator) ++ $(propListGenerator) ++ $(testListGenerator) ] |]

-- | Generate the usual code and extract the usual functions needed for a testGroup in HUnit/Quickcheck/Quickcheck2.
--   All functions beginning with case_, prop_ or test_ will be extracted.
--  
--   > -- file SomeModule.hs
--   > fooTestGroup = $(testGroupGenerator)
--   > main = defaultMain [fooTestGroup]
--   > case_1 = do 1 @=? 1
--   > case_2 = do 2 @=? 2
--   > prop_p xs = reverse (reverse xs) == xs
--   >  where types = xs :: [Int]
--   
--   is the same as
--
--   > -- file SoomeModule.hs
--   > fooTestGroup = testGroup "SomeModule" [testProperty "p" prop_1, testCase "1" case_1, testCase "2" case_2]
--   > main = defaultMain [fooTestGroup]
--   > case_1 = do 1 @=? 1
--   > case_2 = do 2 @=? 2
--   > prop_1 xs = reverse (reverse xs) == xs
--   >  where types = xs :: [Int]
--
testGroupGenerator :: ExpQ
testGroupGenerator :: ExpQ
testGroupGenerator =
  [| testGroup $(locationModule) $ $(propListGenerator) ++ $(caseListGenerator) ++ $(testListGenerator) |]

listGenerator :: String -> String -> ExpQ
listGenerator :: String -> String -> ExpQ
listGenerator beginning :: String
beginning funcName :: String
funcName =
  String -> ExpQ -> ExpQ
functionExtractorMap String
beginning (String -> ExpQ
applyNameFix String
funcName)

propListGenerator :: ExpQ
propListGenerator :: ExpQ
propListGenerator = String -> String -> ExpQ
listGenerator "^prop_" "testProperty"

caseListGenerator :: ExpQ
caseListGenerator :: ExpQ
caseListGenerator = String -> String -> ExpQ
listGenerator "^case_" "testCase"

testListGenerator :: ExpQ
testListGenerator :: ExpQ
testListGenerator = String -> String -> ExpQ
listGenerator "^test_" "testGroup"

-- | The same as
--   e.g. \n f -> testProperty (fixName n) f
applyNameFix :: String -> ExpQ
applyNameFix :: String -> ExpQ
applyNameFix n :: String
n =
  do Exp
fn <- [|fixName|]
     Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP (String -> Name
mkName "n")] (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
n)) (Exp -> Exp -> Exp
AppE (Exp
fn) (Name -> Exp
VarE (String -> Name
mkName "n"))))

fixName :: String -> String
fixName :: String -> String
fixName name :: String
name = Char -> Char -> String -> String
forall a. Eq a => a -> a -> [a] -> [a]
replace '_' ' ' (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop 5 String
name

replace :: Eq a => a -> a -> [a] -> [a]
replace :: a -> a -> [a] -> [a]
replace b :: a
b v :: a
v = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\i :: a
i -> if a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i then a
v else a
i)