{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Tasty.AutoCollect.ConvertTest (
plugin,
) where
import Control.Arrow ((&&&))
import Control.Monad (unless, zipWithM)
import Control.Monad.Trans.State.Strict (State)
import qualified Control.Monad.Trans.State.Strict as State
import Data.Foldable (toList)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (isNothing)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import Test.Tasty.AutoCollect.Constants
import Test.Tasty.AutoCollect.Error
import Test.Tasty.AutoCollect.ExternalNames
import Test.Tasty.AutoCollect.GHC
plugin :: Plugin
plugin :: Plugin
plugin =
Plugin -> Plugin
setKeepRawTokenStream
Plugin
defaultPlugin
{ pluginRecompile :: [[Char]] -> IO PluginRecompile
pluginRecompile = [[Char]] -> IO PluginRecompile
purePlugin
, parsedResultAction :: [[Char]] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = \[[Char]]
_ ModSummary
_ HsParsedModule
result -> do
HscEnv
env <- Hsc HscEnv
getHscEnv
ExternalNames
names <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalNames
loadExternalNames HscEnv
env
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HsParsedModule
-> (HsParsedModule -> HsParsedModule) -> HsParsedModule
withParsedResultModule HsParsedModule
result (ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule ExternalNames
names)
}
transformTestModule :: ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule :: ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule ExternalNames
names HsParsedModule
parsedModl = HsParsedModule
parsedModl{hpm_module :: Located HsModule
hpm_module = HsModule -> HsModule
updateModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsParsedModule -> Located HsModule
hpm_module HsParsedModule
parsedModl}
where
updateModule :: HsModule -> HsModule
updateModule HsModule
modl =
let ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls, [GenLocated SrcSpanAnnN RdrName]
testNames) = forall a.
ConvertTestModuleM a -> (a, [GenLocated SrcSpanAnnN RdrName])
runConvertTestModuleM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (ExternalNames
-> LHsDecl GhcPs -> ConvertTestModuleM [LHsDecl GhcPs]
convertTest ExternalNames
names) forall a b. (a -> b) -> a -> b
$ HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
modl
in HsModule
modl
{ hsmodExports :: Maybe (LocatedL [LIE GhcPs])
hsmodExports = GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
updateExports forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule -> Maybe (LocatedL [LIE GhcPs])
hsmodExports HsModule
modl
, hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = [GenLocated SrcSpanAnnN RdrName] -> [LHsDecl GhcPs]
mkTestsList [GenLocated SrcSpanAnnN RdrName]
testNames forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls
}
updateExports :: GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
updateExports GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports
| Just RealSrcSpan
exportSpan <- forall l e a.
Ord l =>
(GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a
firstLocatedWhere forall {a}. GenLocated a [Char] -> Maybe a
getTestExportAnnSrcSpan (HsParsedModule -> LocatedL [LIE GhcPs] -> [RealLocated [Char]]
getExportComments HsParsedModule
parsedModl GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports) =
(forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> SrcSpanAnnA
toSrcAnnA RealSrcSpan
exportSpan) IE GhcPs
exportIE forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports
| Bool
otherwise =
GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports
getTestExportAnnSrcSpan :: GenLocated a [Char] -> Maybe a
getTestExportAnnSrcSpan (L a
loc [Char]
comment) =
if [Char] -> Bool
isTestExportComment [Char]
comment
then forall a. a -> Maybe a
Just a
loc
else forall a. Maybe a
Nothing
exportIE :: IE GhcPs
exportIE = forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar NoExtField
NoExtField forall a b. (a -> b) -> a -> b
$ forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> IEWrappedName RdrName
mkIEName GenLocated SrcSpanAnnN RdrName
testListName
mkTestsList :: [LocatedN RdrName] -> [LHsDecl GhcPs]
mkTestsList :: [GenLocated SrcSpanAnnN RdrName] -> [LHsDecl GhcPs]
mkTestsList [GenLocated SrcSpanAnnN RdrName]
testNames =
let testsList :: GenLocated (SrcAnn ann) (HsExpr GhcPs)
testsList = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ [LHsExpr GhcPs] -> HsExpr GhcPs
mkExplicitList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN RdrName -> LHsExpr GhcPs
lhsvar [GenLocated SrcSpanAnnN RdrName]
testNames
in [ forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig GenLocated SrcSpanAnnN RdrName
testListName forall a b. (a -> b) -> a -> b
$ ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names
, forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl GenLocated SrcSpanAnnN RdrName
testListName [] (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
flattenTestList forall {ann}. GenLocated (SrcAnn ann) (HsExpr GhcPs)
testsList) forall a. Maybe a
Nothing
]
flattenTestList :: GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs
flattenTestList GenLocated SrcSpanAnnA (HsExpr GhcPs)
testsList =
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (Name -> LHsExpr GhcPs
mkHsVar forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_concat ExternalNames
names) forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkExprTypeSig GenLocated SrcSpanAnnA (HsExpr GhcPs)
testsList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy forall a. EpAnn a
noAnn (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names)
convertTest :: ExternalNames -> LHsDecl GhcPs -> ConvertTestModuleM [LHsDecl GhcPs]
convertTest :: ExternalNames
-> LHsDecl GhcPs -> ConvertTestModuleM [LHsDecl GhcPs]
convertTest ExternalNames
names LHsDecl GhcPs
ldecl =
case LHsDecl GhcPs -> Maybe ParsedDecl
parseDecl LHsDecl GhcPs
ldecl of
Just (FuncSig [GenLocated SrcSpanAnnN RdrName
funcName] LHsSigWcType GhcPs
ty)
| Just TestType
testType <- [Char] -> Maybe TestType
parseTestType (GenLocated SrcSpanAnnN RdrName -> [Char]
fromRdrName GenLocated SrcSpanAnnN RdrName
funcName) -> do
GenLocated SrcSpanAnnN RdrName
testName <- ConvertTestModuleM (GenLocated SrcSpanAnnN RdrName)
getNextTestName
SigInfo -> ConvertTestModuleM ()
setLastSeenSig
SigInfo
{ TestType
testType :: TestType
testType :: TestType
testType
, GenLocated SrcSpanAnnN RdrName
testName :: GenLocated SrcSpanAnnN RdrName
testName :: GenLocated SrcSpanAnnN RdrName
testName
, signatureType :: LHsSigWcType GhcPs
signatureType = LHsSigWcType GhcPs
ty
}
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
testType LHsSigWcType GhcPs
ty) forall a b. (a -> b) -> a -> b
$
forall a. [Char] -> a
autocollectError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
[ [Char]
"Expected type: " forall a. [a] -> [a] -> [a]
++ TestType -> [Char]
typeForTestType TestType
testType
, [Char]
"Got: " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> [Char]
showPpr LHsSigWcType GhcPs
ty
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [GenLocated SrcSpanAnnN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig GenLocated SrcSpanAnnN RdrName
testName (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
ldecl]
Just (FuncDef GenLocated SrcSpanAnnN RdrName
funcName [LocatedA FuncSingleDef]
funcDefs)
| Just TestType
testType <- [Char] -> Maybe TestType
parseTestType (GenLocated SrcSpanAnnN RdrName -> [Char]
fromRdrName GenLocated SrcSpanAnnN RdrName
funcName) -> do
Maybe SigInfo
mSigInfo <- ConvertTestModuleM (Maybe SigInfo)
getLastSeenSig
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (forall {a} {e} {l}.
GenLocated (SrcSpanAnn' a) e
-> TestType
-> Maybe SigInfo
-> GenLocated l FuncSingleDef
-> StateT
ConvertTestModuleState
Identity
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
convertSingleTest GenLocated SrcSpanAnnN RdrName
funcName TestType
testType) (Maybe SigInfo
mSigInfo forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat forall a. Maybe a
Nothing) [LocatedA FuncSingleDef]
funcDefs
Maybe ParsedDecl
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [LHsDecl GhcPs
ldecl]
where
loc :: SrcSpan
loc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsDecl GhcPs
ldecl
convertSingleTest :: GenLocated (SrcSpanAnn' a) e
-> TestType
-> Maybe SigInfo
-> GenLocated l FuncSingleDef
-> StateT
ConvertTestModuleState
Identity
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
convertSingleTest GenLocated (SrcSpanAnn' a) e
funcName TestType
testType Maybe SigInfo
mSigInfo (L l
_ FuncSingleDef{[LPat GhcPs]
[FuncGuardedBody]
HsLocalBinds GhcPs
funcDefWhereClause :: FuncSingleDef -> HsLocalBinds GhcPs
funcDefGuards :: FuncSingleDef -> [FuncGuardedBody]
funcDefArgs :: FuncSingleDef -> [LPat GhcPs]
funcDefWhereClause :: HsLocalBinds GhcPs
funcDefGuards :: [FuncGuardedBody]
funcDefArgs :: [LPat GhcPs]
..}) = do
(GenLocated SrcSpanAnnN RdrName
testName, Maybe
(HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
mSigType) <-
case Maybe SigInfo
mSigInfo of
Maybe SigInfo
Nothing -> do
GenLocated SrcSpanAnnN RdrName
testName <- ConvertTestModuleM (GenLocated SrcSpanAnnN RdrName)
getNextTestName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnN RdrName
testName, forall a. Maybe a
Nothing)
Just SigInfo{testType :: SigInfo -> TestType
testType = TestType
testTypeFromSig, LHsSigWcType GhcPs
GenLocated SrcSpanAnnN RdrName
signatureType :: LHsSigWcType GhcPs
testName :: GenLocated SrcSpanAnnN RdrName
signatureType :: SigInfo -> LHsSigWcType GhcPs
testName :: SigInfo -> GenLocated SrcSpanAnnN RdrName
..}
| TestType
testType forall a. Eq a => a -> a -> Bool
== TestType
testTypeFromSig -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnN RdrName
testName, forall a. a -> Maybe a
Just LHsSigWcType GhcPs
signatureType)
| Bool
otherwise -> forall a. [Char] -> a
autocollectError forall a b. (a -> b) -> a -> b
$ [Char]
"Found test with different type of signature: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (TestType
testType, TestType
testTypeFromSig)
(GenLocated SrcSpanAnnA (HsExpr GhcPs)
testBody, ConvertTestState{Maybe (HsLocalBinds GhcPs)
mWhereClause :: ConvertTestState -> Maybe (HsLocalBinds GhcPs)
mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause}) <-
case [FuncGuardedBody]
funcDefGuards of
[FuncGuardedBody [] LHsExpr GhcPs
body] -> do
let state :: ConvertTestState
state =
ConvertTestState
{ Maybe
(HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
mSigType :: Maybe (LHsSigWcType GhcPs)
mSigType :: Maybe
(HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
mSigType
, testArgs :: [LPat GhcPs]
testArgs = [LPat GhcPs]
funcDefArgs
, mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause = forall a. a -> Maybe a
Just HsLocalBinds GhcPs
funcDefWhereClause
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
ConvertTestState -> ConvertTestM a -> (a, ConvertTestState)
runConvertTestM ConvertTestState
state forall a b. (a -> b) -> a -> b
$ do
GenLocated SrcSpanAnnA (HsExpr GhcPs)
testBody <- TestType
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
convertSingleTestBody TestType
testType LHsExpr GhcPs
body
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets ConvertTestState -> [LPat GhcPs]
testArgs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[GenLocated SrcSpanAnnA (Pat GhcPs)]
_ -> forall a. [Char] -> a
autocollectError forall a b. (a -> b) -> a -> b
$ [Char]
"Found extraneous arguments at " forall a. [a] -> [a] -> [a]
++ SrcSpan -> [Char]
getSpanLine SrcSpan
loc
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
testBody
[FuncGuardedBody]
_ ->
forall a. [Char] -> a
autocollectError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
[ [Char]
"Test should have no guards."
, [Char]
"Found guards at " forall a. [a] -> [a] -> [a]
++ SrcSpan -> [Char]
getSpanLine (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated (SrcSpanAnn' a) e
funcName)
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ if forall a. Maybe a -> Bool
isNothing Maybe SigInfo
mSigInfo
then [forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig GenLocated SrcSpanAnnN RdrName
testName (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names)]
else []
, [GenLocated SrcSpanAnnN RdrName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl GenLocated SrcSpanAnnN RdrName
testName [] GenLocated SrcSpanAnnA (HsExpr GhcPs)
testBody Maybe (HsLocalBinds GhcPs)
mWhereClause forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
ldecl]
]
convertSingleTestBody :: TestType
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
convertSingleTestBody TestType
testType GenLocated SrcSpanAnnA (HsExpr GhcPs)
body =
case TestType
testType of
TestType
TestNormal ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {ann}.
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
TestType
TestProp -> do
state :: ConvertTestState
state@ConvertTestState{Maybe (LHsSigWcType GhcPs)
mSigType :: Maybe (LHsSigWcType GhcPs)
mSigType :: ConvertTestState -> Maybe (LHsSigWcType GhcPs)
mSigType, Maybe (HsLocalBinds GhcPs)
mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause :: ConvertTestState -> Maybe (HsLocalBinds GhcPs)
mWhereClause} <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{mSigType :: Maybe (LHsSigWcType GhcPs)
mSigType = forall a. Maybe a
Nothing, mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause = forall a. Maybe a
Nothing}
([Char]
name, [GenLocated SrcSpanAnnA (Pat GhcPs)]
remainingPats) <-
ConvertTestM [LPat GhcPs]
popRemainingArgs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
GenLocated SrcSpanAnnA (Pat GhcPs)
arg : [GenLocated SrcSpanAnnA (Pat GhcPs)]
rest | Just [Char]
s <- LPat GhcPs -> Maybe [Char]
parseLitStrPat GenLocated SrcSpanAnnA (Pat GhcPs)
arg -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
s, [GenLocated SrcSpanAnnA (Pat GhcPs)]
rest)
[] -> forall a. [Char] -> a
autocollectError [Char]
"test_prop requires at least the name of the test"
GenLocated SrcSpanAnnA (Pat GhcPs)
arg : [GenLocated SrcSpanAnnA (Pat GhcPs)]
_ ->
forall a. [Char] -> a
autocollectError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
[ [Char]
"test_prop expected a String for the name of the test."
, [Char]
"Got: " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> [Char]
showPpr GenLocated SrcSpanAnnA (Pat GhcPs)
arg
]
let propBody :: LHsExpr GhcPs
propBody =
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [GenLocated SrcSpanAnnA (Pat GhcPs)]
remainingPats forall a b. (a -> b) -> a -> b
$
case Maybe (HsLocalBinds GhcPs)
mWhereClause of
Just HsLocalBinds GhcPs
defs -> forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
mkLet HsLocalBinds GhcPs
defs GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
Maybe (HsLocalBinds GhcPs)
Nothing -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {ann}.
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr forall a b. (a -> b) -> a -> b
$
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps
(GenLocated SrcSpanAnnN RdrName -> LHsExpr GhcPs
lhsvar forall a b. (a -> b) -> a -> b
$ [Char] -> GenLocated SrcSpanAnnN RdrName
mkLRdrName [Char]
"testProperty")
[ [Char] -> LHsExpr GhcPs
mkHsLitString [Char]
name
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe GenLocated SrcSpanAnnA (HsExpr GhcPs)
propBody (forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig forall a. EpAnn a
noAnn GenLocated SrcSpanAnnA (HsExpr GhcPs)
propBody) Maybe (LHsSigWcType GhcPs)
mSigType
]
TestType
TestTodo ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {ann}.
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr forall a b. (a -> b) -> a -> b
$
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp
(Name -> LHsExpr GhcPs
mkHsVar forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_testTreeTodo ExternalNames
names)
(LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkExprTypeSig GenLocated SrcSpanAnnA (HsExpr GhcPs)
body forall a b. (a -> b) -> a -> b
$ Name -> LHsType GhcPs
mkHsTyVar (ExternalNames -> Name
name_String ExternalNames
names))
TestType
TestBatch ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
TestModify TestModifier
modifier TestType
testType' ->
ExternalNames
-> TestModifier
-> SrcSpan
-> ConvertTestM (LHsExpr GhcPs)
-> ConvertTestM (LHsExpr GhcPs)
withTestModifier ExternalNames
names TestModifier
modifier SrcSpan
loc forall a b. (a -> b) -> a -> b
$
TestType
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
convertSingleTestBody TestType
testType' GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
singleExpr :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsExpr GhcPs] -> HsExpr GhcPs
mkExplicitList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])
testListName :: LocatedN RdrName
testListName :: GenLocated SrcSpanAnnN RdrName
testListName = [Char] -> GenLocated SrcSpanAnnN RdrName
mkLRdrName [Char]
testListIdentifier
getListOfTestTreeType :: ExternalNames -> LHsType GhcPs
getListOfTestTreeType :: ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy forall a. EpAnn a
noAnn forall a b. (a -> b) -> a -> b
$ Name -> LHsType GhcPs
mkHsTyVar (ExternalNames -> Name
name_TestTree ExternalNames
names)
data TestType
= TestNormal
| TestProp
| TestTodo
| TestBatch
| TestModify TestModifier TestType
deriving (Int -> TestType -> ShowS
[TestType] -> ShowS
TestType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TestType] -> ShowS
$cshowList :: [TestType] -> ShowS
show :: TestType -> [Char]
$cshow :: TestType -> [Char]
showsPrec :: Int -> TestType -> ShowS
$cshowsPrec :: Int -> TestType -> ShowS
Show, TestType -> TestType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestType -> TestType -> Bool
$c/= :: TestType -> TestType -> Bool
== :: TestType -> TestType -> Bool
$c== :: TestType -> TestType -> Bool
Eq)
data TestModifier
= ExpectFail
| ExpectFailBecause
| IgnoreTest
| IgnoreTestBecause
deriving (Int -> TestModifier -> ShowS
[TestModifier] -> ShowS
TestModifier -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TestModifier] -> ShowS
$cshowList :: [TestModifier] -> ShowS
show :: TestModifier -> [Char]
$cshow :: TestModifier -> [Char]
showsPrec :: Int -> TestModifier -> ShowS
$cshowsPrec :: Int -> TestModifier -> ShowS
Show, TestModifier -> TestModifier -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestModifier -> TestModifier -> Bool
$c/= :: TestModifier -> TestModifier -> Bool
== :: TestModifier -> TestModifier -> Bool
$c== :: TestModifier -> TestModifier -> Bool
Eq)
parseTestType :: String -> Maybe TestType
parseTestType :: [Char] -> Maybe TestType
parseTestType = [Text] -> Maybe TestType
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
Text.splitOn Text
"_" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack
where
go :: [Text] -> Maybe TestType
go = \case
[Text
"test"] -> forall a. a -> Maybe a
Just TestType
TestNormal
[Text
"test", Text
"prop"] -> forall a. a -> Maybe a
Just TestType
TestProp
[Text
"test", Text
"todo"] -> forall a. a -> Maybe a
Just TestType
TestTodo
[Text
"test", Text
"batch"] -> forall a. a -> Maybe a
Just TestType
TestBatch
(forall {a}. [a] -> Maybe ([a], a)
unsnoc -> Just ([Text]
t, Text
"expectFail")) -> TestModifier -> TestType -> TestType
TestModify TestModifier
ExpectFail forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe TestType
go [Text]
t
(forall {a}. [a] -> Maybe ([a], a)
unsnoc -> Just ([Text]
t, Text
"expectFailBecause")) -> TestModifier -> TestType -> TestType
TestModify TestModifier
ExpectFailBecause forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe TestType
go [Text]
t
(forall {a}. [a] -> Maybe ([a], a)
unsnoc -> Just ([Text]
t, Text
"ignoreTest")) -> TestModifier -> TestType -> TestType
TestModify TestModifier
IgnoreTest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe TestType
go [Text]
t
(forall {a}. [a] -> Maybe ([a], a)
unsnoc -> Just ([Text]
t, Text
"ignoreTestBecause")) -> TestModifier -> TestType -> TestType
TestModify TestModifier
IgnoreTestBecause forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe TestType
go [Text]
t
[Text]
_ -> forall a. Maybe a
Nothing
unsnoc :: [a] -> Maybe ([a], a)
unsnoc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. NonEmpty a -> [a]
NonEmpty.init forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. NonEmpty a -> a
NonEmpty.last) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty
isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names = \case
TestType
TestNormal -> (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
parsedTypeMatches ParsedType -> Bool
isTestTreeTypeVar
TestType
TestProp -> forall a b. a -> b -> a
const Bool
True
TestType
TestTodo -> (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
parsedTypeMatches forall a b. (a -> b) -> a -> b
$ Name -> ParsedType -> Bool
isTypeVarNamed (ExternalNames -> Name
name_String ExternalNames
names)
TestType
TestBatch -> (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
parsedTypeMatches forall a b. (a -> b) -> a -> b
$ \case
TypeList ParsedType
ty -> ParsedType -> Bool
isTestTreeTypeVar ParsedType
ty
ParsedType
_ -> Bool
False
TestModify TestModifier
modifier TestType
tt -> TestType
-> TestModifier
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
isValidForModifier TestType
tt TestModifier
modifier
where
isValidForModifier :: TestType -> TestModifier -> LHsSigWcType GhcPs -> Bool
isValidForModifier TestType
tt = \case
TestModifier
ExpectFail -> ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
tt
TestModifier
ExpectFailBecause -> ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
tt
TestModifier
IgnoreTest -> ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
tt
TestModifier
IgnoreTestBecause -> ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
tt
parsedTypeMatches :: (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
parsedTypeMatches ParsedType -> Bool
f = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ParsedType -> Bool
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsSigWcType GhcPs -> Maybe ParsedType
parseSigWcType
isTestTreeTypeVar :: ParsedType -> Bool
isTestTreeTypeVar = Name -> ParsedType -> Bool
isTypeVarNamed (ExternalNames -> Name
name_TestTree ExternalNames
names)
typeForTestType :: TestType -> String
typeForTestType :: TestType -> [Char]
typeForTestType = \case
TestType
TestNormal -> [Char]
"TestTree"
TestType
TestProp -> [Char]
"(Testable prop => prop)"
TestType
TestTodo -> [Char]
"String"
TestType
TestBatch -> [Char]
"[TestTree]"
TestModify TestModifier
modifier TestType
tt -> TestType -> TestModifier -> [Char]
typeForTestModifier TestType
tt TestModifier
modifier
where
typeForTestModifier :: TestType -> TestModifier -> [Char]
typeForTestModifier TestType
tt = \case
TestModifier
ExpectFail -> TestType -> [Char]
typeForTestType TestType
tt
TestModifier
ExpectFailBecause -> TestType -> [Char]
typeForTestType TestType
tt
TestModifier
IgnoreTest -> TestType -> [Char]
typeForTestType TestType
tt
TestModifier
IgnoreTestBecause -> TestType -> [Char]
typeForTestType TestType
tt
isTypeVarNamed :: Name -> ParsedType -> Bool
isTypeVarNamed :: Name -> ParsedType -> Bool
isTypeVarNamed Name
name = \case
TypeVar PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
n) -> RdrName -> OccName
rdrNameOcc RdrName
n forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc (forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
name)
ParsedType
_ -> Bool
False
withTestModifier ::
ExternalNames
-> TestModifier
-> SrcSpan
-> ConvertTestM (LHsExpr GhcPs)
-> ConvertTestM (LHsExpr GhcPs)
withTestModifier :: ExternalNames
-> TestModifier
-> SrcSpan
-> ConvertTestM (LHsExpr GhcPs)
-> ConvertTestM (LHsExpr GhcPs)
withTestModifier ExternalNames
names TestModifier
modifier SrcSpan
loc ConvertTestM (LHsExpr GhcPs)
m =
case TestModifier
modifier of
TestModifier
ExpectFail -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests (Name -> LHsExpr GhcPs
mkHsVar forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_expectFail ExternalNames
names) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertTestM (LHsExpr GhcPs)
m
TestModifier
ExpectFailBecause ->
ConvertTestM (Maybe (LPat GhcPs))
popArg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just GenLocated SrcSpanAnnA (Pat GhcPs)
arg
| Just [Char]
s <- LPat GhcPs -> Maybe [Char]
parseLitStrPat GenLocated SrcSpanAnnA (Pat GhcPs)
arg ->
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests (Name
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
applyName (ExternalNames -> Name
name_expectFailBecause ExternalNames
names) [[Char] -> LHsExpr GhcPs
mkHsLitString [Char]
s]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertTestM (LHsExpr GhcPs)
m
Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg -> forall {a} {c}. Outputable a => Maybe a -> [Char] -> c
needsStrArg Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg [Char]
"_expectFailBecause"
TestModifier
IgnoreTest -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests (Name -> LHsExpr GhcPs
mkHsVar forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_ignoreTest ExternalNames
names) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertTestM (LHsExpr GhcPs)
m
TestModifier
IgnoreTestBecause ->
ConvertTestM (Maybe (LPat GhcPs))
popArg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just GenLocated SrcSpanAnnA (Pat GhcPs)
arg
| Just [Char]
s <- LPat GhcPs -> Maybe [Char]
parseLitStrPat GenLocated SrcSpanAnnA (Pat GhcPs)
arg ->
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests (Name
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
applyName (ExternalNames -> Name
name_ignoreTestBecause ExternalNames
names) [[Char] -> LHsExpr GhcPs
mkHsLitString [Char]
s]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertTestM (LHsExpr GhcPs)
m
Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg -> forall {a} {c}. Outputable a => Maybe a -> [Char] -> c
needsStrArg Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg [Char]
"_ignoreTestBecause"
where
needsStrArg :: Maybe a -> [Char] -> c
needsStrArg Maybe a
mArg [Char]
label =
forall a. [Char] -> a
autocollectError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ [[Char]
label forall a. [a] -> [a] -> [a]
++ [Char]
" requires a String argument."]
, case Maybe a
mArg of
Maybe a
Nothing -> []
Just a
arg -> [[Char]
"Got: " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> [Char]
showPpr a
arg]
, [[Char]
"At: " forall a. [a] -> [a] -> [a]
++ SrcSpan -> [Char]
getSpanLine SrcSpan
loc]
]
applyName :: Name -> [LHsExpr GhcPs] -> LHsExpr GhcPs
applyName Name
name = forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps (Name -> LHsExpr GhcPs
mkHsVar Name
name)
mapAllTests :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests GenLocated SrcSpanAnnA (HsExpr GhcPs)
func GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr = Name
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
applyName (ExternalNames -> Name
name_map ExternalNames
names) [GenLocated SrcSpanAnnA (HsExpr GhcPs)
func, GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr]
type ConvertTestM = State ConvertTestState
data ConvertTestState = ConvertTestState
{ ConvertTestState -> Maybe (LHsSigWcType GhcPs)
mSigType :: Maybe (LHsSigWcType GhcPs)
, ConvertTestState -> Maybe (HsLocalBinds GhcPs)
mWhereClause :: Maybe (HsLocalBinds GhcPs)
, ConvertTestState -> [LPat GhcPs]
testArgs :: [LPat GhcPs]
}
runConvertTestM :: ConvertTestState -> ConvertTestM a -> (a, ConvertTestState)
runConvertTestM :: forall a.
ConvertTestState -> ConvertTestM a -> (a, ConvertTestState)
runConvertTestM = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
State.runState
popArg :: ConvertTestM (Maybe (LPat GhcPs))
popArg :: ConvertTestM (Maybe (LPat GhcPs))
popArg = do
ConvertTestState
state <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
let (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg, [GenLocated SrcSpanAnnA (Pat GhcPs)]
rest) =
case ConvertTestState -> [LPat GhcPs]
testArgs ConvertTestState
state of
[] -> (forall a. Maybe a
Nothing, [])
LPat GhcPs
arg : [LPat GhcPs]
args -> (forall a. a -> Maybe a
Just LPat GhcPs
arg, [LPat GhcPs]
args)
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{testArgs :: [LPat GhcPs]
testArgs = [GenLocated SrcSpanAnnA (Pat GhcPs)]
rest}
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg
popRemainingArgs :: ConvertTestM [LPat GhcPs]
popRemainingArgs :: ConvertTestM [LPat GhcPs]
popRemainingArgs = do
state :: ConvertTestState
state@ConvertTestState{[LPat GhcPs]
testArgs :: [LPat GhcPs]
testArgs :: ConvertTestState -> [LPat GhcPs]
testArgs} <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{testArgs :: [LPat GhcPs]
testArgs = []}
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LPat GhcPs]
testArgs
type ConvertTestModuleM = State ConvertTestModuleState
data ConvertTestModuleState = ConvertTestModuleState
{ ConvertTestModuleState -> Maybe SigInfo
lastSeenSig :: Maybe SigInfo
, ConvertTestModuleState -> Seq (GenLocated SrcSpanAnnN RdrName)
allTests :: Seq (LocatedN RdrName)
}
data SigInfo = SigInfo
{ SigInfo -> TestType
testType :: TestType
, SigInfo -> GenLocated SrcSpanAnnN RdrName
testName :: LocatedN RdrName
, SigInfo -> LHsSigWcType GhcPs
signatureType :: LHsSigWcType GhcPs
}
runConvertTestModuleM :: ConvertTestModuleM a -> (a, [LocatedN RdrName])
runConvertTestModuleM :: forall a.
ConvertTestModuleM a -> (a, [GenLocated SrcSpanAnnN RdrName])
runConvertTestModuleM ConvertTestModuleM a
m =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvertTestModuleState -> Seq (GenLocated SrcSpanAnnN RdrName)
allTests) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. State s a -> s -> (a, s)
State.runState ConvertTestModuleM a
m forall a b. (a -> b) -> a -> b
$
ConvertTestModuleState
{ lastSeenSig :: Maybe SigInfo
lastSeenSig = forall a. Maybe a
Nothing
, allTests :: Seq (GenLocated SrcSpanAnnN RdrName)
allTests = forall a. Seq a
Seq.Empty
}
getLastSeenSig :: ConvertTestModuleM (Maybe SigInfo)
getLastSeenSig :: ConvertTestModuleM (Maybe SigInfo)
getLastSeenSig = do
state :: ConvertTestModuleState
state@ConvertTestModuleState{Maybe SigInfo
lastSeenSig :: Maybe SigInfo
lastSeenSig :: ConvertTestModuleState -> Maybe SigInfo
lastSeenSig} <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestModuleState
state{lastSeenSig :: Maybe SigInfo
lastSeenSig = forall a. Maybe a
Nothing}
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SigInfo
lastSeenSig
setLastSeenSig :: SigInfo -> ConvertTestModuleM ()
setLastSeenSig :: SigInfo -> ConvertTestModuleM ()
setLastSeenSig SigInfo
info = forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' forall a b. (a -> b) -> a -> b
$ \ConvertTestModuleState
state -> ConvertTestModuleState
state{lastSeenSig :: Maybe SigInfo
lastSeenSig = forall a. a -> Maybe a
Just SigInfo
info}
getNextTestName :: ConvertTestModuleM (LocatedN RdrName)
getNextTestName :: ConvertTestModuleM (GenLocated SrcSpanAnnN RdrName)
getNextTestName = do
state :: ConvertTestModuleState
state@ConvertTestModuleState{Seq (GenLocated SrcSpanAnnN RdrName)
allTests :: Seq (GenLocated SrcSpanAnnN RdrName)
allTests :: ConvertTestModuleState -> Seq (GenLocated SrcSpanAnnN RdrName)
allTests} <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
let nextTestName :: GenLocated SrcSpanAnnN RdrName
nextTestName = [Char] -> GenLocated SrcSpanAnnN RdrName
mkLRdrName forall a b. (a -> b) -> a -> b
$ Int -> [Char]
testIdentifier (forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (GenLocated SrcSpanAnnN RdrName)
allTests)
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestModuleState
state{allTests :: Seq (GenLocated SrcSpanAnnN RdrName)
allTests = Seq (GenLocated SrcSpanAnnN RdrName)
allTests forall a. Seq a -> a -> Seq a
Seq.|> GenLocated SrcSpanAnnN RdrName
nextTestName}
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnN RdrName
nextTestName
concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m [b]
f