TestKaryaGenerate.hs

{-# LANGUAGE OverloadedStrings #-}
{- | 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 EL.Test.TestKaryaGenerate (main) where
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified System.Directory as Directory
import qualified System.Environment
import qualified System.FilePath as FilePath
import qualified System.IO as IO

import qualified EL.Private.ExtractHs as ExtractHs
import qualified EL.Private.Regex as Regex
import Global


-- pgmF args: OrigSourceName.hs input.hs output.hs
main :: IO ()
main = do
    args <- System.Environment.getArgs
    (baseDir, outputFile, defaultArgs) <- case args of
        origFile : _inputFile : outputFile : defaultArgs -> return
            ( FilePath.takeDirectory origFile
            , outputFile
            , if null defaultArgs then defaultDefaultArgs else defaultArgs
            )
        _ -> error "expected: origFile inputFile outputFile"
    inputFiles <- find (Char.isUpper . head) ("_test.hs" `List.isSuffixOf`)
        baseDir
    extracted <- ExtractHs.extractFiles extract inputFiles
    let (warnings, output) = generate defaultArgs $
            Map.mapKeys (stripPrefix baseDir) extracted
    mapM_ (Text.IO.hPutStrLn IO.stderr) warnings
    progName <- System.Environment.getProgName
    Text.IO.writeFile outputFile $ header progName <> output

defaultDefaultArgs :: [String]
defaultDefaultArgs =
    [ "--jobs=auto"
    , "--clear-dirs"
    , "--output=dist/test-output"
    , "--check-output"
    , "."
    ]

header :: String -> Text
header program = Text.unlines
    [ "-- automatically generated by " <> txt program
    , "{-# LANGUAGE OverloadedStrings #-}"
    ]

-- | Recursively find files below a directory.
find :: (FilePath -> Bool) -> (FilePath -> Bool) -> FilePath -> IO [FilePath]
find wantDir wantFile = fmap concat . go
    where
    go dir = do
        (dirs, fns) <- partitionM Directory.doesDirectoryExist =<< list dir
        rest <- mapM go (filter (wantDir . FilePath.takeFileName) dirs)
        return $ filter wantFile fns : concat rest

list :: FilePath -> IO [FilePath]
list dir = map (dir FilePath.</>) <$> Directory.listDirectory dir

partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM fp = go
    where
    go (x:xs) = fp x >>= \b -> case b of
        True -> (\(as, bs) -> (x:as, bs)) <$> go xs
        False -> (\(as, bs) -> (as, x:bs)) <$> go xs
    go [] = return ([], [])

stripPrefix :: FilePath -> FilePath -> FilePath
stripPrefix prefix fname = dropWhile (=='/') $
    if prefix `List.isPrefixOf` fname
        then drop (length prefix) fname else fname


-- * generate

type Warning = Text

generate :: [String] -> Map FilePath ([Test], HasMeta) -> ([Warning], Text)
generate defaultArgs extracted = (,) warnings $
    testTemplate
        (Text.unlines $ map ExtractHs.makeImport (Map.keys fnameTests))
        (Text.intercalate "\n    , " $ makeTests fnameTests)
        defaultArgs
    where
    (empty, fnameTests) = Map.partition (null . fst) extracted
    warnings = map (("Warning: no (test|profile)_* defs in " <>) . txt)
        (Map.keys empty)

testTemplate :: Text -> Text -> [String] -> Text
testTemplate imports allTests defaultArgs =
    "import qualified EL.Test.RunTests as RunTests\n\
    \import EL.Test.RunTests (Test(..))\n\
    \\n"
    <> imports <> "\n\
    \\n\
    \tests :: [Test]\n\
    \tests = \n\
    \    [ " <> allTests <> "\n\
    \    ]\n\
    \\n\
    \main :: IO ()\n\
    \main = RunTests.run " <> showt defaultArgs <> " tests\n"

data Test  = Test {
    testLineNumber :: !LineNumber
    , testName :: !Text
    } deriving (Show)
type LineNumber = Int


-- * extract

type HasMeta = Maybe Text

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

hasMeta :: Text -> HasMeta
hasMeta =
    (\b -> if b then Just "meta" else Nothing) . Regex.matches reg
    where reg = Regex.compileOptionsUnsafe [Regex.Multiline] "^meta\\b"

extractTests :: Text -> [Test]
extractTests = go . zip [1..] . Text.lines
    where
    go ((i, line) : lines)
        | Just def <- hasTestFunction line = Test
            { testLineNumber = i
            , testName = def
            } : go rest
        | otherwise = go lines
        where
        rest = dropWhile (isIndented . snd) lines
        -- TODO does this get fooled by empty lines?
        isIndented t = " " `Text.isPrefixOf` t || t == "\n"
    go [] = []

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

-- * make

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

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