{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}

module Test.Sandwich.TH (
  getSpecFromFolder

  , defaultGetSpecFromFolderOptions
  , GetSpecFromFolderOptions
  , getSpecCombiner
  , getSpecIndividualSpecHooks
  , getSpecWarnOnParseError
  , ShouldWarnOnParseError(..)

  , buildModuleMap
  ) where

import Control.Monad
import Data.Char
import Data.Function
import qualified Data.List as L
import qualified Data.Map as M
import Data.Maybe
import Data.String.Interpolate
import qualified Data.Text as T
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Safe
import System.Directory
import System.FilePath as F
import Test.Sandwich.TH.HasMainFunction
import Test.Sandwich.TH.ModuleMap
import Test.Sandwich.Types.Spec hiding (location)


constId :: b -> a -> a
constId = forall a b. a -> b -> a
const forall a. a -> a
id

data GetSpecFromFolderOptions = GetSpecFromFolderOptions {
  GetSpecFromFolderOptions -> Name
getSpecCombiner :: Name
  , GetSpecFromFolderOptions -> Name
getSpecIndividualSpecHooks :: Name
  , GetSpecFromFolderOptions -> ShouldWarnOnParseError
getSpecWarnOnParseError :: ShouldWarnOnParseError
  }

defaultGetSpecFromFolderOptions :: GetSpecFromFolderOptions
defaultGetSpecFromFolderOptions :: GetSpecFromFolderOptions
defaultGetSpecFromFolderOptions = GetSpecFromFolderOptions {
  getSpecCombiner :: Name
getSpecCombiner = 'describe
  , getSpecIndividualSpecHooks :: Name
getSpecIndividualSpecHooks = 'constId
  , getSpecWarnOnParseError :: ShouldWarnOnParseError
getSpecWarnOnParseError = ShouldWarnOnParseError
WarnOnParseError
  }

getSpecFromFolder :: GetSpecFromFolderOptions -> Q Exp
getSpecFromFolder :: GetSpecFromFolderOptions -> Q Exp
getSpecFromFolder GetSpecFromFolderOptions
getSpecFromFolderOptions = do
  FilePath
dir <- forall a. IO a -> Q a
runIO IO FilePath
getCurrentDirectory
  FilePath
filename <- Loc -> FilePath
loc_filename forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
  let folder :: FilePath
folder = FilePath -> FilePath
dropExtension (FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
filename)

  Module PkgName
_ (ModName FilePath
moduleName) <- Q Module
thisModule

  let modulePrefix' :: FilePath
modulePrefix' = FilePath
moduleName
                    forall a b. a -> (a -> b) -> b
& FilePath -> Text
T.pack
                    forall a b. a -> (a -> b) -> b
& Text -> Text -> [Text]
T.splitOn Text
"."
                    forall a b. a -> (a -> b) -> b
& forall a. [a] -> Maybe [a]
initMay
                    forall a b. a -> (a -> b) -> b
& forall a. a -> Maybe a -> a
fromMaybe []
                    forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Text
T.intercalate Text
"."
                    forall a b. a -> (a -> b) -> b
& Text -> FilePath
T.unpack
  let modulePrefix :: FilePath
modulePrefix = if FilePath
modulePrefix' forall a. Eq a => a -> a -> Bool
== FilePath
"" then FilePath
"" else FilePath
modulePrefix' forall a. Semigroup a => a -> a -> a
<> FilePath
"."
  ReverseModuleMap
moduleMap <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ReverseModuleMap
buildModuleMap FilePath
folder FilePath
modulePrefix
  let reverseModuleMap :: ReverseModuleMap
reverseModuleMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(FilePath
y, FilePath
x) | (FilePath
x, FilePath
y) <- forall k a. Map k a -> [(k, a)]
M.toList ReverseModuleMap
moduleMap]

  FilePath
-> ReverseModuleMap
-> FilePath
-> GetSpecFromFolderOptions
-> Q Exp
getSpecFromFolder' FilePath
folder ReverseModuleMap
reverseModuleMap (FilePath
moduleName forall a. Semigroup a => a -> a -> a
<> FilePath
".") GetSpecFromFolderOptions
getSpecFromFolderOptions

getSpecFromFolder' :: F.FilePath -> ReverseModuleMap -> String -> GetSpecFromFolderOptions -> Q Exp
getSpecFromFolder' :: FilePath
-> ReverseModuleMap
-> FilePath
-> GetSpecFromFolderOptions
-> Q Exp
getSpecFromFolder' FilePath
folder ReverseModuleMap
reverseModuleMap FilePath
modulePrefix gsfo :: GetSpecFromFolderOptions
gsfo@(GetSpecFromFolderOptions {Name
ShouldWarnOnParseError
getSpecWarnOnParseError :: ShouldWarnOnParseError
getSpecIndividualSpecHooks :: Name
getSpecCombiner :: Name
getSpecWarnOnParseError :: GetSpecFromFolderOptions -> ShouldWarnOnParseError
getSpecIndividualSpecHooks :: GetSpecFromFolderOptions -> Name
getSpecCombiner :: GetSpecFromFolderOptions -> Name
..}) = do
  [FilePath]
items <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
folder
  [Exp]
