Merge pull request #5140 from sellout/numbered-test-results

lib/unison-pretty-printer/src/Unison/Util/Pretty.hs

@@ -78,7 +78,7 @@ module Unison.Util.Pretty
     lineSkip,
     nonEmpty,
     numbered,
-    numberedColumn2,
+    numberedColumn2ListFrom,
     numberedColumn2Header,
     numberedColumnNHeader,
     numberedList,
@@ -544,12 +544,12 @@ numberedHeader num ps = column2 (fmap num (Nothing : fmap Just [1 ..]) `zip` toL
 -- 1. one thing     : this is a thing
 -- 2. another thing : this is another thing
 -- 3. and another   : yet one more thing
-numberedColumn2 ::
-  (Foldable f, LL.ListLike s Char, IsString s) =>
-  (Int -> Pretty s) ->
-  f (Pretty s, Pretty s) ->
-  Pretty s
-numberedColumn2 num ps = numbered num (align $ toList ps)
+numberedColumn2ListFrom ::
+  (Foldable f) =>
+  Int ->
+  f (Pretty ColorText, Pretty ColorText) ->
+  Pretty ColorText
+numberedColumn2ListFrom num ps = numberedListFrom num (align $ toList ps)
 
 numberedColumn2Header ::
   (Foldable f, LL.ListLike s Char, IsString s) =>

parser-typechecker/src/Unison/Codebase/Path.hs

@@ -56,15 +56,13 @@ module Unison.Codebase.Path
     toList,
     toName,
     toName',
-    unsafeToName,
-    unsafeToName',
     toText,
     toText',
     unsplit,
     unsplit',
     unsplitAbsolute,
-    unsplitHQ,
-    unsplitHQ',
+    nameFromHQSplit,
+    nameFromHQSplit',
     nameFromSplit',
     splitFromName,
     splitFromName',
@@ -171,11 +169,11 @@ unsplitAbsolute :: (Absolute, NameSegment) -> Absolute
 unsplitAbsolute =
   coerce unsplit
 
-unsplitHQ :: HQSplit -> HQ'.HashQualified Path
-unsplitHQ (p, a) = fmap (snoc p) a
+nameFromHQSplit :: HQSplit -> HQ'.HashQualified Name
+nameFromHQSplit = nameFromHQSplit' . first (RelativePath' . Relative)
 
-unsplitHQ' :: HQSplit' -> HQ'.HashQualified Path'
-unsplitHQ' (p, a) = fmap (snoc' p) a
+nameFromHQSplit' :: HQSplit' -> HQ'.HashQualified Name
+nameFromHQSplit' (p, a) = fmap (nameFromSplit' . (p,)) a
 
 type Split = (Path, NameSegment)
 
@@ -316,9 +314,6 @@ cons = Lens.cons
 snoc :: Path -> NameSegment -> Path
 snoc = Lens.snoc
 
-snoc' :: Path' -> NameSegment -> Path'
-snoc' = Lens.snoc
-
 unsnoc :: Path -> Maybe (Path, NameSegment)
 unsnoc = Lens.unsnoc
 
@@ -344,15 +339,6 @@ fromName' n
   where
     path = fromName n
 
-unsafeToName :: Path -> Name
-unsafeToName =
-  fromMaybe (error "empty path") . toName
-
--- | Convert a Path' to a Name
-unsafeToName' :: Path' -> Name
-unsafeToName' =
-  fromMaybe (error "empty path") . toName'
-
 toName :: Path -> Maybe Name
 toName = \case
   Path Seq.Empty -> Nothing

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -77,7 +77,6 @@ import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper)
 import Unison.Codebase.Editor.HandleInput.ProjectClone (handleClone)
 import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
 import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename)
-import Unison.Codebase.Editor.HandleInput.Todo (handleTodo)
 import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
 import Unison.Codebase.Editor.HandleInput.Projects (handleProjects)
 import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch)
@@ -88,6 +87,7 @@ import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils
 import Unison.Codebase.Editor.HandleInput.ShowDefinition (showDefinitions)
 import Unison.Codebase.Editor.HandleInput.TermResolution (resolveMainRef)
 import Unison.Codebase.Editor.HandleInput.Tests qualified as Tests
+import Unison.Codebase.Editor.HandleInput.Todo (handleTodo)
 import Unison.Codebase.Editor.HandleInput.UI (openUI)
 import Unison.Codebase.Editor.HandleInput.Update (doSlurpAdds, handleUpdate)
 import Unison.Codebase.Editor.HandleInput.Update2 (handleUpdate2)
