{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Test.Tasty.AutoCollect.ConvertTest (
  plugin,
) where

import Control.Arrow ((&&&))
import Control.Monad (unless, zipWithM)
import Control.Monad.Trans.State.Strict (State)
import Control.Monad.Trans.State.Strict qualified as State
import Data.Foldable (toList)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (isNothing)
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
import Data.Text qualified as Text

import Test.Tasty.AutoCollect.Constants
import Test.Tasty.AutoCollect.Error
import Test.Tasty.AutoCollect.ExternalNames
import Test.Tasty.AutoCollect.GHC hiding (comment)

-- | The plugin to convert a test file. Injected by the preprocessor.
plugin :: Plugin
plugin :: Plugin
plugin =
  Plugin
defaultPlugin
    { driverPlugin = \[[Char]]
_ HscEnv
env ->
        HscEnv -> IO HscEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          HscEnv
env
            { hsc_dflags = hsc_dflags env `gopt_set` Opt_KeepRawTokenStream
            }
    , pluginRecompile = purePlugin
    , parsedResultAction = \[[Char]]
_ ModSummary
_ ParsedResult
result -> do
        HscEnv
env <- Hsc HscEnv
getHscEnv
        ExternalNames
names <- IO ExternalNames -> Hsc ExternalNames
forall a. IO a -> Hsc a
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
        ParsedResult -> Hsc ParsedResult
forall a. a -> Hsc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          ParsedResult
result
            { parsedResultModule = transformTestModule names $ parsedResultModule result
            }
    }

-- | 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 = updateModule <$> hpm_module parsedModl}
  where
    updateModule :: HsModule GhcPs -> HsModule GhcPs
updateModule HsModule GhcPs
modl =
      let ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
decls, [GenLocated SrcSpanAnnN RdrName]
testNames) = ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsDecl GhcPs)],
    [GenLocated SrcSpanAnnN RdrName])
forall a.
ConvertTestModuleM a -> (a, [GenLocated SrcSpanAnnN RdrName])
runConvertTestModuleM (ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> ([GenLocated SrcSpanAnnA (HsDecl GhcPs)],
     [GenLocated SrcSpanAnnN RdrName]))
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ([GenLocated SrcSpanAnnA (HsDecl GhcPs)],
    [GenLocated SrcSpanAnnN RdrName])
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsDecl GhcPs)
 -> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (ExternalNames
-> LHsDecl GhcPs -> ConvertTestModuleM [LHsDecl GhcPs]
convertTest ExternalNames
names) ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
modl
       in HsModule GhcPs
modl
            { hsmodExports = updateExports <$> hsmodExports modl
            , hsmodDecls = mkTestsList testNames ++ decls
            }

    -- Replace "{- AUTOCOLLECT.TEST.export -}" with `tests` in the export list
    updateExports :: GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
updateExports GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports
      | Just RealSrcSpan
exportSpan <- (GenLocated RealSrcSpan [Char] -> Maybe RealSrcSpan)
-> [GenLocated RealSrcSpan [Char]] -> Maybe RealSrcSpan
forall l e a.
Ord l =>
(GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a
firstLocatedWhere GenLocated RealSrcSpan [Char] -> Maybe RealSrcSpan
forall {a}. GenLocated a [Char] -> Maybe a
getTestExportAnnSrcSpan (LocatedL [XRec GhcPs (IE GhcPs)] -> [GenLocated RealSrcSpan [Char]]
getExportComments LocatedL [XRec GhcPs (IE GhcPs)]
GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports) =
          (SrcSpanAnnA -> IE GhcPs -> GenLocated SrcSpanAnnA (IE GhcPs)
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> SrcSpanAnnA
toSrcAnnA RealSrcSpan
exportSpan) IE GhcPs
exportIE GenLocated SrcSpanAnnA (IE GhcPs)
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
forall a. a -> [a] -> [a]
:) ([GenLocated SrcSpanAnnA (IE GhcPs)]
 -> [GenLocated SrcSpanAnnA (IE GhcPs)])
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports
      | Bool
otherwise =
          GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports
    getTestExportAnnSrcSpan :: GenLocated a [Char] -> Maybe a
getTestExportAnnSrcSpan (L a
loc [Char]
comment) =
      if [Char] -> Bool
isTestExportComment [Char]
comment
        then a -> Maybe a
forall a. a -> Maybe a
Just a
loc
        else Maybe a
forall a. Maybe a
Nothing
    exportIE :: IE GhcPs
exportIE = LIEWrappedName GhcPs -> IE GhcPs
mkIEVar (LIEWrappedName GhcPs -> IE GhcPs)
-> LIEWrappedName GhcPs -> IE GhcPs
forall a b. (a -> b) -> a -> b
$ IEWrappedName GhcPs -> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (IEWrappedName GhcPs
 -> GenLocated SrcSpanAnnA (IEWrappedName GhcPs))
-> IEWrappedName GhcPs
-> GenLocated SrcSpanAnnA (IEWrappedName GhcPs)
forall a b. (a -> b) -> a -> b
$ XIEName GhcPs -> LIdP GhcPs -> IEWrappedName GhcPs
forall p. XIEName p -> LIdP p -> IEWrappedName p
IEName XIEName GhcPs
NoExtField
noExtField LIdP GhcPs
GenLocated SrcSpanAnnN RdrName
testListName

    -- Generate the `tests` list
    mkTestsList :: [LocatedN RdrName] -> [LHsDecl GhcPs]
    mkTestsList :: [GenLocated SrcSpanAnnN RdrName] -> [LHsDecl GhcPs]
mkTestsList [GenLocated SrcSpanAnnN RdrName]
testNames =
      let testsList :: GenLocated (SrcAnn ann) (HsExpr GhcPs)
