Report internal errors more clearly

.github/workflows/ci.yaml

@@ -15,7 +15,7 @@ env:
   ## Some version numbers that are used during CI
   ormolu_version: 0.7.2.0
   jit_version: "@unison/internal/releases/0.0.25"
-  runtime_tests_version: "@unison/runtime-tests/releases/0.0.3"
+  runtime_tests_version: "@unison/runtime-tests/@sellout/unison-5661"
 
   ## Some cached directories
   # a temp path for caching a built `ucm`

lib/unison-pretty-printer/src/Unison/PrettyTerminal.hs

@@ -43,9 +43,9 @@ putPretty' p = do
   width <- getAvailableWidth
   putStr $ P.toANSI width p
 
+-- | Returns a `P.Width` in the range 80–100, depending on the terminal width.
 getAvailableWidth :: IO P.Width
-getAvailableWidth =
-  maybe 80 (\s -> 100 `min` P.Width (Terminal.width s)) <$> Terminal.size
+getAvailableWidth = maybe 80 (P.Width . min 100 . Terminal.width) <$> Terminal.size
 
 putPrettyNonempty :: P.Pretty P.ColorText -> IO ()
 putPrettyNonempty msg = do

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

@@ -90,7 +90,6 @@ module Unison.Util.Pretty
     parenthesizeCommas,
     parenthesizeIf,
     render,
-    renderUnbroken,
     rightPad,
     sep,
     sepNonEmpty,
@@ -112,10 +111,8 @@ module Unison.Util.Pretty
     table,
     text,
     toANSI,
-    toAnsiUnbroken,
     toHTML,
     toPlain,
-    toPlainUnbroken,
     underline,
     withSyntax,
     wrap,
@@ -282,8 +279,7 @@ wrapPreserveSpaces p = wrapImplPreserveSpaces (toLeaves [p])
       Wrap _ -> hd : toLeaves tl
       Append hds -> toLeaves (toList hds ++ tl)
 
--- Cut a list every time a predicate changes.  Produces a list of
--- non-empty lists.
+-- | Cut a list every time a predicate changes. Produces a list of non-empty lists.
 alternations :: (LL.ListLike s c) => (c -> Bool) -> s -> [s]
 alternations p s = reverse $ go True s []
   where
@@ -301,31 +297,26 @@ group :: Pretty s -> Pretty s
 group p = Pretty (delta p) (Group p)
 
 toANSI :: Width -> Pretty CT.ColorText -> String
-toANSI avail p = CT.toANSI (render avail p)
-
-toAnsiUnbroken :: Pretty ColorText -> String
-toAnsiUnbroken p = CT.toANSI (renderUnbroken p)
+toANSI avail = CT.toANSI . render avail
 
 toPlain :: Width -> Pretty CT.ColorText -> String
-toPlain avail p = CT.toPlain (render avail p)
-
-toHTML :: String -> Width -> Pretty CT.ColorText -> String
-toHTML cssPrefix avail p = CT.toHTML cssPrefix (render avail p)
+toPlain avail = CT.toPlain . render avail
 
