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

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

import Control.Monad.Trans.State.Strict (State)
import qualified Control.Monad.Trans.State.Strict as State
import Data.Foldable (toList)
import Data.List (intercalate, stripPrefix)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq

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

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

{- |
Transforms a test module of the form

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

test_<tester> :: <type>
test_<tester> <name> <other args> = <test>
@

to the equivalent of

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

tests :: [TestTree]
tests = [test1]

test1 :: TestTree
test1 = <tester> <name> <other args> (<test> :: <type>)
@
-}
transformTestModule :: ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule :: ExternalNames -> HsParsedModule -> HsParsedModule
transformTestModule ExternalNames
names HsParsedModule
parsedModl = HsParsedModule
parsedModl{hpm_module :: Located (HsModule GhcPs)
hpm_module = HsModule GhcPs -> HsModule GhcPs
updateModule (HsModule GhcPs -> HsModule GhcPs)
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsParsedModule -> Located (HsModule GhcPs)
hpm_module HsParsedModule
parsedModl}
  where
    updateModule :: HsModule GhcPs -> HsModule GhcPs
updateModule HsModule GhcPs
modl =
      let ([LHsDecl GhcPs]
decls, [LocatedN RdrName]
testNames) = ConvertTestM [LHsDecl GhcPs]
-> ([LHsDecl GhcPs], [LocatedN RdrName])
forall a. ConvertTestM a -> (a, [LocatedN RdrName])
runConvertTestM (ConvertTestM [LHsDecl GhcPs]
 -> ([LHsDecl GhcPs], [LocatedN RdrName]))
-> ConvertTestM [LHsDecl GhcPs]
-> ([LHsDecl GhcPs], [LocatedN RdrName])
forall a b. (a -> b) -> a -> b
$ (LHsDecl GhcPs -> StateT ConvertTestState Identity (LHsDecl GhcPs))
-> [LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExternalNames
-> LHsDecl GhcPs
-> StateT ConvertTestState Identity (LHsDecl GhcPs)
convertTest ExternalNames
names) ([LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs])
-> [LHsDecl GhcPs] -> ConvertTestM [LHsDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule GhcPs
modl
       in HsModule GhcPs
modl
            { hsmodExports :: Maybe (Located [LIE GhcPs])
hsmodExports = Located [LIE GhcPs] -> Located [LIE GhcPs]
updateExports (Located [LIE GhcPs] -> Located [LIE GhcPs])
-> Maybe (Located [LIE GhcPs]) -> Maybe (Located [LIE GhcPs])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HsModule GhcPs -> Maybe (Located [LIE GhcPs])
forall pass. HsModule pass -> Maybe (Located [LIE pass])
hsmodExports HsModule GhcPs
modl
            , hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = [LocatedN RdrName] -> [LHsDecl GhcPs]
mkTestsList [LocatedN RdrName]
testNames [LHsDecl GhcPs] -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall a. [a] -> [a] -> [a]
++ [LHsDecl GhcPs]
decls
            }

    -- Replace "{- AUTOCOLLECT.TEST.export -}" with `tests` in the export list
    updateExports :: Located [LIE GhcPs] -> Located [LIE GhcPs]
updateExports Located [LIE GhcPs]
lexports
      | Just RealSrcSpan
exportSpan <- (GenLocated RealSrcSpan CommandLineOption -> Maybe RealSrcSpan)
-> [GenLocated RealSrcSpan CommandLineOption] -> Maybe RealSrcSpan
forall l e a.
Ord l =>
(GenLocated l e -> Maybe a) -> [GenLocated l e] -> Maybe a
firstLocatedWhere GenLocated RealSrcSpan CommandLineOption -> Maybe RealSrcSpan
forall a. GenLocated a CommandLineOption -> Maybe a
getTestExportAnnSrcSpan (HsParsedModule
-> Located [LIE GhcPs]
-> [GenLocated RealSrcSpan CommandLineOption]
getExportComments HsParsedModule
parsedModl Located [LIE GhcPs]
lexports) =
          (SrcSpan -> IE GhcPs -> LIE GhcPs
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> SrcSpan
toSrcAnnA RealSrcSpan
exportSpan) IE GhcPs
exportIE LIE GhcPs -> [LIE GhcPs] -> [LIE GhcPs]
forall a. a -> [a] -> [a]
:) ([LIE GhcPs] -> [LIE GhcPs])
-> Located [LIE GhcPs] -> Located [LIE GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Located [LIE GhcPs]
lexports
      | Bool
otherwise =
          Located [LIE GhcPs]
lexports
    getTestExportAnnSrcSpan :: GenLocated a CommandLineOption -> Maybe a
getTestExportAnnSrcSpan (L a
loc CommandLineOption
comment) =
      if CommandLineOption -> Bool
isTestExportComment CommandLineOption
comment
        then a -> Maybe a
forall a. a -> Maybe a
Just a
loc
        else Maybe a
forall a. Maybe a
Nothing
    exportIE :: IE GhcPs
exportIE = XIEVar GhcPs -> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall pass. XIEVar pass -> LIEWrappedName (IdP pass) -> IE pass
IEVar NoExtField
XIEVar GhcPs
NoExtField (LIEWrappedName (IdP GhcPs) -> IE GhcPs)
-> LIEWrappedName (IdP GhcPs) -> IE GhcPs
forall a b. (a -> b) -> a -> b
$ IEWrappedName RdrName -> GenLocated SrcSpan (IEWrappedName RdrName)
forall e ann. e -> GenLocated SrcSpan e
genLoc (IEWrappedName RdrName
 -> GenLocated SrcSpan (IEWrappedName RdrName))
-> IEWrappedName RdrName
-> GenLocated SrcSpan (IEWrappedName RdrName)
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> IEWrappedName RdrName
forall name. Located name -> IEWrappedName name
IEName LocatedN RdrName
testListName

    -- Generate the `tests` list
    mkTestsList :: [LocatedN RdrName] -> [LHsDecl GhcPs]
    mkTestsList :: [LocatedN RdrName] -> [LHsDecl GhcPs]
mkTestsList [LocatedN RdrName]
testNames =
      let testsList :: GenLocated SrcSpan (HsExpr GhcPs)
testsList = HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs
mkExplicitList ([GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs))
-> [LocatedN RdrName] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar [LocatedN RdrName]
testNames
       in [ HsDecl GhcPs -> LHsDecl GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig LocatedN RdrName
testListName (LHsType GhcPs -> HsDecl GhcPs) -> LHsType GhcPs -> HsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names
          , HsDecl GhcPs -> LHsDecl GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ LocatedN RdrName
-> [LPat GhcPs]
-> GenLocated SrcSpan (HsExpr GhcPs)
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl LocatedN RdrName
testListName [] (GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
flattenTestList GenLocated SrcSpan (HsExpr GhcPs)
forall ann. GenLocated SrcSpan (HsExpr GhcPs)
testsList) Maybe (HsLocalBinds GhcPs)
forall a. Maybe a
Nothing
          ]

    flattenTestList :: GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
flattenTestList GenLocated SrcSpan (HsExpr GhcPs)
testsList =
      GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs))
-> LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> LocatedN RdrName
mkLRdrName CommandLineOption
"concat") (GenLocated SrcSpan (HsExpr GhcPs)
 -> GenLocated SrcSpan (HsExpr GhcPs))
-> GenLocated SrcSpan (HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
        HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> (HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> HsExpr GhcPs)
-> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XExprWithTySig GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs)
-> LHsSigWcType (NoGhcTc GhcPs)
-> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcPs
noAnn GenLocated SrcSpan (HsExpr GhcPs)
testsList (HsWildCardBndrs GhcPs (LHsSigType GhcPs)
 -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
          XHsWC GhcPs (LHsSigType GhcPs)
-> LHsSigType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC NoExtField
XHsWC GhcPs (LHsSigType GhcPs)
NoExtField (LHsSigType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType GhcPs))
-> (HsType GhcPs -> LHsSigType GhcPs)
-> HsType GhcPs
-> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> LHsSigType GhcPs
hsTypeToHsSigType (LHsType GhcPs -> LHsSigType GhcPs)
-> (HsType GhcPs -> LHsType GhcPs)
-> HsType GhcPs
-> LHsSigType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> LHsType GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType GhcPs))
-> HsType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$
            XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExtField
XListTy GhcPs
noAnn (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names)

{- |
If the given declaration is a test, return the converted test, or otherwise
return it unmodified
-}
convertTest :: ExternalNames -> LHsDecl GhcPs -> ConvertTestM (LHsDecl GhcPs)
convertTest :: ExternalNames
-> LHsDecl GhcPs
-> StateT ConvertTestState Identity (LHsDecl GhcPs)
convertTest ExternalNames
names LHsDecl GhcPs
loc =
  case LHsDecl GhcPs -> Maybe ParsedDecl
