{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Tasty.AutoCollect.ConvertTest (
plugin,
) where
import Control.Monad (unless)
import Control.Monad.Trans.State.Strict (State)
import qualified Control.Monad.Trans.State.Strict as State
import Data.Foldable (toList)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
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 :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile = [CommandLineOption] -> IO PluginRecompile
purePlugin
, parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = \[CommandLineOption]
_ ModSummary
_ HsParsedModule
modl -> do
HscEnv
env <- Hsc HscEnv
getHscEnv
ExternalNames
names <- IO ExternalNames -> Hsc ExternalNames
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalNames -> Hsc ExternalNames)
-> IO ExternalNames -> Hsc ExternalNames
forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalNames
loadExternalNames HscEnv
env
HsParsedModule -> Hsc HsParsedModule
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HsParsedModule -> Hsc HsParsedModule)
-> HsParsedModule -> Hsc HsParsedModule
forall a b. (a -> b) -> a -> b
$ ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule ExternalNames
names HsParsedModule
modl
}
transformTestModule :: ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule :: ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule ExternalNames
names HsParsedModule
parsedModl = HsParsedModule
parsedModl{hpm_module :: Located (HsModule GhcPs)
hpm_module = HsModule GhcPs -> HsModule GhcPs
updateModule (HsModule GhcPs -> HsModule GhcPs)
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsParsedModule -> Located (HsModule GhcPs)
hpm_module HsParsedModule
parsedModl}
where
updateModule :: HsModule GhcPs -> HsModule GhcPs
updateModule HsModule GhcPs
modl =
let ([LHsDecl GhcPs]
decls, [LocatedN RdrName]
testNames) = ConvertTestM [LHsDecl GhcPs]
-> ([LHsDecl GhcPs], [LocatedN RdrName])
forall a. ConvertTestM a -> (a, [LocatedN RdrName])
runConvertTestM (ConvertTestM [LHsDecl GhcPs]
-> ([LHsDecl GhcPs], [LocatedN RdrName]))
-> ConvertTestM [LHsDecl GhcPs]
-> ([LHsDecl GhcPs], [LocatedN RdrName])
forall a b. (a -> b) -> a -> b
$ (LHsDecl GhcPs -> ConvertTestM [LHsDecl GhcPs])
-> [LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (ExternalNames -> LHsDecl GhcPs -> ConvertTestM [LHsDecl GhcPs]
convertTest ExternalNames
names) ([LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs])
-> [LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule GhcPs
modl
in HsModule GhcPs
modl
{ hsmodExports :: Maybe (Located [LIE GhcPs])
hsmodExports = Located [LIE GhcPs] -> Located [LIE GhcPs]
updateExports (Located [LIE GhcPs] -> Located [LIE GhcPs])
-> Maybe (Located [LIE GhcPs]) -> Maybe (Located [LIE GhcPs])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule GhcPs -> Maybe (Located [LIE GhcPs])
forall pass. HsModule pass -> Maybe (Located [LIE pass])
hsmodExports HsModule GhcPs
modl
, hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = [LocatedN RdrName] -> [LHsDecl GhcPs]
mkTestsList [LocatedN RdrName]
testNames [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
decls
}
updateExports :: Located [LIE GhcPs] -> Located [LIE GhcPs]
updateExports Located [LIE GhcPs]
lexports
| Just RealSrcSpan
exportSpan <- (GenLocated RealSrcSpan CommandLineOption -> Maybe RealSrcSpan)
-> [GenLocated RealSrcSpan CommandLineOption] -> Maybe RealSrcSpan
forall l e a.
Ord l =>
(GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a
firstLocatedWhere GenLocated RealSrcSpan CommandLineOption -> Maybe RealSrcSpan
forall a. GenLocated a CommandLineOption -> Maybe a
getTestExportAnnSrcSpan (HsParsedModule
-> Located [LIE GhcPs]
-> [GenLocated RealSrcSpan CommandLineOption]
getExportComments HsParsedModule
parsedModl Located [LIE GhcPs]
lexports) =
(SrcSpan -> IE GhcPs -> LIE GhcPs
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> SrcSpan
toSrcAnnA RealSrcSpan
exportSpan) IE GhcPs
exportIE LIE GhcPs -> [LIE GhcPs] -> [LIE GhcPs]
forall a. a -> [a] -> [a]
:) ([LIE GhcPs] -> [LIE GhcPs])
-> Located [LIE GhcPs] -> Located [LIE GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located [LIE GhcPs]
lexports
| Bool
otherwise =
Located [LIE GhcPs]
lexports
getTestExportAnnSrcSpan :: GenLocated a CommandLineOption -> Maybe a
getTestExportAnnSrcSpan (L a
loc CommandLineOption
comment) =
if CommandLineOption -> Bool
isTestExportComment CommandLineOption
comment
then a -> Maybe a
forall a. a -> Maybe a
Just a
loc
else Maybe a
forall a. Maybe a
Nothing
exportIE :: IE GhcPs
exportIE = XIEVar GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar NoExtField
XIEVar GhcPs
NoExtField (LIEWrappedName (IdP GhcPs) -> IE GhcPs)
-> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall a b. (a -> b) -> a -> b
$ IEWrappedName RdrName -> GenLocated SrcSpan (IEWrappedName RdrName)
forall e ann. e -> GenLocated SrcSpan e
genLoc (IEWrappedName RdrName
-> GenLocated SrcSpan (IEWrappedName RdrName))
-> IEWrappedName RdrName
-> GenLocated SrcSpan (IEWrappedName RdrName)
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEName LocatedN RdrName
testListName
mkTestsList :: [LocatedN RdrName] -> [LHsDecl GhcPs]
mkTestsList :: [LocatedN RdrName] -> [LHsDecl GhcPs]
mkTestsList [LocatedN RdrName]
testNames =
let testsList :: GenLocated SrcSpan (HsExpr GhcPs)
testsList = HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs
mkExplicitList ([GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs))
-> [LocatedN RdrName] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar [LocatedN RdrName]
testNames
in [ HsDecl GhcPs -> LHsDecl GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig LocatedN RdrName
testListName (LHsType GhcPs -> HsDecl GhcPs) -> LHsType GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names
, HsDecl GhcPs -> LHsDecl GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
-> [LPat GhcPs]
-> GenLocated SrcSpan (HsExpr GhcPs)
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl LocatedN RdrName
testListName [] (GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
flattenTestList GenLocated SrcSpan (HsExpr GhcPs)
forall ann. GenLocated SrcSpan (HsExpr GhcPs)
testsList) Maybe (HsLocalBinds GhcPs)
forall a. Maybe a
Nothing
]
flattenTestList :: GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
flattenTestList GenLocated SrcSpan (HsExpr GhcPs)
testsList =
GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs))
-> LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ RdrName -> LocatedN RdrName
forall e ann. e -> GenLocated SrcSpan e
genLoc (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_concat ExternalNames
names) (GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs))
-> GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpan (HsExpr GhcPs)
-> LHsType GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
mkExprTypeSig GenLocated SrcSpan (HsExpr GhcPs)
testsList (LHsType GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> (HsType GhcPs -> LHsType GhcPs)
-> HsType GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> LHsType GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsType GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsType GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExtField
XListTy GhcPs
noAnn (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names)
convertTest :: ExternalNames -> LHsDecl GhcPs -> ConvertTestM [LHsDecl GhcPs]
convertTest :: ExternalNames -> LHsDecl GhcPs -> ConvertTestM [LHsDecl GhcPs]
convertTest ExternalNames
names LHsDecl GhcPs
ldecl =
case LHsDecl GhcPs -> Maybe ParsedDecl
parseDecl LHsDecl GhcPs
ldecl of
Just (FuncSig [LocatedN RdrName
funcName] LHsSigWcType GhcPs
ty)
| Just TestType
testType <- CommandLineOption -> Maybe TestType
parseTestType (LocatedN RdrName -> CommandLineOption
fromRdrName LocatedN RdrName
funcName) -> do
LocatedN RdrName
testName <- ConvertTestM (LocatedN RdrName)
getNextTestName
SigInfo -> ConvertTestM ()
setLastSeenSig
SigInfo :: TestType -> LocatedN RdrName -> LHsSigWcType GhcPs -> SigInfo
SigInfo
{ TestType
testType :: TestType
testType :: TestType
testType
, LocatedN RdrName
testName :: LocatedN RdrName
testName :: LocatedN RdrName
testName
, signatureType :: LHsSigWcType GhcPs
signatureType = LHsSigWcType GhcPs
ty
}
Bool -> ConvertTestM () -> ConvertTestM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
testType LHsSigWcType GhcPs
ty) (ConvertTestM () -> ConvertTestM ())
-> ConvertTestM () -> ConvertTestM ()
forall a b. (a -> b) -> a -> b
$
CommandLineOption -> ConvertTestM ()
forall a. CommandLineOption -> a
autocollectError (CommandLineOption -> ConvertTestM ())
-> ([CommandLineOption] -> CommandLineOption)
-> [CommandLineOption]
-> ConvertTestM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> CommandLineOption
unlines ([CommandLineOption] -> ConvertTestM ())
-> [CommandLineOption] -> ConvertTestM ()
forall a b. (a -> b) -> a -> b
$
[ CommandLineOption
"Expected type: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ TestType -> CommandLineOption
typeForTestType TestType
testType
, CommandLineOption
"Got: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LHsSigWcType GhcPs -> CommandLineOption
forall a. Outputable a => a -> CommandLineOption
showPpr LHsSigWcType GhcPs
ty
]
[LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig LocatedN RdrName
testName (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names) HsDecl GhcPs -> LHsDecl GhcPs -> LHsDecl GhcPs
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
ldecl]
Just (FuncDef LocatedN RdrName
funcName [LocatedA FuncSingleDef]
funcDefs)
| Just TestType
testType <- CommandLineOption -> Maybe TestType
parseTestType (LocatedN RdrName -> CommandLineOption
fromRdrName LocatedN RdrName
funcName) -> do
Maybe SigInfo
mSigInfo <- ConvertTestM (Maybe SigInfo)
getLastSeenSig
(LocatedA FuncSingleDef -> ConvertTestM [LHsDecl GhcPs])
-> [LocatedA FuncSingleDef] -> ConvertTestM [LHsDecl GhcPs]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (LocatedN RdrName
-> TestType
-> Maybe SigInfo
-> FuncSingleDef
-> ConvertTestM [LHsDecl GhcPs]
forall a e ann.
GenLocated SrcSpan e
-> TestType
-> Maybe SigInfo
-> FuncSingleDef
-> ConvertTestM [LHsDecl GhcPs]
convertSingleTest LocatedN RdrName
funcName TestType
testType Maybe SigInfo
mSigInfo (FuncSingleDef -> ConvertTestM [LHsDecl GhcPs])
-> (LocatedA FuncSingleDef -> FuncSingleDef)
-> LocatedA FuncSingleDef
-> ConvertTestM [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedA FuncSingleDef -> FuncSingleDef
forall l e. GenLocated l e -> e
unLoc) [LocatedA FuncSingleDef]
funcDefs
Maybe ParsedDecl
_ -> [LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LHsDecl GhcPs
ldecl]
where
convertSingleTest :: GenLocated SrcSpan e
-> TestType
-> Maybe SigInfo
-> FuncSingleDef
-> ConvertTestM [LHsDecl GhcPs]
convertSingleTest GenLocated SrcSpan e
funcName TestType
testType Maybe SigInfo
mSigInfo 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
(LocatedN RdrName
testName, Maybe (LHsSigWcType GhcPs)
mSigType, Bool
needsFuncSig) <-
case Maybe SigInfo
mSigInfo of
Maybe SigInfo
Nothing -> do
LocatedN RdrName
testName <- ConvertTestM (LocatedN RdrName)
getNextTestName
(LocatedN RdrName, Maybe (LHsSigWcType GhcPs), Bool)
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, Maybe (LHsSigWcType GhcPs), Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocatedN RdrName
testName, Maybe (LHsSigWcType GhcPs)
forall a. Maybe a
Nothing, Bool
True)
Just SigInfo{testType :: SigInfo -> TestType
testType = TestType
testTypeFromSig, LHsSigWcType GhcPs
LocatedN RdrName
signatureType :: LHsSigWcType GhcPs
testName :: LocatedN RdrName
signatureType :: SigInfo -> LHsSigWcType GhcPs
testName :: SigInfo -> LocatedN RdrName
..}
| TestType
testType TestType -> TestType -> Bool
forall a. Eq a => a -> a -> Bool
== TestType
testTypeFromSig -> (LocatedN RdrName, Maybe (LHsSigWcType GhcPs), Bool)
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, Maybe (LHsSigWcType GhcPs), Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocatedN RdrName
testName, LHsSigWcType GhcPs -> Maybe (LHsSigWcType GhcPs)
forall a. a -> Maybe a
Just LHsSigWcType GhcPs
signatureType, Bool
False)
| Bool
otherwise -> CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, Maybe (LHsSigWcType GhcPs), Bool)
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, Maybe (LHsSigWcType GhcPs), Bool))
-> CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, Maybe (LHsSigWcType GhcPs), Bool)
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"Found test with different type of signature: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ (TestType, TestType) -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show (TestType
testType, TestType
testTypeFromSig)
GenLocated SrcSpan (HsExpr GhcPs)
funcBody <-
case [FuncGuardedBody]
funcDefGuards of
[FuncGuardedBody [] GenLocated SrcSpan (HsExpr GhcPs)
body] -> GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpan (HsExpr GhcPs)
body
[FuncGuardedBody]
_ ->
CommandLineOption
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> ([CommandLineOption] -> CommandLineOption)
-> [CommandLineOption]
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> CommandLineOption
unlines ([CommandLineOption]
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> [CommandLineOption]
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
[ CommandLineOption
"Test should have no guards."
, CommandLineOption
"Found guards at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ GenLocated SrcSpan e -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine GenLocated SrcSpan e
funcName
]
GenLocated SrcSpan (HsExpr GhcPs)
testBody <-
case TestType
testType of
TestType
TestNormal -> do
TestType -> [Located (Pat GhcPs)] -> ConvertTestM ()
forall (f :: * -> *) (t :: * -> *) a.
(Applicative f, Foldable t) =>
TestType -> t a -> f ()
checkNoArgs TestType
testType [LPat GhcPs]
[Located (Pat GhcPs)]
funcDefArgs
GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall ann.
GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
singleExpr GenLocated SrcSpan (HsExpr GhcPs)
funcBody
TestType
TestProp -> do
(CommandLineOption
name, [Located (Pat GhcPs)]
remainingPats) <-
case [LPat GhcPs]
funcDefArgs of
[] -> CommandLineOption
-> StateT
ConvertTestState
Identity
(CommandLineOption, [Located (Pat GhcPs)])
forall a. CommandLineOption -> a
autocollectError CommandLineOption
"test_prop requires at least the name of the test"
L _ (LitPat _ (HsString _ s)) : [LPat GhcPs]
rest -> (CommandLineOption, [Located (Pat GhcPs)])
-> StateT
ConvertTestState
Identity
(CommandLineOption, [Located (Pat GhcPs)])
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString -> CommandLineOption
unpackFS FastString
s, [LPat GhcPs]
[Located (Pat GhcPs)]
rest)
LPat GhcPs
arg : [LPat GhcPs]
_ ->
CommandLineOption
-> StateT
ConvertTestState
Identity
(CommandLineOption, [Located (Pat GhcPs)])
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
-> StateT
ConvertTestState
Identity
(CommandLineOption, [Located (Pat GhcPs)]))
-> ([CommandLineOption] -> CommandLineOption)
-> [CommandLineOption]
-> StateT
ConvertTestState
Identity
(CommandLineOption, [Located (Pat GhcPs)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> CommandLineOption
unlines ([CommandLineOption]
-> StateT
ConvertTestState
Identity
(CommandLineOption, [Located (Pat GhcPs)]))
-> [CommandLineOption]
-> StateT
ConvertTestState
Identity
(CommandLineOption, [Located (Pat GhcPs)])
forall a b. (a -> b) -> a -> b
$
[ CommandLineOption
"test_prop expected a String for the name of the test."
, CommandLineOption
"Got: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ Located (Pat GhcPs) -> CommandLineOption
forall a. Outputable a => a -> CommandLineOption
showPpr LPat GhcPs
Located (Pat GhcPs)
arg
]
let propBody :: GenLocated SrcSpan (HsExpr GhcPs)
propBody = [LPat GhcPs]
-> GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall (p :: Pass).
(XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [LPat GhcPs]
[Located (Pat GhcPs)]
remainingPats GenLocated SrcSpan (HsExpr GhcPs)
funcBody
GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> (GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs))
-> GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall ann.
GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
singleExpr (GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpan (HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
mkHsApps
(LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs))
-> LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> LocatedN RdrName
mkLRdrName CommandLineOption
"testProperty")
[ HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit NoExtField
XLitE GhcPs
noAnn (HsLit GhcPs -> HsExpr GhcPs) -> HsLit GhcPs -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> HsLit GhcPs
forall (p :: Pass). CommandLineOption -> HsLit (GhcPass p)
mkHsString CommandLineOption
name
, GenLocated SrcSpan (HsExpr GhcPs)
-> (LHsSigWcType GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> Maybe (LHsSigWcType GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GenLocated SrcSpan (HsExpr GhcPs)
propBody (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> (LHsSigWcType GhcPs -> HsExpr GhcPs)
-> LHsSigWcType GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XExprWithTySig GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs)
-> LHsSigWcType (NoGhcTc GhcPs)
-> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcPs
noAnn GenLocated SrcSpan (HsExpr GhcPs)
propBody) Maybe (LHsSigWcType GhcPs)
mSigType
]
TestType
TestTodo -> do
TestType -> [Located (Pat GhcPs)] -> ConvertTestM ()
forall (f :: * -> *) (t :: * -> *) a.
(Applicative f, Foldable t) =>
TestType -> t a -> f ()
checkNoArgs TestType
testType [LPat GhcPs]
[Located (Pat GhcPs)]
funcDefArgs
GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> (GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs))
-> GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall ann.
GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
singleExpr (GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp
(LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs))
-> LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ RdrName -> LocatedN RdrName
forall e ann. e -> GenLocated SrcSpan e
genLoc (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_testTreeTodo ExternalNames
names)
(GenLocated SrcSpan (HsExpr GhcPs)
-> LHsType GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
mkExprTypeSig GenLocated SrcSpan (HsExpr GhcPs)
funcBody (LHsType GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> LHsType GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ Name -> LHsType GhcPs
mkHsTyVar (ExternalNames -> Name
name_String ExternalNames
names))
TestType
TestBatch -> do
TestType -> [Located (Pat GhcPs)] -> ConvertTestM ()
forall (f :: * -> *) (t :: * -> *) a.
(Applicative f, Foldable t) =>
TestType -> t a -> f ()
checkNoArgs TestType
testType [LPat GhcPs]
[Located (Pat GhcPs)]
funcDefArgs
GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpan (HsExpr GhcPs)
funcBody
[LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs])
-> ([[LHsDecl GhcPs]] -> [LHsDecl GhcPs])
-> [[LHsDecl GhcPs]]
-> ConvertTestM [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[LHsDecl GhcPs]] -> [LHsDecl GhcPs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[LHsDecl GhcPs]] -> ConvertTestM [LHsDecl GhcPs])
-> [[LHsDecl GhcPs]] -> ConvertTestM [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$
[ if Bool
needsFuncSig
then [HsDecl GhcPs -> LHsDecl GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig LocatedN RdrName
testName (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names)]
else []
, [LocatedN RdrName
-> [LPat GhcPs]
-> GenLocated SrcSpan (HsExpr GhcPs)
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl LocatedN RdrName
testName [] GenLocated SrcSpan (HsExpr GhcPs)
testBody (HsLocalBinds GhcPs -> Maybe (HsLocalBinds GhcPs)
forall a. a -> Maybe a
Just HsLocalBinds GhcPs
funcDefWhereClause) HsDecl GhcPs -> LHsDecl GhcPs -> LHsDecl GhcPs
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
ldecl]
]
singleExpr :: GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
singleExpr = HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> (GenLocated SrcSpan (HsExpr GhcPs) -> HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs
mkExplicitList ([GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs)
-> (GenLocated SrcSpan (HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)])
-> GenLocated SrcSpan (HsExpr GhcPs)
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpan (HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
: [])
checkNoArgs :: TestType -> t a -> f ()
checkNoArgs TestType
testType t a
args =
Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
args) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
CommandLineOption -> f ()
forall a. CommandLineOption -> a
autocollectError (CommandLineOption -> f ())
-> ([CommandLineOption] -> CommandLineOption)
-> [CommandLineOption]
-> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> CommandLineOption
unwords ([CommandLineOption] -> f ()) -> [CommandLineOption] -> f ()
forall a b. (a -> b) -> a -> b
$
[ TestType -> CommandLineOption
showTestType TestType
testType CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
" should not be used with arguments"
, CommandLineOption
"(at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LHsDecl GhcPs -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LHsDecl GhcPs
ldecl CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
")"
]
testListName :: LocatedN RdrName
testListName :: LocatedN RdrName
testListName = CommandLineOption -> LocatedN RdrName
mkLRdrName CommandLineOption
testListIdentifier
data TestType
= TestNormal
| TestProp
| TestTodo
| TestBatch
deriving (Int -> TestType -> CommandLineOption -> CommandLineOption
[TestType] -> CommandLineOption -> CommandLineOption
TestType -> CommandLineOption
(Int -> TestType -> CommandLineOption -> CommandLineOption)
-> (TestType -> CommandLineOption)
-> ([TestType] -> CommandLineOption -> CommandLineOption)
-> Show TestType
forall a.
(Int -> a -> CommandLineOption -> CommandLineOption)
-> (a -> CommandLineOption)
-> ([a] -> CommandLineOption -> CommandLineOption)
-> Show a
showList :: [TestType] -> CommandLineOption -> CommandLineOption
$cshowList :: [TestType] -> CommandLineOption -> CommandLineOption
show :: TestType -> CommandLineOption
$cshow :: TestType -> CommandLineOption
showsPrec :: Int -> TestType -> CommandLineOption -> CommandLineOption
$cshowsPrec :: Int -> TestType -> CommandLineOption -> CommandLineOption
Show, TestType -> TestType -> Bool
(TestType -> TestType -> Bool)
-> (TestType -> TestType -> Bool) -> Eq TestType
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)
parseTestType :: String -> Maybe TestType
parseTestType :: CommandLineOption -> Maybe TestType
parseTestType = \case
CommandLineOption
"test" -> TestType -> Maybe TestType
forall a. a -> Maybe a
Just TestType
TestNormal
CommandLineOption
"test_prop" -> TestType -> Maybe TestType
forall a. a -> Maybe a
Just TestType
TestProp
CommandLineOption
"test_todo" -> TestType -> Maybe TestType
forall a. a -> Maybe a
Just TestType
TestTodo
CommandLineOption
"test_batch" -> TestType -> Maybe TestType
forall a. a -> Maybe a
Just TestType
TestBatch
CommandLineOption
_ -> Maybe TestType
forall a. Maybe a
Nothing
showTestType :: TestType -> String
showTestType :: TestType -> CommandLineOption
showTestType = \case
TestType
TestNormal -> CommandLineOption
"test"
TestType
TestProp -> CommandLineOption
"test_prop"
TestType
TestTodo -> CommandLineOption
"test_todo"
TestType
TestBatch -> CommandLineOption
"test_batch"
isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names = \case
TestType
TestNormal -> (ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool
parsedTypeMatches ((ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool)
-> (ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> ParsedType -> Bool
isTypeVarNamed (ExternalNames -> Name
name_TestTree ExternalNames
names)
TestType
TestProp -> Bool -> LHsSigWcType GhcPs -> Bool
forall a b. a -> b -> a
const Bool
True
TestType
TestTodo -> (ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool
parsedTypeMatches ((ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool)
-> (ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> ParsedType -> Bool
isTypeVarNamed (ExternalNames -> Name
name_String ExternalNames
names)
TestType
TestBatch -> (ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool
parsedTypeMatches ((ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool)
-> (ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool
forall a b. (a -> b) -> a -> b
$ \case
TypeList ParsedType
ty -> Name -> ParsedType -> Bool
isTypeVarNamed (ExternalNames -> Name
name_TestTree ExternalNames
names) ParsedType
ty
ParsedType
_ -> Bool
False
where
parsedTypeMatches :: (ParsedType -> Bool) -> LHsSigWcType GhcPs -> Bool
parsedTypeMatches ParsedType -> Bool
f = Bool -> (ParsedType -> Bool) -> Maybe ParsedType -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ParsedType -> Bool
f (Maybe ParsedType -> Bool)
-> (LHsSigWcType GhcPs -> Maybe ParsedType)
-> LHsSigWcType GhcPs
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsSigWcType GhcPs -> Maybe ParsedType
parseSigWcType
typeForTestType :: TestType -> String
typeForTestType :: TestType -> CommandLineOption
typeForTestType = \case
TestType
TestNormal -> CommandLineOption
"TestTree"
TestType
TestProp -> CommandLineOption
"(Testable prop => prop)"
TestType
TestTodo -> CommandLineOption
"String"
TestType
TestBatch -> CommandLineOption
"[TestTree]"
isTypeVarNamed :: Name -> ParsedType -> Bool
isTypeVarNamed :: Name -> ParsedType -> Bool
isTypeVarNamed Name
name = \case
TypeVar PromotionFlag
_ (L SrcSpan
_ RdrName
n) -> RdrName -> OccName
rdrNameOcc RdrName
n OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
name)
ParsedType
_ -> Bool
False
getListOfTestTreeType :: ExternalNames -> LHsType GhcPs
getListOfTestTreeType :: ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names = HsType GhcPs -> LHsType GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsType GhcPs -> LHsType GhcPs) -> HsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExtField
XListTy GhcPs
noAnn (LHsType GhcPs -> HsType GhcPs) -> LHsType GhcPs -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ Name -> LHsType GhcPs
mkHsTyVar (ExternalNames -> Name
name_TestTree ExternalNames
names)
type ConvertTestM = State ConvertTestState
data ConvertTestState = ConvertTestState
{ ConvertTestState -> Maybe SigInfo
lastSeenSig :: Maybe SigInfo
, ConvertTestState -> Seq (LocatedN RdrName)
allTests :: Seq (LocatedN RdrName)
}
data SigInfo = SigInfo
{ SigInfo -> TestType
testType :: TestType
, SigInfo -> LocatedN RdrName
testName :: LocatedN RdrName
, SigInfo -> LHsSigWcType GhcPs
signatureType :: LHsSigWcType GhcPs
}
runConvertTestM :: ConvertTestM a -> (a, [LocatedN RdrName])
runConvertTestM :: ConvertTestM a -> (a, [LocatedN RdrName])
runConvertTestM ConvertTestM a
m =
(ConvertTestState -> [LocatedN RdrName])
-> (a, ConvertTestState) -> (a, [LocatedN RdrName])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seq (LocatedN RdrName) -> [LocatedN RdrName]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (LocatedN RdrName) -> [LocatedN RdrName])
-> (ConvertTestState -> Seq (LocatedN RdrName))
-> ConvertTestState
-> [LocatedN RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvertTestState -> Seq (LocatedN RdrName)
allTests) ((a, ConvertTestState) -> (a, [LocatedN RdrName]))
-> (ConvertTestState -> (a, ConvertTestState))
-> ConvertTestState
-> (a, [LocatedN RdrName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvertTestM a -> ConvertTestState -> (a, ConvertTestState)
forall s a. State s a -> s -> (a, s)
State.runState ConvertTestM a
m (ConvertTestState -> (a, [LocatedN RdrName]))
-> ConvertTestState -> (a, [LocatedN RdrName])
forall a b. (a -> b) -> a -> b
$
ConvertTestState :: Maybe SigInfo -> Seq (LocatedN RdrName) -> ConvertTestState
ConvertTestState
{ lastSeenSig :: Maybe SigInfo
lastSeenSig = Maybe SigInfo
forall a. Maybe a
Nothing
, allTests :: Seq (LocatedN RdrName)
allTests = Seq (LocatedN RdrName)
forall a. Seq a
Seq.Empty
}
getLastSeenSig :: ConvertTestM (Maybe SigInfo)
getLastSeenSig :: ConvertTestM (Maybe SigInfo)
getLastSeenSig = do
state :: ConvertTestState
state@ConvertTestState{Maybe SigInfo
lastSeenSig :: Maybe SigInfo
lastSeenSig :: ConvertTestState -> Maybe SigInfo
lastSeenSig} <- StateT ConvertTestState Identity ConvertTestState
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
ConvertTestState -> ConvertTestM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{lastSeenSig :: Maybe SigInfo
lastSeenSig = Maybe SigInfo
forall a. Maybe a
Nothing}
Maybe SigInfo -> ConvertTestM (Maybe SigInfo)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SigInfo
lastSeenSig
setLastSeenSig :: SigInfo -> ConvertTestM ()
setLastSeenSig :: SigInfo -> ConvertTestM ()
setLastSeenSig SigInfo
info = (ConvertTestState -> ConvertTestState) -> ConvertTestM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' ((ConvertTestState -> ConvertTestState) -> ConvertTestM ())
-> (ConvertTestState -> ConvertTestState) -> ConvertTestM ()
forall a b. (a -> b) -> a -> b
$ \ConvertTestState
state -> ConvertTestState
state{lastSeenSig :: Maybe SigInfo
lastSeenSig = SigInfo -> Maybe SigInfo
forall a. a -> Maybe a
Just SigInfo
info}
getNextTestName :: ConvertTestM (LocatedN RdrName)
getNextTestName :: ConvertTestM (LocatedN RdrName)
getNextTestName = do
state :: ConvertTestState
state@ConvertTestState{Seq (LocatedN RdrName)
allTests :: Seq (LocatedN RdrName)
allTests :: ConvertTestState -> Seq (LocatedN RdrName)
allTests} <- StateT ConvertTestState Identity ConvertTestState
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
let nextTestName :: LocatedN RdrName
nextTestName = CommandLineOption -> LocatedN RdrName
mkLRdrName (CommandLineOption -> LocatedN RdrName)
-> CommandLineOption -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ Int -> CommandLineOption
testIdentifier (Seq (LocatedN RdrName) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (LocatedN RdrName)
allTests)
ConvertTestState -> ConvertTestM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{allTests :: Seq (LocatedN RdrName)
allTests = Seq (LocatedN RdrName)
allTests Seq (LocatedN RdrName)
-> LocatedN RdrName -> Seq (LocatedN RdrName)
forall a. Seq a -> a -> Seq a
Seq.|> LocatedN RdrName
nextTestName}
LocatedN RdrName -> ConvertTestM (LocatedN RdrName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocatedN RdrName
nextTestName
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM :: (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
f = ([[b]] -> [b]) -> m [[b]] -> m [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (m [[b]] -> m [b]) -> ([a] -> m [[b]]) -> [a] -> m [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m [b]) -> [a] -> m [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m [b]
f