{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Hspec.Discover.Run (
run
, 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 [String]
args_ = do
String
name <- IO String
getProgName
case [String]
args_ of
String
src : String
_ : String
dst : [String]
args -> case String -> [String] -> Either String Config
parseConfig String
name [String]
args of
Left String
err -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
err
IO ()
forall a. IO a
exitFailure
Right 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 String
"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)
[String]
_ -> 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 String
src Config
conf [Spec]
nodes =
( ShowS
"{-# 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
. ShowS
" #-}\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (String
"module " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> Config -> String
moduleName String
src Config
conf String -> ShowS
forall a. [a] -> [a] -> [a]
++String
" 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 String
"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 String
"spec :: Spec\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"spec = "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Spec] -> ShowS
formatSpecs [Spec]
nodes
) String
"\n"
where
driver :: ShowS
driver =
case Config -> Bool
configNoMain Config
conf of
Bool
False ->
String -> ShowS
showString String
"main :: IO ()\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"main = hspec spec\n"
Bool
True -> ShowS
""
moduleName :: FilePath -> Config -> String
moduleName :: String -> Config -> String
moduleName String
src 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 String
"Main") (Config -> Maybe String
configModuleName Config
conf)
pathToModule :: FilePath -> String
pathToModule :: ShowS
pathToModule 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
Char
m:String
ms = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'.') String
fileName
driverWithFormatter :: String -> ShowS
driverWithFormatter :: String -> ShowS
driverWithFormatter String
f =
String -> ShowS
showString String
"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 String
"\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"main :: IO ()\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"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 String
" spec\n"
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
== Char
'.') 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
/= Char
'.') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse
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] -> 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 = ShowS
"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
. ShowS
"Spec\n"
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] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse ShowS
" >> "
formatSpecs :: [Spec] -> ShowS
formatSpecs :: [Spec] -> ShowS
formatSpecs [Spec]
xs
| [Spec] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Spec]
xs = ShowS
"return ()"
| Bool
otherwise = [ShowS] -> ShowS
sequenceS ((Spec -> ShowS) -> [Spec] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map Spec -> ShowS
formatSpec [Spec]
xs)
formatSpec :: Spec -> ShowS
formatSpec :: Spec -> ShowS
formatSpec (Spec String
file String
name) = ShowS
"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
. ShowS
" (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 -> 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
. ShowS
"Spec.spec)"
findSpecs :: FilePath -> IO [Spec]
findSpecs :: String -> IO [Spec]
findSpecs String
src = do
let (String
dir, 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 String
dir 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
String
x:[String]
xs -> case String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"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 String
"Spec.lhs" String
x of
Just 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] -> 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 String
_ -> Maybe Spec
forall a. Maybe a
Nothing
[String]
_ -> Maybe Spec
forall a. Maybe a
Nothing
where
stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix :: [a] -> [a] -> Maybe [a]
stripSuffix [a]
suffix [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)
isValidModuleName :: String -> Bool
isValidModuleName :: String -> Bool
isValidModuleName [] = Bool
False
isValidModuleName (Char
c: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 Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''
getFilesRecursive :: FilePath -> IO [FilePath]
getFilesRecursive :: String -> IO [String]
getFilesRecursive 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 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
".."]) ([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)