{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Syd.Discover where

import Control.Monad.IO.Class
import Data.Char
import Data.List
import Data.Maybe
import Options.Applicative
import Path
import Path.IO
import qualified System.FilePath as FP

sydTestDiscover :: IO ()
sydTestDiscover :: IO ()
sydTestDiscover = do
  Arguments {String
Settings
argSettings :: Arguments -> Settings
argDestination :: Arguments -> String
argIgnored :: Arguments -> String
argSource :: Arguments -> String
argSettings :: Settings
argDestination :: String
argIgnored :: String
argSource :: String
..} <- IO Arguments
getArguments
  Path Abs File
specSourceFile <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' String
argSource
  let testBaseDir :: Path Abs Dir
testBaseDir = forall a. Path Abs a -> Path Abs Dir
findTestBaseDir Path Abs File
specSourceFile
      testDir :: Path Abs Dir
testDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
specSourceFile
  Path Rel Dir
testDirRelToBaseDirParent <- forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix (forall b t. Path b t -> Path b Dir
parent Path Abs Dir
testBaseDir) Path Abs Dir
testDir
  Path Rel Dir
testDirRelToBaseDir <- if Path Abs Dir
testBaseDir forall a. Eq a => a -> a -> Bool
== Path Abs Dir
testDir then forall (f :: * -> *) a. Applicative f => a -> f a
pure [reldir|.|] else forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
testBaseDir Path Abs Dir
testDir
  Path Rel File
specSourceFileRel <- forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
testBaseDir Path Abs File
specSourceFile
  -- traversing the files in the directory below the Spec file, appending the prefix from the test root to the Spec's location
  [Path Rel File]
otherSpecFilesRelativeToBaseDir <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Path Rel File
f -> Path Rel Dir
testDirRelToBaseDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
f) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Path Rel Dir -> m [Path Rel File]
sourceFilesInNonHiddenDirsRecursively Path Rel Dir
testDirRelToBaseDirParent
  let otherSpecFiles :: [SpecModule]
otherSpecFiles = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Path Rel File -> Maybe SpecModule
parseSpecModule forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\Path Rel File
fp -> Path Rel File
fp forall a. Eq a => a -> a -> Bool
/= Path Rel File
specSourceFileRel Bool -> Bool -> Bool
&& Path Rel File -> Bool
isHaskellFile Path Rel File
fp) [Path Rel File]
otherSpecFilesRelativeToBaseDir
      output :: String
output = Settings -> Path Rel File -> [SpecModule] -> String
makeSpecModule Settings
argSettings Path Rel File
specSourceFileRel [SpecModule]
otherSpecFiles
  String -> String -> IO ()
writeFile String
argDestination String
output

-- we're traversing up the file tree until we find a directory that doesn't start with an uppercase letter
findTestBaseDir :: Path Abs a -> Path Abs Dir
findTestBaseDir :: forall a. Path Abs a -> Path Abs Dir
findTestBaseDir Path Abs a
specSourceFile =
  case forall a. [a] -> Maybe a
listToMaybe (forall b t. Path b t -> String
toFilePath forall a b. (a -> b) -> a -> b
$ forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
directParent) of
    Maybe Char
Nothing -> Path Abs Dir
directParent
    Just Char
c ->
      if Char -> Bool
isUpper Char
c
        then forall a. Path Abs a -> Path Abs Dir
findTestBaseDir Path Abs Dir
directParent
        else Path Abs Dir
directParent
  where
    directParent :: Path Abs Dir
directParent = forall b t. Path b t -> Path b Dir
parent Path Abs a
specSourceFile