specs <- (forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
items forall a b. (a -> b) -> a -> b
$ \FilePath
item -> do
    Bool
isDirectory <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist (FilePath
folder FilePath -> FilePath -> FilePath
</> FilePath
item)

    if | Bool
isDirectory -> do
           forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (FilePath -> IO Bool
doesFileExist (FilePath
folder FilePath -> FilePath -> FilePath
</> FilePath
item FilePath -> FilePath -> FilePath
<.> FilePath
"hs")) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
             Bool
False -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath
-> ReverseModuleMap
-> FilePath
-> GetSpecFromFolderOptions
-> Q Exp
getSpecFromFolder' (FilePath
folder FilePath -> FilePath -> FilePath
</> FilePath
item) ReverseModuleMap
reverseModuleMap (FilePath
modulePrefix forall a. Semigroup a => a -> a -> a
<> FilePath
item forall a. Semigroup a => a -> a -> a
<> FilePath
".") GetSpecFromFolderOptions
gsfo
             Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- Do nothing, allow the .hs file to be picked up separately
       | FilePath -> FilePath
takeExtension FilePath
item forall a. Eq a => a -> a -> Bool
== FilePath
".hs" -> do
           let fullyQualifiedModule :: FilePath
fullyQualifiedModule = FilePath
modulePrefix forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
takeBaseName FilePath
item
           case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
fullyQualifiedModule ReverseModuleMap
reverseModuleMap of
             Maybe FilePath
Nothing -> do
               FilePath -> Q ()
reportError [i|Couldn't find module #{fullyQualifiedModule} in #{reverseModuleMap}|]
               forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
             Just FilePath
importedName -> do
               Exp
maybeMainFunction <- FilePath -> ShouldWarnOnParseError -> Q Bool
fileHasMainFunction (FilePath
folder FilePath -> FilePath -> FilePath
</> FilePath
item) ShouldWarnOnParseError
getSpecWarnOnParseError forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                 Bool
True -> [e|Just $(varE $ mkName $ importedName <> ".main")|]
                 Bool
False -> [e|Nothing|]

               Exp
alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) fullyQualifiedModule $(return maybeMainFunction)) })|]

               forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn)
                           $ $(varE getSpecIndividualSpecHooks) $(stringE item) $(varE $ mkName $ importedName <> ".tests")|]
       | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

  let currentModule :: FilePath
currentModule = FilePath
modulePrefix
                    forall a b. a -> (a -> b) -> b
& FilePath -> Text
T.pack
                    forall a b. a -> (a -> b) -> b
& Text -> Text -> Maybe Text
T.stripSuffix Text
"."
                    forall a b. a -> (a -> b) -> b
& forall a. a -> Maybe a -> a
fromMaybe Text
""
                    forall a b. a -> (a -> b) -> b
& Text -> FilePath
T.unpack
  Exp
maybeMainFunction <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
currentModule ReverseModuleMap
reverseModuleMap of
    Maybe FilePath
Nothing -> [e|Nothing|]
    Just FilePath
importedName -> FilePath -> ShouldWarnOnParseError -> Q Bool
fileHasMainFunction (FilePath
folder forall a. Semigroup a => a -> a -> a
<> FilePath
".hs") ShouldWarnOnParseError
getSpecWarnOnParseError forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> [e|Just $(varE $ mkName $ importedName <> ".main")|]
      Bool
False -> [e|Nothing|]
  Exp
alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) currentModule $(return maybeMainFunction)) })|]
  [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn)
     $ $(varE getSpecCombiner) $(stringE $ mangleFolderName folder) (L.foldl (>>) (pure ()) $(listE $ fmap return specs))|]

-- * Util

mangleFolderName :: String -> String
mangleFolderName :: FilePath -> FilePath
mangleFolderName = Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
wordify forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeBaseName

-- | Convert a string like "TeamTests" to "Team tests"
wordify :: T.Text -> T.Text
wordify :: Text -> Text
wordify Text
t = Text -> [Text] -> Text
T.intercalate Text
" " forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
capitalizeFirst forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack) [FilePath]
parts
  where parts :: [FilePath]
parts = (Char -> Bool) -> FilePath -> [FilePath]
splitR (\Char
c -> Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c) forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack Text
t

capitalizeFirst :: [T.Text] -> [T.Text]
capitalizeFirst :: [Text] -> [Text]
capitalizeFirst [] = []
capitalizeFirst (Text
x:[Text]
xs) = Text -> Text
capitalize Text
x forall a. a -> [a] -> [a]
: [Text]
xs

capitalize :: T.Text -> T.Text
capitalize :: Text -> Text
capitalize Text
t | Text -> Int
T.length Text
t forall a. Eq a => a -> a -> Bool
== Int
1 = Text -> Text
T.toUpper Text
t
capitalize Text
t = (Char -> Char
toUpper forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
t) Char -> Text -> Text
`T.cons` (Text -> Text
T.tail Text
t)

splitR :: (Char -> Bool) -> String -> [String]
splitR :: (Char -> Bool) -> FilePath -> [FilePath]
splitR Char -> Bool
_ [] = []
splitR Char -> Bool
p FilePath
s =
  let
    go :: Char -> String -> [String]
    go :: Char -> FilePath -> [FilePath]
go Char
m FilePath
s' = case forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Char -> Bool
p FilePath
s' of
      (FilePath
b', [])     -> [ Char
mforall a. a -> [a] -> [a]
:FilePath
b' ]
      (FilePath
b', Char
x:FilePath
xs) -> ( Char
mforall a. a -> [a] -> [a]
:FilePath
b' ) forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
go Char
x FilePath
xs
  in case forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Char -> Bool
p FilePath
s of
    (FilePath
b,  [])    -> [ FilePath
b ]
    ([], Char
h:FilePath
t) -> Char -> FilePath -> [FilePath]
go Char
h FilePath
t
    (FilePath
b,  Char
h:FilePath
t) -> FilePath
b forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
go Char
h FilePath
t