content: {-# 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 = showString
  
  data Spec = Spec String | Hook String [Spec]
    deriving (Eq, Show)
  
  run :: [String] -> IO ()
  run args_ = do
    name <- getProgName
    case args_ of
      src : _ : dst : args -> case parseConfig name args of
        Left err -> do
          hPutStrLn stderr err
          exitFailure
        Right conf -> do
          when (configNested conf)             (hPutStrLn stderr "hspec-discover: WARNING - The `--nested' option is deprecated and will be removed in a future release!")
          when (configNoMain conf)             (hPutStrLn stderr "hspec-discover: WARNING - The `--no-main' option is deprecated and will be removed in a future release!")
          when (isJust $ configFormatter conf) (hPutStrLn stderr "hspec-discover: WARNING - The `--formatter' option is deprecated and will be removed in a future release!")
          specs <- findSpecs src
          writeFile dst (mkSpecModule src conf specs)
      _ -> do
        hPutStrLn stderr (usage name)
        exitFailure
  
  mkSpecModule :: FilePath -> Config -> Maybe [Spec] -> String
  mkSpecModule src conf nodes =
    ( "{-# LINE 1 " . shows src . " #-}\n"
    . showString "{-# LANGUAGE NoImplicitPrelude #-}\n"
    . showString "{-# OPTIONS_GHC -w -Wall -fno-warn-warnings-deprecations #-}\n"
    . showString ("module " ++ moduleName src conf ++ " where\n")
    . importList nodes
    . showString "import Test.Hspec.Discover\n"
    . maybe driver driverWithFormatter (configFormatter conf)
    . showString "spec :: Spec\n"
    . showString "spec = "
    . formatSpecs nodes
    ) "\n"
    where
      driver =
          case configNoMain conf of
            False ->
                showString "main :: IO ()\n"
              . showString "main = hspec spec\n"
            True -> ""
  
  moduleName :: FilePath -> Config -> String
  moduleName src conf = fromMaybe (if configNoMain conf then pathToModule src else "Main") (configModuleName conf)
  
  -- | Derive module name from specified path.
  pathToModule :: FilePath -> String
  pathToModule f = toUpper m:ms
    where
      fileName = last $ splitDirectories f
      m:ms = takeWhile (/= '.') fileName
  
  driverWithFormatter :: String -> ShowS
  driverWithFormatter f =
      showString "import qualified " . showString (moduleNameFromId f) . showString "\n"
    . showString "main :: IO ()\n"
    . showString "main = hspecWithFormatter " . showString f . showString " spec\n"
  
  -- | Return module name of a fully qualified identifier.
  moduleNameFromId :: String -> String
  moduleNameFromId = reverse . dropWhile (== '.') . dropWhile (/= '.') . reverse
  
  -- | Generate imports for a list of specs.
  importList :: Maybe [Spec] -> ShowS
  importList = foldr (.) "" . map f . maybe [] moduleNames
    where
      f :: String -> ShowS
      f spec = "import qualified " . showString spec . "\n"
  
  moduleNames :: [Spec] -> [String]
  moduleNames = fromForest
    where
      fromForest :: [Spec] -> [String]
      fromForest = concatMap fromTree
  
      fromTree :: Spec -> [String]
      fromTree tree = case tree of
        Spec name -> [name ++ "Spec"]
        Hook name forest -> name : fromForest forest
  
  -- | Combine a list of strings with (>>).
  sequenceS :: [ShowS] -> ShowS
  sequenceS = foldr (.) "" . intersperse " >> "
  
  formatSpecs :: Maybe [Spec] -> ShowS
  formatSpecs = maybe "return ()" fromForest
    where
      fromForest :: [Spec] -> ShowS
      fromForest = sequenceS . map fromTree
  
      fromTree :: Spec -> ShowS
      fromTree tree = case tree of
        Spec name -> "describe " . shows name . " " . showString name . "Spec.spec"
        Hook name forest -> "(" . showString name . ".hook $ " . fromForest forest . ")"
  
  findSpecs :: FilePath -> IO (Maybe [Spec])
  findSpecs = fmap (fmap toSpecs) . discover
  
  toSpecs :: Forest -> [Spec]
  toSpecs = fromForest []
    where
      fromForest :: [String] -> Forest -> [Spec]
      fromForest names (Forest WithHook xs) = [Hook (mkModule ("SpecHook" : names)) $ concatMap (fromTree names) xs]
      fromForest names (Forest WithoutHook xs) = concatMap (fromTree names) xs
  
      fromTree :: [String] -> Tree -> [Spec]
      fromTree names spec = case spec of
        Leaf name -> [Spec $ mkModule (name : names )]
        Node name forest -> fromForest (name : names) forest
  
      mkModule :: [String] -> String
      mkModule = intercalate "." . reverse
  
  -- See `Cabal.Distribution.ModuleName` (https://git.io/bj34)
  isValidModuleName :: String -> Bool
  isValidModuleName [] = False
  isValidModuleName (c:cs) = isUpper c && all isValidModuleChar cs
  
  isValidModuleChar :: Char -> Bool
  isValidModuleChar c = isAlphaNum c || c == '_' || c == '\''
  
  data Tree = Leaf String | Node String Forest
    deriving (Eq, Show)
  
  data Forest = Forest Hook [Tree]
    deriving (Eq, Show)
  
  data Hook = WithHook | WithoutHook
    deriving (Eq, Show)
  
  sortKey :: Tree -> (String, Int)
  sortKey tree = case tree of
    Leaf name -> (name, 0)
    Node name _ -> (name, 1)
  
  discover :: FilePath -> IO (Maybe Forest)
  discover src = (>>= filterSrc) <$> specForest dir
    where
      filterSrc :: Forest -> Maybe Forest
      filterSrc (Forest hook xs) = ensureForest hook $ maybe id (filter . (/=)) (toSpec file) xs
  
      (dir, file) = splitFileName src
  
  specForest :: FilePath -> IO (Maybe Forest)
  specForest dir = do
    files <- listDirectory dir
    hook <- mkHook dir files
    ensureForest hook . sortNaturallyBy sortKey . catMaybes <$> mapM toSpecTree files
    where
      toSpecTree :: FilePath -> IO (Maybe Tree)
      toSpecTree name
        | isValidModuleName name = do
            doesDirectoryExist (dir </> name) `fallback` Nothing $ do
              xs <- specForest (dir </> name)
              return $ Node name <$> xs
        | otherwise = do
            doesFileExist (dir </> name) `fallback` Nothing $ do
              return $ toSpec name
  
  mkHook :: FilePath -> [FilePath] -> IO Hook
  mkHook dir files
    | "SpecHook.hs" `elem` files = do
      doesFileExist (dir </> "SpecHook.hs") `fallback` WithoutHook $ do
        return WithHook
    | otherwise = return WithoutHook
  
  fallback :: IO Bool -> a -> IO a -> IO a
  fallback p def action = do
    bool <- p
    if bool then action else return def
  
  toSpec :: FilePath -> Maybe Tree
  toSpec file = Leaf <$> (spec >>= ensure isValidModuleName)
    where
      spec :: Maybe String
      spec = stripSuffix "Spec.hs" file <|> stripSuffix "Spec.lhs" file
  
      stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
      stripSuffix suffix str = reverse <$> stripPrefix (reverse suffix) (reverse str)
  
  ensure :: (a -> Bool) -> a -> Maybe a
  ensure p a = guard (p a) >> Just a
  
  ensureForest :: Hook -> [Tree] -> Maybe Forest
  ensureForest hook = fmap (Forest hook) . ensure (not . null)
  
  listDirectory :: FilePath -> IO [FilePath]
  listDirectory path = filter f <$> getDirectoryContents path
    where f filename = filename /= "." && filename /= ".."
  