{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PackageImports #-}

--
-- Copyright (c) 2009-2014 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, preprocessorTests, TransformOptions(..)

) where

-- import Debug.Trace
import Control.Monad
import Data.Char
import Language.Preprocessor.Cpphs ( runCpphsPass1,
                                     runCpphsPass2,
                                     CpphsOptions(..),
                                     BoolOptions(..),
                                     defaultCpphsOptions,
                                     WordStyle(..),
                                     Posn,
                                     filename,
                                     lineno,
                                     newfile,
                                     tokenise
                                   )
import System.IO ( hPutStrLn, stderr )
#if MIN_VERSION_HUnit(1,4,0)
import Test.HUnit hiding (State)
#else
import Test.HUnit hiding (State, Location)
#endif
import Control.Monad.State.Strict
import qualified Data.List as List
import Data.Maybe

import Test.Framework.Location

_DEBUG_ :: Bool
_DEBUG_ :: Bool
_DEBUG_ = Bool
False

progName :: String
progName :: String
progName = String
"htfpp"

htfModule :: String
htfModule :: String
htfModule = String
"Test.Framework"

mkName :: String -> String -> String
mkName String
varName String
fullModuleName =
    String
"htf_" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'_' else Char
c)
        (String
fullModuleName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++
         (case String
varName of
            Char
'h':Char
't':Char
'f':Char
'_':String
s -> String
s
            String
s -> String
s))

thisModulesTestsFullName :: String -> String
thisModulesTestsFullName :: String -> String
thisModulesTestsFullName = String -> String -> String
mkName String
thisModulesTestsName

importedTestListFullName :: String -> String
importedTestListFullName :: String -> String
importedTestListFullName = String -> String -> String
mkName String
importedTestListName

thisModulesTestsName :: String
thisModulesTestsName :: String
thisModulesTestsName = String
"htf_thisModulesTests"

importedTestListName :: String
importedTestListName :: String
importedTestListName = String
"htf_importedTests"

nameDefines :: ModuleInfo -> [(String, String)]
nameDefines :: ModuleInfo -> [(String, String)]
nameDefines ModuleInfo
info =
    [(String
thisModulesTestsName, String -> String
thisModulesTestsFullName (ModuleInfo -> String
mi_moduleNameWithDefault ModuleInfo
info)),
     (String
importedTestListName, String -> String
importedTestListFullName (ModuleInfo -> String
mi_moduleNameWithDefault ModuleInfo
info))]

allAsserts :: [String]
allAsserts :: [String]
allAsserts =
    [String] -> [String]
forall (t :: * -> *). Foldable t => t String -> [String]
withGs [String
"assertBool"
           ,String
"assertEqual"
           ,String
"assertEqualPretty"
           ,String
"assertEqualNoShow"
           ,String
"assertNotEqual"
           ,String
"assertNotEqualPretty"
           ,String
"assertNotEqualNoShow"
           ,String
"assertListsEqualAsSets"
           ,String
"assertElem"
           ,String
"assertEmpty"
           ,String
"assertNotEmpty"
           ,String
"assertLeft"
           ,String
"assertLeftNoShow"
           ,String
"assertRight"
           ,String
"assertRightNoShow"
           ,String
"assertJust"
           ,String
"assertNothing"
           ,String
"assertNothingNoShow"
           ,String
"subAssert"
           ,String
"subAssertVerbose"
           ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"assertThrows"
                ,String
"assertThrowsSome"
                ,String
"assertThrowsIO"
                ,String
"assertThrowsSomeIO"
                ,String
"assertThrowsM"
                ,String
"assertThrowsSomeM"]
    where
      withGs :: t String -> [String]
withGs t String
l =
          (String -> [String]) -> t String -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\String
s -> [String
s, Char
'g'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s]) t String
l

assertDefines :: Bool -> String -> [(String, String)]
assertDefines :: Bool -> String -> [(String, String)]
assertDefines Bool
hunitBackwardsCompat String
prefix =
    (String -> [(String, String)]) -> [String] -> [(String, String)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [(String, String)]
fun [String]
allAsserts [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
"assertFailure", String -> String -> String
expansion String
"assertFailure" String
"_")]
    where
      fun :: String -> [(String, String)]
fun String
a =
          if Bool
hunitBackwardsCompat
             then [(String
a, String -> String -> String
expansion String
a String
"Verbose_"), (String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"HTF", String -> String -> String
expansion String
a String
"_")]
             else [(String
a, String -> String -> String
expansion String
a String
"_"), (String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Verbose", String -> String -> String
expansion String
a String
"Verbose_")]
      expansion :: String -> String -> String
expansion String
a String
suffix = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suffix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                           String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"makeLoc __FILE__ __LINE__))"

