Generalize to pretty text

parser-typechecker/src/Unison/PrintError.hs

@@ -16,6 +16,7 @@ where
 
 import Control.Lens ((%~))
 import Control.Lens.Tuple (_1, _2, _3)
+import Data.Foldable qualified as Foldable
 import Data.Function (on)
 import Data.List (find, intersperse, sortBy)
 import Data.List.Extra (nubOrd)
@@ -1498,19 +1499,42 @@ renderParseErrors s = \case
               "",
               style ErrorSite msg
             ]
-  P.TrivialError errOffset unexpected expected ->
-    let (src, ranges) = case unexpected of
-          Just (P.Tokens (toList -> ts)) -> case ts of
-            [] -> (mempty, [])
-            _ ->
-              let rs = rangeForToken <$> ts
-               in (showSource s $ (\r -> (r, ErrorSite)) <$> rs, rs)
-          _ -> mempty
-        -- Same error that we just pattern matched on, but with a different error component (here Void) - we need one
-        -- with a ShowErrorComponent instance, which our error type doesn't have.
-        sameErr :: P.ParseError Parser.Input Void
-        sameErr = P.TrivialError errOffset unexpected expected
-     in [(fromString (P.parseErrorPretty sameErr) <> src, ranges)]
+  P.TrivialError _errOffset unexpected expected ->
+    let unexpectedTokens :: Maybe (Nel.NonEmpty (L.Token L.Lexeme))
+        unexpectedTokenStrs :: Set String
+        (unexpectedTokens, unexpectedTokenStrs) = case unexpected of
+          Just (P.Tokens ts) ->
+            Foldable.toList ts
+              & fmap (L.displayLexeme . L.payload)
+              & Set.fromList
+              & (Just ts,)
+          Just (P.Label ts) -> (mempty, Set.singleton $ Foldable.toList ts)
+          Just (P.EndOfInput) -> (mempty, Set.singleton "end of input")
+          Nothing -> (mempty, mempty)
+        expectedTokenStrs :: Set String
+        expectedTokenStrs =
+          expected & foldMap \case
+            (P.Tokens ts) ->
+              Foldable.toList ts
+                & fmap (L.displayLexeme . L.payload)
+                & Set.fromList
+            (P.Label ts) -> Set.singleton $ Foldable.toList ts
+            (P.EndOfInput) -> Set.singleton "end of input"
+        ranges = case unexpectedTokens of
+          Nothing -> []
+          Just ts -> rangeForToken <$> Foldable.toList ts
+        excerpt = showSource s ((\r -> (r, ErrorSite)) <$> ranges)
+        msg = L.formatTrivialError _ unexpectedTokenStrs expectedTokenStrs
+     in [ ( Pr.lines
+              [ "I got confused here:",
+                "",
+                excerpt,
+                "",
+                style ErrorSite msg
+              ],
+            ranges
+          )
+        ]
   P.FancyError _sp fancyErrors ->
     (go' <$> Set.toList fancyErrors)
   where

unison-syntax/src/Unison/Syntax/Lexer.hs

@@ -22,6 +22,10 @@ module Unison.Syntax.Lexer
     wordyIdChar,
     wordyIdStartChar,
     symbolyIdChar,
+
+    -- * Error formatting
+    formatTrivialError,
+    displayLexeme,
   )
 where
 
@@ -50,6 +54,7 @@ import Unison.NameSegment (NameSegment)
 import Unison.NameSegment qualified as NameSegment
 import Unison.Prelude
 import Unison.ShortHash (ShortHash)
+import Unison.ShortHash qualified as SH
 import Unison.Syntax.HashQualified' qualified as HQ' (toText)
 import Unison.Syntax.Lexer.Token (Token (..), posP, tokenP)
 import Unison.Syntax.Name qualified as Name (isSymboly, nameP, toText, unsafeParseText)
@@ -267,17 +272,21 @@ lexer0' scope rem =
               let msg = intercalateMap "\n" showErrorFancy es
                in [Token (Err (UnexpectedTokens msg)) (toPos top) (toPos top)]
             P.TrivialError _errOffset mayUnexpectedTokens expectedTokens ->
-              let mayUnexpectedStr :: Maybe String
-                  mayUnexpectedStr = errorItemToString <$> mayUnexpectedTokens
+              let unexpectedStr :: Set String
+                  unexpectedStr =
+                    mayUnexpectedTokens
+                      & fmap errorItemToString
+                      & maybeToList
+                      & Set.fromList
                   expectedStr :: Set String
                   expectedStr =
                     expectedTokens
                       & Set.map errorItemToString
-                  err = UnexpectedTokens $ case (mayUnexpectedStr, Set.toList expectedStr) of
-                    (Nothing, []) -> "I found something I didn't expect."
-                    (Nothing, xs) -> "I found something I didn't expect here. I was hoping for one of these instead:\n\n* " <> List.intercalate "\n* " xs
-                    (Just x, []) -> "I was surprised to find the text '" <> x <> "' here."
-                    (Just x, xs) -> "I was surprised to find the text '" <> x <> "' here. I was hoping for one of these instead:\n\n* " <> List.intercalate "\n* " xs
+                  startsWithVowel :: String -> Bool
+                  startsWithVowel = \case
+                    [] -> False
+                    (ch : _) -> ch `elem` ("aeiou" :: String)
+                  err = UnexpectedTokens $ formatTrivialError startsWithVowel unexpectedStr expectedStr
                in [Token (Err err) (toPos top) (toPos top)]
        in errsWithSourcePos >>= errorToTokens
     Right ts -> Token (Open scope) topLeftCorner topLeftCorner : tweak ts
@@ -313,6 +322,46 @@ lexer0' scope rem =
     tweak (h : t) = h : tweak t
     isSigned num = all (\ch -> ch == '-' || ch == '+') $ take 1 num
 
+formatTrivialError ::
+  (IsString s, Monoid s) =>
+  -- | A function that returns True if the given string starts with a vowel,
+  -- Used for selecting the correct article.
+  (s -> Bool) ->
+  Set s ->
+  Set s ->
+  s
+formatTrivialError startsWithVowel unexpectedTokens expectedTokens =
+  let unexpectedMsg = case Set.toList unexpectedTokens of
+        [] -> "I found something I didn't expect."
+        [x] ->
+          let article =
+                if startsWithVowel x
+                  then "an"
+                  else "a"
+           in "I was surprised to find " <> article <> " " <> x <> " here."
+        xs -> "I was surprised to find these:\n\n* " <> intercalateMap "\n* " id xs
+      expectedMsg = case Set.toList expectedTokens of
+        [] -> Nothing
+        xs -> Just $ "\nI was hoping for one of these instead:\n\n* " <> intercalateMap "\n* " id xs
+   in mconcat $ catMaybes [Just unexpectedMsg, expectedMsg]
+
+displayLexeme :: Lexeme -> String
+displayLexeme = \case
+  Open o -> o
+  Semi True -> "end of section"
+  Semi False -> "semicolon"
+  Close -> "end of section"
+  Reserved r -> "'" <> r <> "'"
+  Textual t -> "\"" <> t <> "\""
+  Character c -> "?" <> [c]
+  WordyId hq -> Text.unpack (HQ'.toTextWith Name.toText hq)
+  SymbolyId hq -> Text.unpack (HQ'.toTextWith Name.toText hq)
+  Blank b -> b
+  Numeric n -> n
+  Bytes _b -> "bytes literal"
+  Hash h -> Text.unpack (SH.toText h)
+  Err e -> show e
+
 infixl 2 <+>
 
 (<+>) :: (Monoid a) => P a -> P a -> P a