testsList = HsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExplicitList GhcPs -> [LHsExpr GhcPs] -> HsExpr GhcPs
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcPs
EpAnn AnnList
forall a. EpAnn a
noAnn ([LHsExpr GhcPs] -> HsExpr GhcPs)
-> [LHsExpr GhcPs] -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnN RdrName -> LHsExpr GhcPs)
-> [GenLocated SrcSpanAnnN RdrName] -> [LHsExpr GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN RdrName -> LHsExpr GhcPs
lhsvar [GenLocated SrcSpanAnnN RdrName]
testNames
       in [ HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig GenLocated SrcSpanAnnN 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 -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl GenLocated SrcSpanAnnN RdrName
testListName [] (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
flattenTestList GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}. GenLocated (SrcAnn ann) (HsExpr GhcPs)
testsList) Maybe (HsLocalBinds GhcPs)
forall a. Maybe a
Nothing
          ]

    flattenTestList :: GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs
flattenTestList GenLocated SrcSpanAnnA (HsExpr GhcPs)
testsList =
      LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (Name -> LHsExpr GhcPs
mkHsVar (Name -> LHsExpr GhcPs) -> Name -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_concat ExternalNames
names) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkExprTypeSig LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
testsList (GenLocated SrcSpanAnnA (HsType GhcPs) -> LHsExpr GhcPs)
-> (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs
-> LHsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsType GhcPs -> LHsExpr GhcPs) -> HsType GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
          XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcPs
EpAnn AnnParen
forall a. EpAnn a
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 -> ConvertTestModuleM [LHsDecl GhcPs]
convertTest :: ExternalNames
-> LHsDecl GhcPs -> ConvertTestModuleM [LHsDecl GhcPs]
convertTest ExternalNames
names LHsDecl GhcPs
ldecl =
  case LHsDecl GhcPs -> Maybe ParsedDecl
parseDecl LHsDecl GhcPs
ldecl of
    Just (FuncSig [GenLocated SrcSpanAnnN RdrName
funcName] LHsSigWcType GhcPs
ty)
      | Just TestType
testType <- [Char] -> Maybe TestType
parseTestType (GenLocated SrcSpanAnnN RdrName -> [Char]
fromRdrName GenLocated SrcSpanAnnN RdrName
funcName) -> do
          GenLocated SrcSpanAnnN RdrName
testName <- ConvertTestModuleM (GenLocated SrcSpanAnnN RdrName)
getNextTestName
          SigInfo -> ConvertTestModuleM ()
setLastSeenSig
            SigInfo
              { TestType
testType :: TestType
testType :: TestType
testType
              , GenLocated SrcSpanAnnN RdrName
testName :: GenLocated SrcSpanAnnN RdrName
testName :: GenLocated SrcSpanAnnN RdrName
testName
              , signatureType :: LHsSigWcType GhcPs
signatureType = LHsSigWcType GhcPs
ty
              }
          Bool -> ConvertTestModuleM () -> ConvertTestModuleM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
testType LHsSigWcType GhcPs
ty) (ConvertTestModuleM () -> ConvertTestModuleM ())
-> ConvertTestModuleM () -> ConvertTestModuleM ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> ConvertTestModuleM ()
forall a. [Char] -> a
autocollectError ([Char] -> ConvertTestModuleM ())
-> ([[Char]] -> [Char]) -> [[Char]] -> ConvertTestModuleM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> ConvertTestModuleM ())
-> [[Char]] -> ConvertTestModuleM ()
forall a b. (a -> b) -> a -> b
$
              [ [Char]
"Expected type: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TestType -> [Char]
typeForTestType TestType
testType
              , [Char]
"Got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> [Char]
forall a. Outputable a => a -> [Char]
showPpr LHsSigWcType GhcPs
HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
ty
              ]
          [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> StateT ConvertTestModuleState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [GenLocated SrcSpanAnnN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig GenLocated SrcSpanAnnN RdrName
testName (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names) HsDecl GhcPs
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b.
a -> GenLocated SrcSpanAnnA b -> GenLocated SrcSpanAnnA a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
ldecl]
    Just (FuncDef GenLocated SrcSpanAnnN RdrName
funcName [LocatedA FuncSingleDef]
funcDefs)
      | Just TestType
testType <- [Char] -> Maybe TestType
parseTestType (GenLocated SrcSpanAnnN RdrName -> [Char]
fromRdrName GenLocated SrcSpanAnnN RdrName
funcName) -> do
          Maybe SigInfo
mSigInfo <- ConvertTestModuleM (Maybe SigInfo)
getLastSeenSig
          [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
 -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> StateT
     ConvertTestModuleState
     Identity
     [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe SigInfo
 -> LocatedA FuncSingleDef
 -> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [Maybe SigInfo]
-> [LocatedA FuncSingleDef]
-> StateT
     ConvertTestModuleState
     Identity
     [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (GenLocated SrcSpanAnnN RdrName
-> TestType
-> Maybe SigInfo
-> LocatedA FuncSingleDef
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall {a} {e} {l}.
GenLocated (SrcSpanAnn' a) e
-> TestType
-> Maybe SigInfo
-> GenLocated l FuncSingleDef
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
convertSingleTest GenLocated SrcSpanAnnN RdrName
funcName TestType
testType) (Maybe SigInfo
mSigInfo Maybe SigInfo -> [Maybe SigInfo] -> [Maybe SigInfo]
forall a. a -> [a] -> [a]
: Maybe SigInfo -> [Maybe SigInfo]
forall a. a -> [a]
repeat Maybe SigInfo
forall a. Maybe a
Nothing) [LocatedA FuncSingleDef]
funcDefs
    -- anything else leave unmodified
    Maybe ParsedDecl
_ -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> StateT ConvertTestModuleState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
ldecl]
  where
    loc :: SrcSpan
loc = GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
ldecl

    convertSingleTest :: GenLocated (SrcSpanAnn' a) e
-> TestType
-> Maybe SigInfo
-> GenLocated l FuncSingleDef
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
convertSingleTest GenLocated (SrcSpanAnn' a) e
funcName TestType
testType Maybe SigInfo
mSigInfo (L l
_ FuncSingleDef{[LPat GhcPs]
[FuncGuardedBody]
HsLocalBinds GhcPs
funcDefArgs :: [LPat GhcPs]
funcDefGuards :: [FuncGuardedBody]
funcDefWhereClause :: HsLocalBinds GhcPs
funcDefArgs :: FuncSingleDef -> [LPat GhcPs]
funcDefGuards :: FuncSingleDef -> [FuncGuardedBody]
funcDefWhereClause :: FuncSingleDef -> HsLocalBinds GhcPs
..}) = do
      (GenLocated SrcSpanAnnN RdrName
testName, Maybe
  (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
mSigType) <-
        case Maybe SigInfo
mSigInfo of
          Maybe SigInfo
Nothing -> do
            GenLocated SrcSpanAnnN RdrName
testName <- ConvertTestModuleM (GenLocated SrcSpanAnnN RdrName)
getNextTestName
            (GenLocated SrcSpanAnnN RdrName,
 Maybe
   (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))))
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnN RdrName,
      Maybe
        (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))))
forall a. a -> StateT ConvertTestModuleState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnN RdrName
testName, Maybe
  (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
forall a. Maybe a
Nothing)
          Just SigInfo{testType :: SigInfo -> TestType
testType = TestType
testTypeFromSig, GenLocated SrcSpanAnnN RdrName
LHsSigWcType GhcPs
testName :: SigInfo -> GenLocated SrcSpanAnnN RdrName
signatureType :: SigInfo -> LHsSigWcType GhcPs
testName :: GenLocated SrcSpanAnnN RdrName
signatureType :: LHsSigWcType GhcPs
..}
            | TestType
testType TestType -> TestType -> Bool
forall a. Eq a => a -> a -> Bool
== TestType
testTypeFromSig -> (GenLocated SrcSpanAnnN RdrName,
 Maybe
   (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))))
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnN RdrName,
      Maybe
        (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))))