data ModuleInfo = ModuleInfo { ModuleInfo -> String
mi_htfPrefix  :: String
                             , ModuleInfo -> [ImportDecl]
mi_htfImports :: [ImportDecl]
                             , ModuleInfo -> [Definition]
mi_defs       :: [Definition]
                             , ModuleInfo -> Maybe String
mi_moduleName :: Maybe String }
                  deriving (Int -> ModuleInfo -> String -> String
[ModuleInfo] -> String -> String
ModuleInfo -> String
(Int -> ModuleInfo -> String -> String)
-> (ModuleInfo -> String)
-> ([ModuleInfo] -> String -> String)
-> Show ModuleInfo
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ModuleInfo] -> String -> String
$cshowList :: [ModuleInfo] -> String -> String
show :: ModuleInfo -> String
$cshow :: ModuleInfo -> String
showsPrec :: Int -> ModuleInfo -> String -> String
$cshowsPrec :: Int -> ModuleInfo -> String -> String
Show, ModuleInfo -> ModuleInfo -> Bool
(ModuleInfo -> ModuleInfo -> Bool)
-> (ModuleInfo -> ModuleInfo -> Bool) -> Eq ModuleInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleInfo -> ModuleInfo -> Bool
$c/= :: ModuleInfo -> ModuleInfo -> Bool
== :: ModuleInfo -> ModuleInfo -> Bool
$c== :: ModuleInfo -> ModuleInfo -> Bool
Eq)

mi_moduleNameWithDefault :: ModuleInfo -> String
mi_moduleNameWithDefault :: ModuleInfo -> String
mi_moduleNameWithDefault = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"Main" (Maybe String -> String)
-> (ModuleInfo -> Maybe String) -> ModuleInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleInfo -> Maybe String
mi_moduleName

data ImportDecl = ImportDecl { ImportDecl -> String
imp_moduleName :: Name
                             , ImportDecl -> Bool
imp_qualified :: Bool
                             , ImportDecl -> Maybe String
imp_alias :: Maybe Name
                             , ImportDecl -> Location
imp_loc :: Location }
                  deriving (Int -> ImportDecl -> String -> String
[ImportDecl] -> String -> String
ImportDecl -> String
(Int -> ImportDecl -> String -> String)
-> (ImportDecl -> String)
-> ([ImportDecl] -> String -> String)
-> Show ImportDecl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ImportDecl] -> String -> String
$cshowList :: [ImportDecl] -> String -> String
show :: ImportDecl -> String
$cshow :: ImportDecl -> String
showsPrec :: Int -> ImportDecl -> String -> String
$cshowsPrec :: Int -> ImportDecl -> String -> String
Show, ImportDecl -> ImportDecl -> Bool
(ImportDecl -> ImportDecl -> Bool)
-> (ImportDecl -> ImportDecl -> Bool) -> Eq ImportDecl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportDecl -> ImportDecl -> Bool
$c/= :: ImportDecl -> ImportDecl -> Bool
== :: ImportDecl -> ImportDecl -> Bool
$c== :: ImportDecl -> ImportDecl -> Bool
Eq)

data Definition = TestDef String Location String
                | PropDef String Location String
                  deriving (Definition -> Definition -> Bool
(Definition -> Definition -> Bool)
-> (Definition -> Definition -> Bool) -> Eq Definition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Definition -> Definition -> Bool
$c/= :: Definition -> Definition -> Bool
== :: Definition -> Definition -> Bool
$c== :: Definition -> Definition -> Bool
Eq, Int -> Definition -> String -> String
[Definition] -> String -> String
Definition -> String
(Int -> Definition -> String -> String)
-> (Definition -> String)
-> ([Definition] -> String -> String)
-> Show Definition
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Definition] -> String -> String
$cshowList :: [Definition] -> String -> String
show :: Definition -> String
$cshow :: Definition -> String
showsPrec :: Int -> Definition -> String -> String
$cshowsPrec :: Int -> Definition -> String -> String
Show)

type Name = String

type PMA a = State ModuleInfo a

setModName :: String -> PMA ()
setModName :: String -> PMA ()
setModName String
name =
    do Maybe String
oldName <- (ModuleInfo -> Maybe String)
-> StateT ModuleInfo Identity (Maybe String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ModuleInfo -> Maybe String
mi_moduleName
       Bool -> PMA () -> PMA ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
oldName) (PMA () -> PMA ()) -> PMA () -> PMA ()
forall a b. (a -> b) -> a -> b
$ (ModuleInfo -> ModuleInfo) -> PMA ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ModuleInfo -> ModuleInfo) -> PMA ())
-> (ModuleInfo -> ModuleInfo) -> PMA ()
forall a b. (a -> b) -> a -> b
$ \ModuleInfo
mi -> ModuleInfo
mi { mi_moduleName :: Maybe String
mi_moduleName = String -> Maybe String
forall a. a -> Maybe a
Just String
name }

addTestDef :: String -> String -> Location -> PMA ()
addTestDef :: String -> String -> Location -> PMA ()
addTestDef String
name String
fullName Location
loc =
    (ModuleInfo -> ModuleInfo) -> PMA ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ModuleInfo -> ModuleInfo) -> PMA ())
-> (ModuleInfo -> ModuleInfo) -> PMA ()
forall a b. (a -> b) -> a -> b
$ \ModuleInfo
mi -> ModuleInfo
mi { mi_defs :: [Definition]
mi_defs = (String -> Location -> String -> Definition
TestDef String
name Location
loc String
fullName) Definition -> [Definition] -> [Definition]
forall a. a -> [a] -> [a]
: ModuleInfo -> [Definition]
mi_defs ModuleInfo
mi }

addPropDef :: String -> String -> Location -> PMA ()
addPropDef :: String -> String -> Location -> PMA ()
addPropDef String
name String
fullName Location
loc =
    (ModuleInfo -> ModuleInfo) -> PMA ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ModuleInfo -> ModuleInfo) -> PMA ())
