{-# 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 :: FilePath -> FilePath -> FilePath
fromString = FilePath -> FilePath -> FilePath
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 -> FilePath -> FilePath
[Spec] -> FilePath -> FilePath
Spec -> FilePath
(Int -> Spec -> FilePath -> FilePath)
-> (Spec -> FilePath)
-> ([Spec] -> FilePath -> FilePath)
-> Show Spec
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Spec] -> FilePath -> FilePath
$cshowList :: [Spec] -> FilePath -> FilePath
show :: Spec -> FilePath
$cshow :: Spec -> FilePath
showsPrec :: Int -> Spec -> FilePath -> FilePath
$cshowsPrec :: Int -> Spec -> FilePath -> FilePath
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 (FilePath -> FilePath
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 =
  ( FilePath -> FilePath
"{-# LINE 1 " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
shows FilePath
src (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
" #-}\n"
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"{-# LANGUAGE NoImplicitPrelude #-}\n"
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}\n"
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString (FilePath
"module " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> Config -> FilePath
moduleName FilePath
src Config
conf FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" where\n")
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Spec] -> FilePath -> FilePath
importList Maybe [Spec]
nodes
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"import Test.Hspec.Discover\n"
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath)
-> (FilePath -> FilePath -> FilePath)
-> Maybe FilePath
-> FilePath
-> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath -> FilePath
driver FilePath -> FilePath -> FilePath
driverWithFormatter (Config -> Maybe FilePath
configFormatter Config
conf)
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"spec :: Spec\n"
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"spec = "
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Spec] -> FilePath -> FilePath
formatSpecs Maybe [Spec]
nodes
  ) FilePath
"\n"
  where
    driver :: FilePath -> FilePath
driver =
        case Config -> Bool
configNoMain Config
conf of
          Bool
False ->
              FilePath -> FilePath -> FilePath
showString FilePath
"main :: IO ()\n"
            (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"main = hspec spec\n"
          Bool
True -> FilePath -> FilePath
""

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 FilePath -> FilePath
pathToModule FilePath
src else FilePath
"Main") (Config -> Maybe FilePath
configModuleName Config
conf)

-- | Derive module name from specified path.
pathToModule :: FilePath -> String
pathToModule :: FilePath -> FilePath
pathToModule FilePath
f = Char -> Char
toUpper Char
mChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
ms
  where
    fileName :: FilePath
fileName = [FilePath] -> FilePath
forall a. [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) -> FilePath -> FilePath
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 -> FilePath -> FilePath
driverWithFormatter FilePath
f =
    FilePath -> FilePath -> FilePath