data Arguments = Arguments
  { Arguments -> String
argSource :: FilePath,
    Arguments -> String
argIgnored :: FilePath,
    Arguments -> String
argDestination :: FilePath,
    Arguments -> Settings
argSettings :: Settings
  }
  deriving (Int -> Arguments -> ShowS
[Arguments] -> ShowS
Arguments -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Arguments] -> ShowS
$cshowList :: [Arguments] -> ShowS
show :: Arguments -> String
$cshow :: Arguments -> String
showsPrec :: Int -> Arguments -> ShowS
$cshowsPrec :: Int -> Arguments -> ShowS
Show, Arguments -> Arguments -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Arguments -> Arguments -> Bool
$c/= :: Arguments -> Arguments -> Bool
== :: Arguments -> Arguments -> Bool
$c== :: Arguments -> Arguments -> Bool
Eq)

data Settings = Settings
  { Settings -> Bool
settingMain :: Bool
  }
  deriving (Int -> Settings -> ShowS
[Settings] -> ShowS
Settings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Settings] -> ShowS
$cshowList :: [Settings] -> ShowS
show :: Settings -> String
$cshow :: Settings -> String
showsPrec :: Int -> Settings -> ShowS
$cshowsPrec :: Int -> Settings -> ShowS
Show, Settings -> Settings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Settings -> Settings -> Bool
$c/= :: Settings -> Settings -> Bool
== :: Settings -> Settings -> Bool
$c== :: Settings -> Settings -> Bool
Eq)

getArguments :: IO Arguments
getArguments :: IO Arguments
getArguments = forall a. ParserInfo a -> IO a
execParser forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser Arguments
argumentsParser forall a. InfoMod a
fullDesc

argumentsParser :: Parser Arguments
argumentsParser :: Parser Arguments
argumentsParser =
  String -> String -> String -> Settings -> Arguments
Arguments
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (forall a. Monoid a => [a] -> a
mconcat [forall (f :: * -> *) a. String -> Mod f a
help String
"Source file path"])
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (forall a. Monoid a => [a] -> a
mconcat [forall (f :: * -> *) a. String -> Mod f a
help String
"Ignored argument"])
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument (forall a. Monoid a => [a] -> a
mconcat [forall (f :: * -> *) a. String -> Mod f a
help String
"Destiantion file path"])
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( Bool -> Settings
Settings
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall a. a -> Mod FlagFields a -> Parser a
flag' Bool
True (forall a. Monoid a => [a] -> a
mconcat [forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"main", forall (f :: * -> *) a. String -> Mod f a
help String
"generate a main module and function"])
                    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. a -> Mod FlagFields a -> Parser a
flag' Bool
False (forall a. Monoid a => [a] -> a
mconcat [forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"no-main", forall (f :: * -> *) a. String -> Mod f a
help String
"don't generate a main module and function"])
                    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                )
        )

sourceFilesInNonHiddenDirsRecursively ::
  forall m.
  MonadIO m =>
  Path Rel Dir ->
  m [Path Rel File]
sourceFilesInNonHiddenDirsRecursively :: forall (m :: * -> *).
MonadIO m =>
Path Rel Dir -> m [Path Rel File]
sourceFilesInNonHiddenDirsRecursively =
  forall (m :: * -> *) o b.
(MonadIO m, Monoid o) =>
Maybe
  (Path Rel Dir
   -> [Path Rel Dir] -> [Path Rel File] -> m (WalkAction Rel))
-> (Path Rel Dir -> [Path Rel Dir] -> [Path Rel File] -> m o)
-> Path b Dir
-> m o
walkDirAccumRel (forall a. a -> Maybe a
Just Path Rel Dir
-> [Path Rel Dir] -> [Path Rel File] -> m (WalkAction Rel)
goWalk) Path Rel Dir
-> [Path Rel Dir] -> [Path Rel File] -> m [Path Rel File]
goOutput
  where
    goWalk ::
      Path Rel Dir -> [Path Rel Dir] -> [Path Rel File] -> m (WalkAction Rel)
    goWalk :: Path Rel Dir