-> (ModuleInfo -> ModuleInfo) -> PMA ()
forall a b. (a -> b) -> a -> b
$ \ModuleInfo
mi -> ModuleInfo
mi { mi_defs :: [Definition]
mi_defs = (String -> Location -> String -> Definition
PropDef String
name Location
loc String
fullName) Definition -> [Definition] -> [Definition]
forall a. a -> [a] -> [a]
: ModuleInfo -> [Definition]
mi_defs ModuleInfo
mi }

addHtfImport :: ImportDecl -> PMA ()
addHtfImport :: ImportDecl -> PMA ()
addHtfImport ImportDecl
decl =
    (ModuleInfo -> ModuleInfo) -> PMA ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ModuleInfo -> ModuleInfo) -> PMA ())
-> (ModuleInfo -> ModuleInfo) -> PMA ()
forall a b. (a -> b) -> a -> b
$ \ModuleInfo
mi -> ModuleInfo
mi { mi_htfImports :: [ImportDecl]
mi_htfImports = ImportDecl
decl ImportDecl -> [ImportDecl] -> [ImportDecl]
forall a. a -> [a] -> [a]
: ModuleInfo -> [ImportDecl]
mi_htfImports ModuleInfo
mi }

setTestFrameworkImport :: String -> PMA ()
setTestFrameworkImport :: String -> PMA ()
setTestFrameworkImport String
name =
    (ModuleInfo -> ModuleInfo) -> PMA ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ModuleInfo -> ModuleInfo) -> PMA ())
-> (ModuleInfo -> ModuleInfo) -> PMA ()
forall a b. (a -> b) -> a -> b
$ \ModuleInfo
mi -> ModuleInfo
mi { mi_htfPrefix :: String
mi_htfPrefix = String
name }

data Tok
    = TokModule
    | TokQname Location String
    | TokName Location Bool String
    | TokHtfImport Location
    | TokImport Location

