module System.TestLoop (
setupTestLoop
) where
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (forM_, forever)
import Data.Maybe (catMaybes)
import Data.Monoid (mconcat)
import System.Directory (doesFileExist)
import System.FilePath (joinPath)
import System.IO (hPutStrLn, stderr)
import qualified Filesystem.Path.CurrentOS as FS
import System.FSNotify (withManager)
import System.FSNotify.Devel (treeExtExists)
import System.TestLoop.Internal.Cabal
import System.TestLoop.Internal.Types
import System.TestLoop.Internal.Watcher
import System.TestLoop.Util
startTestLoop :: MainModuleName -> MainModulePath -> HsSourcePaths -> IO ()
startTestLoop moduleName modulePath paths =
withManager $ \manager -> do
forM_ paths $ \path -> do
treeExtExists manager
(FS.decodeString path)
"hs"
(reloadTestSuite moduleName modulePath paths)
forever $ threadDelay 100
getTestMainFilePath :: HsSourcePaths -> MainModulePath -> IO (Either String FilePath)
getTestMainFilePath sourcePaths modulePath = do
mainPaths <- mapM getPossiblePath sourcePaths
case (catMaybes mainPaths) of
[completeModulePath] -> return $ Right completeModulePath
[] -> return . Left $ mconcat [ "Could not find `",
modulePath,
"' in ",
show sourcePaths]
multipleMatches -> return . Left $ mconcat [ "Multiple matches for test `Main' module"
, "on source-paths: \n",
show mainPaths ]
where
getPossiblePath sourcePath = do
let completeModulePath = joinPath [sourcePath, modulePath]
fileExists <- doesFileExist completeModulePath
if fileExists
then return $ Just completeModulePath
else return Nothing
setupTestLoop :: IO ()
setupTestLoop = do
(testsuite, moduleFile, sourcePaths) <- parseCabalFile
result <- getTestMainFilePath sourcePaths moduleFile
case result of
Left e -> hPutStrLn stderr e
Right fullModuleFilePath -> do
putStrLn $ "Found test-suite main function on `" ++ fullModuleFilePath ++ "'"
putStrLn $ "Listening files on source paths: " ++ (join ", " sourcePaths)
_ <- forkIO $ startTestLoop "Main"
fullModuleFilePath
sourcePaths
forever $ threadDelay 100