{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | A preprocessor that finds and combines specs.
--
-- /NOTE:/ This module is not meant for public consumption.  For user
-- documentation look at http://hspec.github.io/hspec-discover.html.
module Test.Hspec.Discover.Run (
  run

-- exported for testing
, Spec(..)
, importList
, fileToSpec
, findSpecs
, getFilesRecursive
, driverWithFormatter
, moduleNameFromId
, pathToModule
) where
import           Control.Monad
import           Control.Applicative
import           Data.List
import           Data.Char
import           Data.Maybe
import           Data.String
import           System.Environment
import           System.Exit
import           System.IO
import           System.Directory (doesDirectoryExist, getDirectoryContents, doesFileExist)
import           System.FilePath hiding (combine)

import           Test.Hspec.Discover.Config
import           Test.Hspec.Discover.Sort

instance IsString ShowS where
  fromString :: String -> ShowS
fromString = String -> ShowS
showString

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

run :: [String] -> IO ()
run :: [String] -> IO ()
run args_ :: [String]
args_ = do
  String
name <- IO String
getProgName
  case [String]
args_ of
    src :: String
src : _ : dst :: String
dst : args :: [String]
args -> case String -> [String] -> Either String Config
parseConfig String
name [String]
args of
      Left err :: String
err -> do
        Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
        IO ()
forall a. IO a
exitFailure
      Right conf :: Config
conf -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configNested Config
conf) (Handle -> String -> IO ()
hPutStrLn Handle
stderr "hspec-discover: WARNING - The `--nested' option is deprecated and will be removed in a future release!")
        [Spec]
specs <- String -> IO [Spec]
findSpecs String
src
        String -> String -> IO ()
writeFile String
dst (String -> Config -> [Spec] -> String
mkSpecModule String
src Config
conf [Spec]
specs)
    _ -> do
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (ShowS
usage String
name)
      IO ()
forall a. IO a
exitFailure

mkSpecModule :: FilePath -> Config -> [Spec] -> String
mkSpecModule :: String -> Config -> [Spec] -> String
mkSpecModule src :: String
src conf :: Config
conf nodes :: [Spec]
nodes =
  ( "{-# LINE 1 " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows String
src ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. " #-}\n"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}\n"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString ("module " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> Config -> String
moduleName String
src Config
conf String -> ShowS
forall a. [a] -> [a] -> [a]
++" where\n")
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Spec] -> ShowS
importList [Spec]
nodes
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "import Test.Hspec.Discover\n"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> (String -> ShowS) -> Maybe String -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
driver String -> ShowS
driverWithFormatter (Config -> Maybe String
configFormatter Config
conf)
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "spec :: Spec\n"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "spec = "
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Spec] -> ShowS
formatSpecs [Spec]
nodes
  ) "\n"
  where
    driver :: ShowS
driver =
        case Config -> Bool
configNoMain Config
conf of
          False ->
              String -> ShowS
showString "main :: IO ()\n"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "main = hspec spec\n"
          True -> ""

moduleName :: FilePath -> Config -> String
moduleName :: String -> Config -> String
moduleName src :: String
src conf :: Config
conf = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (if Config -> Bool
configNoMain Config
conf then ShowS
pathToModule String
src else "Main") (Config -> Maybe String
configModuleName Config
conf)

-- | Derive module name from specified path.
pathToModule :: FilePath -> String
pathToModule :: ShowS
pathToModule f :: String
f = Char -> Char
toUpper Char
mChar -> ShowS
forall a. a -> [a] -> [a]
:String
ms
  where
    fileName :: String
fileName = [String] -> String
forall a. [a] -> a
last ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitDirectories String
f
    m :: Char
m:ms :: String
ms = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/='.') String
fileName

driverWithFormatter :: String -> ShowS
driverWithFormatter :: String -> ShowS
driverWithFormatter f :: String
f =
    String -> ShowS
showString "import qualified " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (ShowS
moduleNameFromId String
f) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "\n"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "main :: IO ()\n"
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString "main = hspecWithFormatter " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
f ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString " spec\n"

-- | Return module name of a fully qualified identifier.
moduleNameFromId :: String -> String
moduleNameFromId :: ShowS
moduleNameFromId = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '.') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse

