{-# LANGUAGE 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 :: FilePath -> ShowS
fromString = FilePath -> 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
$c== :: Spec -> Spec -> Bool
== :: Spec -> Spec -> Bool
$c/= :: Spec -> Spec -> Bool
/= :: Spec -> Spec -> Bool
Eq, Int -> Spec -> ShowS
[Spec] -> ShowS
Spec -> FilePath
(Int -> Spec -> ShowS)
-> (Spec -> FilePath) -> ([Spec] -> ShowS) -> Show Spec
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Spec -> ShowS
showsPrec :: Int -> Spec -> ShowS
$cshow :: Spec -> FilePath
show :: Spec -> FilePath
$cshowList :: [Spec] -> ShowS
showList :: [Spec] -> ShowS
Show)
run :: [String] -> IO ()
run :: [FilePath] -> IO ()
run [FilePath]
args_ = do
FilePath
name <- IO FilePath
getProgName
case [FilePath]
args_ of
FilePath
src : FilePath
_ : FilePath
dst : [FilePath]
args -> case FilePath -> [FilePath] -> Either FilePath Config
parseConfig FilePath
name [FilePath]
args of
Left FilePath
err -> do
Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
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 -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"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 -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"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 FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool) -> Maybe FilePath -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> Maybe FilePath
configFormatter Config
conf) (Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
"hspec-discover: WARNING - The `--formatter' option is deprecated and will be removed in a future release!")
Maybe [Spec]
specs <- FilePath -> IO (Maybe [Spec])
findSpecs FilePath
src
FilePath -> FilePath -> IO ()
writeFile FilePath
dst (FilePath -> Config -> Maybe [Spec] -> FilePath
mkSpecModule FilePath
src Config
conf Maybe [Spec]
specs)
[FilePath]
_ -> do
Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (ShowS
usage FilePath
name)
IO ()
forall a. IO a
exitFailure
mkSpecModule :: FilePath -> Config -> Maybe [Spec] -> String
mkSpecModule :: FilePath -> Config -> Maybe [Spec] -> FilePath
mkSpecModule FilePath
src Config
conf Maybe [Spec]
nodes =
( ShowS
"{-# LINE 1 " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
forall a. Show a => a -> ShowS
shows FilePath
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
. FilePath -> ShowS
showString FilePath
"{-# LANGUAGE NoImplicitPrelude #-}\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
"{-# OPTIONS_GHC -w -Wall -fno-warn-warnings-deprecations #-}\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString (FilePath
"module " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath -> Config -> FilePath
moduleName FilePath
src Config
conf FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++FilePath
" 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
. FilePath -> ShowS
showString FilePath
"import Test.Hspec.Discover\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> (FilePath -> ShowS) -> Maybe FilePath -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
driver FilePath -> ShowS
driverWithFormatter (Config -> Maybe FilePath
configFormatter Config
conf)
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
"spec :: Spec\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
"spec = "
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Spec] -> ShowS
formatSpecs Maybe [Spec]
nodes
) FilePath
"\n"
where
driver :: ShowS
driver =
case Config -> Bool
configNoMain Config
conf of
Bool
False ->
FilePath -> ShowS
showString FilePath
"main :: IO ()\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
"main = hspec spec\n"
Bool
True -> ShowS
""
moduleName :: FilePath -> Config -> String
moduleName :: FilePath -> Config -> FilePath
moduleName FilePath
src Config
conf = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (if Config -> Bool
configNoMain Config
conf then ShowS
pathToModule FilePath
src else FilePath
"Main") (Config -> Maybe FilePath
configModuleName Config
conf)
pathToModule :: FilePath -> String
pathToModule :: ShowS
pathToModule FilePath
f = Char -> Char
toUpper Char
mChar -> ShowS
forall a. a -> [a] -> [a]
:FilePath
ms
where
fileName :: FilePath
fileName = [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
last ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
splitDirectories FilePath
f
Char
m:FilePath
ms = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'.') FilePath
fileName
driverWithFormatter :: String -> ShowS
driverWithFormatter :: FilePath -> ShowS
driverWithFormatter FilePath
f =
FilePath -> ShowS
showString FilePath
"import qualified " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString (ShowS
moduleNameFromId FilePath
f) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
"\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
"main :: IO ()\n"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
"main = hspecWithFormatter " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
f ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
" 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 a b. (a -> b -> b) -> b -> [a] -> b
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
. (FilePath -> ShowS) -> [FilePath] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ShowS
f ([FilePath] -> [ShowS])
-> (Maybe [Spec] -> [FilePath]) -> Maybe [Spec] -> [ShowS]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> ([Spec] -> [FilePath]) -> Maybe [Spec] -> [FilePath]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] [Spec] -> [FilePath]
moduleNames
where
f :: String -> ShowS
f :: FilePath -> ShowS
f FilePath
spec = ShowS
"import qualified " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
spec ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
"\n"
moduleNames :: [Spec] -> [String]
moduleNames :: [Spec] -> [FilePath]
moduleNames = [Spec] -> [FilePath]
fromForest
where
fromForest :: [Spec] -> [String]
fromForest :: [Spec] -> [FilePath]
fromForest = (Spec -> [FilePath]) -> [Spec] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Spec -> [FilePath]
fromTree
fromTree :: Spec -> [String]
fromTree :: Spec -> [FilePath]
fromTree Spec
tree = case Spec
tree of
Spec FilePath
name -> [FilePath
name FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"Spec"]
Hook FilePath
name [Spec]
forest -> FilePath
name FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [Spec] -> [FilePath]
fromForest [Spec]
forest
sequenceS :: [ShowS] -> ShowS
sequenceS :: [ShowS] -> ShowS
sequenceS = (ShowS -> ShowS -> ShowS) -> ShowS -> [ShowS] -> ShowS
forall a b. (a -> b -> b) -> b -> [a] -> b
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 = ShowS -> ([Spec] -> ShowS) -> Maybe [Spec] -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowS
"return ()" [Spec] -> ShowS
fromForest
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 FilePath
name -> ShowS
"describe " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
forall a. Show a => a -> ShowS
shows FilePath
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
. FilePath -> ShowS
showString FilePath
name ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
"Spec.spec"
Hook FilePath
name [Spec]
forest -> ShowS
"(" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ShowS
showString FilePath
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 :: FilePath -> IO (Maybe [Spec])
findSpecs = (Maybe Forest -> Maybe [Spec])
-> IO (Maybe Forest) -> IO (Maybe [Spec])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Forest -> [Spec]) -> Maybe Forest -> Maybe [Spec]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Forest -> [Spec]
toSpecs) (IO (Maybe Forest) -> IO (Maybe [Spec]))
-> (FilePath -> IO (Maybe Forest)) -> FilePath -> IO (Maybe [Spec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Maybe Forest)
discover
toSpecs :: Forest -> [Spec]
toSpecs :: Forest -> [Spec]
toSpecs = [FilePath] -> Forest -> [Spec]
fromForest []
where
fromForest :: [String] -> Forest -> [Spec]
fromForest :: [FilePath] -> Forest -> [Spec]
fromForest [FilePath]
names (Forest Hook
WithHook [Tree]
xs) = [FilePath -> [Spec] -> Spec
Hook ([FilePath] -> FilePath
mkModule (FilePath
"SpecHook" FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
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 ([FilePath] -> Tree -> [Spec]
fromTree [FilePath]
names) [Tree]
xs]
fromForest [FilePath]
names (Forest Hook
WithoutHook [Tree]
xs) = (Tree -> [Spec]) -> [Tree] -> [Spec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([FilePath] -> Tree -> [Spec]
fromTree [FilePath]
names) [Tree]
xs
fromTree :: [String] -> Tree -> [Spec]
fromTree :: [FilePath] -> Tree -> [Spec]
fromTree [FilePath]
names Tree
spec = case Tree
spec of
Leaf FilePath
name -> [FilePath -> Spec
Spec (FilePath -> Spec) -> FilePath -> Spec
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
mkModule (FilePath
name FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
names )]
Node FilePath
name Forest
forest -> [FilePath] -> Forest -> [Spec]
fromForest (FilePath
name FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
names) Forest
forest
mkModule :: [String] -> String
mkModule :: [FilePath] -> FilePath
mkModule = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"." ([FilePath] -> FilePath)
-> ([FilePath] -> [FilePath]) -> [FilePath] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse
isValidModuleName :: String -> Bool
isValidModuleName :: FilePath -> Bool
isValidModuleName [] = Bool
False
isValidModuleName (Char
c:FilePath
cs) = Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
&& (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isValidModuleChar FilePath
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
$c== :: Tree -> Tree -> Bool
== :: Tree -> Tree -> Bool
$c/= :: Tree -> Tree -> Bool
/= :: Tree -> Tree -> Bool
Eq, Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> FilePath
(Int -> Tree -> ShowS)
-> (Tree -> FilePath) -> ([Tree] -> ShowS) -> Show Tree
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tree -> ShowS
showsPrec :: Int -> Tree -> ShowS
$cshow :: Tree -> FilePath
show :: Tree -> FilePath
$cshowList :: [Tree] -> ShowS
showList :: [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
$c== :: Forest -> Forest -> Bool
== :: Forest -> Forest -> Bool
$c/= :: Forest -> Forest -> Bool
/= :: Forest -> Forest -> Bool
Eq, Int -> Forest -> ShowS
[Forest] -> ShowS
Forest -> FilePath
(Int -> Forest -> ShowS)
-> (Forest -> FilePath) -> ([Forest] -> ShowS) -> Show Forest
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Forest -> ShowS
showsPrec :: Int -> Forest -> ShowS
$cshow :: Forest -> FilePath
show :: Forest -> FilePath
$cshowList :: [Forest] -> ShowS
showList :: [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
$c== :: Hook -> Hook -> Bool
== :: Hook -> Hook -> Bool
$c/= :: Hook -> Hook -> Bool
/= :: Hook -> Hook -> Bool
Eq, Int -> Hook -> ShowS
[Hook] -> ShowS
Hook -> FilePath
(Int -> Hook -> ShowS)
-> (Hook -> FilePath) -> ([Hook] -> ShowS) -> Show Hook
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hook -> ShowS
showsPrec :: Int -> Hook -> ShowS
$cshow :: Hook -> FilePath
show :: Hook -> FilePath
$cshowList :: [Hook] -> ShowS
showList :: [Hook] -> ShowS
Show)
sortKey :: Tree -> (String, Int)
sortKey :: Tree -> (FilePath, Int)
sortKey Tree
tree = case Tree
tree of
Leaf FilePath
name -> (FilePath
name, Int
0)
Node FilePath
name Forest
_ -> (FilePath
name, Int
1)
discover :: FilePath -> IO (Maybe Forest)
discover :: FilePath -> IO (Maybe Forest)
discover FilePath
src = (Maybe Forest -> (Forest -> Maybe Forest) -> Maybe Forest
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
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
<$> FilePath -> IO (Maybe Forest)
specForest FilePath
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
(/=)) (FilePath -> Maybe Tree
toSpec FilePath
file) [Tree]
xs
(FilePath
dir, FilePath
file) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
src
specForest :: FilePath -> IO (Maybe Forest)
specForest :: FilePath -> IO (Maybe Forest)
specForest FilePath
dir = do
[FilePath]
files <- FilePath -> IO [FilePath]
listDirectory FilePath
dir
Hook
hook <- FilePath -> [FilePath] -> IO Hook
mkHook FilePath
dir [FilePath]
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 -> (FilePath, Int)) -> [Tree] -> [Tree]
forall a. (a -> (FilePath, Int)) -> [a] -> [a]
sortNaturallyBy Tree -> (FilePath, 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
<$> (FilePath -> IO (Maybe Tree)) -> [FilePath] -> IO [Maybe Tree]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> IO (Maybe Tree)
toSpecTree [FilePath]
files
where
toSpecTree :: FilePath -> IO (Maybe Tree)
toSpecTree :: FilePath -> IO (Maybe Tree)
toSpecTree FilePath
name
| FilePath -> Bool
isValidModuleName FilePath
name = do
FilePath -> IO Bool
doesDirectoryExist (FilePath
dir FilePath -> ShowS
</> FilePath
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 <- FilePath -> IO (Maybe Forest)
specForest (FilePath
dir FilePath -> ShowS
</> FilePath
name)
Maybe Tree -> IO (Maybe Tree)
forall a. a -> IO a
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
$ FilePath -> Forest -> Tree
Node FilePath
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
FilePath -> IO Bool
doesFileExist (FilePath
dir FilePath -> ShowS
</> FilePath
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 a. a -> IO a
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
$ FilePath -> Maybe Tree
toSpec FilePath
name
mkHook :: FilePath -> [FilePath] -> IO Hook
mkHook :: FilePath -> [FilePath] -> IO Hook
mkHook FilePath
dir [FilePath]
files
| FilePath
"SpecHook.hs" FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
files = do
FilePath -> IO Bool
doesFileExist (FilePath
dir FilePath -> ShowS
</> FilePath
"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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Hook
WithHook
| Bool
otherwise = Hook -> IO Hook
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Hook
WithoutHook
fallback :: IO Bool -> a -> IO a -> IO a
fallback :: forall a. 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
def
toSpec :: FilePath -> Maybe Tree
toSpec :: FilePath -> Maybe Tree
toSpec FilePath
file = FilePath -> Tree
Leaf (FilePath -> Tree) -> Maybe FilePath -> Maybe Tree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe FilePath
spec Maybe FilePath -> (FilePath -> Maybe FilePath) -> Maybe FilePath
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> Bool) -> FilePath -> Maybe FilePath
forall a. (a -> Bool) -> a -> Maybe a
ensure FilePath -> Bool
isValidModuleName)
where
spec :: Maybe String
spec :: Maybe FilePath
spec = FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix FilePath
"Spec.hs" FilePath
file Maybe FilePath -> Maybe FilePath -> Maybe FilePath
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix FilePath
"Spec.lhs" FilePath
file
stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
stripSuffix :: forall a. Eq a => [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 :: forall a. (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 a b. Maybe a -> Maybe b -> Maybe b
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 a b. (a -> b) -> Maybe a -> Maybe b
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
listDirectory :: FilePath -> IO [FilePath]
listDirectory :: FilePath -> IO [FilePath]
listDirectory FilePath
path = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
forall {a}. (Eq a, IsString a) => a -> Bool
f ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
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
".."