module Unison.Util.Pretty.MegaParsec where

import Data.List.NonEmpty qualified as NE
import Data.Proxy
import Data.Void
import Text.Megaparsec qualified as Parser
import Unison.Prelude
import Unison.Util.Pretty qualified as P

prettyPrintParseError :: String -> Parser.ParseErrorBundle Text Void -> P.Pretty P.ColorText
prettyPrintParseError :: String -> ParseErrorBundle Text Void -> Pretty ColorText
prettyPrintParseError String
input ParseErrorBundle Text Void
errBundle =
  let (ParseError Text Void
firstError, SourcePos
sp) = NonEmpty (ParseError Text Void, SourcePos)
-> (ParseError Text Void, SourcePos)
forall a. NonEmpty a -> a
NE.head (NonEmpty (ParseError Text Void, SourcePos)
 -> (ParseError Text Void, SourcePos))
-> ((NonEmpty (ParseError Text Void, SourcePos), PosState Text)
    -> NonEmpty (ParseError Text Void, SourcePos))
-> (NonEmpty (ParseError Text Void, SourcePos), PosState Text)
-> (ParseError Text Void, SourcePos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (ParseError Text Void, SourcePos), PosState Text)
-> NonEmpty (ParseError Text Void, SourcePos)
forall a b. (a, b) -> a
fst ((NonEmpty (ParseError Text Void, SourcePos), PosState Text)
 -> (ParseError Text Void, SourcePos))
-> (NonEmpty (ParseError Text Void, SourcePos), PosState Text)
-> (ParseError Text Void, SourcePos)
forall a b. (a -> b) -> a -> b
$ (ParseError Text Void -> Int)
-> NonEmpty (ParseError Text Void)
-> PosState Text
-> (NonEmpty (ParseError Text Void, SourcePos), PosState Text)
forall (t :: * -> *) s a.
(Traversable t, TraversableStream s) =>
(a -> Int) -> t a -> PosState s -> (t (a, SourcePos), PosState s)
Parser.attachSourcePos ParseError Text Void -> Int
forall s e. ParseError s e -> Int
Parser.errorOffset (ParseErrorBundle Text Void -> NonEmpty (ParseError Text Void)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
Parser.bundleErrors ParseErrorBundle Text Void
errBundle) (ParseErrorBundle Text Void -> PosState Text
forall s e. ParseErrorBundle s e -> PosState s
Parser.bundlePosState ParseErrorBundle Text Void
errBundle)
   in case ParseError Text Void
firstError of
        Parser.TrivialError Int
