{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}

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 = (a -> a) -> b -> a -> a
forall a b. a -> b -> a
const a -> a
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 :: Name -> Name -> ShouldWarnOnParseError -> GetSpecFromFolderOptions
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 <- IO FilePath -> Q FilePath
forall a. IO a -> Q a
runIO IO FilePath
getCurrentDirectory
  FilePath
filename <- Loc -> FilePath
loc_filename (Loc -> FilePath) -> Q Loc -> Q FilePath
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
                    FilePath -> (FilePath -> Text) -> Text
forall a b. a -> (a -> b) -> b
& FilePath -> Text
T.pack
                    Text -> (Text -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& Text -> Text -> [Text]
T.splitOn Text
"."
                    [Text] -> ([Text] -> Maybe [Text]) -> Maybe [Text]
forall a b. a -> (a -> b) -> b
& [Text] -> Maybe [Text]
forall a. [a] -> Maybe [a]
initMay
                    Maybe [Text] -> (Maybe [Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe []
                    [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Text
T.intercalate Text
"."
                    Text -> (Text -> FilePath) -> FilePath
forall a b. a -> (a -> b) -> b
& Text -> FilePath
T.unpack
  let modulePrefix :: FilePath
modulePrefix = if FilePath
modulePrefix' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" then FilePath
"" else FilePath
modulePrefix' FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"."
  ModuleMap
moduleMap <- IO ModuleMap -> Q ModuleMap
forall a. IO a -> Q a
runIO (IO ModuleMap -> Q ModuleMap) -> IO ModuleMap -> Q ModuleMap
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ModuleMap
buildModuleMap FilePath
folder FilePath
modulePrefix
  let reverseModuleMap :: ModuleMap
reverseModuleMap = [(FilePath, FilePath)] -> ModuleMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(FilePath
y, FilePath
x) | (FilePath
x, FilePath
y) <- ModuleMap -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
M.toList ModuleMap
moduleMap]

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

getSpecFromFolder' :: F.FilePath -> ReverseModuleMap -> String -> GetSpecFromFolderOptions -> Q Exp
getSpecFromFolder' :: FilePath
-> ModuleMap -> FilePath -> GetSpecFromFolderOptions -> Q Exp
getSpecFromFolder' FilePath
folder ModuleMap
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 <- IO [FilePath] -> Q [FilePath]
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO [FilePath] -> Q [FilePath]) -> IO [FilePath] -> Q [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
L.sort ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
folder
  [Exp]
specs <- ([Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Exp] -> [Exp]) -> Q [Maybe Exp] -> Q [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q [Maybe Exp] -> Q [Exp]) -> Q [Maybe Exp] -> Q [Exp]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> (FilePath -> Q (Maybe Exp)) -> Q [Maybe Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
items ((FilePath -> Q (Maybe Exp)) -> Q [Maybe Exp])
-> (FilePath -> Q (Maybe Exp)) -> Q [Maybe Exp]
forall a b. (a -> b) -> a -> b
$ \FilePath
item -> do
    Bool
isDirectory <- IO Bool -> Q Bool
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesDirectoryExist (FilePath
folder FilePath -> FilePath -> FilePath
</> FilePath
item)

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

               Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Q Exp -> Q (Maybe Exp)
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 -> Maybe Exp -> Q (Maybe Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
forall a. Maybe a
Nothing

  let currentModule :: FilePath
currentModule = FilePath
modulePrefix
                    FilePath -> (FilePath -> Text) -> Text
forall a b. a -> (a -> b) -> b
& FilePath -> Text
T.pack
                    Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
& Text -> Text -> Maybe Text
T.stripSuffix Text
"."
                    Maybe Text -> (Maybe Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
""
                    Text -> (Text -> FilePath) -> FilePath
forall a b. a -> (a -> b) -> b
& Text -> FilePath
T.unpack
  Exp
maybeMainFunction <- case FilePath -> ModuleMap -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
currentModule ModuleMap
reverseModuleMap of
    Maybe FilePath
Nothing -> [e|Nothing|]
    Just FilePath
importedName -> FilePath -> ShouldWarnOnParseError -> Q Bool
fileHasMainFunction (FilePath
folder FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".hs") ShouldWarnOnParseError
getSpecWarnOnParseError Q Bool -> (Bool -> Q Exp) -> Q Exp
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 (Text -> FilePath) -> (FilePath -> Text) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
wordify (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (FilePath -> FilePath) -> FilePath -> Text
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
" " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
capitalizeFirst ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
T.toLower (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
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) (FilePath -> [FilePath]) -> FilePath -> [FilePath]
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 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
xs

capitalize :: T.Text -> T.Text
capitalize :: Text -> Text
capitalize Text
t | Text -> Int
T.length Text
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Text -> Text
T.toUpper Text
t
capitalize Text
t = (Char -> Char
toUpper (Char -> Char) -> Char -> Char
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 (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Char -> Bool
p FilePath
s' of
      (FilePath
b', [])     -> [ Char
mChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
b' ]
      (FilePath
b', Char
x:FilePath
xs) -> ( Char
mChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
b' ) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
go Char
x FilePath
xs
  in case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
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 FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
go Char
h FilePath
t