parseDecl LHsDecl GhcPs
loc of
    -- e.g. test_testCase :: Assertion
    -- =>   test1 :: [TestTree]
    Just (FuncSig [LocatedN RdrName
funcName] HsWildCardBndrs GhcPs (LHsSigType GhcPs)
ty)
      | Just TestType
testType <- LocatedN RdrName -> Maybe TestType
parseTestType LocatedN RdrName
funcName -> do
          LocatedN RdrName
testName <- ConvertTestM (LocatedN RdrName)
getNextTestName
          SigInfo -> ConvertTestM ()
setLastSeenSig
            SigInfo :: TestType
-> LocatedN RdrName
-> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
-> SigInfo
SigInfo
              { TestType
testType :: TestType
testType :: TestType
testType
              , LocatedN RdrName
testName :: LocatedN RdrName
testName :: LocatedN RdrName
testName
              , testHsType :: HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testHsType = HsWildCardBndrs GhcPs (LHsSigType GhcPs)
ty
              }
          LHsDecl GhcPs -> StateT ConvertTestState Identity (LHsDecl GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocatedN RdrName -> LHsType GhcPs -> HsDecl GhcPs
genFuncSig LocatedN RdrName
testName (ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names) HsDecl GhcPs -> LHsDecl GhcPs -> LHsDecl GhcPs
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
loc)
    -- e.g. test_testCase "test name" = <body>
    -- =>   test1 = [testCase "test name" (<body> :: Assertion)]
    Just (FuncDef LocatedN RdrName
funcName [LocatedA FuncSingleDef]
funcDefs)
      | Just TestType
testType <- LocatedN RdrName -> Maybe TestType
parseTestType LocatedN RdrName
funcName -> do
          (LocatedN RdrName
testName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)
funcBodyType) <-
            ConvertTestM (Maybe SigInfo)
getLastSeenSig ConvertTestM (Maybe SigInfo)
-> (Maybe SigInfo
    -> StateT
         ConvertTestState
         Identity
         (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)))
-> StateT
     ConvertTestState
     Identity
     (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe SigInfo
Nothing -> CommandLineOption
-> StateT
     ConvertTestState
     Identity
     (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
 -> StateT
      ConvertTestState
      Identity
      (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)))
-> CommandLineOption
-> StateT
     ConvertTestState
     Identity
     (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"Found test without type signature at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LocatedN RdrName -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LocatedN RdrName
funcName
              Just SigInfo{testType :: SigInfo -> TestType
testType = TestType
testTypeFromSig, HsWildCardBndrs GhcPs (LHsSigType GhcPs)
LocatedN RdrName
testHsType :: HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testName :: LocatedN RdrName
testHsType :: SigInfo -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testName :: SigInfo -> LocatedN RdrName
..}
                | TestType
testType TestType -> TestType -> Bool
forall a. Eq a => a -> a -> Bool
== TestType
testTypeFromSig -> (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
-> StateT
     ConvertTestState
     Identity
     (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocatedN RdrName
testName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testHsType)
                | Bool
otherwise -> CommandLineOption
-> StateT
     ConvertTestState
     Identity
     (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
 -> StateT
      ConvertTestState
      Identity
      (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs)))
-> CommandLineOption
-> StateT
     ConvertTestState
     Identity
     (LocatedN RdrName, HsWildCardBndrs GhcPs (LHsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"Found test with different type of signature: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ (TestType, TestType) -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show (TestType
testType, TestType
testTypeFromSig)

          FuncSingleDef{[LPat GhcPs]
[FuncGuardedBody]
HsLocalBinds GhcPs
funcDefWhereClause :: FuncSingleDef -> HsLocalBinds GhcPs
funcDefGuards :: FuncSingleDef -> [FuncGuardedBody]
funcDefArgs :: FuncSingleDef -> [LPat GhcPs]
funcDefWhereClause :: HsLocalBinds GhcPs
funcDefGuards :: [FuncGuardedBody]
funcDefArgs :: [LPat GhcPs]
..} <-
            case [LocatedA FuncSingleDef]
funcDefs of
              [] -> CommandLineOption -> StateT ConvertTestState Identity FuncSingleDef
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
 -> StateT ConvertTestState Identity FuncSingleDef)
-> CommandLineOption
-> StateT ConvertTestState Identity FuncSingleDef
forall a b. (a -> b) -> a -> b
$ CommandLineOption
"Test unexpectedly had no bindings at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LocatedN RdrName -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LocatedN RdrName
funcName
              [LocatedA FuncSingleDef
funcDef] -> FuncSingleDef -> StateT ConvertTestState Identity FuncSingleDef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FuncSingleDef -> StateT ConvertTestState Identity FuncSingleDef)
-> FuncSingleDef -> StateT ConvertTestState Identity FuncSingleDef
forall a b. (a -> b) -> a -> b
$ LocatedA FuncSingleDef -> FuncSingleDef
forall l e. GenLocated l e -> e
unLoc LocatedA FuncSingleDef
funcDef
              [LocatedA FuncSingleDef]
