tasty-discover-5.2.0: app/Main.hs

-- | Main executable module.

module Main where

import Control.Monad                       (when)
import Data.Maybe                          (fromMaybe)
import System.Environment                  (getArgs, getProgName)
import System.Exit                         (exitFailure)
import System.FilePath                     (takeDirectory)
import System.IO                           (IOMode(ReadMode), hGetContents, hPutStrLn, withFile, stderr)
import Test.Tasty.Discover.Internal.Config (Config (..), parseConfig)
import Test.Tasty.Discover.Internal.Driver (findTests, generateTestDriver)

-- | Main function.
main :: IO ()
main = do
  args <- getArgs
  name <- getProgName
  case args of
    src:_:dst:opts ->
      case parseConfig (takeDirectory src) name opts of
        Left err -> do
          hPutStrLn stderr err
          exitFailure
        Right config -> do
          tests <- findTests config
          let ingredients = tastyIngredients config
              moduleName  = fromMaybe "Main" (generatedModuleName config)
          header <- readHeader src
          let output = generateTestDriver config moduleName ingredients src tests
          when (debug config) $ hPutStrLn stderr output
          -- Write in-place only when content differs (no temp file)
          when (inPlace config) $ do
            let newContent = unlines $ header ++ [marker, output]
            -- Strictly read the existing file so the handle is closed before we write (important on Windows)
            oldContent <- withFile src ReadMode $ \h -> do
              s <- hGetContents h
              length s `seq` return s
            when (oldContent /= newContent) $ writeFile src newContent
          writeFile dst $
            "{-# LINE " ++ show (length header + 2) ++ " " ++ show src ++ " #-}\n"
            ++ output
    _ -> do
      hPutStrLn stderr "Usage: tasty-discover src _ dst [OPTION...]"
      exitFailure
  where
    marker = "-- GENERATED BY tasty-discover"
    readHeader src = withFile src ReadMode $ \h -> do
      header <- takeWhile (marker /=) . lines <$> hGetContents h
      seq (length header) (return header)