-toPlainUnbroken :: Pretty ColorText -> String
-toPlainUnbroken p = CT.toPlain (renderUnbroken p)
+toHTML :: String -> Pretty CT.ColorText -> String
+toHTML cssPrefix = CT.toHTML cssPrefix . render 0
 
 syntaxToColor :: Pretty (ST.SyntaxText' r) -> Pretty ColorText
 syntaxToColor = fmap $ annotateMaybe . fmap CT.defaultColors
 
--- set the syntax, overriding any present syntax
+-- | set the syntax, overriding any present syntax
 withSyntax ::
   ST.Element r -> Pretty (ST.SyntaxText' r) -> Pretty (ST.SyntaxText' r)
 withSyntax e = fmap $ ST.syntax e
 
-renderUnbroken :: (Monoid s, IsString s) => Pretty s -> s
-renderUnbroken = render maxBound
-
+-- | Renders to the underlying literal type.
+--
+--   Since `Width` less than @1@ is invalid, those values result in rendering without introducing any automatic line
+--   breaks.
 render :: (Monoid s, IsString s) => Width -> Pretty s -> s
 render availableWidth p = go mempty [Right p]
   where
@@ -355,7 +346,9 @@ render availableWidth p = go mempty [Right p]
       Wrap ps -> foldMap flow ps
 
     fits p cur =
-      maxCol (surgery cur <> delta p) < availableWidth
+      if availableWidth <= 0
+        then True
+        else maxCol (surgery cur <> delta p) < availableWidth
       where
         -- Surgically modify 'cur' to pretend it has not exceeded availableWidth.
         -- This is necessary because sometimes things cannot be split and *must*
@@ -1041,7 +1034,7 @@ plural f p = case length f of
   1 -> p
   -- todo: consider use of plural package
   _ ->
-    p <> case reverse (toPlainUnbroken p) of
+    p <> case reverse (toPlain 0 p) of
       's' : _ -> "es"
       _ -> "s"
 

parser-typechecker/src/Unison/KindInference/Solve.hs

@@ -460,4 +460,4 @@ prettyUVar :: (Var v) => PrettyPrintEnv -> UVar v loc -> P.Pretty P.ColorText
 prettyUVar ppe (UVar s t) = TP.pretty ppe t <> " :: " <> P.prettyVar s
 
 tracePretty :: P.Pretty P.ColorText -> a -> a
-tracePretty p = trace (P.toAnsiUnbroken p)
+tracePretty p = trace (P.toANSI 0 p)

parser-typechecker/src/Unison/PatternMatchCoverage.hs

@@ -82,5 +82,5 @@ checkMatch scrutineeType cases = do
   where
     title = P.bold
     doDebug out = case shouldDebug PatternCoverage of
-      True -> trace (P.toAnsiUnbroken out)
+      True -> trace (P.toANSI 0 out)
       False -> id

parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs

@@ -650,7 +650,7 @@ addConstraint con0 nc = do
                 P.hang (P.green "resulting constraint: ") (maybe "contradiction" (prettyNormalizedConstraints ppe) x),
                 ""
               ]
-       in if shouldDebug PatternCoverageConstraintSolver then trace (P.toAnsiUnbroken debugOutput) x else x
+       in if shouldDebug PatternCoverageConstraintSolver then trace (P.toANSI 0 debugOutput) x else x
 
 -- | Like 'addConstraint', but for a list of constraints
 addConstraints ::

parser-typechecker/src/Unison/PrettyPrintEnv.hs

@@ -148,6 +148,12 @@ patternName env r =
 empty :: PrettyPrintEnv
 empty = PrettyPrintEnv mempty mempty
 
+instance Semigroup PrettyPrintEnv where
+  (<>) = union
+
+instance Monoid PrettyPrintEnv where
+  mempty = empty
+
 -- | Prefer names which share a common prefix with any provided target.
 --
 -- Results are sorted according to the longest common prefix found against ANY target.

parser-typechecker/src/Unison/PrintError.hs

@@ -1127,15 +1127,18 @@ renderContext env ctx@(C.Context es) =
 
 renderTerm :: (IsString s, Var v) => Env -> Term.Term' (TypeVar.TypeVar loc0 v) v loc1 -> s
 renderTerm env e =
