module Unison.Codebase.Editor.HandleInput.Tests
  ( handleTest,
    handleIOTest,
    handleAllIOTests,
    isTestOk,
  )
where

import Control.Lens
import Control.Monad.Reader (ask)
import Control.Monad.Trans.Maybe (mapMaybeT)
import Data.Foldable qualified as Foldable
import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as NESet
import Data.Text.IO qualified as Text
import Unison.ABT qualified as ABT
import Unison.Builtin.Decls qualified as DD
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.NamesUtils qualified as Cli
import Unison.Cli.Pretty qualified as Cli
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.HandleInput.RuntimeUtils (EvalMode (..))
import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils
import Unison.Codebase.Editor.Input (TestInput (..))
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.Runtime qualified as Runtime
import Unison.Codebase.Runtime.Profile (ProfileSpec (NoProf))
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.Debug qualified as Debug
import Unison.HashQualified qualified as HQ
import Unison.Name (Name)
import Unison.Names (Names)
import Unison.NamesWithHistory qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.Reference (TermReferenceId)
import Unison.Reference qualified as Reference
import Unison.Referent qualified as Referent
import Unison.ShortHash qualified as SH
import Unison.Symbol (Symbol)
import Unison.Syntax.HashQualified qualified as HQ
import Unison.Syntax.Name qualified as Name
import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Type qualified as Type
import Unison.Typechecker qualified as Typechecker
import Unison.UnisonFile qualified as UF
import Unison.Util.Monoid (foldMapM)
import Unison.Util.Pretty qualified as P
import Unison.Util.Relation qualified as R
import Unison.Util.Set qualified as Set
import Unison.WatchKind qualified as WK

-- | Handle a @test@ command.
-- Run pure tests in the current subnamespace.
handleTest :: TestInput -> Cli ()
handleTest :: TestInput -> Cli ()
handleTest TestInput {Bool
includeLibNamespace :: Bool
includeLibNamespace :: TestInput -> Bool
includeLibNamespace, Path
path :: Path
path :: TestInput -> Path
path, Bool
showFailures :: Bool
showFailures :: TestInput -> Bool
showFailures, Bool
showSuccesses :: Bool
showSuccesses :: TestInput -> Bool
showSuccesses} = do
  Cli.Env {codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask

  testRefs <- findTermsOfTypes codebase includeLibNamespace path (NESet.singleton (DD.testResultListType mempty))

  cachedTests <-
    Map.fromList <$> Cli.runTransaction do
      Set.toList testRefs & wither \case
        Id
rid -> (Term Symbol Ann -> (Id, Term Symbol Ann))
-> Maybe (Term Symbol Ann) -> Maybe (Id, Term Symbol Ann)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Id
rid,) (Maybe (Term Symbol Ann) -> Maybe (Id, Term Symbol Ann))
-> Transaction (Maybe (Term Symbol Ann))
-> Transaction (Maybe (Id, Term Symbol Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Codebase IO Symbol Ann
-> WatchKind -> Id -> Transaction (Maybe (Term Symbol Ann))
forall (m :: * -> *) v a.
Codebase m v a -> WatchKind -> Id -> Transaction (Maybe (Term v a))
Codebase.getWatch Codebase IO Symbol Ann
codebase WatchKind
forall a. (Eq a, IsString a) => a
WK.TestWatch Id
rid
  let (fails, oks) = passFails cachedTests
      passFails :: (Ord r) => Map r (Term v a) -> (Map r [Text], Map r [Text])
      passFails =
        (r
 -> Term v a
 -> (Map r [Text], Map r [Text])
 -> (Map r [Text], Map r [Text]))
-> (Map r [Text], Map r [Text])
-> Map r (Term v a)
-> (Map r [Text], Map r [Text])
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
          (\r
r Term v a
v (Map r [Text]
f, Map r [Text]
o) -> ([Text] -> Map r [Text])
-> ([Text] -> Map r [Text])
-> ([Text], [Text])
-> (Map r [Text], Map r [Text])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (\[Text]
ts -> if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
ts then Map r [Text]
f else r -> [Text] -> Map r [Text] -> Map r [Text]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert r
r [Text]
ts Map r [Text]
f) (\[Text]
ts -> if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
ts then Map r [Text]
o else r -> [Text] -> Map r [Text] -> Map r [Text]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert r
r [Text]
ts Map r [Text]
o) (([Text], [Text]) -> (Map r [Text], Map r [Text]))
-> ([Either Text Text] -> ([Text], [Text]))
-> [Either Text Text]
-> (Map r [Text], Map r [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Text Text] -> ([Text], [Text])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Text Text] -> (Map r [Text], Map r [Text]))
-> [Either Text Text] -> (Map r [Text], Map r [Text])
forall a b. (a -> b) -> a -> b
$ Term v a -> [Either Text Text]
forall v a. Term v a -> [Either Text Text]
p Term v a
v)
          (Map r [Text]
forall k a. Map k a
Map.empty, Map r [Text]
forall k a. Map k a
Map.empty)
        where
          p :: Term v a -> [Either Text Text]
          p :: forall v a. Term v a -> [Either Text Text]
p = \case
            Term.List' Seq (Term v a)
ts -> (Term v a -> Maybe (Either Text Text))
-> [Term v a] -> [Either Text Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe Term v a -> Maybe (Either Text Text)
forall {typeVar} {typeAnn} {patternAnn} {v} {a}.
Term (F typeVar typeAnn patternAnn) v a -> Maybe (Either Text Text)
q ([Term v a] -> [Either Text Text])
-> [Term v a] -> [Either Text Text]
forall a b. (a -> b) -> a -> b
$ Seq (Term v a) -> [Term v a]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term v a)
ts
            Term v a
_ -> []
          q :: Term (F typeVar typeAnn patternAnn) v a -> Maybe (Either Text Text)
q = \case
            Term.App' (Term.Constructor' (ConstructorReference TypeReference
ref ConstructorId
cid)) (Term.Text' Text
msg) ->
              if
                | TypeReference