forall a. a -> StateT ConvertTestModuleState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnN RdrName
testName, HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Maybe
     (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
forall a. a -> Maybe a
Just LHsSigWcType GhcPs
HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
signatureType)
            | Bool
otherwise -> [Char]
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnN RdrName,
      Maybe
        (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))))
forall a. [Char] -> a
autocollectError ([Char]
 -> StateT
      ConvertTestModuleState
      Identity
      (GenLocated SrcSpanAnnN RdrName,
       Maybe
         (HsWildCardBndrs
            GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))))
-> [Char]
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnN RdrName,
      Maybe
        (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))))
forall a b. (a -> b) -> a -> b
$ [Char]
"Found test with different type of signature: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (TestType, TestType) -> [Char]
forall a. Show a => a -> [Char]
show (TestType
testType, TestType
testTypeFromSig)

      (GenLocated SrcSpanAnnA (HsExpr GhcPs)
testBody, ConvertTestState{Maybe (HsLocalBinds GhcPs)
mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause :: ConvertTestState -> Maybe (HsLocalBinds GhcPs)
mWhereClause}) <-
        case [FuncGuardedBody]
funcDefGuards of
          [FuncGuardedBody [] LHsExpr GhcPs
body] -> do
            let state :: ConvertTestState
state =
                  ConvertTestState
                    { Maybe (LHsSigWcType GhcPs)
Maybe
  (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
mSigType :: Maybe
  (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
mSigType :: Maybe (LHsSigWcType GhcPs)
mSigType
                    , testArgs :: [LPat GhcPs]
testArgs = [LPat GhcPs]
funcDefArgs
                    , mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause = HsLocalBinds GhcPs -> Maybe (HsLocalBinds GhcPs)
forall a. a -> Maybe a
Just HsLocalBinds GhcPs
funcDefWhereClause
                    }
            (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
forall a. a -> StateT ConvertTestModuleState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
 -> StateT
      ConvertTestModuleState
      Identity
      (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState))
-> (ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
    -> (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvertTestState
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
forall a.
ConvertTestState -> ConvertTestM a -> (a, ConvertTestState)
runConvertTestM ConvertTestState
state (ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
 -> StateT
      ConvertTestModuleState
      Identity
      (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
forall a b. (a -> b) -> a -> b
$ do
              GenLocated SrcSpanAnnA (HsExpr GhcPs)
testBody <- TestType
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
convertSingleTestBody TestType
testType LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
              (ConvertTestState -> [GenLocated SrcSpanAnnA (Pat GhcPs)])
-> StateT
     ConvertTestState Identity [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
State.gets ConvertTestState -> [LPat GhcPs]
ConvertTestState -> [GenLocated SrcSpanAnnA (Pat GhcPs)]
testArgs StateT
  ConvertTestState Identity [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)]
    -> StateT ConvertTestState Identity ())
-> StateT ConvertTestState Identity ()
forall a b.
StateT ConvertTestState Identity a
-> (a -> StateT ConvertTestState Identity b)
-> StateT ConvertTestState Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                [] -> () -> StateT ConvertTestState Identity ()
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                [GenLocated SrcSpanAnnA (Pat GhcPs)]
_ -> [Char] -> StateT ConvertTestState Identity ()
forall a. [Char] -> a
autocollectError ([Char] -> StateT ConvertTestState Identity ())
-> [Char] -> StateT ConvertTestState Identity ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Found extraneous arguments at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [Char]
getSpanLine SrcSpan
loc
              GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
testBody
          [FuncGuardedBody]
_ ->
            [Char]
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
forall a. [Char] -> a
autocollectError ([Char]
 -> StateT
      ConvertTestModuleState
      Identity
      (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState))
-> ([[Char]] -> [Char])
-> [[Char]]
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]]
 -> StateT
      ConvertTestModuleState
      Identity
      (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState))
-> [[Char]]
-> StateT
     ConvertTestModuleState
     Identity
     (GenLocated SrcSpanAnnA (HsExpr GhcPs), ConvertTestState)
forall a b. (a -> b) -> a -> b
$
              [ [Char]
"Test should have no guards."
              , [Char]
"Found guards at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [Char]
getSpanLine (GenLocated (SrcSpanAnn' a) e -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA GenLocated (SrcSpanAnn' a) e
funcName)
              ]

      [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a. a -> StateT ConvertTestModuleState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
 -> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> ([[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
    -> [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
 -> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)])
-> [[GenLocated SrcSpanAnnA (HsDecl GhcPs)]]
-> ConvertTestModuleM [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. (a -> b) -> a -> b
$
        [ if Maybe SigInfo -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SigInfo
mSigInfo
            then [HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
-> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig GenLocated SrcSpanAnnN RdrName
testName (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names)]
            else []
        , [GenLocated SrcSpanAnnN RdrName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl GenLocated SrcSpanAnnN RdrName
testName [] LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
testBody Maybe (HsLocalBinds GhcPs)
mWhereClause HsDecl GhcPs
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> GenLocated SrcSpanAnnA (HsDecl GhcPs)
forall a b.
a -> GenLocated SrcSpanAnnA b -> GenLocated SrcSpanAnnA a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
GenLocated SrcSpanAnnA (HsDecl GhcPs)
ldecl]
        ]

    convertSingleTestBody :: TestType
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
convertSingleTestBody TestType
testType GenLocated SrcSpanAnnA (HsExpr GhcPs)
body =
      case TestType
testType of
        TestType
TestNormal ->
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}.
LHsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
        TestType
TestProp -> do
          -- test_prop :: <type>
          -- test_prop "name" arg1 arg2 = <body> where <defs>
          -- ====>
          -- test = testProperty "name" ((\arg1 arg2 -> let <defs> in <body>) :: <type>)

          state :: ConvertTestState
state@ConvertTestState{Maybe (LHsSigWcType GhcPs)
mSigType :: ConvertTestState -> Maybe (LHsSigWcType GhcPs)
mSigType :: Maybe (LHsSigWcType GhcPs)
mSigType, Maybe (HsLocalBinds GhcPs)
mWhereClause :: ConvertTestState -> Maybe (HsLocalBinds GhcPs)
mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause} <- StateT ConvertTestState Identity ConvertTestState
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
          ConvertTestState -> StateT ConvertTestState Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{mSigType = Nothing, mWhereClause = Nothing}

          ([Char]
name, [GenLocated SrcSpanAnnA (Pat GhcPs)]
remainingPats) <-
            ConvertTestM [LPat GhcPs]
StateT
  ConvertTestState Identity [GenLocated SrcSpanAnnA (Pat GhcPs)]
popRemainingArgs StateT
  ConvertTestState Identity [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)]
    -> StateT
         ConvertTestState
         Identity
         ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)]))