_ ->
                CommandLineOption -> StateT ConvertTestState Identity FuncSingleDef
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
 -> StateT ConvertTestState Identity FuncSingleDef)
-> ([CommandLineOption] -> CommandLineOption)
-> [CommandLineOption]
-> StateT ConvertTestState Identity FuncSingleDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> CommandLineOption
unlines ([CommandLineOption]
 -> StateT ConvertTestState Identity FuncSingleDef)
-> [CommandLineOption]
-> StateT ConvertTestState Identity FuncSingleDef
forall a b. (a -> b) -> a -> b
$
                  [ CommandLineOption
"Found multiple tests named " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LocatedN RdrName -> CommandLineOption
fromRdrName LocatedN RdrName
funcName CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
" at: " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption -> [CommandLineOption] -> CommandLineOption
forall a. [a] -> [[a]] -> [a]
intercalate CommandLineOption
", " ((LocatedA FuncSingleDef -> CommandLineOption)
-> [LocatedA FuncSingleDef] -> [CommandLineOption]
forall a b. (a -> b) -> [a] -> [b]
map LocatedA FuncSingleDef -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine [LocatedA FuncSingleDef]
funcDefs)
                  , CommandLineOption
"Did you forget to add a type annotation for a test?"
                  ]

          GenLocated SrcSpan (HsExpr GhcPs)
funcBody <-
            case [FuncGuardedBody]
funcDefGuards of
              [FuncGuardedBody [] GenLocated SrcSpan (HsExpr GhcPs)
body] -> GenLocated SrcSpan (HsExpr GhcPs)
-> StateT
     ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenLocated SrcSpan (HsExpr GhcPs)
body
              [FuncGuardedBody]
_ ->
                CommandLineOption
-> StateT
     ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall a. CommandLineOption -> a
autocollectError (CommandLineOption
 -> StateT
      ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> ([CommandLineOption] -> CommandLineOption)
-> [CommandLineOption]
-> StateT
     ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> CommandLineOption
unlines ([CommandLineOption]
 -> StateT
      ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs)))