ref TypeReference -> TypeReference -> Bool
forall a. Eq a => a -> a -> Bool
== TypeReference
DD.testResultRef ->
                    if
                      | ConstructorId
cid ConstructorId -> ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorId
DD.okConstructorId -> Either Text Text -> Maybe (Either Text Text)
forall a. a -> Maybe a
Just (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
msg)
                      | ConstructorId
cid ConstructorId -> ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorId
DD.failConstructorId -> Either Text Text -> Maybe (Either Text Text)
forall a. a -> Maybe a
Just (Text -> Either Text Text
forall a b. a -> Either a b
Left Text
msg)
                      | Bool
otherwise -> Maybe (Either Text Text)
forall a. Maybe a
Nothing
                | Bool
otherwise -> Maybe (Either Text Text)
forall a. Maybe a
Nothing
            Term (F typeVar typeAnn patternAnn) v a
_ -> Maybe (Either Text Text)
forall a. Maybe a
Nothing
  let stats = Int -> Int -> TestReportStats
Output.CachedTests (Set Id -> Int
forall a. Set a -> Int
Set.size Set Id
testRefs) (Map Id (Term Symbol Ann) -> Int
forall k a. Map k a -> Int
Map.size Map Id (Term Symbol Ann)
cachedTests)
  names <- Cli.currentNames
  let pped = Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED (Int -> Names -> Namer
PPE.hqNamer Int
10 Names
names) (Names -> Suffixifier
PPE.suffixifyByHash Names
names)
  let fqnPPE = PrettyPrintEnvDecl -> PrettyPrintEnv
PPED.unsuffixifiedPPE PrettyPrintEnvDecl
pped
  Cli.respondNumbered $
    TestResults
      stats
      fqnPPE
      showSuccesses
      showFailures
      oks
      fails
  let toCompute = Set Id -> Set Id -> Set Id
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set Id
testRefs (Map Id (Term Symbol Ann) -> Set Id
forall k a. Map k a -> Set k
Map.keysSet Map Id (Term Symbol Ann)
cachedTests)
  when (not (Set.null toCompute)) do
    let total = Set Id -> Int
