-- Copyright 2015 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | Collect tests from the given modules and generate a haskell module that
    calls the tests.  Test functions are any function starting with @test_@ or
    @profile_@ and immediately followed by @=@ (implying the function has no
    arguments).  This module doesn't distinguish between tests and profiles,
    but they should presumably be compiled separately since they require
    different flags.

    If a module has a function called @initialize@, it will be called as
    @IO ()@ prior to the tests.
-}
module Util.Test.GenerateRunTests (main, patchFile) where
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified System.Environment

import qualified Util.ExtractHs as ExtractHs
import qualified Util.Regex as Regex
import qualified Util.Lists as Lists

import           Global


main :: IO ()
main :: IO ()
main = do
    [FilePath]
args <- IO [FilePath]
System.Environment.getArgs
    forall a.
[FilePath]
-> (Text -> a)
-> (FilePath -> Map FilePath a -> Either Text ([Text], Text))
-> IO ()
ExtractHs.process [FilePath]
args (Text -> ([Test], HasMeta)
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
ExtractHs.stripComments)
        (\FilePath
_ -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FilePath ([Test], HasMeta) -> ([Text], Text)
generate)

generate :: Map FilePath ([Test], HasMeta) -> ([ExtractHs.Warning], Text)
generate :: Map FilePath ([Test], HasMeta) -> ([Text], Text)
generate Map FilePath ([Test], HasMeta)
fnameTests = (,) [Text]
warnings forall a b. (a -> b) -> a -> b
$
    Text -> Text -> Text
testTemplate
        ([Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
ExtractHs.makeImport (forall k a. Map k a -> [k]
Map.keys Map FilePath ([Test], HasMeta)
fnameTests))
        (Text -> [Text] -> Text
Text.intercalate Text
"\n    , " forall a b. (a -> b) -> a -> b
$ Map FilePath ([Test], HasMeta) -> [Text]
makeTests Map FilePath ([Test], HasMeta)
fnameTests)
    where
    noTests :: [FilePath]
noTests = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath ([Test], HasMeta)
fnameTests
    -- I tend to have empty test modules with hand tests.  I used to filter out
    -- the empty modules, but at least this way they get type-checked.
    --
    -- Most likely ghc will already warn with -Wunused-imports but let's warn
    -- here too.
    warnings :: [Text]
warnings = forall a b. (a -> b) -> [a] -> [b]
map ((Text
"Warning: no (test|profile)_* defs in " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
txt) [FilePath]
noTests

testTemplate :: Text -> Text -> Text
testTemplate :: Text -> Text -> Text
testTemplate Text
imports Text
allTests =
    Text
"import qualified Util.Test.RunTests as RunTests\n\
    \import Util.Test.RunTests (Test(..))\n\
    \\n"
    forall a. Semigroup a => a -> a -> a
<> Text
imports forall a. Semigroup a => a -> a -> a
<> Text
"\n\
    \\n\
    \tests :: [Test]\n\
    \tests = \n\
    \    [ " forall a. Semigroup a => a -> a -> a
<> Text
allTests forall a. Semigroup a => a -> a -> a
<> Text
"\n\
    \    ]\n\
    \\n\
    \main :: IO ()\n\
    \main = RunTests.run tests\n"

data Test  = Test {
    Test -> LineNumber
testLineNumber :: !LineNumber
    , Test -> Text
testName :: !Text
    } deriving (LineNumber -> Test -> ShowS
[Test] -> ShowS
Test -> FilePath
forall a.
(LineNumber -> a -> ShowS)
-> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Test] -> ShowS
$cshowList :: [Test] -> ShowS
show :: Test -> FilePath
$cshow :: Test -> FilePath
showsPrec :: LineNumber -> Test -> ShowS
$cshowsPrec :: LineNumber -> Test -> ShowS
Show)
type LineNumber = Int

-- * extract

type HasMeta = Maybe Text

-- | Extract test functions and possible metadata from the file.
extract :: Text -> ([Test], HasMeta)
extract :: Text -> ([Test], HasMeta)
extract Text
content = (Text -> [Test]
extractTests Text
content, Text -> HasMeta
hasMeta Text
content)

hasMeta :: Text -> HasMeta
hasMeta :: Text -> HasMeta
hasMeta =
    (\Bool
b -> if Bool
b then forall a. a -> Maybe a
Just Text
"meta" else forall a. Maybe a
Nothing) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> Text -> Bool
Regex.matches Regex
reg
    where reg :: Regex
reg = HasCallStack => [Option] -> FilePath -> Regex
Regex.compileOptionsUnsafe [Option
Regex.Multiline] FilePath
"^meta\\b"

-- | Add a ':: Test' type signature to naked test declarations.
patchFile :: FilePath -> IO ()
patchFile :: FilePath -> IO ()
patchFile FilePath
fname = do
    FilePath -> IO ()
putStrLn FilePath
fname
    Text
content <- FilePath -> IO Text
Text.IO.readFile FilePath
fname
    let tests :: [Test]
tests = Text -> [Test]
extractNakedTests Text
content
    let out :: [Text]
out = FilePath -> [Test] -> [Text] -> [Text]
patchTests FilePath
fname [Test]
tests (Text -> [Text]
Text.lines Text
content)
    FilePath -> Text -> IO ()
Text.IO.writeFile FilePath
fname forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines [Text]
out

patchTests :: FilePath -> [Test] -> [Text] -> [Text]
patchTests :: FilePath -> [Test] -> [Text] -> [Text]
patchTests FilePath
fname [Test]
tests = [Test] -> [(LineNumber, Text)] -> [Text]
go [Test]
tests forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [LineNumber
1..]
    where
    go :: [Test] -> [(LineNumber, Text)] -> [Text]
go ts :: [Test]
ts@(Test LineNumber
ti Text
name : [Test]
tests) ((LineNumber
i, Text
line) : [(LineNumber, Text)]
lines)
        | LineNumber
ti forall a. Eq a => a -> a -> Bool
== LineNumber
i = Text
name forall a. Semigroup a => a -> a -> a
<> Text
" :: Test" forall a. a -> [a] -> [a]
: Text
line forall a. a -> [a] -> [a]
: [Test] -> [(LineNumber, Text)] -> [Text]
go [Test]
tests [(LineNumber, Text)]
lines
        | Bool
otherwise = Text
line forall a. a -> [a] -> [a]
: [Test] -> [(LineNumber, Text)] -> [Text]
go [Test]
ts [(LineNumber, Text)]
lines
    go [] [(LineNumber, Text)]
lines = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(LineNumber, Text)]
lines
    go [Test]