-> [CommandLineOption]
-> StateT
     ConvertTestState Identity (GenLocated SrcSpan (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
                  [ CommandLineOption
"Test should have no guards."
                  , CommandLineOption
"Found guards at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ LocatedN RdrName -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LocatedN RdrName
funcName
                  ]

          -- tester (...funcArgs) (funcBody :: funcBodyType)
          let funcBodyWithType :: GenLocated SrcSpan (HsExpr GhcPs)
funcBodyWithType = HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExprWithTySig GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs)
-> LHsSigWcType (NoGhcTc GhcPs)
-> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcPs
noAnn GenLocated SrcSpan (HsExpr GhcPs)
funcBody HsWildCardBndrs GhcPs (LHsSigType GhcPs)
LHsSigWcType (NoGhcTc GhcPs)
funcBodyType
              testBody :: GenLocated SrcSpan (HsExpr GhcPs)
testBody =
                case TestType
testType of
                  TestSingle Tester
tester ->
                    HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> ([GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs
mkExplicitList ([GenLocated SrcSpan (HsExpr GhcPs)]
 -> GenLocated SrcSpan (HsExpr GhcPs))
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                      [ GenLocated SrcSpan (HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
mkHsApps (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs))
-> LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ RdrName -> LocatedN RdrName
forall e ann. e -> GenLocated SrcSpan e
genLoc (RdrName -> LocatedN RdrName) -> RdrName -> LocatedN RdrName
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Tester -> RdrName
fromTester ExternalNames
names Tester
tester) ([GenLocated SrcSpan (HsExpr GhcPs)]
 -> GenLocated SrcSpan (HsExpr GhcPs))
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                          (Located (Pat GhcPs) -> GenLocated SrcSpan (HsExpr GhcPs))
-> [Located (Pat GhcPs)] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map LPat GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
Located (Pat GhcPs) -> GenLocated SrcSpan (HsExpr GhcPs)
patternToExpr [LPat GhcPs]
[Located (Pat GhcPs)]
funcDefArgs [GenLocated SrcSpan (HsExpr GhcPs)]
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [GenLocated SrcSpan (HsExpr GhcPs)
forall ann. GenLocated SrcSpan (HsExpr GhcPs)
funcBodyWithType]
                      ]
                  TestType
TestBatch
                    | Bool -> Bool
not ([Located (Pat GhcPs)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LPat GhcPs]
[Located (Pat GhcPs)]
funcDefArgs) -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
autocollectError CommandLineOption
"test_batch should not be used with arguments"
                    | Bool -> Bool
not (ExternalNames -> HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> Bool
isListOfTestTree ExternalNames
names HsWildCardBndrs GhcPs (LHsSigType GhcPs)
funcBodyType) -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
autocollectError CommandLineOption
"test_batch needs to be set to a [TestTree]"
                    | Bool
otherwise -> GenLocated SrcSpan (HsExpr GhcPs)
forall ann. GenLocated SrcSpan (HsExpr GhcPs)
funcBodyWithType

          LHsDecl GhcPs -> StateT ConvertTestState Identity (LHsDecl GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocatedN RdrName
-> [LPat GhcPs]
-> GenLocated SrcSpan (HsExpr GhcPs)
-> Maybe (HsLocalBinds GhcPs)
-> HsDecl GhcPs
genFuncDecl LocatedN RdrName
testName [] GenLocated SrcSpan (HsExpr GhcPs)
forall ann. GenLocated SrcSpan (HsExpr GhcPs)
testBody (HsLocalBinds GhcPs -> Maybe (HsLocalBinds GhcPs)
forall a. a -> Maybe a
Just HsLocalBinds GhcPs
funcDefWhereClause) HsDecl GhcPs -> LHsDecl GhcPs -> LHsDecl GhcPs
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ LHsDecl GhcPs
loc)
    -- anything else leave unmodified
    Maybe ParsedDecl
_ -> LHsDecl GhcPs -> StateT ConvertTestState Identity (LHsDecl GhcPs)
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsDecl GhcPs
loc

{- |
Convert the given pattern to the expression that it would represent
if it were in an expression context.
-}
patternToExpr :: LPat GhcPs -> LHsExpr GhcPs
patternToExpr :: LPat GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
patternToExpr LPat GhcPs
lpat = ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go (LPat GhcPs -> ParsedPat
parsePat LPat GhcPs
lpat)
  where
    unsupported :: CommandLineOption -> a
unsupported CommandLineOption
label = CommandLineOption -> a
forall a. CommandLineOption -> a
autocollectError (CommandLineOption -> a) -> CommandLineOption -> a
forall a b. (a -> b) -> a -> b
$ CommandLineOption
label CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ CommandLineOption
" unsupported as test argument at " CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ Located (Pat GhcPs) -> CommandLineOption
forall a e. GenLocated SrcSpan e -> CommandLineOption
getSpanLine LPat GhcPs
Located (Pat GhcPs)
lpat
    go :: ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go = \case
      ParsedPat
PatWildCard -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"wildcard patterns"
      PatVar LocatedN RdrName
name -> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XVar GhcPs -> Located (IdP GhcPs) -> HsExpr GhcPs
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcPs
NoExtField Located (IdP GhcPs)
LocatedN RdrName
name
      ParsedPat
PatLazy -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"lazy patterns"
      ParsedPat
PatAs -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"as patterns"
      PatParens ParsedPat
p -> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XPar GhcPs -> GenLocated SrcSpan (HsExpr GhcPs) -> HsExpr GhcPs
forall p. XPar p -> LHsExpr p -> HsExpr p
HsPar NoExtField
XPar GhcPs
noAnn (GenLocated SrcSpan (HsExpr GhcPs) -> HsExpr GhcPs)
-> GenLocated SrcSpan (HsExpr GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go ParsedPat
p
      ParsedPat
PatBang -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"bang patterns"
      PatList [ParsedPat]
ps -> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs
mkExplicitList ([GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)] -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> [ParsedPat] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go [ParsedPat]
ps
      PatTuple [ParsedPat]
ps Boxity
boxity -> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsTupArg GhcPs] -> Boxity -> HsExpr GhcPs
mkExplicitTuple ((ParsedPat -> HsTupArg GhcPs) -> [ParsedPat] -> [HsTupArg GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (XPresent GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs) -> HsTupArg GhcPs
forall id. XPresent id -> LHsExpr id -> HsTupArg id
Present NoExtField
XPresent GhcPs
noAnn (GenLocated SrcSpan (HsExpr GhcPs) -> HsTupArg GhcPs)
-> (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> ParsedPat
-> HsTupArg GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go) [ParsedPat]
ps) Boxity
boxity
      ParsedPat
PatSum -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"anonymous sum patterns"
      PatConstructor LocatedN RdrName
name ConstructorDetails
details ->
        case ConstructorDetails
details of
          ConstructorPrefix [LHsType GhcPs]
tys [ParsedPat]
args -> LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar LocatedN RdrName
name GenLocated SrcSpan (HsExpr GhcPs)
-> [LHsType GhcPs] -> GenLocated SrcSpan (HsExpr GhcPs)
`mkHsAppTypes` [LHsType GhcPs]
tys GenLocated SrcSpan (HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
`mkHsApps` (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> [ParsedPat] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go [ParsedPat]
args
          ConstructorRecord HsRecFields{[LHsRecField GhcPs ParsedPat]
Maybe (Located Int)
rec_flds :: forall p arg. HsRecFields p arg -> [LHsRecField p arg]
rec_dotdot :: forall p arg. HsRecFields p arg -> Maybe (Located Int)
rec_dotdot :: Maybe (Located Int)
rec_flds :: [LHsRecField GhcPs ParsedPat]
..} ->
            HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> (HsRecordBinds GhcPs -> HsExpr GhcPs)
-> HsRecordBinds GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRecordCon GhcPs
-> Located (IdP GhcPs) -> HsRecordBinds GhcPs -> HsExpr GhcPs
forall p.
XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p
RecordCon NoExtField
XRecordCon GhcPs
noAnn Located (IdP GhcPs)
LocatedN RdrName
name (HsRecordBinds GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsRecordBinds GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
              HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields
                { rec_flds :: [LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))]
rec_flds = ((LHsRecField GhcPs ParsedPat
 -> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs)))
-> [LHsRecField GhcPs ParsedPat]
-> [LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LHsRecField GhcPs ParsedPat
  -> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs)))
 -> [LHsRecField GhcPs ParsedPat]
 -> [LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))])