@@ -104,7 +104,6 @@ import Unison.Codebase.Editor.StructuredArgument qualified as SA
 import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase)
 import Unison.Codebase.Metadata qualified as Metadata
 import Unison.Codebase.Path (Path, Path' (..))
-import Unison.Codebase.Path qualified as HQSplit'
 import Unison.Codebase.Path qualified as Path
 import Unison.Codebase.Runtime qualified as Runtime
 import Unison.Codebase.ShortCausalHash qualified as SCH
@@ -119,7 +118,6 @@ import Unison.DataDeclaration qualified as DD
 import Unison.Hash qualified as Hash
 import Unison.HashQualified qualified as HQ
 import Unison.HashQualified' qualified as HQ'
-import Unison.HashQualified' qualified as HashQualified
 import Unison.LabeledDependency (LabeledDependency)
 import Unison.LabeledDependency qualified as LD
 import Unison.LabeledDependency qualified as LabeledDependency
@@ -574,7 +572,7 @@ loop e = do
                         (Just as1, Just as2) -> (missingSrcs, actions ++ as1 ++ as2)
 
                 fixupOutput :: Path.HQSplit -> HQ.HashQualified Name
-                fixupOutput = fmap Path.unsafeToName . HQ'.toHQ . Path.unsplitHQ
+                fixupOutput = HQ'.toHQ . Path.nameFromHQSplit
             NamesI global query -> do
               hqLength <- Cli.runTransaction Codebase.hashLength
               root <- Cli.getRootBranch
@@ -659,7 +657,7 @@ loop e = do
                 description <- inputDescription input
                 let toDelete =
                       Names.prefix0
-                        (Path.unsafeToName (Path.unsplit (p)))
+                        (Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) p)
                         (Branch.toNames (Branch.head branch))
                 afterDelete <- do
                   names <- Cli.currentNames