-  fromString (Color.toPlain $ TermPrinter.pretty' (Just 80) env (TypeVar.lowerTerm e))
+  fromString (Color.toPlain $ TermPrinter.pretty' 80 env (TypeVar.lowerTerm e))
 
 renderPattern :: Env -> Pattern ann -> ColorText
-renderPattern env e = Pr.renderUnbroken . Pr.syntaxToColor . fst $ TermPrinter.prettyPattern env TermPrinter.emptyAc Precedence.Annotation ([] :: [Symbol]) e
+renderPattern env =
+  Pr.render 0
+    . Pr.syntaxToColor
+    . fst
+    . TermPrinter.prettyPattern env TermPrinter.emptyAc Precedence.Annotation ([] :: [Symbol])
 
 -- | renders a type with no special styling
 renderType' :: (IsString s, Var v) => Env -> Type v loc -> s
-renderType' env typ =
-  fromString . Pr.toPlain defaultWidth $ renderType env (const id) typ
+renderType' env = fromString . Pr.toPlain defaultWidth . renderType env (const id)
 
 -- | `f` may do some styling based on `loc`.
 -- | You can pass `(const id)` if no styling is needed, or call `renderType'`.
@@ -1278,7 +1281,7 @@ renderNoteAsANSI ::
   String ->
   Note v a ->
   String
-renderNoteAsANSI w e s n = Pr.toANSI w $ printNoteWithSource e s n
+renderNoteAsANSI w e s = Pr.toANSI w . printNoteWithSource e s
 
 renderParseErrorAsANSI :: (Var v) => Pr.Width -> String -> Parser.Err v -> String
 renderParseErrorAsANSI w src = Pr.toANSI w . prettyParseError src

parser-typechecker/src/Unison/Syntax/TermPrinter.hs

@@ -72,7 +72,7 @@ import Unison.Var qualified as Var
 
 type SyntaxText = S.SyntaxText' Reference
 
--- Gets rid of unsightly "_eta" expansion in the pretty-printed output
+-- | Gets rid of unsightly "_eta" expansion in the pretty-printed output
 etaReduce :: (Var v) => Term3 v a -> Term3 v a
 etaReduce (LamNamed' v (App' f (Var' v'))) | v == v' && Var.name v == "_eta" = f
 etaReduce tm = tm
@@ -81,8 +81,7 @@ goPretty :: (Var v) => PrettyPrintEnv -> Term2 v at ap v a -> Pretty SyntaxText
 goPretty ppe tm = runPretty (avoidShadowing tm ppe) $ pretty0 emptyAc $ printAnnotate ppe tm
 
 pretty :: (HasCallStack, Var v) => PrettyPrintEnv -> Term v a -> Pretty ColorText
-pretty ppe tm =
-  PP.syntaxToColor $ goPretty ppe tm
+pretty ppe = PP.syntaxToColor . goPretty ppe
 
 prettyBlock :: (Var v) => Bool -> PrettyPrintEnv -> Term v a -> Pretty ColorText
 prettyBlock elideUnit ppe = PP.syntaxToColor . prettyBlock' elideUnit ppe
@@ -91,11 +90,8 @@ prettyBlock' :: (HasCallStack, Var v) => Bool -> PrettyPrintEnv -> Term v a -> P
 prettyBlock' elideUnit ppe tm =
   runPretty (avoidShadowing tm ppe) . pretty0 (emptyBlockAc {elideUnit = elideUnit}) $ printAnnotate ppe tm
 
-pretty' :: (HasCallStack, Var v) => Maybe Width -> PrettyPrintEnv -> Term v a -> ColorText
-pretty' (Just width) n t =
-  PP.render width . PP.syntaxToColor $ goPretty n t
-pretty' Nothing n t =
-  PP.renderUnbroken . PP.syntaxToColor $ goPretty n t
+pretty' :: (HasCallStack, Var v) => Width -> PrettyPrintEnv -> Term v a -> ColorText
+pretty' width n = PP.render width . pretty n
 
 -- Information about the context in which a term appears, which affects how the
 -- term should be rendered.
@@ -977,8 +973,7 @@ prettyBinding' ::
   HQ.HashQualified Name ->
   Term v a ->
   ColorText
-prettyBinding' ppe width v t =
-  PP.render width . PP.syntaxToColor $ prettyBinding ppe v t
+prettyBinding' ppe width v = PP.render width . PP.syntaxToColor . prettyBinding ppe v
 
 prettyBinding0 ::
   (HasCallStack, MonadPretty v m) =>
@@ -1918,12 +1913,12 @@ prettyDoc2 ac tm = do
       bail tm = brace <$> pretty0 ac tm
       contains :: Char -> Pretty SyntaxText -> Bool
       contains c p =
-        PP.toPlainUnbroken (PP.syntaxToColor p)
+        PP.toPlain 0 (PP.syntaxToColor p)
           & elem c
       -- Finds the longest run of a character and return one bigger than that
       longestRun c s =
         case filter (\s -> take 2 s == [c, c]) $
-          List.group (PP.toPlainUnbroken $ PP.syntaxToColor s) of
+          List.group (PP.toPlain 0 $ PP.syntaxToColor s) of
           [] -> 2
           x -> 1 + maximum (map length x)
       oneMore c inner = replicate (longestRun c inner) c
@@ -1939,7 +1934,7 @@ prettyDoc2 ac tm = do
           prettyDs <- intercalateMapM "\n\n" (go (hdr + 1)) ds
           pure $
             PP.lines
-              [ PP.text (Text.replicate (PP.widthToInt hdr) "#") <> " " <> prettyTitle,
+              [ PP.string (replicate (PP.widthToInt hdr) '#') <> " " <> prettyTitle,
                 "",
                 PP.indentN (hdr + 1) prettyDs
               ]

parser-typechecker/src/Unison/Syntax/TypePrinter.hs

@@ -32,7 +32,6 @@ import Unison.Referent (Referent)
 import Unison.Settings qualified as Settings
 import Unison.Syntax.NamePrinter (styleHashQualified'')
 import Unison.Type
-import Unison.Util.ColorText (toPlain)
 import Unison.Util.Pretty (ColorText, Pretty, Width)
 import Unison.Util.Pretty qualified as PP
 import Unison.Util.SyntaxText qualified as S
@@ -42,16 +41,13 @@ import Unison.Var qualified as Var
 type SyntaxText = S.SyntaxText' Reference
 
 pretty :: (Var v) => PrettyPrintEnv -> Type v a -> Pretty ColorText
-pretty ppe t = PP.syntaxToColor $ prettySyntax ppe t
+pretty ppe = PP.syntaxToColor . prettySyntax ppe
 
 prettySyntax :: (Var v) => PrettyPrintEnv -> Type v a -> Pretty SyntaxText
 prettySyntax ppe = runPretty ppe . pretty0 Map.empty (-1)
 
-prettyStr :: (Var v) => Maybe Width -> PrettyPrintEnv -> Type v a -> String
-prettyStr (Just width) ppe t =
-  toPlain . PP.render width . PP.syntaxToColor . runPretty ppe $ pretty0 Map.empty (-1) t
-prettyStr Nothing ppe t =
-  toPlain . PP.render maxBound . PP.syntaxToColor . runPretty ppe $ pretty0 Map.empty (-1) t
+prettyStr :: (Var v) => Width -> PrettyPrintEnv -> Type v a -> String
+prettyStr width ppe = PP.toPlain width . pretty ppe
 
 {- Explanation of precedence handling
 

parser-typechecker/src/Unison/Typechecker/Context.hs

@@ -67,6 +67,7 @@ import Data.Sequence qualified as Seq
 import Data.Sequence.NonEmpty (NESeq)
 import Data.Sequence.NonEmpty qualified as NESeq
 import Data.Set qualified as Set
+import Data.Set.NonEmpty (NESet)
 import Data.Text qualified as Text
 import Unison.ABT qualified as ABT
 import Unison.Blank qualified as B
@@ -105,7 +106,6 @@ import Unison.Typechecker.TypeLookup qualified as TL
 import Unison.Typechecker.TypeVar qualified as TypeVar
 import Unison.Var (Var)
 import Unison.Var qualified as Var
-import Data.Set.NonEmpty (NESet)
 
 type TypeVar v loc = TypeVar.TypeVar (B.Blank loc) v
 
@@ -390,12 +390,11 @@ substituteSolved ::
   [Element v loc] ->
   InfoNote v loc ->
   InfoNote v loc
-substituteSolved ctx  = \case
+substituteSolved ctx = \case
   (SolvedBlank b v t) -> SolvedBlank b v (applyCtx ctx t)
   VarBinding v loc t -> VarBinding v loc (applyCtx ctx t)
   i -> i
 
-
 -- The typechecker generates synthetic type variables as part of type inference.
 -- This function converts these synthetic type variables to regular named type
 -- variables guaranteed to not collide with any other type variables.
@@ -620,7 +619,7 @@ debugTrace e | debugEnabled = trace e False
 debugTrace _ = False
 
 showType :: (Var v) => Type.Type v a -> String
-showType ty = TP.prettyStr (Just 120) PPE.empty ty
+showType ty = TP.prettyStr 120 PPE.empty ty
 
 debugType :: (Var v) => String -> Type.Type v a -> Bool
 debugType tag ty
@@ -1120,7 +1119,7 @@ noteTopLevelType e binding typ = case binding of
 -- | Take note of the types and locations of all bindings, including let bindings, letrec
 -- bindings, lambda argument bindings and top-level bindings.
 -- This information is used to provide information to the LSP after typechecking.
-noteVarBinding :: (Var v) => v -> loc -> Type v loc ->  M v loc ()
+noteVarBinding :: (Var v) => v -> loc -> Type v loc -> M v loc ()
 noteVarBinding v loc t = btw $ VarBinding v loc t
 
 noteVarMention :: (Var v) => v -> loc -> M v loc ()
@@ -1244,7 +1243,7 @@ synthesizeWanted (Term.Let1Top' top binding boundVarAnn e) = do
   appendContext [Ann v' boundVarAnn tbinding]
   (t, w) <- synthesize (ABT.bindInheritAnnotation e (Term.var () v'))
   t <- applyM t
-  when top $ noteTopLevelType  e binding tbinding
+  when top $ noteTopLevelType e binding tbinding
   want <- coalesceWanted w wb
   -- doRetract $ Ann v' tbinding
   pure (t, want)
@@ -1328,7 +1327,7 @@ synthesizeWanted e
             synthesizeApps e ft v
 
   -- ->I=> (Full Damas Milner rule)
-  -- | Term.Lam' body <- e = do
+  -- \| Term.Lam' body <- e = do
   | (ABT.Tm' (Term.Lam (ABT.Abs' boundVarAnn body))) <- e = do
       -- arya: are there more meaningful locations we could put into and
       -- pull out of the abschain?)
@@ -1879,7 +1878,8 @@ annotateLetRecBindings isTop letrec =
           btw $
             topLevelComponent ((\(v, b) -> (Var.reset v, b, False)) . unTypeVar <$> vts)
       pure body
-    else do -- If this isn't a top-level letrec, then we don't have to do anything special
+    else do
+      -- If this isn't a top-level letrec, then we don't have to do anything special
       (body, _vts) <- annotateLetRecBindings' True
       pure body
   where
@@ -2479,7 +2479,7 @@ checkWanted want (Term.LetRecNamed' [] m) t =
 -- letrec can't have effects, so it doesn't extend the wanted set
 checkWanted want (Term.LetRecAnnotatedTop' isTop lr) t =
   markThenRetractWanted (Var.named "let-rec-marker") $ do
-    e <- annotateLetRecBindings  isTop lr
+    e <- annotateLetRecBindings isTop lr
     checkWanted want e t
 checkWanted want e@(Term.Match' scrut cases) t = do
   (scrutType, swant) <- synthesize scrut
@@ -3403,11 +3403,11 @@ instance (Var v) => Show (Element v loc) where
   show (Var v) = case v of
     TypeVar.Universal x -> "@" <> show x
     e -> show e
-  show (Solved _ v t) = "'" ++ Text.unpack (Var.name v) ++ " = " ++ TP.prettyStr Nothing PPE.empty (Type.getPolytype t)
+  show (Solved _ v t) = "'" ++ Text.unpack (Var.name v) ++ " = " ++ TP.prettyStr 0 PPE.empty (Type.getPolytype t)
   show (Ann v _loc t) =
     Text.unpack (Var.name v)
       ++ " : "
-      ++ TP.prettyStr Nothing PPE.empty t
+      ++ TP.prettyStr 0 PPE.empty t
   show (Marker v) = "|" ++ Text.unpack (Var.name v) ++ "|"
 
 instance (Ord loc, Var v) => Show (Context v loc) where
@@ -3416,8 +3416,8 @@ instance (Ord loc, Var v) => Show (Context v loc) where
       showElem _ctx (Var v) = case v of
         TypeVar.Universal x -> "@" <> show x
         e -> show e
-      showElem ctx (Solved _ v (Type.Monotype t)) = "'" ++ Text.unpack (Var.name v) ++ " = " ++ TP.prettyStr Nothing PPE.empty (apply ctx t)
-      showElem ctx (Ann v _loc t) = Text.unpack (Var.name v) ++ " : " ++ TP.prettyStr Nothing PPE.empty (apply ctx t)
+      showElem ctx (Solved _ v (Type.Monotype t)) = "'" ++ Text.unpack (Var.name v) ++ " = " ++ TP.prettyStr 0 PPE.empty (apply ctx t)
+      showElem ctx (Ann v _loc t) = Text.unpack (Var.name v) ++ " : " ++ TP.prettyStr 0 PPE.empty (apply ctx t)
       showElem _ (Marker v) = "|" ++ Text.unpack (Var.name v) ++ "|"
 
 instance (Monad f) => Monad (MT v loc f) where

parser-typechecker/tests/Unison/Test/Syntax/TypePrinter.hs

@@ -23,10 +23,7 @@ tc_diff_rtt rtt s expected width =
   let input_type = Common.t s
       get_names = PPE.makePPE (PPE.hqNamer Common.hqLength Unison.Builtin.names) PPE.dontSuffixify
       prettied = fmap toPlain $ PP.syntaxToColor . runPretty get_names $ prettyRaw Map.empty (-1) input_type
-      actual =
-        if width == 0
-          then PP.renderUnbroken $ prettied
-          else PP.render width $ prettied
+      actual = PP.render width prettied
       actual_reparsed = Common.t actual
    in scope s $
         tests