forall a. Set a -> Int
Set.size Set Id
toCompute
    computedTests <- fmap join . for (toList toCompute `zip` [1 ..]) $ \(Id
r, Int
n) ->
      Transaction (Maybe (Term Symbol Ann))
-> Cli (Maybe (Term Symbol Ann))
forall a. Transaction a -> Cli a
Cli.runTransaction (Codebase IO Symbol Ann
-> Id -> Transaction (Maybe (Term Symbol Ann))
forall (m :: * -> *) v a.
Codebase m v a -> Id -> Transaction (Maybe (Term v a))
Codebase.getTerm Codebase IO Symbol Ann
codebase Id
r) Cli (Maybe (Term Symbol Ann))
-> (Maybe (Term Symbol Ann) -> Cli [(Id, Term Symbol Ann)])
-> Cli [(Id, Term Symbol Ann)]
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (Term Symbol Ann)
Nothing -> do
          hqLength <- Transaction Int -> Cli Int
forall a. Transaction a -> Cli a
Cli.runTransaction Transaction Int
Codebase.hashLength
          Cli.respond (TermNotFound' . SH.shortenTo hqLength . Reference.toShortHash $ Reference.DerivedId r)
          pure []
        Just Term Symbol Ann
tm -> do
          let testName :: Pretty ColorText
testName = PrettyPrintEnv -> Referent -> Pretty ColorText
Cli.prettyTermName PrettyPrintEnv
fqnPPE (Id -> Referent
Referent.fromTermReferenceId Id
r)
          DebugFlag -> Cli () -> Cli ()
forall (m :: * -> *). Monad m => DebugFlag -> m () -> m ()
Debug.whenDebug DebugFlag
Debug.Tests (Cli () -> Cli ()) -> Cli () -> Cli ()
forall a b. (a -> b) -> a -> b
$
            IO () -> Cli ()
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"\nAbout to run test:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Width -> Pretty ColorText -> Text
P.toPlain Width
80 Pretty ColorText
testName))
          Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> (Int, Int) -> Id -> Output
TestIncrementalOutputStart PrettyPrintEnv
fqnPPE (Int
n, Int
total) Id
r
          --                        v don't cache; test cache populated below
          tm' <- Text
-> Cli (Either Error (Term Symbol Ann))
-> Cli (Either Error (Term Symbol Ann))
forall a. Text -> Cli a -> Cli a
Cli.time (Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Width -> Pretty ColorText -> Text
P.toPlain Width
80 Pretty ColorText
testName) (Cli (Either Error (Term Symbol Ann))
 -> Cli (Either Error (Term Symbol Ann)))
-> Cli (Either Error (Term Symbol Ann))
-> Cli (Either Error (Term Symbol Ann))
forall a b. (a -> b) -> a -> b
$ EvalMode
-> PrettyPrintEnv
-> Bool
-> Term Symbol Ann
-> Cli (Either Error (Term Symbol Ann))
RuntimeUtils.evalUnisonTermE EvalMode
Sandboxed PrettyPrintEnv
fqnPPE Bool
False Term Symbol Ann
tm
          case tm' of
            Left Error
e -> do
              Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> (Int, Int) -> Id -> Bool -> Output
TestIncrementalOutputEnd PrettyPrintEnv
fqnPPE (Int
n, Int
total) Id
r Bool
False
              Output -> Cli [(Id, Term Symbol Ann)]
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli [(Id, Term Symbol Ann)])
-> Output -> Cli [(Id, Term Symbol Ann)]
forall a b. (a -> b) -> a -> b
$ (Pretty ColorText -> Pretty ColorText) -> Error -> Output
EvaluationFailure (Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Pretty s -> Pretty s -> Pretty s
P.callout (Pretty ColorText
"Error while evaluating test " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText -> Pretty ColorText
forall s. IsString s => Pretty s -> Pretty s
P.backticked Pretty ColorText
testName Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> Pretty ColorText
":") (Pretty ColorText -> Pretty ColorText)
-> (Pretty ColorText -> Pretty ColorText)
-> Pretty ColorText
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Pretty ColorText -> Pretty ColorText
forall s.
(ListLike s Char, IsString s) =>
Width -> Pretty s -> Pretty s
P.indentN Width
2) Error
e
            Right Term Symbol Ann