-> StateT
     ConvertTestState
     Identity
     ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall a b.
StateT ConvertTestState Identity a
-> (a -> StateT ConvertTestState Identity b)
-> StateT ConvertTestState Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              GenLocated SrcSpanAnnA (Pat GhcPs)
arg : [GenLocated SrcSpanAnnA (Pat GhcPs)]
rest | Just [Char]
s <- LPat GhcPs -> Maybe [Char]
parseLitStrPat LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
arg -> ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)])
-> StateT
     ConvertTestState
     Identity
     ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
s, [GenLocated SrcSpanAnnA (Pat GhcPs)]
rest)
              [] -> [Char]
-> StateT
     ConvertTestState
     Identity
     ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall a. [Char] -> a
autocollectError [Char]
"test_prop requires at least the name of the test"
              GenLocated SrcSpanAnnA (Pat GhcPs)
arg : [GenLocated SrcSpanAnnA (Pat GhcPs)]
_ ->
                [Char]
-> StateT
     ConvertTestState
     Identity
     ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall a. [Char] -> a
autocollectError ([Char]
 -> StateT
      ConvertTestState
      Identity
      ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)]))
-> ([[Char]] -> [Char])
-> [[Char]]
-> StateT
     ConvertTestState
     Identity
     ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]]
 -> StateT
      ConvertTestState
      Identity
      ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)]))
-> [[Char]]
-> StateT
     ConvertTestState
     Identity
     ([Char], [GenLocated SrcSpanAnnA (Pat GhcPs)])
forall a b. (a -> b) -> a -> b
$
                  [ [Char]
"test_prop expected a String for the name of the test."
                  , [Char]
"Got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ GenLocated SrcSpanAnnA (Pat GhcPs) -> [Char]
forall a. Outputable a => a -> [Char]
showPpr GenLocated SrcSpanAnnA (Pat GhcPs)
arg
                  ]

          let propBody :: LHsExpr GhcPs
