{-# LANGUAGE 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 https://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 -> 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)

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

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

-- | Combine a list of strings with (>>).
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

-- See `Cabal.Distribution.ModuleName` (https://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
$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
".."