tm' -> do
              -- After evaluation, cache the result of the test
              Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction (WatchKind -> Id -> Term Symbol Ann -> Transaction ()
Codebase.putWatch WatchKind
forall a. (Eq a, IsString a) => a
WK.TestWatch Id
r Term Symbol Ann
tm')
              Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> (Int, Int) -> Id -> Bool -> Output
TestIncrementalOutputEnd PrettyPrintEnv
fqnPPE (Int
n, Int
total) Id
r (Term Symbol Ann -> Bool
forall v. Term v Ann -> Bool
isTestOk Term Symbol Ann
tm')
              [(Id, Term Symbol Ann)] -> Cli [(Id, Term Symbol Ann)]
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(Id
r, Term Symbol Ann
tm')]

    let m = [(Id, Term Symbol Ann)] -> Map Id (Term Symbol Ann)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Id, Term Symbol Ann)]
computedTests
        (mFails, mOks) = passFails m
    Cli.respondNumbered $ TestResults Output.NewlyComputed fqnPPE showSuccesses showFailures mOks mFails

handleIOTest :: HQ.HashQualified Name -> Cli ()
handleIOTest :: HashQualified Name -> Cli ()
handleIOTest HashQualified Name
main = do
  let mode :: EvalMode
mode = ProfileSpec -> EvalMode
Permissive ProfileSpec
NoProf
  runtime <- EvalMode -> Cli (Runtime Symbol)
RuntimeUtils.selectRuntime EvalMode
mode
  names <- Cli.currentNames
  let pped = Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED (Int -> Names -> Namer
PPE.hqNamer Int
10 Names
names) (Names -> Suffixifier
PPE.suffixifyByHash Names
names)
  let suffixifiedPPE = PrettyPrintEnvDecl -> PrettyPrintEnv
PPED.suffixifiedPPE PrettyPrintEnvDecl
pped
  let isIOTest Type Symbol Ann
typ = (Type Symbol Ann -> Bool) -> NESet (Type Symbol Ann) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Foldable.any (Type Symbol Ann -> Type Symbol Ann -> Bool
forall v loc. Var v => Type v loc -> Type v loc -> Bool
Typechecker.isSubtype Type Symbol Ann
typ) (NESet (Type Symbol Ann) -> Bool)
-> NESet (Type Symbol Ann) -> Bool
forall a b. (a -> b) -> a -> b
$ Runtime Symbol -> NESet (Type Symbol Ann)
forall e e' v. Runtime e e' v -> NESet (Type v Ann)
Runtime.ioTestTypes Runtime Symbol
runtime
  refs <- resolveHQNames names (Set.singleton main)
  (fails, oks) <-
    Foldable.foldrM
      ( \(Id
ref, Type Symbol Ann
typ) (Map Id [Text]
f, Map Id [Text]
o) -> do
          Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Type Symbol Ann -> Bool
isIOTest Type Symbol Ann
typ) do
            Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$
              Text
-> [(HashQualified Name, Type Symbol Ann)]
-> PrettyPrintEnv
-> [Type Symbol Ann]
-> Output
BadMainFunction
                Text
"io.test"
                [(HashQualified Name
main, Type Symbol Ann
typ)]
                PrettyPrintEnv
suffixifiedPPE
                (NESet (Type Symbol Ann) -> [Type Symbol Ann]
forall a. NESet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Runtime Symbol -> NESet (Type Symbol Ann)
forall e e' v. Runtime e e' v -> NESet (Type v Ann)
Runtime.ioTestTypes Runtime Symbol
runtime))
          ([Text] -> Map Id [Text])
