Cabal.hs

module System.TestLoop.Internal.Cabal (parseCabalFile) where

--------------------

import           Control.Applicative                   ((<$>), (<*>))
import           Data.List                             (isSuffixOf)
import           Data.Monoid                           (First (..), mconcat)
import           System.Directory                      (getCurrentDirectory,
                                                        getDirectoryContents,
                                                        getHomeDirectory)
import           System.Environment                    (getArgs)
import           System.FilePath                       (joinPath, takeDirectory)

--------------------

import           Distribution.PackageDescription       (CondTree (..),
                                                        GenericPackageDescription (..),
                                                        TestSuite (..),
                                                        TestSuiteInterface (..),
                                                        condTreeData,
                                                        hsSourceDirs,
                                                        testBuildInfo)
import           Distribution.PackageDescription.Parse (readPackageDescription)
import           Distribution.Verbosity                (normal)

--------------------

import           System.TestLoop.Internal.Types

--------------------------------------------------------------------------------

getTestSuiteToRun :: IO (Maybe String)
getTestSuiteToRun = do
    args <- getArgs
    case args of
      (x:_) -> return (Just x)
      _ -> return Nothing

parseTestSuiteInfo :: Maybe String
                   -> (String, CondTree a b TestSuite)
                   -> Maybe (String, String, [String])
parseTestSuiteInfo (Just inputName) (name, CondNode { condTreeData=testSuite })
    | inputName == name =
      case testInterface testSuite of
        TestSuiteExeV10 _ file ->
            Just (name, file, hsSourceDirs $ testBuildInfo testSuite)
        _ -> Nothing
    | otherwise = Nothing
parseTestSuiteInfo Nothing input@(name, _) = parseTestSuiteInfo (Just name) input

getCabalFilePathFrom :: FilePath -> IO (Maybe FilePath)
getCabalFilePathFrom originalPath =
    getHomeDirectory >>= loop originalPath
  where
    loop currentPath finalPath = do
      if currentPath == finalPath
        then return Nothing
        else do
          contents <- getDirectoryContents currentPath
          case dropWhile (not . (".cabal" `isSuffixOf`)) contents of
            [] -> loop (takeDirectory currentPath) finalPath
            (result:_) -> return $ Just (joinPath [currentPath, result])


getCabalFilePath :: IO (Maybe FilePath)
getCabalFilePath = do
    getCurrentDirectory >>= getCabalFilePathFrom

parseCabalFile_ :: Maybe String
                -> GenericPackageDescription
                -> Maybe (String, String, [String])
parseCabalFile_ testSuiteName genericPackDesc =
    getFirst . mconcat $ map (First . parseTestSuiteInfo testSuiteName)
                             (condTestSuites genericPackDesc)

parseCabalFile :: IO (TestSuiteName, MainModuleName, HsSourcePaths)
parseCabalFile = do
    mcabalFilePath <- getCabalFilePath
    case mcabalFilePath of
      Just cabalFilePath -> do
        result <- parseCabalFile_ <$> getTestSuiteToRun
                                  <*> readPackageDescription normal cabalFilePath
        maybe (error $ msg ++ cabalFilePath)
              return
              result
      Nothing ->
          error "Couldn't find a cabal file in this directory"
  where
    msg = mconcat [ "You need to have at least one test-suite "
                  , "with type == exitcode-stdio-1.0 on "]