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

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

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

import Test.Tasty.AutoCollect.Constants
import Test.Tasty.AutoCollect.Error
import Test.Tasty.AutoCollect.ExternalNames
import Test.Tasty.AutoCollect.GHC

-- | The plugin to convert a test file. Injected by the preprocessor.
plugin :: Plugin
plugin :: Plugin
plugin =
  Plugin -> Plugin
setKeepRawTokenStream
    Plugin
defaultPlugin
      { pluginRecompile :: [[Char]] -> IO PluginRecompile
pluginRecompile = [[Char]] -> IO PluginRecompile
purePlugin
      , parsedResultAction :: [[Char]] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = \[[Char]]
_ ModSummary
_ HsParsedModule
result -> do
          HscEnv
env <- Hsc HscEnv
getHscEnv
          ExternalNames
names <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalNames
loadExternalNames HscEnv
env
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ HsParsedModule
-> (HsParsedModule -> HsParsedModule) -> HsParsedModule
withParsedResultModule HsParsedModule
result (ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule ExternalNames
names)
      }

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

    -- 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 <- forall l e a.
Ord l =>
(GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a
firstLocatedWhere forall {a}. GenLocated a [Char] -> Maybe a
getTestExportAnnSrcSpan (HsParsedModule -> LocatedL [LIE GhcPs] -> [RealLocated [Char]]
getExportComments HsParsedModule
parsedModl GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports) =
          (forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> SrcSpanAnnA
toSrcAnnA RealSrcSpan
exportSpan) IE GhcPs
exportIE forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports
      | Bool
otherwise =
          GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
lexports
    getTestExportAnnSrcSpan :: GenLocated a [Char] -> Maybe a
getTestExportAnnSrcSpan (L a
loc [Char]
comment) =
      if [Char] -> Bool
isTestExportComment [Char]
comment
        then forall a. a -> Maybe a
Just a
loc
        else forall a. Maybe a
Nothing
    exportIE :: IE GhcPs
exportIE = forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar NoExtField
NoExtField forall a b. (a -> b) -> a -> b
$ forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> IEWrappedName RdrName
mkIEName GenLocated SrcSpanAnnN RdrName
testListName

    -- 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 = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ [LHsExpr GhcPs] -> HsExpr GhcPs
mkExplicitList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnN RdrName -> LHsExpr GhcPs
lhsvar [GenLocated SrcSpanAnnN RdrName]
testNames
       in [ forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig GenLocated SrcSpanAnnN RdrName
testListName forall a b. (a -> b) -> a -> b
$ ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names
          , forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnN RdrName
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl GenLocated SrcSpanAnnN RdrName
testListName [] (GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
flattenTestList forall {ann}. GenLocated (SrcAnn ann) (HsExpr GhcPs)
testsList) forall a. Maybe a
Nothing
          ]

    flattenTestList :: GenLocated SrcSpanAnnA (HsExpr GhcPs) -> LHsExpr GhcPs
flattenTestList GenLocated SrcSpanAnnA (HsExpr GhcPs)
testsList =
      forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (Name -> LHsExpr GhcPs
mkHsVar forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_concat ExternalNames
names) forall a b. (a -> b) -> a -> b
$
        LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
mkExprTypeSig GenLocated SrcSpanAnnA (HsExpr GhcPs)
testsList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$
          forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy forall a. EpAnn a
noAnn (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names)

-- | 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
              }
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ExternalNames -> TestType -> LHsSigWcType GhcPs -> Bool
isValidForTestType ExternalNames
names TestType
testType LHsSigWcType GhcPs
ty) forall a b. (a -> b) -> a -> b
$
            forall a. [Char] -> a
autocollectError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
              [ [Char]
"Expected type: " forall a. [a] -> [a] -> [a]
++ TestType -> [Char]
typeForTestType TestType
testType
              , [Char]
"Got: " forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> [Char]
showPpr LHsSigWcType GhcPs
ty
              ]
          forall (f :: * -> *) a. Applicative f => a -> f a
pure [GenLocated SrcSpanAnnN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig GenLocated SrcSpanAnnN RdrName
testName (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
ldecl]
    Just (FuncDef GenLocated SrcSpanAnnN RdrName
funcName [LocatedA FuncSingleDef]
funcDefs)
      | Just TestType
testType <- [Char] -> Maybe TestType
parseTestType (GenLocated SrcSpanAnnN RdrName -> [Char]
fromRdrName GenLocated SrcSpanAnnN RdrName
funcName) -> do
          Maybe SigInfo
mSigInfo <- ConvertTestModuleM (Maybe SigInfo)
getLastSeenSig
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM (forall {a} {e} {l}.
GenLocated (SrcSpanAnn' a) e
-> TestType
-> Maybe SigInfo
-> GenLocated l FuncSingleDef
-> StateT
     ConvertTestModuleState
     Identity
     [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
convertSingleTest GenLocated SrcSpanAnnN RdrName
funcName TestType
testType) (Maybe SigInfo
mSigInfo forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat forall a. Maybe a
Nothing) [LocatedA FuncSingleDef]
funcDefs
    -- anything else leave unmodified
    Maybe ParsedDecl
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [LHsDecl GhcPs
ldecl]
  where
    loc :: SrcSpan
loc = forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LHsDecl GhcPs
ldecl

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

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

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

    convertSingleTestBody :: TestType
-> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> ConvertTestM (GenLocated SrcSpanAnnA (HsExpr GhcPs))
convertSingleTestBody TestType
testType GenLocated SrcSpanAnnA (HsExpr GhcPs)
body =
      case TestType
testType of
        TestType
TestNormal ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {ann}.
GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr GenLocated SrcSpanAnnA (HsExpr GhcPs)
body
        TestType
TestProp -> do
          -- 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 :: Maybe (LHsSigWcType GhcPs)
mSigType :: ConvertTestState -> Maybe (LHsSigWcType GhcPs)
mSigType, Maybe (HsLocalBinds GhcPs)
mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause :: ConvertTestState -> Maybe (HsLocalBinds GhcPs)
mWhereClause} <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
          forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put ConvertTestState
state{mSigType :: Maybe (LHsSigWcType GhcPs)
mSigType = forall a. Maybe a
Nothing, mWhereClause :: Maybe (HsLocalBinds GhcPs)
mWhereClause = forall a. Maybe a
Nothing}

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

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

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

    singleExpr :: GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> GenLocated (SrcAnn ann) (HsExpr GhcPs)
singleExpr = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LHsExpr GhcPs] -> HsExpr GhcPs
mkExplicitList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: [])

-- | 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 = forall e ann. e -> GenLocated (SrcAnn ann) e
genLoc forall a b. (a -> b) -> a -> b
$ forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy forall a. EpAnn a
noAnn forall a b. (a -> b) -> a -> b
$ Name -> LHsType GhcPs
mkHsTyVar (ExternalNames -> Name
name_TestTree ExternalNames
names)

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

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

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

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

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

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

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

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

isTypeVarNamed :: Name -> ParsedType -> Bool
isTypeVarNamed :: Name -> ParsedType -> Bool
isTypeVarNamed Name
name = \case
  TypeVar PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
n) -> RdrName -> OccName
rdrNameOcc RdrName
n forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc (forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
name)
  ParsedType
_ -> Bool
False

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

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

    -- mapAllTests 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> (a, s)
State.runState

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

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

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

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

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

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

{----- 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m [b]
f