-> ([Text] -> Map Id [Text])
-> ([Text], [Text])
-> (Map Id [Text], Map Id [Text])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (\[Text]
ts -> if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
ts then Map Id [Text]
f else Id -> [Text] -> Map Id [Text] -> Map Id [Text]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
ref [Text]
ts Map Id [Text]
f) (\[Text]
ts -> if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
ts then Map Id [Text]
o else Id -> [Text] -> Map Id [Text] -> Map Id [Text]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Id
ref [Text]
ts Map Id [Text]
o)
            (([Text], [Text]) -> (Map Id [Text], Map Id [Text]))
-> Cli ([Text], [Text]) -> Cli (Map Id [Text], Map Id [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrettyPrintEnv -> Id -> Cli ([Text], [Text])
runIOTest PrettyPrintEnv
suffixifiedPPE Id
ref
      )
      (Map.empty, Map.empty)
      refs
  Cli.respondNumbered $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails

findTermsOfTypes :: Codebase.Codebase m Symbol Ann -> Bool -> Path.Path -> NESet (Type.Type Symbol Ann) -> Cli (Set TermReferenceId)
findTermsOfTypes :: forall (m :: * -> *).
Codebase m Symbol Ann
-> Bool -> Path -> NESet (Type Symbol Ann) -> Cli (Set Id)
findTermsOfTypes Codebase m Symbol Ann
codebase Bool
includeLib Path
path NESet (Type Symbol Ann)
filterTypes = do
  branch <- Path -> Cli (Branch0 IO)
Cli.expectBranch0AtPath Path
path

  let possibleTests =
        Branch0 IO
branch
          Branch0 IO -> (Branch0 IO -> Branch0 IO) -> Branch0 IO
forall a b. a -> (a -> b) -> b
& (if Bool
includeLib then Branch0 IO -> Branch0 IO
forall a. a -> a
id else Branch0 IO -> Branch0 IO
forall (m :: * -> *). Branch0 m -> Branch0 m
Branch.withoutLib)
          Branch0 IO
-> (Branch0 IO -> Relation Referent Name) -> Relation Referent Name
forall a b. a -> (a -> b) -> b
& Branch0 IO -> Relation Referent Name
forall (m :: * -> *). Branch0 m -> Relation Referent Name
Branch.deepTerms
          Relation Referent Name
-> (Relation Referent Name -> Set Referent) -> Set Referent
forall a b. a -> (a -> b) -> b
& Relation Referent Name -> Set Referent
forall a b. Relation a b -> Set a
R.dom
          Set Referent -> (Set Referent -> Set Id) -> Set Id
forall a b. a -> (a -> b) -> b
& (Referent -> Maybe Id) -> Set Referent -> Set Id
forall b a. Ord b => (a -> Maybe b) -> Set a -> Set b
Set.mapMaybe Referent -> Maybe Id
Referent.toTermReferenceId
  Cli.runTransaction do
    filterTypes & foldMapM \Type Symbol Ann
matchTyp -> do
      Codebase m Symbol Ann
-> Type Symbol Ann -> Set Id -> Transaction (Set Id)
forall v (m :: * -> *) a.
Var v =>
Codebase m v a -> Type v a -> Set Id -> Transaction (Set Id)
Codebase.filterTermsByReferenceIdHavingType Codebase m Symbol Ann
codebase Type Symbol Ann
matchTyp Set Id
possibleTests

handleAllIOTests :: Cli ()
handleAllIOTests :: Cli ()
handleAllIOTests = do
  Cli.Env {codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  runtime <- RuntimeUtils.selectRuntime (Permissive NoProf)
  names <- Cli.currentNames
  let pped = Namer -> Suffixifier -> PrettyPrintEnvDecl
PPED.makePPED (Int -> Names -> Namer
PPE.hqNamer Int
10 Names
names) (Names -> Suffixifier
PPE.suffixifyByHash Names
names)
  let suffixifiedPPE = PrettyPrintEnvDecl -> PrettyPrintEnv
PPED.suffixifiedPPE PrettyPrintEnvDecl
pped
  ioTestRefs <- findTermsOfTypes codebase False mempty (Runtime.ioTestTypes runtime)
  case NESet.nonEmptySet ioTestRefs of
    Maybe (NESet Id)
Nothing -> NumberedOutput -> Cli ()
Cli.respondNumbered (NumberedOutput -> Cli ()) -> NumberedOutput -> Cli ()
forall a b. (a -> b) -> a -> b
$ TestReportStats
-> PrettyPrintEnv
-> Bool
-> Bool
-> Map Id [Text]
-> Map Id [Text]
-> NumberedOutput
TestResults TestReportStats
Output.NewlyComputed PrettyPrintEnv
suffixifiedPPE Bool
True Bool
True Map Id [Text]
forall k a. Map k a
Map.empty Map Id [Text]
forall k a. Map k a
Map.empty
    Just NESet Id
neTestRefs -> do
      let total :: Int
total = NESet Id -> Int
forall a. NESet a -> Int
NESet.size NESet Id
neTestRefs
      (fails, oks) <-
        NESet Id -> [Id]
forall a. NESet a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NESet Id
neTestRefs
          [Id] -> ([Id] -> [(Int, Id)]) -> [(Int, Id)]
forall a b. a -> (a -> b) -> b
& [Int] -> [Id] -> [(Int, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..]
          [(Int, Id)]
-> ([(Int, Id)] -> Cli (Map Id [Text], Map Id [Text]))
-> Cli (Map Id [Text], Map Id [Text])
forall a b. a -> (a -> b) -> b
& ((Int, Id)
 -> (Map Id [Text], Map Id [Text])
 -> Cli (Map Id [Text], Map Id [Text]))
-> (Map Id [Text], Map Id [Text])
-> [(Int, Id)]
-> Cli (Map Id [Text], Map Id [Text])
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
Foldable.foldrM
            ( \(Int
n, Id
r) (Map Id [Text]
f, Map Id [Text]
o) -> do
                Output -> Cli ()
Cli.respond (Output -> Cli ()) -> Output -> Cli ()
forall a b. (a -> b) -> a -> b
$ PrettyPrintEnv -> (Int, Int) -> Id -> Output
TestIncrementalOutputStart PrettyPrintEnv
suffixifiedPPE (Int
n, Int
total) Id
r
                (fails, oks) <- PrettyPrintEnv -> Id -> Cli ([Text], [Text])
runIOTest PrettyPrintEnv
suffixifiedPPE Id
r
                Cli.respond $ TestIncrementalOutputEnd suffixifiedPPE (n, total) r (null fails)
                pure (if null fails then f else Map.insert r fails f, if null oks then o else Map.insert r oks o)
            )
            (Map Id [Text]
forall k a. Map k a
Map.empty, Map Id [Text]
forall k a. Map k a
Map.empty)
      Cli.respondNumbered $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails

resolveHQNames :: Names -> Set (HQ.HashQualified Name) -> Cli (Set (Reference.Id, Type.Type Symbol Ann))
resolveHQNames :: Names
-> Set (HashQualified Name) -> Cli (Set (Id, Type Symbol Ann))
resolveHQNames Names
parseNames Set (HashQualified Name)
hqNames =
  [(Id, Type Symbol Ann)] -> Set (Id, Type Symbol Ann)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Id, Type Symbol Ann)] -> Set (Id, Type Symbol Ann))
