{-# OPTIONS_GHC -cpp -pgmP "cpphs --layout --hashes --cpp" #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PackageImports #-}
module Test.Framework.Preprocessor (
transform, progName, preprocessorTests, TransformOptions(..)
) where
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))]
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
$cshowsPrec :: Int -> ModuleInfo -> String -> String
showsPrec :: Int -> ModuleInfo -> String -> String
$cshow :: ModuleInfo -> String
show :: ModuleInfo -> String
$cshowList :: [ModuleInfo] -> String -> String
showList :: [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
$c== :: ModuleInfo -> ModuleInfo -> Bool
== :: ModuleInfo -> ModuleInfo -> Bool
$c/= :: ModuleInfo -> ModuleInfo -> Bool
/= :: 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
$cshowsPrec :: Int -> ImportDecl -> String -> String
showsPrec :: Int -> ImportDecl -> String -> String
$cshow :: ImportDecl -> String
show :: ImportDecl -> String
$cshowList :: [ImportDecl] -> String -> String
showList :: [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
$c== :: ImportDecl -> ImportDecl -> Bool
== :: ImportDecl -> ImportDecl -> Bool
$c/= :: ImportDecl -> ImportDecl -> Bool
/= :: 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
$c== :: Definition -> Definition -> Bool
== :: Definition -> Definition -> Bool
$c/= :: Definition -> Definition -> Bool
/= :: 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
$cshowsPrec :: Int -> Definition -> String -> String
showsPrec :: Int -> Definition -> String -> String
$cshow :: Definition -> String
show :: Definition -> String
$cshowList :: [Definition] -> String -> String
showList :: [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 = Just 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 = (TestDef name loc fullName) : mi_defs 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 = (PropDef name loc fullName) : mi_defs 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 = decl : mi_htfImports 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 = 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 { 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 { 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 a. [a] -> 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 a. a -> StateT ModuleInfo Identity a
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 Location
_ Bool
_ String
"qualified" : [Tok]
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 a. a -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
name, [Tok]
rest)
[Tok]
_ -> String -> m (String, [Tok])
forall a. String -> m a
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 { 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 a. a -> m a
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 a. a -> IO a
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 { mi_htfPrefix :: String
mi_htfPrefix = String
""
, mi_htfImports :: [ImportDecl]
mi_htfImports =
[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 { 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 { 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 { 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 { 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 { 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 { 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 { 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 a. a -> IO a
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 = (boolopts defaultCpphsOptions) { lang = True }
}
data TransformOptions = TransformOptions { TransformOptions -> Bool
debug :: Bool
, TransformOptions -> Bool
literateTex :: Bool }
transform :: TransformOptions -> FilePath -> String -> IO String
transform :: TransformOptions -> String -> String -> IO String
transform (TransformOptions 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 a. a -> IO a
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 :: 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 =
defines defaultCpphsOptions ++
nameDefines info
, boolopts = (boolopts defaultCpphsOptions) { lang = True }
}
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
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)]