{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Test.Tasty.AutoCollect.ConvertTest (
plugin,
) where
import Control.Monad.Trans.State.Strict (State)
import qualified Control.Monad.Trans.State.Strict as State
import Data.Foldable (toList)
import Data.List (intercalate, stripPrefix)
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 -> StateT ConvertTestState Identity (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExternalNames
-> LHsDecl GhcPs
-> StateT ConvertTestState Identity (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
$ CommandLineOption -> LocatedN RdrName
mkLRdrName CommandLineOption
"concat") (GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs))
-> GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> (HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> HsExpr GhcPs)
-> HsWildCardBndrs GhcPs (LHsSigType 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)
testsList (HsWildCardBndrs GhcPs (LHsSigType GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs))
-> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
XHsWC GhcPs (LHsSigType GhcPs)
-> LHsSigType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC NoExtField
XHsWC GhcPs (LHsSigType GhcPs)
NoExtField (LHsSigType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType GhcPs))
-> (HsType GhcPs -> LHsSigType GhcPs)
-> HsType GhcPs
-> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> LHsSigType GhcPs
hsTypeToHsSigType (LHsType GhcPs -> LHsSigType GhcPs)
-> (HsType GhcPs -> LHsType GhcPs)
-> HsType GhcPs
-> LHsSigType 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 -> HsWildCardBndrs GhcPs (LHsSigType GhcPs))
-> HsType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType 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
-> StateT ConvertTestState Identity (LHsDecl GhcPs)
convertTest ExternalNames
names LHsDecl GhcPs
loc =
case LHsDecl GhcPs -> Maybe ParsedDecl
parseDecl LHsDecl GhcPs
loc of
Just (FuncSig [LocatedN RdrName
funcName] HsWildCardBndrs GhcPs (LHsSigType GhcPs)
ty)
| Just TestType
testType <- LocatedN RdrName -> Maybe TestType
parseTestType LocatedN RdrName
funcName -> do
LocatedN RdrName
testName <- ConvertTestM (LocatedN RdrName)
getNextTestName
SigInfo -> ConvertTestM ()
setLastSeenSig
SigInfo :: TestType
-> LocatedN RdrName
-> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
-> SigInfo
SigInfo
{ TestType
testType :: TestType
testType :: TestType
testType
, LocatedN RdrName
testName :: LocatedN RdrName
testName :: LocatedN RdrName
testName
, testHsType :: HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testHsType = HsWildCardBndrs GhcPs (LHsSigType GhcPs)
ty
}
LHsDecl GhcPs -> StateT ConvertTestState Identity (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
loc)
Just (FuncDef LocatedN RdrName
funcName [LocatedA FuncSingleDef]
funcDefs)
| Just TestType
testType <- LocatedN RdrName -> Maybe TestType
parseTestType LocatedN RdrName
funcName -> do
(LocatedN RdrName
testName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)
funcBodyType) <-
ConvertTestM (Maybe SigInfo)
getLastSeenSig ConvertTestM (Maybe SigInfo)
-> (Maybe SigInfo
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)))
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe SigInfo
Nothing -> CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)))
-> CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"Found test without type signature at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LocatedN RdrName -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LocatedN RdrName
funcName
Just SigInfo{testType :: SigInfo -> TestType
testType = TestType
testTypeFromSig, HsWildCardBndrs GhcPs (LHsSigType GhcPs)
LocatedN RdrName
testHsType :: HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testName :: LocatedN RdrName
testHsType :: SigInfo -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testName :: SigInfo -> LocatedN RdrName
..}
| TestType
testType TestType -> TestType -> Bool
forall a. Eq a => a -> a -> Bool
== TestType
testTypeFromSig -> (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocatedN RdrName
testName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testHsType)
| Bool
otherwise -> CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)))
-> CommandLineOption
-> StateT
ConvertTestState
Identity
(LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
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)
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]
..} <-
case [LocatedA FuncSingleDef]
funcDefs of
[] -> CommandLineOption -> StateT ConvertTestState Identity FuncSingleDef
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
-> StateT ConvertTestState Identity FuncSingleDef)
-> CommandLineOption
-> StateT ConvertTestState Identity FuncSingleDef
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"Test unexpectedly had no bindings at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LocatedN RdrName -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LocatedN RdrName
funcName
[LocatedA FuncSingleDef
funcDef] -> FuncSingleDef -> StateT ConvertTestState Identity FuncSingleDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuncSingleDef -> StateT ConvertTestState Identity FuncSingleDef)
-> FuncSingleDef -> StateT ConvertTestState Identity FuncSingleDef
forall a b. (a -> b) -> a -> b
$ LocatedA FuncSingleDef -> FuncSingleDef
forall l e. GenLocated l e -> e
unLoc LocatedA FuncSingleDef
funcDef
[LocatedA FuncSingleDef]
_ ->
CommandLineOption -> StateT ConvertTestState Identity FuncSingleDef
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
-> StateT ConvertTestState Identity FuncSingleDef)
-> ([CommandLineOption] -> CommandLineOption)
-> [CommandLineOption]
-> StateT ConvertTestState Identity FuncSingleDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> CommandLineOption
unlines ([CommandLineOption]
-> StateT ConvertTestState Identity FuncSingleDef)
-> [CommandLineOption]
-> StateT ConvertTestState Identity FuncSingleDef
forall a b. (a -> b) -> a -> b
$
[ CommandLineOption
"Found multiple tests named " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LocatedN RdrName -> CommandLineOption
fromRdrName LocatedN RdrName
funcName CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
" at: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption -> [CommandLineOption] -> CommandLineOption
forall a. [a] -> [[a]] -> [a]
intercalate CommandLineOption
", " ((LocatedA FuncSingleDef -> CommandLineOption)
-> [LocatedA FuncSingleDef] -> [CommandLineOption]
forall a b. (a -> b) -> [a] -> [b]
map LocatedA FuncSingleDef -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine [LocatedA FuncSingleDef]
funcDefs)
, CommandLineOption
"Did you forget to add a type annotation for a test?"
]
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]
++ LocatedN RdrName -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LocatedN RdrName
funcName
]
let funcBodyWithType :: GenLocated SrcSpan (HsExpr GhcPs)
funcBodyWithType = 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
$ 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)
funcBody HsWildCardBndrs GhcPs (LHsSigType GhcPs)
LHsSigWcType (NoGhcTc GhcPs)
funcBodyType
testBody :: GenLocated SrcSpan (HsExpr GhcPs)
testBody =
case TestType
testType of
TestSingle Tester
tester ->
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)]
-> GenLocated SrcSpan (HsExpr GhcPs))
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> 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
$ RdrName -> LocatedN RdrName
forall e ann. e -> GenLocated SrcSpan e
genLoc (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Tester -> RdrName
fromTester ExternalNames
names Tester
tester) ([GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs))
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
(Located (Pat GhcPs) -> GenLocated SrcSpan (HsExpr GhcPs))
-> [Located (Pat GhcPs)] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
Located (Pat GhcPs) -> GenLocated SrcSpan (HsExpr GhcPs)
patternToExpr [LPat GhcPs]
[Located (Pat GhcPs)]
funcDefArgs [GenLocated SrcSpan (HsExpr GhcPs)]
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpan (HsExpr GhcPs)
forall ann. GenLocated SrcSpan (HsExpr GhcPs)
funcBodyWithType]
]
TestType
TestBatch
| Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
[Located (Pat GhcPs)]
funcDefArgs) -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
autocollectError CommandLineOption
"test_batch should not be used with arguments"
| Bool -> Bool
not (ExternalNames -> HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> Bool
isListOfTestTree ExternalNames
names HsWildCardBndrs GhcPs (LHsSigType GhcPs)
funcBodyType) -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
autocollectError CommandLineOption
"test_batch needs to be set to a [TestTree]"
| Bool
otherwise -> GenLocated SrcSpan (HsExpr GhcPs)
forall ann. GenLocated SrcSpan (HsExpr GhcPs)
funcBodyWithType
LHsDecl GhcPs -> StateT ConvertTestState Identity (LHsDecl GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocatedN RdrName
-> [LPat GhcPs]
-> GenLocated SrcSpan (HsExpr GhcPs)
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl LocatedN RdrName
testName [] GenLocated SrcSpan (HsExpr GhcPs)
forall ann. 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
loc)
Maybe ParsedDecl
_ -> LHsDecl GhcPs -> StateT ConvertTestState Identity (LHsDecl GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsDecl GhcPs
loc
patternToExpr :: LPat GhcPs -> LHsExpr GhcPs
patternToExpr :: LPat GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
patternToExpr LPat GhcPs
lpat = ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go (LPat GhcPs -> ParsedPat
parsePat LPat GhcPs
lpat)
where
unsupported :: CommandLineOption -> a
unsupported CommandLineOption
label = CommandLineOption -> a
forall a. CommandLineOption -> a
autocollectError (CommandLineOption -> a) -> CommandLineOption -> a
forall a b. (a -> b) -> a -> b
$ CommandLineOption
label CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
" unsupported as test argument at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ Located (Pat GhcPs) -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LPat GhcPs
Located (Pat GhcPs)
lpat
go :: ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go = \case
ParsedPat
PatWildCard -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"wildcard patterns"
PatVar LocatedN RdrName
name -> 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
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
NoExtField Located (IdP GhcPs)
LocatedN RdrName
name
ParsedPat
PatLazy -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"lazy patterns"
ParsedPat
PatAs -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"as patterns"
PatParens ParsedPat
p -> 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
$ XPar GhcPs -> GenLocated SrcSpan (HsExpr GhcPs) -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noAnn (GenLocated SrcSpan (HsExpr GhcPs) -> HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go ParsedPat
p
ParsedPat
PatBang -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"bang patterns"
PatList [ParsedPat]
ps -> 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
$ (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> [ParsedPat] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go [ParsedPat]
ps
PatTuple [ParsedPat]
ps Boxity
boxity -> 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
$ [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
mkExplicitTuple ((ParsedPat -> HsTupArg GhcPs) -> [ParsedPat] -> [HsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (XPresent GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs) -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present NoExtField
XPresent GhcPs
noAnn (GenLocated SrcSpan (HsExpr GhcPs) -> HsTupArg GhcPs)
-> (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> ParsedPat
-> HsTupArg GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go) [ParsedPat]
ps) Boxity
boxity
ParsedPat
PatSum -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"anonymous sum patterns"
PatConstructor LocatedN RdrName
name ConstructorDetails
details ->
case ConstructorDetails
details of
ConstructorPrefix [LHsType GhcPs]
tys [ParsedPat]
args -> LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar LocatedN RdrName
name GenLocated SrcSpan (HsExpr GhcPs)
-> [LHsType GhcPs] -> GenLocated SrcSpan (HsExpr GhcPs)
`mkHsAppTypes` [LHsType GhcPs]
tys GenLocated SrcSpan (HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
`mkHsApps` (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> [ParsedPat] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go [ParsedPat]
args
ConstructorRecord HsRecFields{[LHsRecField GhcPs ParsedPat]
Maybe (Located Int)
rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_dotdot :: forall p arg. HsRecFields p arg -> Maybe (Located Int)
rec_dotdot :: Maybe (Located Int)
rec_flds :: [LHsRecField GhcPs ParsedPat]
..} ->
HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> (HsRecordBinds GhcPs -> HsExpr GhcPs)
-> HsRecordBinds GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRecordCon GhcPs
-> Located (IdP GhcPs) -> HsRecordBinds GhcPs -> HsExpr GhcPs
forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon NoExtField
XRecordCon GhcPs
noAnn Located (IdP GhcPs)
LocatedN RdrName
name (HsRecordBinds GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsRecordBinds GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields
{ rec_flds :: [LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))]
rec_flds = ((LHsRecField GhcPs ParsedPat
-> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs)))
-> [LHsRecField GhcPs ParsedPat]
-> [LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LHsRecField GhcPs ParsedPat
-> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs)))
-> [LHsRecField GhcPs ParsedPat]
-> [LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))])
-> ((ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> LHsRecField GhcPs ParsedPat
-> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs)))
-> (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> [LHsRecField GhcPs ParsedPat]
-> [LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsRecField' (FieldOcc GhcPs) ParsedPat
-> HsRecField'
(FieldOcc GhcPs) (GenLocated SrcSpan (HsExpr GhcPs)))
-> LHsRecField GhcPs ParsedPat
-> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HsRecField' (FieldOcc GhcPs) ParsedPat
-> HsRecField'
(FieldOcc GhcPs) (GenLocated SrcSpan (HsExpr GhcPs)))
-> LHsRecField GhcPs ParsedPat
-> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs)))
-> ((ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsRecField' (FieldOcc GhcPs) ParsedPat
-> HsRecField'
(FieldOcc GhcPs) (GenLocated SrcSpan (HsExpr GhcPs)))
-> (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> LHsRecField GhcPs ParsedPat
-> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsRecField' (FieldOcc GhcPs) ParsedPat
-> HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go [LHsRecField GhcPs ParsedPat]
rec_flds
, Maybe (Located Int)
rec_dotdot :: Maybe (Located Int)
rec_dotdot :: Maybe (Located Int)
..
}
ConstructorInfix ParsedPat
l ParsedPat
r -> GenLocated SrcSpan (HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
mkHsApps (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar LocatedN RdrName
name) ([GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs))
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> [ParsedPat] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go [ParsedPat
l, ParsedPat
r]
ParsedPat
PatView -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"view patterns"
PatSplice HsSplice GhcPs
splice -> 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
$ XSpliceE GhcPs -> HsSplice GhcPs -> HsExpr GhcPs
forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE NoExtField
XSpliceE GhcPs
noAnn HsSplice GhcPs
splice
PatLiteral HsLit GhcPs
lit -> 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
lit
PatOverloadedLit Located (HsOverLit GhcPs)
lit -> 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
$ XOverLitE GhcPs -> HsOverLit GhcPs -> HsExpr GhcPs
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit NoExtField
XOverLitE GhcPs
noAnn (Located (HsOverLit GhcPs) -> HsOverLit GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsOverLit GhcPs)
lit)
ParsedPat
PatNPlusK -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"n+k patterns"
PatTypeSig ParsedPat
p LHsType GhcPs
ty -> 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
$ 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 (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go ParsedPat
p) (LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs)
-> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
hsTypeToHsSigWcType (HsType GhcPs -> LHsType GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (LHsType GhcPs -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
ty))
testListName :: LocatedN RdrName
testListName :: LocatedN RdrName
testListName = CommandLineOption -> LocatedN RdrName
mkLRdrName CommandLineOption
testListIdentifier
data TestType
= TestSingle Tester
| 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)
data Tester
= Tester String
| TesterTodo
deriving (Int -> Tester -> CommandLineOption -> CommandLineOption
[Tester] -> CommandLineOption -> CommandLineOption
Tester -> CommandLineOption
(Int -> Tester -> CommandLineOption -> CommandLineOption)
-> (Tester -> CommandLineOption)
-> ([Tester] -> CommandLineOption -> CommandLineOption)
-> Show Tester
forall a.
(Int -> a -> CommandLineOption -> CommandLineOption)
-> (a -> CommandLineOption)
-> ([a] -> CommandLineOption -> CommandLineOption)
-> Show a
showList :: [Tester] -> CommandLineOption -> CommandLineOption
$cshowList :: [Tester] -> CommandLineOption -> CommandLineOption
show :: Tester -> CommandLineOption
$cshow :: Tester -> CommandLineOption
showsPrec :: Int -> Tester -> CommandLineOption -> CommandLineOption
$cshowsPrec :: Int -> Tester -> CommandLineOption -> CommandLineOption
Show, Tester -> Tester -> Bool
(Tester -> Tester -> Bool)
-> (Tester -> Tester -> Bool) -> Eq Tester
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tester -> Tester -> Bool
$c/= :: Tester -> Tester -> Bool
== :: Tester -> Tester -> Bool
$c== :: Tester -> Tester -> Bool
Eq)
parseTestType :: LocatedN RdrName -> Maybe TestType
parseTestType :: LocatedN RdrName -> Maybe TestType
parseTestType = (CommandLineOption -> TestType)
-> Maybe CommandLineOption -> Maybe TestType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommandLineOption -> TestType
toTestType (Maybe CommandLineOption -> Maybe TestType)
-> (LocatedN RdrName -> Maybe CommandLineOption)
-> LocatedN RdrName
-> Maybe TestType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> CommandLineOption -> Maybe CommandLineOption
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix CommandLineOption
"test_" (CommandLineOption -> Maybe CommandLineOption)
-> (LocatedN RdrName -> CommandLineOption)
-> LocatedN RdrName
-> Maybe CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN RdrName -> CommandLineOption
fromRdrName
where
toTestType :: CommandLineOption -> TestType
toTestType = \case
CommandLineOption
"batch" -> TestType
TestBatch
CommandLineOption
"todo" -> Tester -> TestType
TestSingle Tester
TesterTodo
CommandLineOption
s -> Tester -> TestType
TestSingle (CommandLineOption -> Tester
Tester CommandLineOption
s)
fromTester :: ExternalNames -> Tester -> RdrName
fromTester :: ExternalNames -> Tester -> RdrName
fromTester ExternalNames
names = \case
Tester CommandLineOption
name -> CommandLineOption -> RdrName
mkRdrName CommandLineOption
name
Tester
TesterTodo -> 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
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)
-> (LHsType GhcPs -> HsType GhcPs)
-> LHsType GhcPs
-> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExtField
XListTy GhcPs
noAnn)
(LHsType GhcPs -> LHsType GhcPs)
-> (LocatedN RdrName -> LHsType GhcPs)
-> LocatedN RdrName
-> LHsType 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 -> LHsType GhcPs)
-> (LocatedN RdrName -> HsType GhcPs)
-> LocatedN RdrName
-> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcPs
noAnn PromotionFlag
NotPromoted)
(LocatedN RdrName -> LHsType GhcPs)
-> LocatedN RdrName -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> LocatedN RdrName
forall e ann. e -> GenLocated SrcSpan e
genLoc RdrName
testTreeName
where
testTreeName :: RdrName
testTreeName = Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (ExternalNames -> Name
name_TestTree ExternalNames
names)
isListOfTestTree :: ExternalNames -> LHsSigWcType GhcPs -> Bool
isListOfTestTree :: ExternalNames -> HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> Bool
isListOfTestTree ExternalNames
names HsWildCardBndrs GhcPs (LHsSigType GhcPs)
ty =
case HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> Maybe ParsedType
parseSigWcType HsWildCardBndrs GhcPs (LHsSigType GhcPs)
ty of
Just (TypeList (TypeVar PromotionFlag
_ (L SrcSpan
_ RdrName
name))) -> RdrName -> OccName
rdrNameOcc RdrName
name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc RdrName
testTreeName
Maybe ParsedType
_ -> Bool
False
where
testTreeName :: RdrName
testTreeName = Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (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 -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testHsType :: 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