_errorOffset Maybe (ErrorItem (Token Text))
ue Set (ErrorItem (Token Text))
ee ->
          [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
            [ SourcePos -> Pretty ColorText
printLocation SourcePos
sp,
              Pretty ColorText
forall s. IsString s => Pretty s
P.newline,
              Maybe (ErrorItem Char) -> Set (ErrorItem Char) -> Pretty ColorText
printTrivial Maybe (ErrorItem Char)
Maybe (ErrorItem (Token Text))
ue Set (ErrorItem Char)
Set (ErrorItem (Token Text))
ee
            ]
        Parser.FancyError Int
_errorOffset Set (ErrorFancy Void)
ee ->
          let errors :: Pretty ColorText
errors = (ErrorFancy Void -> Pretty ColorText)
-> Set (ErrorFancy Void) -> Pretty ColorText
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (String -> Pretty ColorText)
-> (ErrorFancy Void -> String)
-> ErrorFancy Void
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. Monoid a => a -> a -> a
mappend String
"\n" (String -> String)
-> (ErrorFancy Void -> String) -> ErrorFancy Void -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorFancy Void -> String
forall e. ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy) Set (ErrorFancy Void)
ee
           in [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
                [ SourcePos -> Pretty ColorText
printLocation SourcePos
sp,
                  Pretty ColorText
errors
                ]
  where
    printLocation :: Parser.SourcePos -> P.Pretty P.ColorText
    printLocation :: SourcePos -> Pretty ColorText
printLocation SourcePos
sp =
      let col :: Int
col = (Pos -> Int
Parser.unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
Parser.sourceColumn SourcePos
sp) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          row :: Int
row = (Pos -> Int
Parser.unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
Parser.sourceLine SourcePos
sp) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          errorLine :: String
errorLine = String -> [String]
lines String
input [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
row
       in [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
f (Pretty s) -> Pretty s
P.lines
            [ Pretty ColorText
forall s. IsString s => Pretty s
P.newline,
              String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string String
errorLine,
              String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (String -> Pretty ColorText) -> String -> Pretty ColorText
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
Prelude.replicate Int
col Char
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"^-- This is where I gave up."
            ]

    printTrivial :: (Maybe (Parser.ErrorItem Char)) -> (Set (Parser.ErrorItem Char)) -> P.Pretty P.ColorText
    printTrivial :: Maybe (ErrorItem Char) -> Set (ErrorItem Char) -> Pretty ColorText
printTrivial Maybe (ErrorItem Char)
ue Set (ErrorItem Char)
ee =
      let expected :: Pretty ColorText
expected = Pretty ColorText
"I expected " Pretty ColorText -> Pretty ColorText -> Pretty ColorText
forall a. Semigroup a => a -> a -> a
<> (ErrorItem Char -> Pretty ColorText)
-> Set (ErrorItem Char) -> Pretty ColorText
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Pretty ColorText -> Pretty ColorText
forall s. IsString s => Pretty s -> Pretty s
P.singleQuoted (Pretty ColorText -> Pretty ColorText)
-> (ErrorItem Char -> Pretty ColorText)
-> ErrorItem Char
-> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (String -> Pretty ColorText)
-> (ErrorItem Char -> String) -> ErrorItem Char -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorItem Char -> String
ErrorItem (Token Text) -> String
showErrorItem) Set (ErrorItem Char)
ee
          found :: Maybe (Pretty ColorText)
found = String -> Pretty ColorText
forall s. IsString s => String -> Pretty s
P.string (String -> Pretty ColorText)
-> (ErrorItem Char -> String) -> ErrorItem Char -> Pretty ColorText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall a. Monoid a => a -> a -> a
mappend String
"I found " (String -> String)
-> (ErrorItem Char -> String) -> ErrorItem Char -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorItem Char -> String
ErrorItem (Token Text) -> String
showErrorItem (ErrorItem Char -> Pretty ColorText)
-> Maybe (ErrorItem Char) -> Maybe (Pretty ColorText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (ErrorItem Char)
ue
          message :: [Pretty ColorText]
message = [Pretty ColorText
expected] [Pretty ColorText] -> [Pretty ColorText] -> [Pretty ColorText]
forall a. Semigroup a => a -> a -> a
<> [Maybe (Pretty ColorText)] -> [Pretty ColorText]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Pretty ColorText)
found]
       in Pretty ColorText -> [Pretty ColorText] -> Pretty ColorText
forall (f :: * -> *) s.
(Foldable f, IsString s) =>
Pretty s -> f (Pretty s) -> Pretty s
P.oxfordCommasWith Pretty ColorText
"." [Pretty ColorText]
message

showErrorFancy :: (Parser.ShowErrorComponent e) => Parser.ErrorFancy e -> String
showErrorFancy :: forall e. ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy (Parser.ErrorFail String
msg) = String
msg
showErrorFancy (Parser.ErrorIndentation Ordering
ord Pos
ref Pos
actual) =
  String
"incorrect indentation (got "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Pos -> Int
Parser.unPos Pos
actual)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", should be "
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
p
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Pos -> Int
Parser.unPos Pos
ref)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
  where
    p :: String
p = case Ordering
ord of
      Ordering
LT -> String
"less than "
      Ordering
EQ -> String
"equal to "
      Ordering
GT -> String
"greater than "
showErrorFancy (Parser.ErrorCustom e
a) = e -> String
forall a. ShowErrorComponent a => a -> String
Parser.showErrorComponent e
a

showErrorItem :: Parser.ErrorItem (Parser.Token Text) -> String
showErrorItem :: ErrorItem (Token Text) -> String
showErrorItem (Parser.Tokens NonEmpty (Token Text)
ts) = Proxy Text -> NonEmpty (Token Text) -> String
forall s. VisualStream s => Proxy s -> NonEmpty (Token s) -> String
Parser.showTokens (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Text) NonEmpty (Token Text)
ts
showErrorItem (Parser.Label NonEmpty Char
label) = NonEmpty Char -> String
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Char
label
showErrorItem ErrorItem (Token Text)
Parser.EndOfInput = String
"end of input"