-> Cli [(Id, Type Symbol Ann)] -> Cli (Set (Id, Type Symbol Ann))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    (Set (HashQualified Name) -> [HashQualified Name]
forall a. Set a -> [a]
Set.toList Set (HashQualified Name)
hqNames) [HashQualified Name]
-> ([HashQualified Name] -> Cli [(Id, Type Symbol Ann)])
-> Cli [(Id, Type Symbol Ann)]
forall a b. a -> (a -> b) -> b
& (HashQualified Name -> Cli [(Id, Type Symbol Ann)])
-> [HashQualified Name] -> Cli [(Id, Type Symbol Ann)]
forall (m :: * -> *) (f :: * -> *) b a.
(Monad m, Foldable f, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM \HashQualified Name
main -> do
      (Maybe (Id, Type Symbol Ann) -> [(Id, Type Symbol Ann)])
-> Cli (Maybe (Id, Type Symbol Ann)) -> Cli [(Id, Type Symbol Ann)]
forall a b. (a -> b) -> Cli a -> Cli b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Id, Type Symbol Ann) -> [(Id, Type Symbol Ann)]
forall a. Maybe a -> [a]
maybeToList (Cli (Maybe (Id, Type Symbol Ann)) -> Cli [(Id, Type Symbol Ann)])
-> (MaybeT Cli (Id, Type Symbol Ann)
    -> Cli (Maybe (Id, Type Symbol Ann)))