tests [] = forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
fname forall a. Semigroup a => a -> a -> a
<> FilePath
": left over tests: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show [Test]
tests


extractNakedTests :: Text -> [Test]
extractNakedTests :: Text -> [Test]
extractNakedTests = [(LineNumber, (HasMeta, Text))] -> [Test]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [LineNumber
1..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(Maybe a, a)]
Lists.zipPrev forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
    where
    go :: [(LineNumber, (HasMeta, Text))] -> [Test]
go ((LineNumber
i, (HasMeta
mb_prev, Text
line)) : [(LineNumber, (HasMeta, Text))]
lines)
        | Just Text
def <- Text -> HasMeta
hasTestFunction Text
line, Just Text
prev <- HasMeta
mb_prev
        , Bool -> Bool
not ((Text
def forall a. Semigroup a => a -> a -> a
<> Text
" ::") Text -> Text -> Bool
`Text.isPrefixOf` Text
prev) = Test
            { testLineNumber :: LineNumber
testLineNumber = LineNumber
i
            , testName :: Text
testName = Text
def
            } forall a. a -> [a] -> [a]
: [(LineNumber, (HasMeta, Text))] -> [Test]
go [(LineNumber, (HasMeta, Text))]
lines
        | Bool
otherwise = [(LineNumber, (HasMeta, Text))] -> [Test]
go [(LineNumber, (HasMeta, Text))]
lines
    go [] = []

extractTests :: Text -> [Test]
extractTests :: Text -> [Test]
extractTests = [(LineNumber, Text)] -> [Test]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [LineNumber
1..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
    where
    go :: [(LineNumber, Text)] -> [Test]
go ((LineNumber
i, Text
line) : [(LineNumber, Text)]
lines)
        | Just Text
def <- Text -> HasMeta
hasTestFunction Text
line = Test
            { testLineNumber :: LineNumber
testLineNumber = LineNumber
i
            , testName :: Text
testName = Text
def
            } forall a. a -> [a] -> [a]
: [(LineNumber, Text)] -> [Test]
go [(LineNumber, Text)]
lines
        | Bool
otherwise = [(LineNumber, Text)] -> [Test]
go [(LineNumber, Text)]
lines
    go [] = []

hasTestFunction :: Text -> Maybe Text
hasTestFunction :: Text -> HasMeta
hasTestFunction Text
line
    | Regex -> Text -> Bool
Regex.matches Regex
reg Text
line = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head (Text -> [Text]
Text.words Text
line)
    | Bool
otherwise = forall a. Maybe a
Nothing
    where
    reg :: Regex
reg = HasCallStack => FilePath -> Regex
Regex.compileUnsafe FilePath
"^(?:test|profile)_[a-zA-Z0-9_]+ \\="

-- * make

makeTests :: Map.Map FilePath ([Test], HasMeta) -> [Text]
makeTests :: Map FilePath ([Test], HasMeta) -> [Text]
makeTests Map FilePath ([Test], HasMeta)
fnameTests =
    [ FilePath -> Test -> HasMeta -> Text
makeTestLine FilePath
fname Test
test HasMeta
meta
    | (FilePath
fname, ([Test]
tests, HasMeta
meta)) <- forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath ([Test], HasMeta)
fnameTests, Test
test <- [Test]
tests
    ]

makeTestLine :: FilePath -> Test -> HasMeta -> Text
makeTestLine :: FilePath -> Test -> HasMeta -> Text
makeTestLine FilePath
fname Test
test HasMeta
meta = [Text] -> Text
Text.unwords
    [ Text
"Test", forall a. Show a => a -> Text
showt Text
name, Text
"(" forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" >> return ())"
    , forall a. Show a => a -> Text
showt FilePath
fname, forall a. Show a => a -> Text
showt (Test -> LineNumber
testLineNumber Test
test)
    , case HasMeta
meta of
        HasMeta
Nothing -> Text
"Nothing"
        Just Text
fn -> Text
"(Just " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
ExtractHs.pathToModule FilePath
fname forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
fn forall a. Semigroup a => a -> a -> a
<> Text
")"
    ]
    where name :: Text
name = FilePath -> Text
ExtractHs.pathToModule FilePath
fname forall a. Semigroup a => a -> a -> a
<> Text
"." forall a. Semigroup a => a -> a -> a
<> Test -> Text
testName Test
test