{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Hspec.Discover.Run (
run
, Spec(..)
, importList
, driverWithFormatter
, moduleNameFromId
, pathToModule
, Tree(..)
, Forest(..)
, Hook(..)
, discover
) 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 String | Hook String [Spec]
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!")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configNoMain Config
conf) (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"hspec-discover: WARNING - The `--no-main' option is deprecated and will be removed in a future release!")
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> Maybe String
configFormatter Config
conf) (Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"hspec-discover: WARNING - The `--formatter' option is deprecated and will be removed in a future release!")
Maybe [Spec]
specs <- String -> IO (Maybe [Spec])
findSpecs String
src
String -> String -> IO ()
writeFile String
dst (String -> Config -> Maybe [Spec] -> String
mkSpecModule String
src Config
conf Maybe [Spec]
specs)
[String]
_ -> do
Handle -> String -> IO ()
hPutStrLn Handle
stderr (ShowS
usage String
name)
IO ()
forall a. IO a
exitFailure
mkSpecModule :: FilePath -> Config -> Maybe [Spec] -> String
mkSpecModule :: String -> Config -> Maybe [Spec] -> String
mkSpecModule String
src Config
conf Maybe [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
"{-# LANGUAGE NoImplicitPrelude #-}\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
. Maybe [Spec] -> ShowS
importList Maybe [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
. Maybe [Spec] -> ShowS
formatSpecs Maybe [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 :: Maybe [Spec] -> ShowS
importList :: Maybe [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)
-> (Maybe [Spec] -> [ShowS]) -> Maybe [Spec] -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS) -> [String] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map String -> ShowS
f ([String] -> [ShowS])
-> (Maybe [Spec] -> [String]) -> Maybe [Spec] -> [ShowS]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ([Spec] -> [String]) -> Maybe [Spec] -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Spec] -> [String]
moduleNames
where
f :: String -> ShowS
f :: String -> ShowS
f String
spec = ShowS
"import qualified " 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
. ShowS
"\n"
moduleNames :: [Spec] -> [String]
moduleNames :: [Spec] -> [String]
moduleNames = [Spec] -> [String]
fromForest
where
fromForest :: [Spec] -> [String]
fromForest :: [Spec] -> [String]
fromForest = (Spec -> [String]) -> [Spec] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Spec -> [String]
fromTree
fromTree :: Spec -> [String]
fromTree :: Spec -> [String]
fromTree Spec
tree = case Spec
tree of
Spec String
name -> [String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Spec"]
Hook String
name [Spec]
forest -> String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [Spec] -> [String]
fromForest [Spec]
forest
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 :: Maybe [Spec] -> ShowS
formatSpecs :: Maybe [Spec] -> ShowS
formatSpecs Maybe [Spec]
specs = case Maybe [Spec]
specs of
Maybe [Spec]
Nothing -> ShowS
"return ()"
Just [Spec]
xs -> [Spec] -> ShowS
fromForest [Spec]
xs
where
fromForest :: [Spec] -> ShowS
fromForest :: [Spec] -> ShowS
fromForest = [ShowS] -> ShowS
sequenceS ([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
fromTree
fromTree :: Spec -> ShowS
fromTree :: Spec -> ShowS
fromTree Spec
tree = case Spec
tree of
Spec String
name -> 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"
Hook String
name [Spec]
forest -> 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
".hook $ " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Spec] -> ShowS
fromForest [Spec]
forest ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
")"
findSpecs :: FilePath -> IO (Maybe [Spec])
findSpecs :: String -> IO (Maybe [Spec])
findSpecs = (Maybe Forest -> Maybe [Spec])
-> IO (Maybe Forest) -> IO (Maybe [Spec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Forest -> [Spec]) -> Maybe Forest -> Maybe [Spec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Forest -> [Spec]
toSpecs) (IO (Maybe Forest) -> IO (Maybe [Spec]))
-> (String -> IO (Maybe Forest)) -> String -> IO (Maybe [Spec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe Forest)
discover
toSpecs :: Forest -> [Spec]
toSpecs :: Forest -> [Spec]
toSpecs = [String] -> Forest -> [Spec]
fromForest []
where
fromForest :: [String] -> Forest -> [Spec]
fromForest :: [String] -> Forest -> [Spec]
fromForest [String]
names (Forest Hook
WithHook [Tree]
xs) = [String -> [Spec] -> Spec
Hook ([String] -> String
mkModule (String
"SpecHook" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
names)) ([Spec] -> Spec) -> [Spec] -> Spec
forall a b. (a -> b) -> a -> b
$ (Tree -> [Spec]) -> [Tree] -> [Spec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String] -> Tree -> [Spec]
fromTree [String]
names) [Tree]
xs]
fromForest [String]
names (Forest Hook
WithoutHook [Tree]
xs) = (Tree -> [Spec]) -> [Tree] -> [Spec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String] -> Tree -> [Spec]
fromTree [String]
names) [Tree]
xs
fromTree :: [String] -> Tree -> [Spec]
fromTree :: [String] -> Tree -> [Spec]
fromTree [String]
names Tree
spec = case Tree
spec of
Leaf String
name -> [String -> Spec
Spec (String -> Spec) -> String -> Spec
forall a b. (a -> b) -> a -> b
$ [String] -> String
mkModule (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
names )]
Node String
name Forest
forest -> [String] -> Forest -> [Spec]
fromForest (String
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
names) Forest
forest
mkModule :: [String] -> String
mkModule :: [String] -> String
mkModule = 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
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
'\''
data Tree = Leaf String | Node String Forest
deriving (Tree -> Tree -> Bool
(Tree -> Tree -> Bool) -> (Tree -> Tree -> Bool) -> Eq Tree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tree -> Tree -> Bool
$c/= :: Tree -> Tree -> Bool
== :: Tree -> Tree -> Bool
$c== :: Tree -> Tree -> Bool
Eq, Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> String
(Int -> Tree -> ShowS)
-> (Tree -> String) -> ([Tree] -> ShowS) -> Show Tree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tree] -> ShowS
$cshowList :: [Tree] -> ShowS
show :: Tree -> String
$cshow :: Tree -> String
showsPrec :: Int -> Tree -> ShowS
$cshowsPrec :: Int -> Tree -> ShowS
Show)
data Forest = Forest Hook [Tree]
deriving (Forest -> Forest -> Bool
(Forest -> Forest -> Bool)
-> (Forest -> Forest -> Bool) -> Eq Forest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Forest -> Forest -> Bool
$c/= :: Forest -> Forest -> Bool
== :: Forest -> Forest -> Bool
$c== :: Forest -> Forest -> Bool
Eq, Int -> Forest -> ShowS
[Forest] -> ShowS
Forest -> String
(Int -> Forest -> ShowS)
-> (Forest -> String) -> ([Forest] -> ShowS) -> Show Forest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Forest] -> ShowS
$cshowList :: [Forest] -> ShowS
show :: Forest -> String
$cshow :: Forest -> String
showsPrec :: Int -> Forest -> ShowS
$cshowsPrec :: Int -> Forest -> ShowS
Show)
data Hook = WithHook | WithoutHook
deriving (Hook -> Hook -> Bool
(Hook -> Hook -> Bool) -> (Hook -> Hook -> Bool) -> Eq Hook
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Hook -> Hook -> Bool
$c/= :: Hook -> Hook -> Bool
== :: Hook -> Hook -> Bool
$c== :: Hook -> Hook -> Bool
Eq, Int -> Hook -> ShowS
[Hook] -> ShowS
Hook -> String
(Int -> Hook -> ShowS)
-> (Hook -> String) -> ([Hook] -> ShowS) -> Show Hook
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Hook] -> ShowS
$cshowList :: [Hook] -> ShowS
show :: Hook -> String
$cshow :: Hook -> String
showsPrec :: Int -> Hook -> ShowS
$cshowsPrec :: Int -> Hook -> ShowS
Show)
sortKey :: Tree -> (String, Int)
sortKey :: Tree -> (String, Int)
sortKey Tree
tree = case Tree
tree of
Leaf String
name -> (String
name, Int
0)
Node String
name Forest
_ -> (String
name, Int
1)
discover :: FilePath -> IO (Maybe Forest)
discover :: String -> IO (Maybe Forest)
discover String
src = (Maybe Forest -> (Forest -> Maybe Forest) -> Maybe Forest
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Forest -> Maybe Forest
filterSrc) (Maybe Forest -> Maybe Forest)
-> IO (Maybe Forest) -> IO (Maybe Forest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe Forest)
specForest String
dir
where
filterSrc :: Forest -> Maybe Forest
filterSrc :: Forest -> Maybe Forest
filterSrc (Forest Hook
hook [Tree]
xs) = Hook -> [Tree] -> Maybe Forest
ensureForest Hook
hook ([Tree] -> Maybe Forest) -> [Tree] -> Maybe Forest
forall a b. (a -> b) -> a -> b
$ ([Tree] -> [Tree])
-> (Tree -> [Tree] -> [Tree]) -> Maybe Tree -> [Tree] -> [Tree]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Tree] -> [Tree]
forall a. a -> a
id ((Tree -> Bool) -> [Tree] -> [Tree]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Tree -> Bool) -> [Tree] -> [Tree])
-> (Tree -> Tree -> Bool) -> Tree -> [Tree] -> [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Tree -> Bool
forall a. Eq a => a -> a -> Bool
(/=)) (String -> Maybe Tree
toSpec String
file) [Tree]
xs
(String
dir, String
file) = String -> (String, String)
splitFileName String
src
specForest :: FilePath -> IO (Maybe Forest)
specForest :: String -> IO (Maybe Forest)
specForest String
dir = do
[String]
files <- String -> IO [String]
listDirectory String
dir
Hook
hook <- String -> [String] -> IO Hook
mkHook String
dir [String]
files
Hook -> [Tree] -> Maybe Forest
ensureForest Hook
hook ([Tree] -> Maybe Forest)
-> ([Maybe Tree] -> [Tree]) -> [Maybe Tree] -> Maybe Forest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree -> (String, Int)) -> [Tree] -> [Tree]
forall a. (a -> (String, Int)) -> [a] -> [a]
sortNaturallyBy Tree -> (String, Int)
sortKey ([Tree] -> [Tree])
-> ([Maybe Tree] -> [Tree]) -> [Maybe Tree] -> [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Tree] -> [Tree]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Tree] -> Maybe Forest)
-> IO [Maybe Tree] -> IO (Maybe Forest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (Maybe Tree)) -> [String] -> IO [Maybe Tree]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO (Maybe Tree)
toSpecTree [String]
files
where
toSpecTree :: FilePath -> IO (Maybe Tree)
toSpecTree :: String -> IO (Maybe Tree)
toSpecTree String
name
| String -> Bool
isValidModuleName String
name = do
String -> IO Bool
doesDirectoryExist (String
dir String -> ShowS
</> String
name) IO Bool -> Maybe Tree -> IO (Maybe Tree) -> IO (Maybe Tree)
forall a. IO Bool -> a -> IO a -> IO a
`fallback` Maybe Tree
forall a. Maybe a
Nothing (IO (Maybe Tree) -> IO (Maybe Tree))
-> IO (Maybe Tree) -> IO (Maybe Tree)
forall a b. (a -> b) -> a -> b
$ do
Maybe Forest
xs <- String -> IO (Maybe Forest)
specForest (String
dir String -> ShowS
</> String
name)
Maybe Tree -> IO (Maybe Tree)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Tree -> IO (Maybe Tree)) -> Maybe Tree -> IO (Maybe Tree)
forall a b. (a -> b) -> a -> b
$ String -> Forest -> Tree
Node String
name (Forest -> Tree) -> Maybe Forest -> Maybe Tree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Forest
xs
| Bool
otherwise = do
String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
name) IO Bool -> Maybe Tree -> IO (Maybe Tree) -> IO (Maybe Tree)
forall a. IO Bool -> a -> IO a -> IO a
`fallback` Maybe Tree
forall a. Maybe a
Nothing (IO (Maybe Tree) -> IO (Maybe Tree))
-> IO (Maybe Tree) -> IO (Maybe Tree)
forall a b. (a -> b) -> a -> b
$ do
Maybe Tree -> IO (Maybe Tree)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Tree -> IO (Maybe Tree)) -> Maybe Tree -> IO (Maybe Tree)
forall a b. (a -> b) -> a -> b
$ String -> Maybe Tree
toSpec String
name
mkHook :: FilePath -> [FilePath] -> IO Hook
mkHook :: String -> [String] -> IO Hook
mkHook String
dir [String]
files
| String
"SpecHook.hs" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
files = do
String -> IO Bool
doesFileExist (String
dir String -> ShowS
</> String
"SpecHook.hs") IO Bool -> Hook -> IO Hook -> IO Hook
forall a. IO Bool -> a -> IO a -> IO a
`fallback` Hook
WithoutHook (IO Hook -> IO Hook) -> IO Hook -> IO Hook
forall a b. (a -> b) -> a -> b
$ do
Hook -> IO Hook
forall (m :: * -> *) a. Monad m => a -> m a
return Hook
WithHook
| Bool
otherwise = Hook -> IO Hook
forall (m :: * -> *) a. Monad m => a -> m a
return Hook
WithoutHook
fallback :: IO Bool -> a -> IO a -> IO a
fallback :: IO Bool -> a -> IO a -> IO a
fallback IO Bool
p a
def IO a
action = do
Bool
bool <- IO Bool
p
if Bool
bool then IO a
action else a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
def
toSpec :: FilePath -> Maybe Tree
toSpec :: String -> Maybe Tree
toSpec String
file = String -> Tree
Leaf (String -> Tree) -> Maybe String -> Maybe Tree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe String
spec Maybe String -> (String -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Bool) -> String -> Maybe String
forall a. (a -> Bool) -> a -> Maybe a
ensure String -> Bool
isValidModuleName)
where
spec :: Maybe String
spec :: Maybe String
spec = String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"Spec.hs" String
file 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
file
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)
ensure :: (a -> Bool) -> a -> Maybe a
ensure :: (a -> Bool) -> a -> Maybe a
ensure a -> Bool
p a
a = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (a -> Bool
p a
a) Maybe () -> Maybe a -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Maybe a
forall a. a -> Maybe a
Just a
a
ensureForest :: Hook -> [Tree] -> Maybe Forest
ensureForest :: Hook -> [Tree] -> Maybe Forest
ensureForest Hook
hook = ([Tree] -> Forest) -> Maybe [Tree] -> Maybe Forest
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Hook -> [Tree] -> Forest
Forest Hook
hook) (Maybe [Tree] -> Maybe Forest)
-> ([Tree] -> Maybe [Tree]) -> [Tree] -> Maybe Forest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Tree] -> Bool) -> [Tree] -> Maybe [Tree]
forall a. (a -> Bool) -> a -> Maybe a
ensure (Bool -> Bool
not (Bool -> Bool) -> ([Tree] -> Bool) -> [Tree] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
listDirectory :: FilePath -> IO [FilePath]
listDirectory :: String -> IO [String]
listDirectory String
path = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. (Eq a, IsString a) => a -> Bool
f ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
path
where f :: a -> Bool
f a
filename = a
filename a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
"." Bool -> Bool -> Bool
&& a
filename a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
".."