@@ -1540,7 +1538,7 @@ delete input doutput getTerms getTypes hqs' = do
     then do
       let toName :: [(Path.HQSplit', Set Reference, Set referent)] -> [Name]
           toName notFounds =
-            mapMaybe (\(split, _, _) -> Path.toName' $ HashQualified.toName (HQSplit'.unsplitHQ' split)) notFounds
+            map (\(split, _, _) -> HQ'.toName $ Path.nameFromHQSplit' split) notFounds
       Cli.returnEarly $ NamesNotFound (toName notFounds)
     else do
       checkDeletes typesTermsTuple doutput input
@@ -1551,8 +1549,14 @@ checkDeletes typesTermsTuples doutput inputs = do
         (Path.HQSplit', Set Reference, Set Referent) ->
         Cli (Path.Split, Name, Set Reference, Set Referent)
       toSplitName hq = do
+        -- __FIXME__: `resolvedPath` is ostensiby `Absolute`, but the paths here must be `Relative` below
         resolvedPath <- first Path.unabsolute <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
-        return (resolvedPath, Path.unsafeToName (Path.unsplit resolvedPath), hq ^. _2, hq ^. _3)
+        return
+          ( resolvedPath,
+            Path.nameFromSplit' $ first (Path.RelativePath' . Path.Relative) resolvedPath,
+            hq ^. _2,
+            hq ^. _3
+          )
   -- get the splits and names with terms and types
   splitsNames <- traverse toSplitName typesTermsTuples
   let toRel :: (Ord ref) => Set ref -> Name -> R.Relation Name ref

unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs

@@ -91,7 +91,7 @@ handleTest TestInput {includeLibNamespace, path, showFailures, showSuccesses} =
   names <- Cli.currentNames
   pped <- Cli.prettyPrintEnvDeclFromNames names
   let fqnPPE = PPED.unsuffixifiedPPE pped
-  Cli.respond $
+  Cli.respondNumbered $
     TestResults
       stats
       fqnPPE
@@ -124,7 +124,7 @@ handleTest TestInput {includeLibNamespace, path, showFailures, showSuccesses} =
 
     let m = Map.fromList computedTests
         (mOks, mFails) = passFails m
-    Cli.respond $ TestResults Output.NewlyComputed fqnPPE showSuccesses showFailures mOks mFails
+    Cli.respondNumbered $ TestResults Output.NewlyComputed fqnPPE showSuccesses showFailures mOks mFails
 
 handleIOTest :: HQ.HashQualified Name -> Cli ()
 handleIOTest main = do
@@ -139,7 +139,7 @@ handleIOTest main = do
       when (not $ isIOTest typ) do
         Cli.returnEarly (BadMainFunction "io.test" main typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime))
       runIOTest suffixifiedPPE ref
-  Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails
+  Cli.respondNumbered $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails
 
 findTermsOfTypes :: Codebase.Codebase m Symbol Ann -> Bool -> Path -> NESet (Type.Type Symbol Ann) -> Cli (Set TermReferenceId)
 findTermsOfTypes codebase includeLib path filterTypes = do
@@ -163,7 +163,7 @@ handleAllIOTests = do
   let suffixifiedPPE = PPED.suffixifiedPPE pped
   ioTestRefs <- findTermsOfTypes codebase False Path.empty (Runtime.ioTestTypes runtime)
   case NESet.nonEmptySet ioTestRefs of
-    Nothing -> Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True [] []
+    Nothing -> Cli.respondNumbered $ TestResults Output.NewlyComputed suffixifiedPPE True True [] []
     Just neTestRefs -> do
       let total = NESet.size neTestRefs
       (fails, oks) <-
@@ -172,7 +172,7 @@ handleAllIOTests = do
           (fails, oks) <- runIOTest suffixifiedPPE r
           Cli.respond $ TestIncrementalOutputEnd suffixifiedPPE (n, total) r (null fails)
           pure (fails, oks)
-      Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails
+      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 parseNames hqNames =

unison-cli/src/Unison/Codebase/Editor/Output.hs

@@ -119,6 +119,13 @@ data NumberedOutput
   | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | -- <authorIdentifier> <authorPath> <relativeBase>
     ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
+  | TestResults
+      TestReportStats
+      PPE.PrettyPrintEnv
+      ShowSuccesses
+      ShowFailures
+      [(TermReferenceId, Text)] -- oks
+      [(TermReferenceId, Text)] -- fails
   | Output'Todo !TodoOutput
   | -- | CantDeleteDefinitions ppe couldntDelete becauseTheseStillReferenceThem
     CantDeleteDefinitions PPE.PrettyPrintEnvDecl (Map LabeledDependency (NESet LabeledDependency))
@@ -263,13 +270,6 @@ data Output
   | LoadedDefinitionsToSourceFile FilePath Int
   | TestIncrementalOutputStart PPE.PrettyPrintEnv (Int, Int) TermReferenceId
   | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int, Int) TermReferenceId Bool {- True if success, False for Failure -}
-  | TestResults
-      TestReportStats
-      PPE.PrettyPrintEnv
-      ShowSuccesses
-      ShowFailures
-      [(TermReferenceId, Text)] -- oks
-      [(TermReferenceId, Text)] -- fails
   | CantUndo UndoFailureReason
   | -- new/unrepresented references followed by old/removed
     -- todo: eventually replace these sets with [SearchResult' v Ann]
@@ -542,7 +542,6 @@ isFailure o = case o of
   DisplayRendered {} -> False
   TestIncrementalOutputStart {} -> False
   TestIncrementalOutputEnd {} -> False
-  TestResults _ _ _ _ _ fails -> not (null fails)
   CantUndo {} -> True
   BustedBuiltins {} -> True
   NoConfiguredRemoteMapping {} -> True
@@ -677,4 +676,5 @@ isNumberedFailure = \case
   ShowDiffAfterUndo {} -> False
   ShowDiffNamespace _ _ _ bd -> BD.isEmpty bd
   ListNamespaceDependencies {} -> False
+  TestResults _ _ _ _ _ fails -> not (null fails)
   Output'Todo {} -> False

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -110,7 +110,7 @@ import Unison.PrintError
     renderCompilerBug,
   )
 import Unison.Project (ProjectAndBranch (..))
-import Unison.Reference (Reference, TermReferenceId)
+import Unison.Reference (Reference)
 import Unison.Reference qualified as Reference
 import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
@@ -307,6 +307,29 @@ notifyNumbered = \case
             ]
       )
       (showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff)
+  TestResults stats ppe _showSuccess _showFailures oksUnsorted failsUnsorted ->
+    let oks = Name.sortByText (HQ.toText . fst) [(name r, msg) | (r, msg) <- oksUnsorted]
+        fails = Name.sortByText (HQ.toText . fst) [(name r, msg) | (r, msg) <- failsUnsorted]
+        name r = PPE.termName ppe (Referent.fromTermReferenceId r)
+     in ( case stats of
+            CachedTests 0 _ -> P.callout "😶" $ "No tests to run."
+            CachedTests n n' | n == n' -> P.lines [cache, "", displayTestResults True oks fails]
+            CachedTests _n m ->
+              if m == 0
+                then "✅  "
+                else
+                  P.indentN 2 $
+                    P.lines ["", cache, "", displayTestResults False oks fails, "", "✅  "]
+            NewlyComputed ->
+              P.lines
+                [ "  " <> P.bold "New test results:",
+                  "",
+                  displayTestResults True oks fails
+                ],
+          fmap (SA.HashQualified . fst) $ oks <> fails
+        )
+    where
+      cache = P.bold "Cached test results " <> "(`help testcache` to learn more)"
   Output'Todo todoOutput -> runNumbered (handleTodoOutput todoOutput)
   CantDeleteDefinitions ppeDecl endangerments ->
     ( P.warnCallout $
@@ -638,29 +661,6 @@ notifyUser dir = \case
   OutputRewrittenFile dest vs -> displayOutputRewrittenFile dest vs
   DisplayRendered outputLoc pp ->
     displayRendered outputLoc pp
-  TestResults stats ppe _showSuccess _showFailures oks fails -> case stats of
-    CachedTests 0 _ -> pure . P.callout "😶" $ "No tests to run."
-    CachedTests n n'
-      | n == n' ->
-          pure $
-            P.lines [cache, "", displayTestResults True ppe oks fails]
-    CachedTests _n m ->
-      pure $
-        if m == 0
-          then "✅  "
-          else
-            P.indentN 2 $
-              P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "✅  "]
-    NewlyComputed -> do
-      clearCurrentLine
-      pure $
-        P.lines
-          [ "  " <> P.bold "New test results:",
-            "",
-            displayTestResults True ppe oks fails
-          ]
-    where
-      cache = P.bold "Cached test results " <> "(`help testcache` to learn more)"
   TestIncrementalOutputStart ppe (n, total) r -> do
     putPretty' $
       P.shown (total - n)