showString FilePath
"import qualified " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString (FilePath -> FilePath
moduleNameFromId FilePath
f) (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"\n"
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"main :: IO ()\n"
  (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
"main = hspecWithFormatter " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
f (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
" spec\n"

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

-- | Generate imports for a list of specs.
importList :: Maybe [Spec] -> ShowS
importList :: Maybe [Spec] -> FilePath -> FilePath
importList = ((FilePath -> FilePath)
 -> (FilePath -> FilePath) -> FilePath -> FilePath)
-> (FilePath -> FilePath)
-> [FilePath -> FilePath]
-> FilePath
-> FilePath
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) FilePath -> FilePath
"" ([FilePath -> FilePath] -> FilePath -> FilePath)
-> (Maybe [Spec] -> [FilePath -> FilePath])
-> Maybe [Spec]
-> FilePath
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath)
-> [FilePath] -> [FilePath -> FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath -> FilePath
f ([FilePath] -> [FilePath -> FilePath])
-> (Maybe [Spec] -> [FilePath])
-> Maybe [Spec]
-> [FilePath -> FilePath]
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 -> FilePath -> FilePath
f FilePath
spec = FilePath -> FilePath
"import qualified " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
spec (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
"\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 -> FilePath -> FilePath
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

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

formatSpecs :: Maybe [Spec] -> ShowS
formatSpecs :: Maybe [Spec] -> FilePath -> FilePath
formatSpecs Maybe [Spec]
specs = case Maybe [Spec]
specs of
  Maybe [Spec]
Nothing -> FilePath -> FilePath
"return ()"
  Just [Spec]
xs -> [Spec] -> FilePath -> FilePath
fromForest [Spec]
xs
  where
    fromForest :: [Spec] -> ShowS
    fromForest :: [Spec] -> FilePath -> FilePath
fromForest = [FilePath -> FilePath] -> FilePath -> FilePath
sequenceS ([FilePath -> FilePath] -> FilePath -> FilePath)
-> ([Spec] -> [FilePath -> FilePath])
-> [Spec]
-> FilePath
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Spec -> FilePath -> FilePath) -> [Spec] -> [FilePath -> FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Spec -> FilePath -> FilePath
fromTree

    fromTree :: Spec -> ShowS
    fromTree :: Spec -> FilePath -> FilePath
fromTree Spec
tree = case Spec
tree of
      Spec FilePath
name -> FilePath -> FilePath
"describe " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall a. Show a => a -> FilePath -> FilePath
shows FilePath
name (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
" " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
name (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
"Spec.spec"
      Hook FilePath
name [Spec]
forest -> FilePath -> FilePath
"(" (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
showString FilePath
name (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
".hook $ " (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Spec] -> FilePath -> FilePath
fromForest [Spec]
forest (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
")"

findSpecs :: FilePath -> IO (Maybe [Spec])
findSpecs :: FilePath -> 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]))
-> (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

-- See `Cabal.Distribution.ModuleName` (http://git.io/bj34)
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
/= :: Tree -> Tree -> Bool
$c/= :: Tree -> Tree -> Bool
== :: Tree -> Tree -> Bool
$c== :: Tree -> Tree -> Bool
Eq, Int -> Tree -> FilePath -> FilePath
[Tree] -> FilePath -> FilePath
Tree -> FilePath
(Int -> Tree -> FilePath -> FilePath)
-> (Tree -> FilePath)
-> ([Tree] -> FilePath -> FilePath)
-> Show Tree
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Tree] -> FilePath -> FilePath
$cshowList :: [Tree] -> FilePath -> FilePath
show :: Tree -> FilePath
$cshow :: Tree -> FilePath
showsPrec :: Int -> Tree -> FilePath -> FilePath
$cshowsPrec :: Int -> Tree -> FilePath -> FilePath
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 -> FilePath -> FilePath
[Forest] -> FilePath -> FilePath
Forest -> FilePath
(Int -> Forest -> FilePath -> FilePath)
-> (Forest -> FilePath)
-> ([Forest] -> FilePath -> FilePath)
-> Show Forest
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Forest] -> FilePath -> FilePath
$cshowList :: [Forest] -> FilePath -> FilePath
show :: Forest -> FilePath
$cshow :: Forest -> FilePath
showsPrec :: Int -> Forest -> FilePath -> FilePath
$cshowsPrec :: Int -> Forest -> FilePath -> FilePath
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 -> FilePath -> FilePath
[Hook] -> FilePath -> FilePath
Hook -> FilePath
(Int -> Hook -> FilePath -> FilePath)
-> (Hook -> FilePath)
-> ([Hook] -> FilePath -> FilePath)
-> Show Hook
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Hook] -> FilePath -> FilePath
$cshowList :: [Hook] -> FilePath -> FilePath
show :: Hook -> FilePath
$cshow :: Hook -> FilePath
showsPrec :: Int -> Hook -> FilePath -> FilePath
$cshowsPrec :: Int -> Hook -> FilePath -> FilePath
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 (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)
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 -> FilePath -> FilePath
</> 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 -> FilePath -> FilePath
</> FilePath
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
$ 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 -> FilePath -> FilePath
</> 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 (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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
files = do
    FilePath -> IO Bool
doesFileExist (FilePath
dir FilePath -> FilePath -> FilePath
</> 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 (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 :: 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 (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 (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 (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 (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 :: 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
".."