{-# 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
, 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)

-- | Derive module name from specified path.
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"

-- | 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
== 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

-- | Generate imports for a list of specs.
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

-- | 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] -> 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

-- See `Cabal.Distribution.ModuleName` (http://git.io/bj34)
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
".."