propBody =
                [LPat GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
remainingPats (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
                  case Maybe (HsLocalBinds GhcPs)
mWhereClause of
                    Just HsLocalBinds GhcPs
defs -> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ HsLocalBinds GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
mkLet HsLocalBinds GhcPs
defs LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
                    Maybe (HsLocalBinds GhcPs)
Nothing -> LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body

          GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}.
LHsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps
              (GenLocated SrcSpanAnnN RdrName -> LHsExpr GhcPs
lhsvar (GenLocated SrcSpanAnnN RdrName -> LHsExpr GhcPs)
-> GenLocated SrcSpanAnnN RdrName -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ [Char] -> GenLocated SrcSpanAnnN RdrName
mkLRdrName [Char]
"testProperty")
              [ [Char] -> LHsExpr GhcPs
mkHsLitString [Char]
name
              , GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> (HsWildCardBndrs
      GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> Maybe
     (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GenLocated SrcSpanAnnA (HsExpr GhcPs)
propBody (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> (HsWildCardBndrs
      GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
    -> HsExpr GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XExprWithTySig GhcPs
-> LHsExpr GhcPs -> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig GhcPs
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
propBody) Maybe (LHsSigWcType GhcPs)
Maybe
  (HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
mSigType
              ]
        TestType
TestTodo ->
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> (GenLocated SrcSpanAnnA (HsExpr GhcPs)
    -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {ann}.
LHsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp
              (Name -> LHsExpr GhcPs
mkHsVar (Name -> LHsExpr GhcPs) -> Name -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_testTreeTodo ExternalNames
names)
              (LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkExprTypeSig LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
body (LHsType GhcPs -> LHsExpr GhcPs) -> LHsType GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Name -> LHsType GhcPs
mkHsTyVar (ExternalNames -> Name
name_String ExternalNames
names))
        TestType
TestBatch ->
          GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
        TestModify TestModifier
modifier TestType
testType' ->
          ExternalNames
-> TestModifier
-> SrcSpan
-> ConvertTestM (LHsExpr GhcPs)
-> ConvertTestM (LHsExpr GhcPs)
withTestModifier ExternalNames
names TestModifier
modifier SrcSpan
loc (ConvertTestM (LHsExpr GhcPs) -> ConvertTestM (LHsExpr GhcPs))
-> ConvertTestM (LHsExpr GhcPs) -> ConvertTestM (LHsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
            TestType
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
convertSingleTestBody TestType
testType' GenLocated SrcSpanAnnA (HsExpr GhcPs)
body

    singleExpr :: LHsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr = HsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsExpr GhcPs -> GenLocated (SrcAnn ann) (HsExpr GhcPs))
-> (LHsExpr GhcPs -> HsExpr GhcPs)
-> LHsExpr GhcPs
-> GenLocated (SrcAnn ann) (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XExplicitList GhcPs -> [LHsExpr GhcPs] -> HsExpr GhcPs
forall p. XExplicitList p -> [LHsExpr p] -> HsExpr p
ExplicitList XExplicitList GhcPs
EpAnn AnnList
forall a. EpAnn a
noAnn ([LHsExpr GhcPs] -> HsExpr GhcPs)
-> (LHsExpr GhcPs -> [LHsExpr GhcPs])
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsExpr GhcPs -> [LHsExpr GhcPs] -> [LHsExpr GhcPs]
forall a. a -> [a] -> [a]
: [])

-- | Identifier for the generated `tests` list.
testListName :: LocatedN RdrName
testListName :: GenLocated SrcSpanAnnN RdrName
testListName = [Char] -> GenLocated SrcSpanAnnN RdrName
mkLRdrName [Char]
testListIdentifier

-- | Return the `[TestTree]` type.
getListOfTestTreeType :: ExternalNames -> LHsType GhcPs
getListOfTestTreeType :: ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names = HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcPs
EpAnn AnnParen
forall a. EpAnn a
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)

{----- TestType -----}

data TestType
  = TestNormal
  | TestProp
  | TestTodo
  | TestBatch
  | TestModify TestModifier TestType
  deriving (Int -> TestType -> [Char] -> [Char]
[TestType] -> [Char] -> [Char]
TestType -> [Char]
(Int -> TestType -> [Char] -> [Char])
-> (TestType -> [Char])
-> ([TestType] -> [Char] -> [Char])
-> Show TestType
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TestType -> [Char] -> [Char]
showsPrec :: Int -> TestType -> [Char] -> [Char]
$cshow :: TestType -> [Char]
show :: TestType -> [Char]
$cshowList :: [TestType] -> [Char] -> [Char]
showList :: [TestType] -> [Char] -> [Char]
Show, TestType -> TestType -> Bool
(TestType -> TestType -> Bool)
-> (TestType -> TestType -> Bool) -> Eq TestType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestType -> TestType -> Bool
== :: TestType -> TestType -> Bool
$c/= :: TestType -> TestType -> Bool
/= :: TestType -> TestType -> Bool
Eq)

data TestModifier
  = ExpectFail
  | ExpectFailBecause
  | IgnoreTest
  | IgnoreTestBecause
  deriving (Int -> TestModifier -> [Char] -> [Char]
[TestModifier] -> [Char] -> [Char]
TestModifier -> [Char]
(Int -> TestModifier -> [Char] -> [Char])
-> (TestModifier -> [Char])
-> ([TestModifier] -> [Char] -> [Char])
-> Show TestModifier
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TestModifier -> [Char] -> [Char]
showsPrec :: Int -> TestModifier -> [Char] -> [Char]
$cshow :: TestModifier -> [Char]
show :: TestModifier -> [Char]
$cshowList :: [TestModifier] -> [Char] -> [Char]
showList :: [TestModifier] -> [Char] -> [Char]
Show, TestModifier -> TestModifier -> Bool
(TestModifier -> TestModifier -> Bool)
-> (TestModifier -> TestModifier -> Bool) -> Eq TestModifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestModifier -> TestModifier -> Bool
== :: TestModifier -> TestModifier -> Bool
$c/= :: TestModifier -> TestModifier -> Bool
/= :: TestModifier -> TestModifier -> Bool
Eq)

parseTestType :: String -> Maybe TestType
parseTestType :: [Char] -> Maybe TestType
parseTestType = [Text] -> Maybe TestType
go ([Text] -> Maybe TestType)
-> ([Char] -> [Text]) -> [Char] -> Maybe TestType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"_" (Text -> [Text]) -> ([Char] -> Text) -> [Char] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack
  where
    go :: [Text] -> Maybe TestType
go = \case
      [Text
"test"] -> TestType -> Maybe TestType
forall a. a -> Maybe a
Just TestType
TestNormal
      [Text
"test", Text
"prop"] -> TestType -> Maybe TestType
forall a. a -> Maybe a
Just TestType
TestProp
      [Text
"test", Text
"todo"] -> TestType -> Maybe TestType
forall a. a -> Maybe a
Just TestType
TestTodo
      [Text
"test", Text
"batch"] -> TestType -> Maybe TestType
forall a. a -> Maybe a
Just TestType
TestBatch
      ([Text] -> Maybe ([Text], Text)
forall {a}. [a] -> Maybe ([a], a)
unsnoc -> Just ([Text]
t, Text
"expectFail")) -> TestModifier -> TestType -> TestType
TestModify TestModifier
ExpectFail (TestType -> TestType) -> Maybe TestType -> Maybe TestType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe TestType
go [Text]
t
      ([Text] -> Maybe ([Text], Text)
forall {a}. [a] -> Maybe ([a], a)
unsnoc -> Just ([Text]
t, Text
"expectFailBecause")) -> TestModifier -> TestType -> TestType
TestModify TestModifier
ExpectFailBecause (TestType -> TestType) -> Maybe TestType -> Maybe TestType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe TestType
go [Text]
t
      ([Text] -> Maybe ([Text], Text)
forall {a}. [a] -> Maybe ([a], a)
unsnoc -> Just ([Text]
t, Text
"ignoreTest")) -> TestModifier -> TestType -> TestType
TestModify TestModifier
IgnoreTest (TestType -> TestType) -> Maybe TestType -> Maybe TestType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe TestType
go [Text]
t
      ([Text] -> Maybe ([Text], Text)
forall {a}. [a] -> Maybe ([a], a)
unsnoc -> Just ([Text]
t, Text
"ignoreTestBecause")) -> TestModifier -> TestType -> TestType
TestModify TestModifier
IgnoreTestBecause (TestType -> TestType) -> Maybe TestType -> Maybe TestType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe TestType
go [Text]
t
      [Text]
_ -> Maybe TestType
forall a. Maybe a
Nothing

    unsnoc :: [a] -> Maybe ([a], a)
unsnoc = (NonEmpty a -> ([a], a)) -> Maybe (NonEmpty a) -> Maybe ([a], a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NonEmpty.init (NonEmpty a -> [a]) -> (NonEmpty a -> a) -> NonEmpty a -> ([a], a)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& NonEmpty a -> a
forall a. NonEmpty a -> a
NonEmpty.last) (Maybe (NonEmpty a) -> Maybe ([a], a))
-> ([a] -> Maybe (NonEmpty a)) -> [a] -> Maybe ([a], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty

isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType :: ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names = \case
  TestType
TestNormal -> (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
parsedTypeMatches ParsedType -> Bool
isTestTreeTypeVar
  TestType
TestProp -> Bool
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
forall a b. a -> b -> a
const Bool
True
  TestType
TestTodo -> (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
parsedTypeMatches ((ParsedType -> Bool)
 -> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
 -> Bool)
-> (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
forall a b. (a -> b) -> a -> b
$ Name -> ParsedType -> Bool
isTypeVarNamed (ExternalNames -> Name
name_String ExternalNames
names)
  TestType
TestBatch -> (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
parsedTypeMatches ((ParsedType -> Bool)
 -> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
 -> Bool)
-> (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
forall a b. (a -> b) -> a -> b
$ \case
    TypeList ParsedType
ty -> ParsedType -> Bool
isTestTreeTypeVar ParsedType
ty
    ParsedType
_ -> Bool
False
  TestModify TestModifier
modifier TestType
tt -> TestType
-> TestModifier
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
isValidForModifier TestType
tt TestModifier
modifier
  where
    isValidForModifier :: TestType -> TestModifier -> LHsSigWcType GhcPs -> Bool
isValidForModifier TestType
tt = \case
      TestModifier
ExpectFail -> ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
tt
      TestModifier
ExpectFailBecause -> ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
tt
      TestModifier
IgnoreTest -> ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
tt
      TestModifier
IgnoreTestBecause -> ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
tt

    parsedTypeMatches :: (ParsedType -> Bool)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
parsedTypeMatches ParsedType -> Bool
f = Bool -> (ParsedType -> Bool) -> Maybe ParsedType -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ParsedType -> Bool
f (Maybe ParsedType -> Bool)
-> (HsWildCardBndrs
      GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
    -> Maybe ParsedType)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsSigWcType GhcPs -> Maybe ParsedType
HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> Maybe ParsedType
parseSigWcType
    isTestTreeTypeVar :: ParsedType -> Bool
isTestTreeTypeVar = Name -> ParsedType -> Bool
isTypeVarNamed (ExternalNames -> Name
name_TestTree ExternalNames
names)

typeForTestType :: TestType -> String
typeForTestType :: TestType -> [Char]
typeForTestType = \case
  TestType
TestNormal -> [Char]
"TestTree"
  TestType
TestProp -> [Char]
"(Testable prop => prop)"
  TestType
TestTodo -> [Char]
"String"
  TestType
TestBatch -> [Char]
"[TestTree]"
  TestModify TestModifier
modifier TestType
tt -> TestType -> TestModifier -> [Char]
typeForTestModifier TestType
tt TestModifier
modifier
  where
    typeForTestModifier :: TestType -> TestModifier -> [Char]
typeForTestModifier TestType
tt = \case
      TestModifier
ExpectFail -> TestType -> [Char]
typeForTestType TestType
tt
      TestModifier
ExpectFailBecause -> TestType -> [Char]
typeForTestType TestType
tt
      TestModifier
IgnoreTest -> TestType -> [Char]
typeForTestType TestType
tt
      TestModifier
IgnoreTestBecause -> TestType -> [Char]
typeForTestType TestType
tt

isTypeVarNamed :: Name -> ParsedType -> Bool
isTypeVarNamed :: Name -> ParsedType -> Bool
isTypeVarNamed Name
name = \case
  TypeVar PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
n) -> RdrName -> OccName
rdrNameOcc RdrName
n 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

withTestModifier ::
  ExternalNames
  -> TestModifier
  -> SrcSpan
  -> ConvertTestM (LHsExpr GhcPs)
  -> ConvertTestM (LHsExpr GhcPs)
withTestModifier :: ExternalNames
-> TestModifier
-> SrcSpan
-> ConvertTestM (LHsExpr GhcPs)
-> ConvertTestM (LHsExpr GhcPs)
withTestModifier ExternalNames
names TestModifier
modifier SrcSpan
loc ConvertTestM (LHsExpr GhcPs)
m =
  case TestModifier
modifier of
    TestModifier
ExpectFail -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests (Name -> LHsExpr GhcPs
mkHsVar (Name -> LHsExpr GhcPs) -> Name -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_expectFail ExternalNames
names) (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertTestM (LHsExpr GhcPs)
ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m
    TestModifier
ExpectFailBecause ->
      ConvertTestM (Maybe (LPat GhcPs))
StateT
  ConvertTestState
  Identity
  (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs)))
popArg StateT
  ConvertTestState
  Identity
  (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
    -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b.
StateT ConvertTestState Identity a
-> (a -> StateT ConvertTestState Identity b)
-> StateT ConvertTestState Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just GenLocated SrcSpanAnnA (Pat GhcPs)
arg
          | Just [Char]
s <- LPat GhcPs -> Maybe [Char]
parseLitStrPat LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
arg ->
              GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests (Name
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
applyName (ExternalNames -> Name
name_expectFailBecause ExternalNames
names) [[Char] -> LHsExpr GhcPs
mkHsLitString [Char]
s]) (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertTestM (LHsExpr GhcPs)
ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m
        Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg -> Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
-> [Char] -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {a} {c}. Outputable a => Maybe a -> [Char] -> c
needsStrArg Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg [Char]
"_expectFailBecause"
    TestModifier
IgnoreTest -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests (Name -> LHsExpr GhcPs
mkHsVar (Name -> LHsExpr GhcPs) -> Name -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_ignoreTest ExternalNames
names) (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertTestM (LHsExpr GhcPs)
ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m
    TestModifier
IgnoreTestBecause ->
      ConvertTestM (Maybe (LPat GhcPs))
StateT
  ConvertTestState
  Identity
  (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs)))
popArg StateT
  ConvertTestState
  Identity
  (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs)))
-> (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
    -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b.
StateT ConvertTestState Identity a
-> (a -> StateT ConvertTestState Identity b)
-> StateT ConvertTestState Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just GenLocated SrcSpanAnnA (Pat GhcPs)
arg
          | Just [Char]
s <- LPat GhcPs -> Maybe [Char]
parseLitStrPat LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
arg ->
              GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests (Name
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
applyName (ExternalNames -> Name
name_ignoreTestBecause ExternalNames
names) [[Char] -> LHsExpr GhcPs
mkHsLitString [Char]
s]) (GenLocated SrcSpanAnnA (HsExpr GhcPs)
 -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConvertTestM (LHsExpr GhcPs)
ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
m
        Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg -> Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
-> [Char] -> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall {a} {c}. Outputable a => Maybe a -> [Char] -> c
needsStrArg Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg [Char]
"_ignoreTestBecause"
  where
    needsStrArg :: Maybe a -> [Char] -> c
needsStrArg Maybe a
mArg [Char]
label =
      [Char] -> c
forall a. [Char] -> a
autocollectError ([Char] -> c) -> ([[[Char]]] -> [Char]) -> [[[Char]]] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines ([[Char]] -> [Char])
-> ([[[Char]]] -> [[Char]]) -> [[[Char]]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Char]]] -> c) -> [[[Char]]] -> c
forall a b. (a -> b) -> a -> b
$
        [ [[Char]
label [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" requires a String argument."]
        , case Maybe a
mArg of
            Maybe a
Nothing -> []
            Just a
arg -> [[Char]
"Got: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Outputable a => a -> [Char]
showPpr a
arg]
        , [[Char]
"At: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SrcSpan -> [Char]
getSpanLine SrcSpan
loc]
        ]

    applyName :: Name -> [LHsExpr GhcPs] -> LHsExpr GhcPs
applyName Name
name = LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkHsApps (Name -> LHsExpr GhcPs
mkHsVar Name
name)

    -- mapAllTests f e = [| map $f $e |]
    mapAllTests :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
mapAllTests GenLocated SrcSpanAnnA (HsExpr GhcPs)
func GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr = Name
-> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
applyName (ExternalNames -> Name
name_map ExternalNames
names) [GenLocated SrcSpanAnnA (HsExpr GhcPs)
func, GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr]

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

type ConvertTestM = State ConvertTestState

data ConvertTestState = ConvertTestState
  { ConvertTestState -> Maybe (LHsSigWcType GhcPs)
mSigType :: Maybe (LHsSigWcType GhcPs)
  , ConvertTestState -> Maybe (HsLocalBinds GhcPs)
mWhereClause :: Maybe (HsLocalBinds GhcPs)
  , ConvertTestState -> [LPat GhcPs]
testArgs :: [LPat GhcPs]
  }

runConvertTestM :: ConvertTestState -> ConvertTestM a -> (a, ConvertTestState)
runConvertTestM :: forall a.
ConvertTestState -> ConvertTestM a -> (a, ConvertTestState)
runConvertTestM = (ConvertTestM a -> ConvertTestState -> (a, ConvertTestState))
-> ConvertTestState -> ConvertTestM a -> (a, ConvertTestState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConvertTestM a -> ConvertTestState -> (a, ConvertTestState)
forall s a. State s a -> s -> (a, s)
State.runState

popArg :: ConvertTestM (Maybe (LPat GhcPs))
popArg :: ConvertTestM (Maybe (LPat GhcPs))
popArg = do
  ConvertTestState
state <- StateT ConvertTestState Identity ConvertTestState
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  let (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg, [GenLocated SrcSpanAnnA (Pat GhcPs)]
rest) =
        case ConvertTestState -> [LPat GhcPs]
testArgs ConvertTestState
state of
          [] -> (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. Maybe a
Nothing, [])
          LPat GhcPs
arg : [LPat GhcPs]
args -> (GenLocated SrcSpanAnnA (Pat GhcPs)
-> Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
forall a. a -> Maybe a
Just LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
arg, [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
args)
  ConvertTestState -> StateT ConvertTestState Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{testArgs = rest}
  Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
-> StateT
     ConvertTestState
     Identity
     (Maybe (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (GenLocated SrcSpanAnnA (Pat GhcPs))
mArg

popRemainingArgs :: ConvertTestM [LPat GhcPs]
popRemainingArgs :: ConvertTestM [LPat GhcPs]
popRemainingArgs = do
  state :: ConvertTestState
state@ConvertTestState{[LPat GhcPs]
testArgs :: ConvertTestState -> [LPat GhcPs]
testArgs :: [LPat GhcPs]
testArgs} <- StateT ConvertTestState Identity ConvertTestState
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  ConvertTestState -> StateT ConvertTestState Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{testArgs = []}
  [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> StateT
     ConvertTestState Identity [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. a -> StateT ConvertTestState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [LPat GhcPs]
[GenLocated SrcSpanAnnA (Pat GhcPs)]
testArgs

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

type ConvertTestModuleM = State ConvertTestModuleState

data ConvertTestModuleState = ConvertTestModuleState
  { ConvertTestModuleState -> Maybe SigInfo
lastSeenSig :: Maybe SigInfo
  , ConvertTestModuleState -> Seq (GenLocated SrcSpanAnnN RdrName)
allTests :: Seq (LocatedN RdrName)
  }

data SigInfo = SigInfo
  { SigInfo -> TestType
testType :: TestType
  -- ^ The type of test represented in this signature
  , SigInfo -> GenLocated SrcSpanAnnN RdrName
testName :: LocatedN RdrName
  -- ^ The generated name for the test
  , SigInfo -> LHsSigWcType GhcPs
signatureType :: LHsSigWcType GhcPs
  -- ^ The type captured in the signature
  }

runConvertTestModuleM :: ConvertTestModuleM a -> (a, [LocatedN RdrName])
runConvertTestModuleM :: forall a.
ConvertTestModuleM a -> (a, [GenLocated SrcSpanAnnN RdrName])
runConvertTestModuleM ConvertTestModuleM a
m =
  (ConvertTestModuleState -> [GenLocated SrcSpanAnnN RdrName])
-> (a, ConvertTestModuleState)
-> (a, [GenLocated SrcSpanAnnN RdrName])
forall a b. (a -> b) -> (a, a) -> (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seq (GenLocated SrcSpanAnnN RdrName)
-> [GenLocated SrcSpanAnnN RdrName]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (GenLocated SrcSpanAnnN RdrName)
 -> [GenLocated SrcSpanAnnN RdrName])
-> (ConvertTestModuleState -> Seq (GenLocated SrcSpanAnnN RdrName))
-> ConvertTestModuleState
-> [GenLocated SrcSpanAnnN RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvertTestModuleState -> Seq (GenLocated SrcSpanAnnN RdrName)
allTests) ((a, ConvertTestModuleState)
 -> (a, [GenLocated SrcSpanAnnN RdrName]))
-> (ConvertTestModuleState -> (a, ConvertTestModuleState))
-> ConvertTestModuleState
-> (a, [GenLocated SrcSpanAnnN RdrName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConvertTestModuleM a
-> ConvertTestModuleState -> (a, ConvertTestModuleState)
forall s a. State s a -> s -> (a, s)
State.runState ConvertTestModuleM a
m (ConvertTestModuleState -> (a, [GenLocated SrcSpanAnnN RdrName]))
-> ConvertTestModuleState -> (a, [GenLocated SrcSpanAnnN RdrName])
forall a b. (a -> b) -> a -> b
$
    ConvertTestModuleState
      { lastSeenSig :: Maybe SigInfo
lastSeenSig = Maybe SigInfo
forall a. Maybe a
Nothing
      , allTests :: Seq (GenLocated SrcSpanAnnN RdrName)
allTests = Seq (GenLocated SrcSpanAnnN RdrName)
forall a. Seq a
Seq.Empty
      }

getLastSeenSig :: ConvertTestModuleM (Maybe SigInfo)
getLastSeenSig :: ConvertTestModuleM (Maybe SigInfo)
getLastSeenSig = do
  state :: ConvertTestModuleState
state@ConvertTestModuleState{Maybe SigInfo
lastSeenSig :: ConvertTestModuleState -> Maybe SigInfo
lastSeenSig :: Maybe SigInfo
lastSeenSig} <- StateT ConvertTestModuleState Identity ConvertTestModuleState
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  ConvertTestModuleState -> ConvertTestModuleM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestModuleState
state{lastSeenSig = Nothing}
  Maybe SigInfo -> ConvertTestModuleM (Maybe SigInfo)
forall a. a -> StateT ConvertTestModuleState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SigInfo
lastSeenSig

setLastSeenSig :: SigInfo -> ConvertTestModuleM ()
setLastSeenSig :: SigInfo -> ConvertTestModuleM ()
setLastSeenSig SigInfo
info = (ConvertTestModuleState -> ConvertTestModuleState)
-> ConvertTestModuleM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' ((ConvertTestModuleState -> ConvertTestModuleState)
 -> ConvertTestModuleM ())
-> (ConvertTestModuleState -> ConvertTestModuleState)
-> ConvertTestModuleM ()
forall a b. (a -> b) -> a -> b
$ \ConvertTestModuleState
state -> ConvertTestModuleState
state{lastSeenSig = Just info}

getNextTestName :: ConvertTestModuleM (LocatedN RdrName)
getNextTestName :: ConvertTestModuleM (GenLocated SrcSpanAnnN RdrName)
getNextTestName = do
  state :: ConvertTestModuleState
state@ConvertTestModuleState{Seq (GenLocated SrcSpanAnnN RdrName)
allTests :: ConvertTestModuleState -> Seq (GenLocated SrcSpanAnnN RdrName)
allTests :: Seq (GenLocated SrcSpanAnnN RdrName)
allTests} <- StateT ConvertTestModuleState Identity ConvertTestModuleState
forall (m :: * -> *) s. Monad m => StateT s m s
State.get
  let nextTestName :: GenLocated SrcSpanAnnN RdrName
nextTestName = [Char] -> GenLocated SrcSpanAnnN RdrName
mkLRdrName ([Char] -> GenLocated SrcSpanAnnN RdrName)
-> [Char] -> GenLocated SrcSpanAnnN RdrName
forall a b. (a -> b) -> a -> b
$ Int -> [Char]
testIdentifier (Seq (GenLocated SrcSpanAnnN RdrName) -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq (GenLocated SrcSpanAnnN RdrName)
allTests)
  ConvertTestModuleState -> ConvertTestModuleM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestModuleState
state{allTests = allTests Seq.|> nextTestName}
  GenLocated SrcSpanAnnN RdrName
-> ConvertTestModuleM (GenLocated SrcSpanAnnN RdrName)
forall a. a -> StateT ConvertTestModuleState Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpanAnnN RdrName
nextTestName

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

concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
concatMapM :: forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM a -> m [b]
f = ([[b]] -> [b]) -> m [[b]] -> m [b]
forall a b. (a -> b) -> m a -> 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m [b]
f