@@ -1199,7 +1199,7 @@ notifyUser dir = \case
       ]
     where
       name :: Name
-      name = Path.unsafeToName' (HQ'.toName (Path.unsplitHQ' p))
+      name = HQ'.toName $ Path.nameFromHQSplit' p
       qualifyTerm :: Referent -> Pretty
       qualifyTerm = P.syntaxToColor . prettyNamedReferent hashLen name
       qualifyType :: Reference -> Pretty
@@ -2535,38 +2535,37 @@ displayRendered outputLoc pp =
 
 displayTestResults ::
   Bool -> -- whether to show the tip
-  PPE.PrettyPrintEnv ->
-  [(TermReferenceId, Text)] ->
-  [(TermReferenceId, Text)] ->
+  [(HQ.HashQualified Name, Text)] ->
+  [(HQ.HashQualified Name, Text)] ->
   Pretty
-displayTestResults showTip ppe oksUnsorted failsUnsorted =
-  let oks = Name.sortByText fst [(name r, msg) | (r, msg) <- oksUnsorted]
-      fails = Name.sortByText fst [(name r, msg) | (r, msg) <- failsUnsorted]
-      name r = HQ.toText $ PPE.termName ppe (Referent.fromTermReferenceId r)
+displayTestResults showTip oks fails =
+  let name = P.text . HQ.toText
       okMsg =
         if null oks
           then mempty
-          else P.column2 [(P.green "◉ " <> P.text r, "  " <> P.green (P.text msg)) | (r, msg) <- oks]
+          else
+            P.indentN 2 $
+              P.numberedColumn2ListFrom 0 [(P.green "◉ " <> name r, "  " <> P.green (P.text msg)) | (r, msg) <- oks]
       okSummary =
         if null oks
           then mempty
           else "✅ " <> P.bold (P.num (length oks)) <> P.green " test(s) passing"
       failMsg =
         if null fails
           then mempty
-          else P.column2 [(P.red "✗ " <> P.text r, "  " <> P.red (P.text msg)) | (r, msg) <- fails]
+          else
+            P.indentN 2 $
+              P.numberedColumn2ListFrom
+                (length oks)
+                [(P.red "✗ " <> name r, "  " <> P.red (P.text msg)) | (r, msg) <- fails]
       failSummary =
         if null fails
           then mempty
           else "🚫 " <> P.bold (P.num (length fails)) <> P.red " test(s) failing"
       tipMsg =
         if not showTip || (null oks && null fails)
           then mempty
-          else
-            tip $
-              "Use "
-                <> P.blue ("view " <> P.text (fst $ head (fails ++ oks)))
-                <> "to view the source of a test."
+          else tip $ "Use " <> P.blue "view 1" <> "to view the source of a test."
    in if null oks && null fails
         then "😶 No tests available."
         else
@@ -3449,7 +3448,7 @@ listDependentsOrDependencies ppe labelStart label lds types terms =
           P.lines $
             [ P.indentN 2 $ P.bold "Types:",
               "",
-              P.indentN 2 $ P.numbered (numFrom 0) $ c . prettyHashQualified <$> types
+              P.indentN 2 . P.numberedList $ c . prettyHashQualified <$> types
             ]
     termsOut =
       if null terms
@@ -3458,7 +3457,6 @@ listDependentsOrDependencies ppe labelStart label lds types terms =
           P.lines
             [ P.indentN 2 $ P.bold "Terms:",
               "",
-              P.indentN 2 $ P.numbered (numFrom $ length types) $ c . prettyHashQualified <$> terms
+              P.indentN 2 . P.numberedListFrom (length types) $ c . prettyHashQualified <$> terms
             ]
-    numFrom k n = P.hiBlack $ P.shown (k + n) <> "."
     c = P.syntaxToColor