{-# LANGUAGE 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

  The spaces of comment symbols are due to limitation of haddock.

  An example of test code in the src directory (test/Test.hs):

  > 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

  This code is based on Test.Framework.TH by Oscar Finnsson and Emil Nordling
  and the author integrated doctest.

  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

import Language.Haskell.Extract
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Test.Framework (defaultMain)
import Test.Framework.Providers.API

----------------------------------------------------------------

-- | 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 <- $(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)

----------------------------------------------------------------
-- code from Hiromi Ishii

isDefined :: String -> Q Bool
isDefined n = do
  return False  `recover` do
    VarI (Name _ flavour) _ _ _ <- reify (mkName n)
    loc <- location
    case flavour of
      NameG ns _ mdl -> return (ns == VarName && modString mdl == loc_module loc)
      _              -> return False

----------------------------------------------------------------

docTestKeyword :: String
docTestKeyword = "doc_test"

docListGenerator :: ExpQ
docListGenerator = varE $ mkName docTestKeyword