transWordStyles :: [WordStyle] -> [Tok]
transWordStyles :: [WordStyle] -> [Tok]
transWordStyles [WordStyle]
styles = [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
styles Bool
True
    where
      loop :: [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
styles Bool
startOfLine =
        case [WordStyle]
styles of
          [] -> []
          Ident Posn
pos String
name : [WordStyle]
rest ->
              case String
name of
                String
"module" -> Tok
TokModule Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
: [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
rest Bool
False
                String
"import" ->
                    case [WordStyle] -> [WordStyle]
dropWhite [WordStyle]
rest of
                      Other String
"{-@ HTF_TESTS @-}" : [WordStyle]
rest2 ->
                          Location -> Tok
TokHtfImport (Posn -> Location
posToLocation Posn
pos) Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
: [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
rest2 Bool
False
                      [WordStyle]
_ ->
                          Location -> Tok
TokImport (Posn -> Location
posToLocation Posn
pos) Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
: [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
rest Bool
False
                String
_ ->
                    case [WordStyle] -> ([String], [WordStyle])
parseQname [WordStyle]
rest of
                      ([], [WordStyle]
rest2) ->
                          Location -> Bool -> String -> Tok
TokName (Posn -> Location
posToLocation Posn
pos) Bool
startOfLine String
name Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
: [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
rest2 Bool
False
                      ([String]
nameParts, [WordStyle]
rest2) ->
                          Location -> String -> Tok
TokQname (Posn -> Location
posToLocation Posn
pos) (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"." (String
nameString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
nameParts)) Tok -> [Tok] -> [Tok]
forall a. a -> [a] -> [a]
: [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
rest2 Bool
False
          Other String
str : [WordStyle]
rest ->
              let startOfLine :: Bool
startOfLine =
                      case String -> String
forall a. [a] -> [a]
reverse String
str of
                        Char
'\n':String
_ -> Bool
True
                        String
_ -> Bool
False
              in [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
rest Bool
startOfLine
          Cmd Maybe HashDefine
_ : [WordStyle]
rest -> [WordStyle] -> Bool -> [Tok]
loop [WordStyle]
rest Bool
False
      dropWhite :: [WordStyle] -> [WordStyle]
dropWhite [WordStyle]
styles =
          case [WordStyle]
styles of
            Other String
str : [WordStyle]
rest ->
                case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
str of
                  [] -> [WordStyle] -> [WordStyle]
dropWhite [WordStyle]
rest
                  String
str' -> String -> WordStyle
Other String
str' WordStyle -> [WordStyle] -> [WordStyle]
forall a. a -> [a] -> [a]
: [WordStyle]
rest
            [WordStyle]
_ -> [WordStyle]
styles
      parseQname :: [WordStyle] -> ([String], [WordStyle])
parseQname [WordStyle]
styles =
          case [WordStyle]
styles of
            Other String
"." : Ident Posn
_ String
name : [WordStyle]
rest ->
                let ([String]
restParts, [WordStyle]
rest2) = [WordStyle] -> ([String], [WordStyle])
parseQname [WordStyle]
rest
                in (String
nameString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
restParts, [WordStyle]
rest2)
            [WordStyle]
_ -> ([], [WordStyle]
styles)
      posToLocation :: Posn -> Location
posToLocation Posn
pos = String -> Int -> Location
makeLoc (Posn -> String
filename Posn
pos) (Posn -> Int
lineno Posn
pos)

poorManAnalyzeTokens :: [WordStyle] -> ModuleInfo
poorManAnalyzeTokens :: [WordStyle] -> ModuleInfo
poorManAnalyzeTokens [WordStyle]
styles =
    let toks :: [Tok]
toks = [WordStyle] -> [Tok]
transWordStyles [WordStyle]
styles
        revRes :: ModuleInfo
revRes =
            PMA () -> ModuleInfo -> ModuleInfo
forall s a. State s a -> s -> s
execState ([Tok] -> PMA ()
loop [Tok]
toks) (ModuleInfo -> ModuleInfo) -> ModuleInfo -> ModuleInfo
forall a b. (a -> b) -> a -> b
$
                      ModuleInfo :: String
-> [ImportDecl] -> [Definition] -> Maybe String -> ModuleInfo
ModuleInfo { mi_htfPrefix :: String
mi_htfPrefix = String
htfModule String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
                                 , mi_htfImports :: [ImportDecl]
mi_htfImports = []
                                 , mi_defs :: [Definition]
mi_defs = []
                                 , mi_moduleName :: Maybe String
mi_moduleName = Maybe String
forall a. Maybe a
Nothing }
    in ModuleInfo :: String
-> [ImportDecl] -> [Definition] -> Maybe String -> ModuleInfo
ModuleInfo { mi_htfPrefix :: String
mi_htfPrefix = ModuleInfo -> String
mi_htfPrefix ModuleInfo
revRes
                  , mi_htfImports :: [ImportDecl]
mi_htfImports = [ImportDecl] -> [ImportDecl]
forall a. [a] -> [a]
reverse (ModuleInfo -> [ImportDecl]
mi_htfImports ModuleInfo
revRes)
                  , mi_defs :: [Definition]
mi_defs = [Definition] -> [Definition]
forall a. [a] -> [a]
reverse ([Definition] -> [Definition]) -> [Definition] -> [Definition]
forall a b. (a -> b) -> a -> b
$ (Definition -> Definition -> Bool) -> [Definition] -> [Definition]
forall a. (a -> a -> Bool) -> [a] -> [a]
List.nubBy Definition -> Definition -> Bool
defEqByName (ModuleInfo -> [Definition]
mi_defs ModuleInfo
revRes)
                  , mi_moduleName :: Maybe String
mi_moduleName = ModuleInfo -> Maybe String
mi_moduleName ModuleInfo
revRes
                  }
    where
      defEqByName :: Definition -> Definition -> Bool
defEqByName (TestDef String
n1 Location
_ String
_) (TestDef String
n2 Location
_ String
_) = String
n1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n2
      defEqByName (PropDef String
n1 Location
_ String
_) (PropDef String
n2 Location
_ String
_) = String
n1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
n2
      defEqByName Definition
_ Definition
_ = Bool
False
      loop :: [Tok] -> PMA ()
loop [Tok]
toks =
        case [Tok]
toks of
          Tok
TokModule : TokQname Location
_ String
name : [Tok]
rest ->
              do String -> PMA ()
setModName String
name
                 [Tok] -> PMA ()
loop [Tok]
rest
          Tok
TokModule : TokName Location
_ Bool
_ String
name : [Tok]
rest ->
              do String -> PMA ()
setModName String
name
                 [Tok] -> PMA ()
loop [Tok]
rest
          TokName Location
loc Bool
startOfLine String
name : [Tok]
rest
              | Bool
startOfLine ->
                  case String
name of
                    Char
't':Char
'e':Char
's':Char
't':Char
'_':String
shortName ->
                        do String -> String -> Location -> PMA ()
addTestDef String
shortName String
name Location
loc
                           [Tok] -> PMA ()
loop [Tok]
rest
                    Char
'p':Char
'r':Char
'o':Char
'p':Char
'_':String
shortName ->
                        do String -> String -> Location -> PMA ()
addPropDef String
shortName String
name Location
loc
                           [Tok] -> PMA ()
loop [Tok]
rest
                    String
_ -> [Tok] -> PMA ()
loop [Tok]
rest
              | Bool
otherwise -> [Tok] -> PMA ()
loop [Tok]
rest
          TokHtfImport Location
loc : [Tok]
rest ->
              case Location -> [Tok] -> Maybe (ImportDecl, [Tok])
forall (m :: * -> *).
MonadFail m =>
Location -> [Tok] -> m (ImportDecl, [Tok])
parseImport Location
loc [Tok]
rest of
                Just (ImportDecl
imp, [Tok]
rest2) ->
                    do ImportDecl -> PMA ()
addHtfImport ImportDecl
imp
                       [Tok] -> PMA ()
loop [Tok]
rest2
                Maybe (ImportDecl, [Tok])
Nothing -> [Tok] -> PMA ()
loop [Tok]
rest
          TokImport Location
loc : [Tok]
rest ->
              do case Location -> [Tok] -> Maybe (ImportDecl, [Tok])
forall (m :: * -> *).
MonadFail m =>
Location -> [Tok] -> m (ImportDecl, [Tok])
parseImport Location
loc [Tok]
rest of
                   Maybe (ImportDecl, [Tok])
Nothing -> [Tok] -> PMA ()
loop [Tok]
rest
                   Just (ImportDecl
imp, [Tok]
rest2) ->
                       do Bool -> PMA () -> PMA ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ImportDecl -> String
imp_moduleName ImportDecl
imp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
htfModule) (PMA () -> PMA ()) -> PMA () -> PMA ()
forall a b. (a -> b) -> a -> b
$
                            let prefix :: String
prefix = case (ImportDecl -> Maybe String
imp_alias ImportDecl
imp, ImportDecl -> Bool
imp_qualified ImportDecl
imp) of
                                           (Just String
alias, Bool
True) -> String
alias
                                           (Maybe String
Nothing, Bool
True) -> ImportDecl -> String
imp_moduleName ImportDecl
imp
                                           (Maybe String, Bool)
_ -> String
""
                            in String -> PMA ()
setTestFrameworkImport
                                   (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
prefix then String
prefix else String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
                          [Tok] -> PMA ()
loop [Tok]
rest2
          Tok
_ : [Tok]
rest -> [Tok] -> PMA ()
loop [Tok]
rest
          [] -> () -> PMA ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      parseImport :: Location -> [Tok] -> m (ImportDecl, [Tok])
parseImport Location
loc [Tok]
toks =
          do let (Bool
qualified, [Tok]
toks2) =
                  case [Tok]
toks of
                    TokName _ _ "qualified" : rest -> (Bool
True, [Tok]
rest)
                    [Tok]
_ -> (Bool
False, [Tok]
toks)
             (String
name, [Tok]
toks3) <-
                  case [Tok]
toks2 of
                    TokName Location
_ Bool
_ String
name : [Tok]
rest -> (String, [Tok]) -> m (String, [Tok])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, [Tok]
rest)
                    TokQname Location
_ String
name : [Tok]
rest -> (String, [Tok]) -> m (String, [Tok])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, [Tok]
rest)
                    [Tok]
_ -> String -> m (String, [Tok])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no import"
             let (Maybe String
mAlias, [Tok]
toks4) =
                   case [Tok]
toks3 of
                     TokName Location
_ Bool
_ String
"as" : TokName Location
_ Bool
_ String
alias : [Tok]
rest -> (String -> Maybe String
forall a. a -> Maybe a
Just String
alias, [Tok]
rest)
                     [Tok]
_ -> (Maybe String
forall a. Maybe a
Nothing, [Tok]
toks3)
                 decl :: ImportDecl
decl = ImportDecl :: String -> Bool -> Maybe String -> Location -> ImportDecl
ImportDecl { imp_moduleName :: String
imp_moduleName = String
name
                                   , imp_qualified :: Bool
imp_qualified = Bool
qualified
                                   , imp_alias :: Maybe String
imp_alias = Maybe String
mAlias
                                   , imp_loc :: Location
imp_loc = Location
loc }
             (ImportDecl, [Tok]) -> m (ImportDecl, [Tok])
forall (m :: * -> *) a. Monad m => a -> m a
return (ImportDecl
decl, [Tok]
toks4)

analyze :: FilePath -> String -> IO (ModuleInfo, [WordStyle], [(Posn,String)])
analyze :: String -> String -> IO (ModuleInfo, [WordStyle], [(Posn, String)])
analyze String
originalFileName String
input =
    do [(Posn, String)]
xs <- CpphsOptions -> String -> String -> IO [(Posn, String)]
runCpphsPass1 CpphsOptions
cpphsOptions String
originalFileName String
input
       let bopts :: BoolOptions
bopts = CpphsOptions -> BoolOptions
boolopts CpphsOptions
cpphsOptions
           toks :: [WordStyle]
toks = Bool -> Bool -> Bool -> Bool -> [(Posn, String)] -> [WordStyle]
tokenise (BoolOptions -> Bool
stripEol BoolOptions
bopts) (BoolOptions -> Bool
stripC89 BoolOptions
bopts) (BoolOptions -> Bool
ansi BoolOptions
bopts) (BoolOptions -> Bool
lang BoolOptions
bopts) ((String -> Posn
newfile String
"preDefined",String
"")(Posn, String) -> [(Posn, String)] -> [(Posn, String)]
forall a. a -> [a] -> [a]
:[(Posn, String)]
xs)
           mi :: ModuleInfo
mi = [WordStyle] -> ModuleInfo
poorManAnalyzeTokens [WordStyle]
toks
       (ModuleInfo, [WordStyle], [(Posn, String)])
-> IO (ModuleInfo, [WordStyle], [(Posn, String)])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleInfo
mi, [WordStyle]
toks, [(Posn, String)]
xs)

analyzeTests :: [(String, ModuleInfo)]
analyzeTests =
    [([String] -> String
unlines [String
"module FOO where"
              ,String
"import Test.Framework"
              ,String
"import {-@ HTF_TESTS @-} qualified Foo as Bar"
              ,String
"import {-@ HTF_TESTS @-} qualified Foo.X as Egg"
              ,String
"import {-@ HTF_TESTS @-} Foo.Y as Spam"
              ,String
"import {-@ HTF_TESTS @-} Foo.Z"
              ,String
"import {-@ HTF_TESTS @-} Baz"
              ,String
"deriveSafeCopy 1 'base ''T"
              ,String
"$(deriveSafeCopy 2 'extension ''T)"
              ,String
"test_blub test_foo = 1"
              ,String
"test_blah test_foo = '\''"
              ,String
"prop_abc prop_foo = 2"
              ,String
"prop_xyz = True"]
     ,ModuleInfo :: String
-> [ImportDecl] -> [Definition] -> Maybe String -> ModuleInfo
ModuleInfo { mi_htfPrefix :: String
mi_htfPrefix = String
""
                 , mi_htfImports :: [ImportDecl]
mi_htfImports =
                     [ImportDecl :: String -> Bool -> Maybe String -> Location -> ImportDecl
ImportDecl { imp_moduleName :: String
imp_moduleName = String
"Foo"
                                 , imp_qualified :: Bool
imp_qualified = Bool
True
                                 , imp_alias :: Maybe String
imp_alias = String -> Maybe String
forall a. a -> Maybe a
Just String
"Bar"
                                 , imp_loc :: Location
imp_loc = String -> Int -> Location
makeLoc String
"<input>" Int
3}
                     ,ImportDecl :: String -> Bool -> Maybe String -> Location -> ImportDecl
ImportDecl { imp_moduleName :: String
imp_moduleName = String
"Foo.X"
                                 , imp_qualified :: Bool
imp_qualified = Bool
True
                                 , imp_alias :: Maybe String
imp_alias = String -> Maybe String
forall a. a -> Maybe a
Just String
"Egg"
                                 , imp_loc :: Location
imp_loc = String -> Int -> Location
makeLoc String
"<input>" Int
4}
                     ,ImportDecl :: String -> Bool -> Maybe String -> Location -> ImportDecl
ImportDecl { imp_moduleName :: String
imp_moduleName = String
"Foo.Y"
                                 , imp_qualified :: Bool
imp_qualified = Bool
False
                                 , imp_alias :: Maybe String
imp_alias = String -> Maybe String
forall a. a -> Maybe a
Just String
"Spam"
                                 , imp_loc :: Location
imp_loc = String -> Int -> Location
makeLoc String
"<input>" Int
5}
                     ,ImportDecl :: String -> Bool -> Maybe String -> Location -> ImportDecl
ImportDecl { imp_moduleName :: String
imp_moduleName = String
"Foo.Z"
                                 , imp_qualified :: Bool
imp_qualified = Bool
False
                                 , imp_alias :: Maybe String
imp_alias = Maybe String
forall a. Maybe a
Nothing
                                 , imp_loc :: Location
imp_loc = String -> Int -> Location
makeLoc String
"<input>" Int
6}
                     ,ImportDecl :: String -> Bool -> Maybe String -> Location -> ImportDecl
ImportDecl { imp_moduleName :: String
imp_moduleName = String
"Baz"
                                 , imp_qualified :: Bool
imp_qualified = Bool
False
                                 , imp_alias :: Maybe String
imp_alias = Maybe String
forall a. Maybe a
Nothing
                                 , imp_loc :: Location
imp_loc = String -> Int -> Location
makeLoc String
"<input>" Int
7}]
                 , mi_moduleName :: Maybe String
mi_moduleName = String -> Maybe String
forall a. a -> Maybe a
Just String
"FOO"
                 , mi_defs :: [Definition]
mi_defs = [String -> Location -> String -> Definition
TestDef String
"blub" (String -> Int -> Location
makeLoc String
"<input>" Int
10) String
"test_blub"
                             ,String -> Location -> String -> Definition
TestDef String
"blah" (String -> Int -> Location
makeLoc String
"<input>" Int
11) String
"test_blah"
                             ,String -> Location -> String -> Definition
PropDef String
"abc" (String -> Int -> Location
makeLoc String
"<input>" Int
12) String
"prop_abc"
                             ,String -> Location -> String -> Definition
PropDef String
"xyz" (String -> Int -> Location
makeLoc String
"<input>" Int
13) String
"prop_xyz"]
                 })
    ,([String] -> String
unlines [String
"module Foo.Bar where"
              ,String
"import Test.Framework as Blub"
              ,String
"prop_xyz = True"]
     ,ModuleInfo :: String
-> [ImportDecl] -> [Definition] -> Maybe String -> ModuleInfo
ModuleInfo { mi_htfPrefix :: String
mi_htfPrefix = String
""
                 , mi_htfImports :: [ImportDecl]
mi_htfImports = []
                 , mi_moduleName :: Maybe String
mi_moduleName = String -> Maybe String
forall a. a -> Maybe a
Just String
"Foo.Bar"
                 , mi_defs :: [Definition]
mi_defs = [String -> Location -> String -> Definition
PropDef String
"xyz" (String -> Int -> Location
makeLoc String
"<input>" Int
3) String
"prop_xyz"]
                 })
    ,([String] -> String
unlines [String
"module Foo.Bar where"
              ,String
"import qualified Test.Framework as Blub"
              ,String
"prop_xyz = True"]
     ,ModuleInfo :: String
-> [ImportDecl] -> [Definition] -> Maybe String -> ModuleInfo
ModuleInfo { mi_htfPrefix :: String
mi_htfPrefix = String
"Blub."
                 , mi_htfImports :: [ImportDecl]
mi_htfImports = []
                 , mi_moduleName :: Maybe String
mi_moduleName = String -> Maybe String
forall a. a -> Maybe a
Just String
"Foo.Bar"
                 , mi_defs :: [Definition]
mi_defs = [String -> Location -> String -> Definition
PropDef String
"xyz" (String -> Int -> Location
makeLoc String
"<input>" Int
3) String
"prop_xyz"]
                 })
    ,([String] -> String
unlines [String
"module Foo.Bar where"
              ,String
"import qualified Test.Framework"
              ,String
"prop_xyz = True"]
     ,ModuleInfo :: String
-> [ImportDecl] -> [Definition] -> Maybe String -> ModuleInfo
ModuleInfo { mi_htfPrefix :: String
mi_htfPrefix = String
"Test.Framework."
                 , mi_htfImports :: [ImportDecl]
mi_htfImports = []
                 , mi_moduleName :: Maybe String
mi_moduleName = String -> Maybe String
forall a. a -> Maybe a
Just String
"Foo.Bar"
                 , mi_defs :: [Definition]
mi_defs = [String -> Location -> String -> Definition
PropDef String
"xyz" (String -> Int -> Location
makeLoc String
"<input>" Int
3) String
"prop_xyz"]
                 })]

testAnalyze :: IO ()
testAnalyze =
    do ((Integer, (String, ModuleInfo)) -> IO ())
-> [(Integer, (String, ModuleInfo))] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Integer, (String, ModuleInfo)) -> IO ()
forall a. Show a => (a, (String, ModuleInfo)) -> IO ()
runTest ([Integer]
-> [(String, ModuleInfo)] -> [(Integer, (String, ModuleInfo))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [(String, ModuleInfo)]
analyzeTests)
    where
      runTest :: (a, (String, ModuleInfo)) -> IO ()
runTest (a
i, (String
src, ModuleInfo
mi)) =
          do (ModuleInfo
givenMi, [WordStyle]
_, [(Posn, String)]
_) <- String -> String -> IO (ModuleInfo, [WordStyle], [(Posn, String)])
analyze String
"<input>" String
src
             if ModuleInfo
givenMi ModuleInfo -> ModuleInfo -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleInfo
mi
             then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             else String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String
"Error in test " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 String
", expected:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleInfo -> String
forall a. Show a => a -> String
show ModuleInfo
mi String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 String
"\nGiven:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleInfo -> String
forall a. Show a => a -> String
show ModuleInfo
givenMi String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                 String
"\nSrc:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
src)

cpphsOptions :: CpphsOptions
cpphsOptions :: CpphsOptions
cpphsOptions =
    CpphsOptions
defaultCpphsOptions {
      boolopts :: BoolOptions
boolopts = (CpphsOptions -> BoolOptions
boolopts CpphsOptions
defaultCpphsOptions) { lang :: Bool
lang = Bool
True } -- lex as haskell
    }

data TransformOptions = TransformOptions { TransformOptions -> Bool
hunitBackwardsCompat :: Bool
                                         , TransformOptions -> Bool
debug :: Bool
                                         , TransformOptions -> Bool
literateTex :: Bool }

transform :: TransformOptions -> FilePath -> String -> IO String
transform :: TransformOptions -> String -> String -> IO String
transform (TransformOptions Bool
hunitBackwardsCompat Bool
debug Bool
literateTex) String
originalFileName String
input =
    do (ModuleInfo
info, [WordStyle]
toks, [(Posn, String)]
pass1) <- String -> String -> IO (ModuleInfo, [WordStyle], [(Posn, String)])
analyze String
originalFileName String
fixedInput
       ModuleInfo -> [WordStyle] -> [(Posn, String)] -> IO String
forall a.
Show a =>
ModuleInfo -> a -> [(Posn, String)] -> IO String
preprocess ModuleInfo
info [WordStyle]
toks [(Posn, String)]
pass1
    where
      preprocess :: ModuleInfo -> a -> [(Posn, String)] -> IO String
preprocess ModuleInfo
info a
toks [(Posn, String)]
pass1 =
          do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  do Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Tokens: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
toks)
                     Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"Module info:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleInfo -> String
forall a. Show a => a -> String
show ModuleInfo
info)
             let opts :: CpphsOptions
opts = ModuleInfo -> CpphsOptions
mkOptionsForModule ModuleInfo
info
             String
preProcessedInput <-
                 BoolOptions
-> [(String, String)] -> String -> [(Posn, String)] -> IO String
runCpphsPass2 (CpphsOptions -> BoolOptions
boolopts CpphsOptions
opts) (CpphsOptions -> [(String, String)]
defines CpphsOptions
opts) String
originalFileName [(Posn, String)]
pass1
             String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
preProcessedInput String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> String -> String
possiblyWrap Bool
literateTex (ModuleInfo -> String
additionalCode ModuleInfo
info) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      -- fixedInput serves two purposes:
      -- 1. add a trailing \n
      -- 2. turn lines of the form '# <number> "<filename>"' into line directives '#line <number> <filename>'
      -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output).
      fixedInput :: String
      fixedInput :: String
fixedInput = ([String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
fixLine ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
input
          where
            fixLine :: String -> String
fixLine String
s =
                case String -> Maybe (String, String)
parseCppLineInfoOut String
s of
                  Just (String
line, String
fileName) -> String
"#line " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fileName
                  Maybe (String, String)
_ -> String
s
      mkOptionsForModule :: ModuleInfo -> CpphsOptions
      mkOptionsForModule :: ModuleInfo -> CpphsOptions
mkOptionsForModule ModuleInfo
info =
          CpphsOptions
defaultCpphsOptions { defines :: [(String, String)]
defines =
                                    CpphsOptions -> [(String, String)]
defines CpphsOptions
defaultCpphsOptions [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++
                                    Bool -> String -> [(String, String)]
assertDefines Bool
hunitBackwardsCompat (ModuleInfo -> String
mi_htfPrefix ModuleInfo
info) [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++
                                    ModuleInfo -> [(String, String)]
nameDefines ModuleInfo
info
                              , boolopts :: BoolOptions
boolopts = (CpphsOptions -> BoolOptions
boolopts CpphsOptions
defaultCpphsOptions) { lang :: Bool
lang = Bool
True } -- lex as haskell
                              }
      possiblyWrap :: Bool -> String -> String
      possiblyWrap :: Bool -> String -> String
possiblyWrap Bool
b String
s = if Bool
b then String
"\\begin{code}\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\\end{code}" else String
s
      additionalCode :: ModuleInfo -> String
      additionalCode :: ModuleInfo -> String
additionalCode ModuleInfo
info =
          String -> String
thisModulesTestsFullName (ModuleInfo -> String
mi_moduleNameWithDefault ModuleInfo
info) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            ModuleInfo -> String
mi_htfPrefix ModuleInfo
info String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"TestSuite\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String -> String
thisModulesTestsFullName (ModuleInfo -> String
mi_moduleNameWithDefault ModuleInfo
info) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++
            ModuleInfo -> String
mi_htfPrefix ModuleInfo
info String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"makeTestSuite" String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (ModuleInfo -> String
mi_moduleNameWithDefault ModuleInfo
info) String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
" [\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
",\n"
                          ((Definition -> String) -> [Definition] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Definition -> String
codeForDef (ModuleInfo -> String
mi_htfPrefix ModuleInfo
info)) (ModuleInfo -> [Definition]
mi_defs ModuleInfo
info))
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n  ]\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleInfo -> String
importedTestListCode ModuleInfo
info
      codeForDef :: String -> Definition -> String
      codeForDef :: String -> Definition -> String
codeForDef String
pref (TestDef String
s Location
loc String
name) =
          Location -> String
locPragma Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pref String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"makeUnitTest " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Location -> String
codeForLoc String
pref Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
      codeForDef String
pref (PropDef String
s Location
loc String
name) =
          Location -> String
locPragma Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pref String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"makeQuickCheckTest " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
forall a. Show a => a -> String
show String
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String -> Location -> String
codeForLoc String
pref Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pref String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"qcAssertion " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      locPragma :: Location -> String
      locPragma :: Location -> String
locPragma Location
loc =
          String
"{-# LINE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Location -> Int
lineNumber Location
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Location -> String
fileName Location
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #-}\n    "
      codeForLoc :: String -> Location -> String
      codeForLoc :: String -> Location -> String
codeForLoc String
pref Location
loc = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pref String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"makeLoc " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (Location -> String
fileName Location
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                            String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Location -> Int
lineNumber Location
loc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      importedTestListCode :: ModuleInfo -> String
      importedTestListCode :: ModuleInfo -> String
importedTestListCode ModuleInfo
info =
          let l :: [ImportDecl]
l = ModuleInfo -> [ImportDecl]
mi_htfImports ModuleInfo
info
          in case [ImportDecl]
l of
               [] -> String
""
               [ImportDecl]
_ -> (String -> String
importedTestListFullName (ModuleInfo -> String
mi_moduleNameWithDefault ModuleInfo
info)
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" :: [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleInfo -> String
mi_htfPrefix ModuleInfo
info String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"TestSuite]\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String -> String
importedTestListFullName (ModuleInfo -> String
mi_moduleNameWithDefault ModuleInfo
info)
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = [\n    " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
",\n     " ((ImportDecl -> String) -> [ImportDecl] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl -> String
htfTestsInModule [ImportDecl]
l) String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
"\n  ]\n")
      htfTestsInModule :: ImportDecl -> String
      htfTestsInModule :: ImportDecl -> String
htfTestsInModule ImportDecl
imp = ImportDecl -> String -> String
qualify ImportDecl
imp (String -> String
thisModulesTestsFullName (ImportDecl -> String
imp_moduleName ImportDecl
imp))
      qualify :: ImportDecl -> String -> String
      qualify :: ImportDecl -> String -> String
qualify ImportDecl
imp String
name =
          case (ImportDecl -> Bool
imp_qualified ImportDecl
imp, ImportDecl -> Maybe String
imp_alias ImportDecl
imp) of
            (Bool
False, Maybe String
_) -> String
name
            (Bool
True, Just String
alias) -> String
alias String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
            (Bool
True, Maybe String
_) -> ImportDecl -> String
imp_moduleName ImportDecl
imp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name

-- Returns for lines of the form '# <number> "<filename>"'
-- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output)
-- the value 'Just <number> "<filename>"'
parseCppLineInfoOut :: String -> Maybe (String, String)
parseCppLineInfoOut :: String -> Maybe (String, String)
parseCppLineInfoOut String
line =
    case String
line of
      Char
'#':Char
' ':Char
c:String
rest
        | Char -> Bool
isDigit Char
c ->
            case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span Char -> Bool
isDigit String
rest of
              (String
restDigits, Char
' ' : Char
'"' : String
rest) ->
                  case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'"') (String -> String
forall a. [a] -> [a]
reverse String
rest) of
                    Char
'"' : String
fileNameRev ->
                        let line :: String
line = (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
restDigits)
                            file :: String
file = String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse String
fileNameRev String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
                        in (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
line, String
file)
                    String
_ -> Maybe (String, String)
forall a. Maybe a
Nothing
              (String, String)
_ -> Maybe (String, String)
forall a. Maybe a
Nothing
      String
_ -> Maybe (String, String)
forall a. Maybe a
Nothing

preprocessorTests :: [(String, IO ())]
preprocessorTests =
    [(String
"testAnalyze", IO ()
testAnalyze)]