Preprocessor.hs

{-# LANGUAGE ScopedTypeVariables #-}

--
-- Copyright (c) 2009   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

module Test.Framework.Preprocessor ( transform, progName ) where

import Data.Maybe ( mapMaybe )
import Data.List ( intercalate )
import System.IO ( hPutStrLn, stderr )
import Language.Preprocessor.Cpphs ( runCpphs,
                                     CpphsOptions(..),
                                     defaultCpphsOptions)

import Test.Framework.HaskellParser
import Test.Framework.Location

progName :: String
progName = "htfpp"

htfModule :: String
htfModule = "Test.Framework"

testDeclName :: String
testDeclName = "allHTFTests"

assertDefines :: String -> [(String, String)]
assertDefines prefix =
    map (\s -> (s, "(" ++ prefix ++ s ++ "_ (" ++
                   prefix ++ "makeLoc __FILE__ __LINE__))"))
        ["assertBool"
        ,"assertEqual"
        ,"assertEqualP"
        ,"assertEqualNoShow"
        ,"assertSetEqual"
        ,"assertEmpty"
        ,"assertNotEmpty"
        ,"assertThrows"
        ,"assertThrowsSome"
        ,"assertLeft"
        ,"assertLeftNoShow"
        ,"assertRight"
        ,"assertRightNoShow"
        ,"assertJust"
        ]

warn :: String -> IO ()
warn s =
    hPutStrLn stderr $ progName ++ " warning: " ++ s

data ModuleInfo = ModuleInfo { mi_prefix     :: String
                             , mi_defs       :: [Definition]
                             , mi_moduleName :: String }

data Definition = TestDef String Location String
                | PropDef String Location String

analyse :: FilePath -> String
        -> IO (ParseResult ModuleInfo)
analyse originalFileName s =
    do parseResult <- parse originalFileName s
       case parseResult of
         ParseOK (Module moduleName imports decls) ->
             do -- putStrLn $ show decls
                let defs = mapMaybe defFromDecl decls
                htfPrefix <-
                  case mapMaybe prefixFromImport imports of
                    (s:_) -> return s
                    [] -> do warn ("No import found for " ++ htfModule ++
                                   " in " ++ originalFileName)
                             return (htfModule ++ ".")
                return $ ParseOK (ModuleInfo htfPrefix defs moduleName)
         ParseError loc err -> return (ParseError loc err)
    where
      prefixFromImport :: ImportDecl -> Maybe String
      prefixFromImport (ImportDecl s qualified alias)
          | s == htfModule =
              if qualified
                  then case alias of
                         Just s' -> Just $ s' ++ "."
                         Nothing -> Just $ s ++ "."
                  else Just ""
      prefixFromImport _ = Nothing
      defFromDecl :: Decl -> Maybe Definition
      defFromDecl (Decl loc name) = defFromNameAndLoc name loc
      defFromNameAndLoc :: Name -> Location -> Maybe Definition
      defFromNameAndLoc name loc =
          case name of
            ('t':'e':'s':'t':'_':rest) | not (null rest) ->
                Just (TestDef rest loc name)
            ('p':'r':'o':'p':'_':rest) | not (null rest) ->
                Just (PropDef rest loc name)
            _ -> Nothing

transform :: FilePath -> String -> IO String
transform originalFileName input =
    do analyseResult <- analyse originalFileName input
       case analyseResult of
         ParseError loc err ->
             do warn ("Parsing of " ++ originalFileName ++ " failed at line "
                      ++ show (lineNumber loc) ++ ": " ++ err)
                preprocess (ModuleInfo "" [] "UNKNOWN_MODULE")
         ParseOK info ->
             preprocess info
    where
      preprocess :: ModuleInfo -> IO String
      preprocess info =
          do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName
                                           input
             return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n"
      cpphsOptions :: ModuleInfo -> CpphsOptions
      cpphsOptions info =
          defaultCpphsOptions { defines =
                                    defines defaultCpphsOptions ++
                                            assertDefines (mi_prefix info)
                              }
      additionalCode :: ModuleInfo -> String
      additionalCode info =
          testDeclName ++ " :: " ++ mi_prefix info ++ "TestSuite\n" ++
          testDeclName ++ " = " ++ mi_prefix info ++ "makeTestSuite" ++
          " " ++ show (mi_moduleName info) ++
          " [\n    " ++ intercalate ",\n    "
                          (map (codeForDef (mi_prefix info)) (mi_defs info))
          ++ "\n  ]"
      codeForDef :: String -> Definition -> String
      codeForDef pref (TestDef s loc name) =
          pref ++ "makeUnitTest " ++ (show s) ++ " " ++ codeForLoc pref loc ++
          " " ++ name
      codeForDef pref (PropDef s loc name) =
          pref ++ "makeQuickCheckTest " ++ (show s) ++ " " ++
          codeForLoc pref loc ++ " (" ++ pref ++ "testableAsAssertion (" ++
          pref ++ "asTestableWithQCArgs " ++ name ++ "))"
      codeForLoc :: String -> Location -> String
      codeForLoc pref loc = "(" ++ pref ++ "makeLoc " ++ show (fileName loc) ++
                            " " ++ show (lineNumber loc) ++ ")"