-> MaybeT Cli (Id, Type Symbol Ann)
-> Cli [(Id, Type Symbol Ann)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT Cli (Id, Type Symbol Ann)
-> Cli (Maybe (Id, Type Symbol Ann))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Cli (Id, Type Symbol Ann) -> Cli [(Id, Type Symbol Ann)])
-> MaybeT Cli (Id, Type Symbol Ann) -> Cli [(Id, Type Symbol Ann)]
forall a b. (a -> b) -> a -> b
$ do
        HashQualified Name -> MaybeT Cli (Id, Type Symbol Ann)
getNameFromScratchFile HashQualified Name
main MaybeT Cli (Id, Type Symbol Ann)
-> MaybeT Cli (Id, Type Symbol Ann)
-> MaybeT Cli (Id, Type Symbol Ann)
forall a. MaybeT Cli a -> MaybeT Cli a -> MaybeT Cli a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Names -> HashQualified Name -> MaybeT Cli (Id, Type Symbol Ann)
getNameFromCodebase Names
parseNames HashQualified Name
main
  where
    getNameFromScratchFile :: HQ.HashQualified Name -> MaybeT Cli (Reference.Id, Type.Type Symbol Ann)
    getNameFromScratchFile :: HashQualified Name -> MaybeT Cli (Id, Type Symbol Ann)
getNameFromScratchFile HashQualified Name
main = do
      typecheckedFile <- Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
-> MaybeT Cli (TypecheckedUnisonFile Symbol Ann)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
Cli.getLatestTypecheckedFile
      mainName <- hoistMaybe $ Name.parseText (HQ.toText main)
      (_, ref, _wk, _term, typ) <- hoistMaybe $ Map.lookup (Name.toVar mainName) (UF.hashTermsId typecheckedFile)
      pure (ref, typ)

    getNameFromCodebase :: Names -> HQ.HashQualified Name -> MaybeT Cli (Reference.Id, Type.Type Symbol Ann)
    getNameFromCodebase :: Names -> HashQualified Name -> MaybeT Cli (Id, Type Symbol Ann)
getNameFromCodebase Names
parseNames HashQualified Name
main = do
      Cli.Env {codebase} <- MaybeT Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
      mapMaybeT Cli.runTransaction do
        (Set.toList (Names.lookupHQTerm Names.IncludeSuffixes main parseNames)) & altMap \Referent
ref0 -> do
          ref <- Maybe Id -> MaybeT Transaction Id
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeT m a
hoistMaybe (Referent -> Maybe Id
Referent.toTermReferenceId Referent
ref0)
          typ <- MaybeT (Codebase.getTypeOfReferent codebase (Referent.fromTermReferenceId ref))
          pure (ref, typ)

runIOTest :: PPE.PrettyPrintEnv -> Reference.Id -> Cli ([Text], [Text])
runIOTest :: PrettyPrintEnv -> Id -> Cli ([Text], [Text])
runIOTest PrettyPrintEnv
ppe Id
ref = do
  let a :: Ann
