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

-- | The plugin to convert a test file. Injected by the preprocessor.
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
      }

{- |
Transforms a test module of the form

@
{\- AUTOCOLLECT.TEST -\}
module MyTest (
  foo,
  {\- AUTOCOLLECT.TEST.export -\}
  bar,
) where

test = ...
@

to the equivalent of

@
module MyTest (
  foo,
  tasty_tests,
  bar,
) where

tasty_tests :: [TestTree]
tasty_tests = [tasty_test_1]

tasty_test_1 :: TestTree
tasty_test_1 = ...
@
-}
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
            }

    -- Replace "{- AUTOCOLLECT.TEST.export -}" with `tests` in the export list
    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

    -- Generate the `tests` list
    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)

{- |
If the given declaration is a test, return the converted test, or otherwise
return it unmodified
-}
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
    -- anything else leave unmodified
    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
")"
          ]

-- | Identifier for the generated `tests` list.
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

-- | Return the `[TestTree]` type.
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)

{----- Test converter monad -----}

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
  -- ^ The type of test represented in this signature
  , SigInfo -> LocatedN RdrName
testName :: LocatedN RdrName
  -- ^ The generated name for the test
  , SigInfo -> LHsSigWcType GhcPs
signatureType :: LHsSigWcType GhcPs
  -- ^ The type captured in the signature
  }

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

{----- Utilities -----}

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