-> [Path Rel Dir] -> [Path Rel File] -> m (WalkAction Rel)
goWalk Path Rel Dir
curdir [Path Rel Dir]
subdirs [Path Rel File]
_ = do
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. [Path b Dir] -> WalkAction b
WalkExclude forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn Path Rel Dir
curdir) [Path Rel Dir]
subdirs
    goOutput ::
      Path Rel Dir -> [Path Rel Dir] -> [Path Rel File] -> m [Path Rel File]
    goOutput :: Path Rel Dir
-> [Path Rel Dir] -> [Path Rel File] -> m [Path Rel File]
goOutput Path Rel Dir
curdir [Path Rel Dir]
_ [Path Rel File]
files =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Path Rel Dir
curdir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> Bool
hiddenFile) [Path Rel File]
files

hiddenFile :: Path Rel File -> Bool
hiddenFile :: Path Rel File -> Bool
hiddenFile = Path Rel File -> Bool
goFile
  where
    goFile :: Path Rel File -> Bool
    goFile :: Path Rel File -> Bool
goFile Path Rel File
f = forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn (forall b t. Path b t -> Path b Dir
parent Path Rel File
f) Path Rel File
f Bool -> Bool -> Bool
|| Path Rel Dir -> Bool
goDir (forall b t. Path b t -> Path b Dir
parent Path Rel File
f)
    goDir :: Path Rel Dir -> Bool
    goDir :: Path Rel Dir -> Bool
goDir Path Rel Dir
f
      | forall b t. Path b t -> Path b Dir
parent Path Rel Dir
f forall a. Eq a => a -> a -> Bool
== Path Rel Dir
f = Bool
False
      | Bool
otherwise = forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn (forall b t. Path b t -> Path b Dir
parent Path Rel Dir
f) Path Rel Dir
f Bool -> Bool -> Bool
|| Path Rel Dir -> Bool
goDir (forall b t. Path b t -> Path b Dir
parent Path Rel Dir
f)

isHiddenIn :: Path b Dir -> Path b t -> Bool
isHiddenIn :: forall b t. Path b Dir -> Path b t -> Bool
isHiddenIn Path b Dir
curdir Path b t
ad =
  case forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path b Dir
curdir Path b t
ad of
    Maybe (Path Rel t)
Nothing -> Bool
False
    Just Path Rel t