a = Term Symbol Ann -> Ann
forall (f :: * -> *) v a. Term f v a -> a
ABT.annotation Term Symbol Ann
tm
      tm :: Term Symbol Ann
tm = Ann -> Ann -> Term Symbol Ann -> Term Symbol Ann
forall v a. Var v => a -> a -> Term v a -> Term v a
DD.forceTerm Ann
a Ann
a (Ann -> Id -> Term Symbol Ann
forall v a vt at ap. Ord v => a -> Id -> Term2 vt at ap v a
Term.refId Ann
a Id
ref)
  -- Don't cache IO tests
  tm' <- EvalMode
-> PrettyPrintEnv
-> Bool
-> Term Symbol Ann
-> Cli (Term Symbol Ann)
RuntimeUtils.evalUnisonTerm (ProfileSpec -> EvalMode
Permissive ProfileSpec
NoProf) PrettyPrintEnv
ppe Bool
False Term Symbol Ann
tm
  pure $ partitionTestResults tm'

partitionTestResults :: Term Symbol Ann -> ([Text {- fails -}], [Text {- oks -}])
partitionTestResults :: Term Symbol Ann -> ([Text], [Text])
partitionTestResults Term Symbol Ann
tm = [([Text], [Text])] -> ([Text], [Text])
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([([Text], [Text])] -> ([Text], [Text]))
-> [([Text], [Text])] -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ do
  element <- case Term Symbol Ann
tm of
    Term.List' Seq (Term Symbol Ann)
ts -> Seq (Term Symbol Ann) -> [Term Symbol Ann]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq (Term Symbol Ann)
ts
    Term Symbol Ann
_ -> [Term Symbol Ann]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
  case element of
    Term.App' (Term.Constructor' (ConstructorReference TypeReference
conRef ConstructorId
cid)) (Term.Text' Text
msg) -> do
      Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (TypeReference
conRef TypeReference -> TypeReference -> Bool
forall a. Eq a => a -> a -> Bool
== TypeReference
DD.testResultRef)
      if
        | ConstructorId
cid ConstructorId -> ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorId
DD.okConstructorId -> ([Text], [Text]) -> [([Text], [Text])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
forall a. Monoid a => a
mempty, [Text
msg])
        | ConstructorId
cid ConstructorId -> ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorId
DD.failConstructorId -> ([Text], [Text]) -> [([Text], [Text])]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text
msg], [Text]
forall a. Monoid a => a
mempty)
        | Bool
otherwise -> [([Text], [Text])]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
    Term Symbol Ann
_ -> [([Text], [Text])]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty

isTestOk :: Term v Ann -> Bool
isTestOk :: forall v. Term v Ann -> Bool
isTestOk Term v Ann
tm = case Term v Ann
tm of
  Term.List' Seq (Term v Ann)
ts -> (Term v Ann -> Bool) -> Seq (Term v Ann) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Term v Ann -> Bool
forall {typeVar} {typeAnn} {patternAnn} {v} {a}.
Term (F typeVar typeAnn patternAnn) v a -> Bool
isSuccess Seq (Term v Ann)
ts
    where
      isSuccess :: Term (F typeVar typeAnn patternAnn) v a -> Bool
isSuccess (Term.App' (Term.Constructor' (ConstructorReference TypeReference
ref ConstructorId
cid)) Term (F typeVar typeAnn patternAnn) v a
_) =
        ConstructorId
cid ConstructorId -> ConstructorId -> Bool
forall a. Eq a => a -> a -> Bool
== ConstructorId
DD.okConstructorId
          Bool -> Bool -> Bool
&& TypeReference
ref TypeReference -> TypeReference -> Bool
forall a. Eq a => a -> a -> Bool
== TypeReference
DD.testResultRef
      isSuccess Term (F typeVar typeAnn patternAnn) v a
_ = Bool
False
  Term v Ann
_ -> Bool
False