-- | Generate imports for a list of specs.
importList :: [Spec] -> ShowS
importList :: [Spec] -> ShowS
importList = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) "" ([ShowS] -> ShowS) -> ([Spec] -> [ShowS]) -> [Spec] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Spec -> ShowS) -> [Spec] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Spec -> ShowS
f
  where
    f :: Spec -> ShowS
    f :: Spec -> ShowS
f spec :: Spec
spec = "import qualified " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (Spec -> String
specModule Spec
spec) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. "Spec\n"

-- | Combine a list of strings with (>>).
sequenceS :: [ShowS] -> ShowS
sequenceS :: [ShowS] -> ShowS
sequenceS = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) "" ([ShowS] -> ShowS) -> ([ShowS] -> [ShowS]) -> [ShowS] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse " >> "

-- | Convert a list of specs to code.
formatSpecs :: [Spec] -> ShowS
formatSpecs :: [Spec] -> ShowS
formatSpecs xs :: [Spec]
xs
  | [Spec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Spec]
xs   = "return ()"
  | Bool
otherwise = [ShowS] -> ShowS
sequenceS ((Spec -> ShowS) -> [Spec] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Spec -> ShowS
formatSpec [Spec]
xs)

-- | Convert a spec to code.
formatSpec :: Spec -> ShowS
formatSpec :: Spec -> ShowS
formatSpec (Spec file :: String
file name :: String
name) = "postProcessSpec " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows String
file ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. " (describe " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall a. Show a => a -> ShowS
shows String
name ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. " " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
name ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. "Spec.spec)"

findSpecs :: FilePath -> IO [Spec]
findSpecs :: String -> IO [Spec]
findSpecs src :: String
src = do
  let (dir :: String
dir, file :: String
file) = String -> (String, String)
splitFileName String
src
  (String -> Maybe Spec) -> [String] -> [Spec]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> String -> Maybe Spec
fileToSpec String
dir) ([String] -> [Spec])
-> ([String] -> [String]) -> [String] -> [Spec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
file) ([String] -> [Spec]) -> IO [String] -> IO [Spec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getFilesRecursive String
dir

fileToSpec :: FilePath -> FilePath -> Maybe Spec
fileToSpec :: String -> String -> Maybe Spec
fileToSpec dir :: String
dir file :: String
file = case [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitDirectories String
file of
  x :: String
x:xs :: [String]
xs -> case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix "Spec.hs" String
x Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix "Spec.lhs" String
x of
    Just name :: String
name | String -> Bool
isValidModuleName String
name Bool -> Bool -> Bool
&& (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all String -> Bool
isValidModuleName [String]
xs ->
      Spec -> Maybe Spec
forall a. a -> Maybe a
Just (Spec -> Maybe Spec) -> (String -> Spec) -> String -> Maybe Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Spec
Spec (String
dir String -> ShowS
</> String
file) (String -> Maybe Spec) -> String -> Maybe Spec
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "." ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse) (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
xs)
    _ -> Maybe Spec
forall a. Maybe a
Nothing
  _ -> Maybe Spec
forall a. Maybe a
Nothing
  where
    stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
    stripSuffix :: [a] -> [a] -> Maybe [a]
stripSuffix suffix :: [a]
suffix str :: [a]
str = [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
suffix) ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
str)

-- See `Cabal.Distribution.ModuleName` (http://git.io/bj34)
isValidModuleName :: String -> Bool
isValidModuleName :: String -> Bool
isValidModuleName [] = Bool
False
isValidModuleName (c :: Char
c:cs :: String
cs) = Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isValidModuleChar String
cs

isValidModuleChar :: Char -> Bool
isValidModuleChar :: Char -> Bool
isValidModuleChar c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\''

getFilesRecursive :: FilePath -> IO [FilePath]
getFilesRecursive :: String -> IO [String]
getFilesRecursive baseDir :: String
baseDir = [String] -> [String]
sortNaturally ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
go []

  where
    go :: FilePath -> IO [FilePath]
    go :: String -> IO [String]
go dir :: String
dir = do
      [String]
c <- ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> ShowS
</>) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [".", ".."]) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents (String
baseDir String -> ShowS
</> String
dir)
      [[String]]
dirs <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesDirectoryExist (String -> IO Bool) -> ShowS -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
baseDir String -> ShowS
</>)) [String]
c IO [String] -> ([String] -> IO [[String]]) -> IO [[String]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
go
      [String]
files <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool) -> ShowS -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
baseDir String -> ShowS
</>)) [String]
c
      [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
files [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
dirs)