{-# 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
| 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))|]
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
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