-> ((ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
    -> LHsRecField GhcPs ParsedPat
    -> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs)))
-> (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> [LHsRecField GhcPs ParsedPat]
-> [LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsRecField' (FieldOcc GhcPs) ParsedPat
 -> HsRecField'
      (FieldOcc GhcPs) (GenLocated SrcSpan (HsExpr GhcPs)))
-> LHsRecField GhcPs ParsedPat
-> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HsRecField' (FieldOcc GhcPs) ParsedPat
  -> HsRecField'
       (FieldOcc GhcPs) (GenLocated SrcSpan (HsExpr GhcPs)))
 -> LHsRecField GhcPs ParsedPat
 -> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs)))
-> ((ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
    -> HsRecField' (FieldOcc GhcPs) ParsedPat
    -> HsRecField'
         (FieldOcc GhcPs) (GenLocated SrcSpan (HsExpr GhcPs)))
-> (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> LHsRecField GhcPs ParsedPat
-> LHsRecField GhcPs (GenLocated SrcSpan (HsExpr GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsRecField' (FieldOcc GhcPs) ParsedPat
-> HsRecField' (FieldOcc GhcPs) (GenLocated SrcSpan (HsExpr GhcPs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go [LHsRecField GhcPs ParsedPat]
rec_flds
                , Maybe (Located Int)
rec_dotdot :: Maybe (Located Int)
rec_dotdot :: Maybe (Located Int)
..
                }
          ConstructorInfix ParsedPat
l ParsedPat
r -> GenLocated SrcSpan (HsExpr GhcPs)
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
mkHsApps (LocatedN RdrName -> GenLocated SrcSpan (HsExpr GhcPs)
lhsvar LocatedN RdrName
name) ([GenLocated SrcSpan (HsExpr GhcPs)]
 -> GenLocated SrcSpan (HsExpr GhcPs))
-> [GenLocated SrcSpan (HsExpr GhcPs)]
-> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs))
-> [ParsedPat] -> [GenLocated SrcSpan (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go [ParsedPat
l, ParsedPat
r]
      ParsedPat
PatView -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"view patterns"
      PatSplice HsSplice GhcPs
splice -> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XSpliceE GhcPs -> HsSplice GhcPs -> HsExpr GhcPs
forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE NoExtField
XSpliceE GhcPs
noAnn HsSplice GhcPs
splice
      PatLiteral HsLit GhcPs
lit -> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit NoExtField
XLitE GhcPs
noAnn HsLit GhcPs
lit
      PatOverloadedLit Located (HsOverLit GhcPs)
lit -> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XOverLitE GhcPs -> HsOverLit GhcPs -> HsExpr GhcPs
forall p. XOverLitE p -> HsOverLit p -> HsExpr p
HsOverLit NoExtField
XOverLitE GhcPs
noAnn (Located (HsOverLit GhcPs) -> HsOverLit GhcPs
forall l e. GenLocated l e -> e
unLoc Located (HsOverLit GhcPs)
lit)
      ParsedPat
PatNPlusK -> CommandLineOption -> GenLocated SrcSpan (HsExpr GhcPs)
forall a. CommandLineOption -> a
unsupported CommandLineOption
"n+k patterns"
      PatTypeSig ParsedPat
p LHsType GhcPs
ty -> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs))
-> HsExpr GhcPs -> GenLocated SrcSpan (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ XExprWithTySig GhcPs
-> GenLocated SrcSpan (HsExpr GhcPs)
-> LHsSigWcType (NoGhcTc GhcPs)
-> HsExpr GhcPs
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig GhcPs
noAnn (ParsedPat -> GenLocated SrcSpan (HsExpr GhcPs)
go ParsedPat
p) (LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs)
-> LHsSigWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
hsTypeToHsSigWcType (HsType GhcPs -> LHsType GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (LHsType GhcPs -> HsType GhcPs
forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
ty))

-- | Identifier for the generated `tests` list.
testListName :: LocatedN RdrName
testListName :: LocatedN RdrName
testListName = CommandLineOption -> LocatedN RdrName
mkLRdrName CommandLineOption
testListIdentifier

data TestType
  = TestSingle Tester
  | TestBatch
  deriving (Int -> TestType -> CommandLineOption -> CommandLineOption
[TestType] -> CommandLineOption -> CommandLineOption
TestType -> CommandLineOption
(Int -> TestType -> CommandLineOption -> CommandLineOption)
-> (TestType -> CommandLineOption)
-> ([TestType] -> CommandLineOption -> CommandLineOption)
-> Show TestType
forall a.
(Int -> a -> CommandLineOption -> CommandLineOption)
-> (a -> CommandLineOption)
-> ([a] -> CommandLineOption -> CommandLineOption)
-> Show a
showList :: [TestType] -> CommandLineOption -> CommandLineOption
$cshowList :: [TestType] -> CommandLineOption -> CommandLineOption
show :: TestType -> CommandLineOption
$cshow :: TestType -> CommandLineOption
showsPrec :: Int -> TestType -> CommandLineOption -> CommandLineOption
$cshowsPrec :: Int -> TestType -> CommandLineOption -> CommandLineOption
Show, TestType -> TestType -> Bool
(TestType -> TestType -> Bool)
-> (TestType -> TestType -> Bool) -> Eq TestType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TestType -> TestType -> Bool
$c/= :: TestType -> TestType -> Bool
== :: TestType -> TestType -> Bool
$c== :: TestType -> TestType -> Bool
Eq)

data Tester
  = Tester String
  | TesterTodo
  deriving (Int -> Tester -> CommandLineOption -> CommandLineOption
[Tester] -> CommandLineOption -> CommandLineOption
Tester -> CommandLineOption
(Int -> Tester -> CommandLineOption -> CommandLineOption)
-> (Tester -> CommandLineOption)
-> ([Tester] -> CommandLineOption -> CommandLineOption)
-> Show Tester
forall a.
(Int -> a -> CommandLineOption -> CommandLineOption)
-> (a -> CommandLineOption)
-> ([a] -> CommandLineOption -> CommandLineOption)
-> Show a
showList :: [Tester] -> CommandLineOption -> CommandLineOption
$cshowList :: [Tester] -> CommandLineOption -> CommandLineOption
show :: Tester -> CommandLineOption
$cshow :: Tester -> CommandLineOption
showsPrec :: Int -> Tester -> CommandLineOption -> CommandLineOption
$cshowsPrec :: Int -> Tester -> CommandLineOption -> CommandLineOption
Show, Tester -> Tester -> Bool
(Tester -> Tester -> Bool)
-> (Tester -> Tester -> Bool) -> Eq Tester
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tester -> Tester -> Bool
$c/= :: Tester -> Tester -> Bool
== :: Tester -> Tester -> Bool
$c== :: Tester -> Tester -> Bool
Eq)

parseTestType :: LocatedN RdrName -> Maybe TestType
parseTestType :: LocatedN RdrName -> Maybe TestType
parseTestType = (CommandLineOption -> TestType)
-> Maybe CommandLineOption -> Maybe TestType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CommandLineOption -> TestType
toTestType (Maybe CommandLineOption -> Maybe TestType)
-> (LocatedN RdrName -> Maybe CommandLineOption)
-> LocatedN RdrName
-> Maybe TestType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> CommandLineOption -> Maybe CommandLineOption
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix CommandLineOption
"test_" (CommandLineOption -> Maybe CommandLineOption)
-> (LocatedN RdrName -> CommandLineOption)
-> LocatedN RdrName
-> Maybe CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedN RdrName -> CommandLineOption
fromRdrName
  where
    toTestType :: CommandLineOption -> TestType
toTestType = \case
      CommandLineOption
"batch" -> TestType
TestBatch
      CommandLineOption
"todo" -> Tester -> TestType
TestSingle Tester
TesterTodo
      CommandLineOption
s -> Tester -> TestType
TestSingle (CommandLineOption -> Tester
Tester CommandLineOption
s)

fromTester :: ExternalNames -> Tester -> RdrName
fromTester :: ExternalNames -> Tester -> RdrName
fromTester ExternalNames
names = \case
  Tester CommandLineOption
name -> CommandLineOption -> RdrName
mkRdrName CommandLineOption
name
  Tester
TesterTodo -> Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ ExternalNames -> Name
name_testTreeTodo ExternalNames
names

-- | Return the `[TestTree]` type.
getListOfTestTreeType :: ExternalNames -> LHsType GhcPs
getListOfTestTreeType :: ExternalNames -> LHsType GhcPs
getListOfTestTreeType ExternalNames
names =
  (HsType GhcPs -> LHsType GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsType GhcPs -> LHsType GhcPs)
-> (LHsType GhcPs -> HsType GhcPs)
-> LHsType GhcPs
-> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExtField
XListTy GhcPs
noAnn)
    (LHsType GhcPs -> LHsType GhcPs)
-> (LocatedN RdrName -> LHsType GhcPs)
-> LocatedN RdrName
-> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsType GhcPs -> LHsType GhcPs
forall e ann. e -> GenLocated SrcSpan e
genLoc (HsType GhcPs -> LHsType GhcPs)
-> (LocatedN RdrName -> HsType GhcPs)
-> LocatedN RdrName
-> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XTyVar GhcPs
-> PromotionFlag -> Located (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcPs
noAnn PromotionFlag
NotPromoted)
    (LocatedN RdrName -> LHsType GhcPs)
-> LocatedN RdrName -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> LocatedN RdrName
forall e ann. e -> GenLocated SrcSpan e
genLoc RdrName
testTreeName
  where
    testTreeName :: RdrName
testTreeName = Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (ExternalNames -> Name
name_TestTree ExternalNames
names)

-- | Return True if the given type is `[TestTree]`.
isListOfTestTree :: ExternalNames -> LHsSigWcType GhcPs -> Bool
isListOfTestTree :: ExternalNames -> HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> Bool
isListOfTestTree ExternalNames
names HsWildCardBndrs GhcPs (LHsSigType GhcPs)
ty =
  case HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> Maybe ParsedType
parseSigWcType HsWildCardBndrs GhcPs (LHsSigType GhcPs)
ty of
    Just (TypeList (TypeVar PromotionFlag
_ (L SrcSpan
_ RdrName
name))) -> RdrName -> OccName
rdrNameOcc RdrName
name OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== RdrName -> OccName
rdrNameOcc RdrName
testTreeName
    Maybe ParsedType
_ -> Bool
False
  where
    testTreeName :: RdrName
testTreeName = Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (ExternalNames -> Name
name_TestTree ExternalNames
names)

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

type ConvertTestM = State ConvertTestState

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

data SigInfo = SigInfo
  { SigInfo -> TestType
testType :: TestType
  -- ^ The parsed tester
  , SigInfo -> LocatedN RdrName
testName :: LocatedN RdrName
  -- ^ The generated name for the test
  , SigInfo -> HsWildCardBndrs GhcPs (LHsSigType GhcPs)
testHsType :: LHsSigWcType GhcPs
  -- ^ The type of the test body
  }

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

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

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

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