module Inferno.Parse.Error where

import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NEList
import Data.Maybe (isNothing)
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text, pack, replace, unpack)
import Text.Megaparsec
  ( ErrorFancy (..),
    ErrorItem (..),
    ParseError (..),
    ShowErrorComponent (..),
    Stream (Token),
    unPos,
  )
import Text.Megaparsec.Stream (showTokens)

drop_ :: String -> String
drop_ :: String -> String
drop_ String
"" = String
""
drop_ (Char
'_' : String
xs) = String
xs
drop_ String
xs = String
xs

orList :: NonEmpty Text -> String
orList :: NonEmpty Text -> String
orList (Text
x :| []) = String -> String
drop_ forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
x
orList NonEmpty Text
xs =
  String
"one of the following:\n∙ "
    forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
intercalate String
"\n∙ " (forall a b. (a -> b) -> [a] -> [b]
map (String -> String
drop_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
replace Text
"\n" Text
"\n  ") forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NEList.toList NonEmpty Text
xs)

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

messageItemsPretty ::
  -- | Prefix to prepend
  String ->
  -- | Collection of messages
  Set String ->
  -- | Result of rendering
  String
messageItemsPretty :: String -> Set String -> String
messageItemsPretty String
prefix Set String
ts
  | forall a. Set a -> Bool
Set.null Set String
ts = String
""
  | Bool
otherwise =
    String
prefix forall a. Semigroup a => a -> a -> a
<> (NonEmpty Text -> String
orList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> NonEmpty a
NEList.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map String -> Text
pack) Set String
ts forall a. Semigroup a => a -> a -> a
<> String
"\n"

showErrorFancy :: ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy :: forall e. ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy = \case
  ErrorFail String
msg -> String
msg
  ErrorIndentation Ordering
ord Pos
ref Pos
actual ->
    String
"incorrect indentation (got " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
actual)
      forall a. Semigroup a => a -> a -> a
<> String
", should be "
      forall a. Semigroup a => a -> a -> a
<> String
p
      forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Pos -> Int
unPos Pos
ref)
      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 "
  ErrorCustom e
a -> forall a. ShowErrorComponent a => a -> String
showErrorComponent e
a

prettyError ::
  ShowErrorComponent e =>
  -- | Parse error to render
  ParseError Text e ->
  String
prettyError :: forall e. ShowErrorComponent e => ParseError Text e -> String
prettyError (TrivialError Int
_ Maybe (ErrorItem (Token Text))
us Set (ErrorItem (Token Text))
ps) =
  if forall a. Maybe a -> Bool
isNothing Maybe (ErrorItem (Token Text))
us Bool -> Bool -> Bool
&& forall a. Set a -> Bool
Set.null Set (ErrorItem (Token Text))
ps
    then String
"unknown parse error\n"
    else
      String -> Set String -> String
messageItemsPretty String
"unexpected " (ErrorItem (Token Text) -> String
showErrorItem forall b a. Ord b => (a -> b) -> Set a -> Set b
`Set.map` forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Set a
Set.empty forall a. a -> Set a
Set.singleton Maybe (ErrorItem (Token Text))
us)
        forall a. Semigroup a => a -> a -> a
<> String -> Set String -> String
messageItemsPretty String
"expecting " (ErrorItem (Token Text) -> String
showErrorItem forall b a. Ord b => (a -> b) -> Set a -> Set b
`Set.map` Set (ErrorItem (Token Text))
ps)
prettyError (FancyError Int
_ Set (ErrorFancy e)
xs) =
  if forall a. Set a -> Bool
Set.null Set (ErrorFancy e)
xs
    then String
"unknown fancy parse error\n"
    else [String] -> String
unlines (forall e. ShowErrorComponent e => ErrorFancy e -> String
showErrorFancy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toAscList Set (ErrorFancy e)
xs)