rp -> String
"." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` forall b t. Path b t -> String
toFilePath Path Rel t
rp

#if MIN_VERSION_path(0,7,0)
isHaskellFile :: Path Rel File -> Bool
isHaskellFile :: Path Rel File -> Bool
isHaskellFile Path Rel File
p =
  case forall (m :: * -> *) b. MonadThrow m => Path b File -> m String
fileExtension Path Rel File
p of
    Just String
".hs" -> Bool
True
    Just String
".lhs" -> Bool
True
    Maybe String
_ -> Bool
False
#else
isHaskellFile :: Path Rel File -> Bool
isHaskellFile p =
  case fileExtension p of
    ".hs" -> True
    ".lhs" -> True
    _ -> False
#endif

data SpecModule = SpecModule
  { SpecModule -> Path Rel File
specModulePath :: Path Rel File,
    SpecModule -> String
specModuleModuleName :: String,
    SpecModule -> String
specModuleDescription :: String
  }

parseSpecModule :: Path Rel File -> Maybe SpecModule
parseSpecModule :: Path Rel File -> Maybe SpecModule
parseSpecModule Path Rel File
rf = do
  let specModulePath :: Path Rel File
specModulePath = Path Rel File
rf
  let specModuleModuleName :: String
specModuleModuleName = Path Rel File -> String
makeModuleName Path Rel File
rf
  let withoutExtension :: String
withoutExtension = ShowS
FP.dropExtension forall a b. (a -> b) -> a -> b
$ Path Rel File -> String
fromRelFile Path Rel File
rf
  String
withoutSpecSuffix <- forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"Spec" String
withoutExtension
  Path Rel File
withoutSpecSuffixPath <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile String
withoutSpecSuffix
  let specModuleDescription :: String
specModuleDescription = Path Rel File -> String
makeModuleName Path Rel File
withoutSpecSuffixPath
  forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecModule {String
Path Rel File
specModuleDescription :: String
specModuleModuleName :: String
specModulePath :: Path Rel File
specModuleDescription :: String
specModuleModuleName :: String
specModulePath :: Path Rel File
..}
  where
    stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
    stripSuffix :: forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [a]
suffix [a]
s = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (forall a. [a] -> [a]
reverse [a]
suffix) (forall a. [a] -> [a]
reverse [a]
s)

makeModuleName :: Path Rel File -> String
makeModuleName :: Path Rel File -> String
makeModuleName Path Rel File
fp =
  forall a. [a] -> [[a]] -> [a]
intercalate String
"." forall a b. (a -> b) -> a -> b
$ String -> [String]
FP.splitDirectories forall a b. (a -> b) -> a -> b
$ ShowS
FP.dropExtensions forall a b. (a -> b) -> a -> b
$ Path Rel File -> String
fromRelFile Path Rel File
fp

makeSpecModule :: Settings -> Path Rel File -> [SpecModule] -> String
makeSpecModule :: Settings -> Path Rel File -> [SpecModule] -> String
makeSpecModule Settings {Bool
settingMain :: Bool
settingMain :: Settings -> Bool
..} Path Rel File
destination [SpecModule]
sources =
  [String] -> String
unlines
    [ -- We use "-w -Wall" to first turn off all warnings and then turn on
      -- specific ones we want.
      -- This allows globally set warnings to fail on this module without
      -- failing the build.
      -- See also https://github.com/NorfairKing/sydtest/issues/54
      String
"{-# OPTIONS_GHC -w -Wall -fno-warn-missing-signatures -fno-warn-unused-imports #-}",
      if Bool
settingMain then String
"" else ShowS
moduleDeclaration (Path Rel File -> String
makeModuleName Path Rel File
destination),
      String
"",
      String
"import Test.Syd",
      String
"import qualified Prelude",
      String
"",
      [SpecModule] -> String
importDeclarations [SpecModule]
sources,
      if Bool
settingMain then String
mainDeclaration else String
"",
      [SpecModule] -> String
specDeclaration [SpecModule]
sources
    ]

moduleDeclaration :: String -> String
moduleDeclaration :: ShowS
moduleDeclaration String
mn = [String] -> String
unwords [String
"module", String
mn, String
"(spec) where"]

mainDeclaration :: String
mainDeclaration :: String
mainDeclaration =
  [String] -> String
unlines
    [ String
"main :: Prelude.IO ()",
      String
"main = sydTest spec"
    ]

importDeclarations :: [SpecModule] -> String
importDeclarations :: [SpecModule] -> String
importDeclarations = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((String
"import qualified " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecModule -> String
specModuleModuleName)

specDeclaration :: [SpecModule] -> String
specDeclaration :: [SpecModule] -> String
specDeclaration [SpecModule]
fs =
  [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SpecModule]
fs
      then [String
"spec = Prelude.pure ()"]
      else
        String
"spec = do"
          forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map SpecModule -> String
moduleSpecLine [SpecModule]
fs

moduleSpecLine :: SpecModule -> String
moduleSpecLine :: SpecModule -> String
moduleSpecLine SpecModule
rf = [String] -> String
unwords [String
" ", String
"describe", String
"\"" forall a. Semigroup a => a -> a -> a
<> SpecModule -> String
specModuleModuleName SpecModule
rf forall a. Semigroup a => a -> a -> a
<> String
"\"", SpecModule -> String
specFunctionName SpecModule
rf]

specFunctionName :: SpecModule -> String
specFunctionName :: SpecModule -> String
specFunctionName SpecModule
rf = SpecModule -> String
specModuleModuleName SpecModule
rf forall a. [a] -> [a] -> [a]
++ String
".spec"