module Language.PureScript.CST.Errors
  ( ParserErrorInfo(..)
  , ParserErrorType(..)
  , ParserWarningType(..)
  , ParserError
  , ParserWarning
  , prettyPrintError
  , prettyPrintErrorMessage
  , prettyPrintWarningMessage
  ) where

import Prelude

import Data.Text qualified as Text
import Data.Char (isSpace, toUpper)
import Language.PureScript.CST.Layout (LayoutStack)
import Language.PureScript.CST.Print (printToken)
import Language.PureScript.CST.Types (SourcePos(..), SourceRange(..), SourceToken(..), Token(..))
import Text.Printf (printf)

data ParserErrorType
  = ErrWildcardInType
  | ErrConstraintInKind
  | ErrHoleInType
  | ErrExprInBinder
  | ErrExprInDeclOrBinder
  | ErrExprInDecl
  | ErrBinderInDecl
  | ErrRecordUpdateInCtr
  | ErrRecordPunInUpdate
  | ErrRecordCtrInUpdate
  | ErrTypeInConstraint
  | ErrElseInDecl
  | ErrInstanceNameMismatch
  | ErrUnknownFundep
  | ErrImportInDecl
  | ErrGuardInLetBinder
  | ErrKeywordVar
  | ErrKeywordSymbol
  | ErrQuotedPun
  | ErrToken
  | ErrLineFeedInString
  | ErrAstralCodePointInChar
  | ErrCharEscape
  | ErrNumberOutOfRange
  | ErrLeadingZero
  | ErrExpectedFraction
  | ErrExpectedExponent
  | ErrExpectedHex
  | ErrReservedSymbol
  | ErrCharInGap Char
  | ErrModuleName
  | ErrQualifiedName
  | ErrEmptyDo
  | ErrLexeme (Maybe String) [String]
  | ErrConstraintInForeignImportSyntax
  | ErrEof
  | ErrCustom String
  deriving (Int -> ParserErrorType -> ShowS
[ParserErrorType] -> ShowS
ParserErrorType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserErrorType] -> ShowS
$cshowList :: [ParserErrorType] -> ShowS
show :: ParserErrorType -> String
$cshow :: ParserErrorType -> String
showsPrec :: Int -> ParserErrorType -> ShowS
$cshowsPrec :: Int -> ParserErrorType -> ShowS
Show, ParserErrorType -> ParserErrorType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParserErrorType -> ParserErrorType -> Bool
$c/= :: ParserErrorType -> ParserErrorType -> Bool
== :: ParserErrorType -> ParserErrorType -> Bool
$c== :: ParserErrorType -> ParserErrorType -> Bool
Eq, Eq ParserErrorType
ParserErrorType -> ParserErrorType -> Bool
ParserErrorType -> ParserErrorType -> Ordering
ParserErrorType -> ParserErrorType -> ParserErrorType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ParserErrorType -> ParserErrorType -> ParserErrorType
$cmin :: ParserErrorType -> ParserErrorType -> ParserErrorType
max :: ParserErrorType -> ParserErrorType -> ParserErrorType
$cmax :: ParserErrorType -> ParserErrorType -> ParserErrorType
>= :: ParserErrorType -> ParserErrorType -> Bool
$c>= :: ParserErrorType -> ParserErrorType -> Bool
> :: ParserErrorType -> ParserErrorType -> Bool
$c> :: ParserErrorType -> ParserErrorType -> Bool
<= :: ParserErrorType -> ParserErrorType -> Bool
$c<= :: ParserErrorType -> ParserErrorType -> Bool
< :: ParserErrorType -> ParserErrorType -> Bool
$c< :: ParserErrorType -> ParserErrorType -> Bool
compare :: ParserErrorType -> ParserErrorType -> Ordering
$ccompare :: ParserErrorType -> ParserErrorType -> Ordering
Ord)

data ParserWarningType
  = WarnDeprecatedRowSyntax
  | WarnDeprecatedForeignKindSyntax
  | WarnDeprecatedKindImportSyntax
  | WarnDeprecatedKindExportSyntax
  | WarnDeprecatedCaseOfOffsideSyntax
  deriving (Int -> ParserWarningType -> ShowS
[ParserWarningType] -> ShowS
ParserWarningType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserWarningType] -> ShowS
$cshowList :: [ParserWarningType] -> ShowS
show :: ParserWarningType -> String
$cshow :: ParserWarningType -> String
showsPrec :: Int -> ParserWarningType -> ShowS
$cshowsPrec :: Int -> ParserWarningType -> ShowS
Show, ParserWarningType -> ParserWarningType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParserWarningType -> ParserWarningType -> Bool
$c/= :: ParserWarningType -> ParserWarningType -> Bool
== :: ParserWarningType -> ParserWarningType -> Bool
$c== :: ParserWarningType -> ParserWarningType -> Bool
Eq, Eq ParserWarningType
ParserWarningType -> ParserWarningType -> Bool
ParserWarningType -> ParserWarningType -> Ordering
ParserWarningType -> ParserWarningType -> ParserWarningType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ParserWarningType -> ParserWarningType -> ParserWarningType
$cmin :: ParserWarningType -> ParserWarningType -> ParserWarningType
max :: ParserWarningType -> ParserWarningType -> ParserWarningType
$cmax :: ParserWarningType -> ParserWarningType -> ParserWarningType
>= :: ParserWarningType -> ParserWarningType -> Bool
$c>= :: ParserWarningType -> ParserWarningType -> Bool
> :: ParserWarningType -> ParserWarningType -> Bool
$c> :: ParserWarningType -> ParserWarningType -> Bool
<= :: ParserWarningType -> ParserWarningType -> Bool
$c<= :: ParserWarningType -> ParserWarningType -> Bool
< :: ParserWarningType -> ParserWarningType -> Bool
$c< :: ParserWarningType -> ParserWarningType -> Bool
compare :: ParserWarningType -> ParserWarningType -> Ordering
$ccompare :: ParserWarningType -> ParserWarningType -> Ordering
Ord)

data ParserErrorInfo a = ParserErrorInfo
  { forall a. ParserErrorInfo a -> SourceRange
errRange :: SourceRange
  , forall a. ParserErrorInfo a -> [SourceToken]
errToks :: [SourceToken]
  , forall a. ParserErrorInfo a -> LayoutStack
errStack :: LayoutStack
  , forall a. ParserErrorInfo a -> a
errType :: a
  } deriving (Int -> ParserErrorInfo a -> ShowS
forall a. Show a => Int -> ParserErrorInfo a -> ShowS
forall a. Show a => [ParserErrorInfo a] -> ShowS
forall a. Show a => ParserErrorInfo a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserErrorInfo a] -> ShowS
$cshowList :: forall a. Show a => [ParserErrorInfo a] -> ShowS
show :: ParserErrorInfo a -> String
$cshow :: forall a. Show a => ParserErrorInfo a -> String
showsPrec :: Int -> ParserErrorInfo a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParserErrorInfo a -> ShowS
Show, ParserErrorInfo a -> ParserErrorInfo a -> Bool
forall a. Eq a => ParserErrorInfo a -> ParserErrorInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParserErrorInfo a -> ParserErrorInfo a -> Bool
$c/= :: forall a. Eq a => ParserErrorInfo a -> ParserErrorInfo a -> Bool
== :: ParserErrorInfo a -> ParserErrorInfo a -> Bool
$c== :: forall a. Eq a => ParserErrorInfo a -> ParserErrorInfo a -> Bool
Eq)

type ParserError = ParserErrorInfo ParserErrorType
type ParserWarning = ParserErrorInfo ParserWarningType

prettyPrintError :: ParserError -> String
prettyPrintError :: ParserError -> String
prettyPrintError pe :: ParserError
pe@ParserErrorInfo { SourceRange
errRange :: SourceRange
errRange :: forall a. ParserErrorInfo a -> SourceRange
errRange } =
  ParserError -> String
prettyPrintErrorMessage ParserError
pe forall a. Semigroup a => a -> a -> a
<> String
" at " forall a. Semigroup a => a -> a -> a
<> String
errPos
  where
  errPos :: String
errPos = case SourceRange
errRange of
    SourceRange (SourcePos Int
line Int
col) SourcePos
_ ->
      String
"line " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
line forall a. Semigroup a => a -> a -> a
<> String
", column " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
col

prettyPrintErrorMessage :: ParserError -> String
prettyPrintErrorMessage :: ParserError -> String
prettyPrintErrorMessage ParserErrorInfo {LayoutStack
[SourceToken]
SourceRange
ParserErrorType
errType :: ParserErrorType
errStack :: LayoutStack
errToks :: [SourceToken]
errRange :: SourceRange
errType :: forall a. ParserErrorInfo a -> a
errStack :: forall a. ParserErrorInfo a -> LayoutStack
errToks :: forall a. ParserErrorInfo a -> [SourceToken]
errRange :: forall a. ParserErrorInfo a -> SourceRange
..} = case ParserErrorType
errType of
  ParserErrorType
ErrWildcardInType ->
    String
"Unexpected wildcard in type; type wildcards are only allowed in value annotations"
  ParserErrorType
ErrConstraintInKind ->
    String
"Unsupported constraint in kind; constraints are only allowed in value annotations"
  ParserErrorType
ErrHoleInType ->
    String
"Unexpected hole in type; type holes are only allowed in value annotations"
  ParserErrorType
ErrExprInBinder ->
    String
"Expected pattern, saw expression"
  ParserErrorType
ErrExprInDeclOrBinder ->
    String
"Expected declaration or pattern, saw expression"
  ParserErrorType
ErrExprInDecl ->
    String
"Expected declaration, saw expression"
  ParserErrorType
ErrBinderInDecl ->
    String
"Expected declaration, saw pattern"
  ParserErrorType
ErrRecordUpdateInCtr ->
    String
"Expected ':', saw '='"
  ParserErrorType
ErrRecordPunInUpdate ->
    String
"Expected record update, saw pun"
  ParserErrorType
ErrRecordCtrInUpdate ->
    String
"Expected '=', saw ':'"
  ParserErrorType
ErrTypeInConstraint ->
    String
"Expected constraint, saw type"
  ParserErrorType
ErrElseInDecl ->
    String
"Expected declaration, saw 'else'"
  ParserErrorType
ErrInstanceNameMismatch ->
    String
"All instances in a chain must implement the same type class"
  ParserErrorType
ErrUnknownFundep ->
    String
"Unknown type variable in functional dependency"
  ParserErrorType
ErrImportInDecl ->
    String
"Expected declaration, saw 'import'"
  ParserErrorType
ErrGuardInLetBinder ->
    String
"Unexpected guard in let pattern"
  ParserErrorType
ErrKeywordVar ->
    String
"Expected variable, saw keyword"
  ParserErrorType
ErrKeywordSymbol ->
    String
"Expected symbol, saw reserved symbol"
  ParserErrorType
ErrQuotedPun ->
    String
"Unexpected quoted label in record pun, perhaps due to a missing ':'"
  ParserErrorType
ErrEof ->
    String
"Unexpected end of input"
  ErrLexeme (Just (Char
hd : String
_)) [String]
_ | Char -> Bool
isSpace Char
hd ->
    String
"Illegal whitespace character " forall a. Semigroup a => a -> a -> a
<> Char -> String
displayCodePoint Char
hd
  ErrLexeme (Just String
a) [String]
_ ->
    String
"Unexpected " forall a. Semigroup a => a -> a -> a
<> String
a
  ParserErrorType
ErrLineFeedInString ->
    String
"Unexpected line feed in string literal"
  ParserErrorType
ErrAstralCodePointInChar ->
    String
"Illegal astral code point in character literal"
  ParserErrorType
ErrCharEscape ->
    String
"Illegal character escape code"
  ParserErrorType
ErrNumberOutOfRange ->
    String
"Number literal is out of range"
  ParserErrorType
ErrLeadingZero ->
    String
"Unexpected leading zeros"
  ParserErrorType
ErrExpectedFraction ->
    String
"Expected fraction"
  ParserErrorType
ErrExpectedExponent ->
    String
"Expected exponent"
  ParserErrorType
ErrExpectedHex ->
    String
"Expected hex digit"
  ParserErrorType
ErrReservedSymbol ->
    String
"Unexpected reserved symbol"
  ErrCharInGap Char
ch ->
    String
"Unexpected character '" forall a. Semigroup a => a -> a -> a
<> [Char
ch] forall a. Semigroup a => a -> a -> a
<> String
"' in gap"
  ParserErrorType
ErrModuleName ->
    String
"Invalid module name; underscores and primes are not allowed in module names"
  ParserErrorType
ErrQualifiedName ->
    String
"Unexpected qualified name"
  ParserErrorType
ErrEmptyDo ->
    String
"Expected do statement"
  ErrLexeme Maybe String
_ [String]
_ ->
    String
basicError
  ParserErrorType
ErrConstraintInForeignImportSyntax ->
    String
"Constraints are not allowed in foreign imports. Omit the constraint instead and update the foreign module accordingly."
  ParserErrorType
ErrToken
    | SourceToken TokenAnn
_ (TokLeftArrow SourceStyle
_) : [SourceToken]
_ <- [SourceToken]
errToks ->
        String
"Unexpected \"<-\" in expression, perhaps due to a missing 'do' or 'ado' keyword"
  ParserErrorType
ErrToken ->
    String
basicError
  ErrCustom String
err ->
    String
err

  where
  basicError :: String
basicError = case [SourceToken]
errToks of
    SourceToken
tok : [SourceToken]
_ -> Token -> String
basicTokError (SourceToken -> Token
tokValue SourceToken
tok)
    [] -> String
"Unexpected input"

  basicTokError :: Token -> String
basicTokError = \case
    Token
TokLayoutStart -> String
"Unexpected or mismatched indentation"
    Token
TokLayoutSep   -> String
"Unexpected or mismatched indentation"
    Token
TokLayoutEnd   -> String
"Unexpected or mismatched indentation"
    Token
TokEof         -> String
"Unexpected end of input"
    Token
tok            -> String
"Unexpected token '" forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (Token -> Text
printToken Token
tok) forall a. Semigroup a => a -> a -> a
<> String
"'"

  displayCodePoint :: Char -> String
  displayCodePoint :: Char -> String
displayCodePoint Char
x =
    String
"U+" forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (forall r. PrintfType r => String -> r
printf String
"%0.4x" (forall a. Enum a => a -> Int
fromEnum Char
x))

prettyPrintWarningMessage :: ParserWarning -> String
prettyPrintWarningMessage :: ParserWarning -> String
prettyPrintWarningMessage ParserErrorInfo {LayoutStack
[SourceToken]
SourceRange
ParserWarningType
errType :: ParserWarningType
errStack :: LayoutStack
errToks :: [SourceToken]
errRange :: SourceRange
errType :: forall a. ParserErrorInfo a -> a
errStack :: forall a. ParserErrorInfo a -> LayoutStack
errToks :: forall a. ParserErrorInfo a -> [SourceToken]
errRange :: forall a. ParserErrorInfo a -> SourceRange
..} = case ParserWarningType
errType of
  ParserWarningType
WarnDeprecatedRowSyntax ->
    String
"Unary '#' syntax for row kinds is deprecated and will be removed in a future release. Use the 'Row' kind instead."
  ParserWarningType
WarnDeprecatedForeignKindSyntax ->
    String
"Foreign kind imports are deprecated and will be removed in a future release. Use empty 'data' instead."
  ParserWarningType
WarnDeprecatedKindImportSyntax ->
    String
"Kind imports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead."
  ParserWarningType
WarnDeprecatedKindExportSyntax ->
    String
"Kind exports are deprecated and will be removed in a future release. Omit the 'kind' keyword instead."
  ParserWarningType
WarnDeprecatedCaseOfOffsideSyntax ->
    String
"Dedented expressions in case branches are deprecated and will be removed in a future release. Indent the branch's expression past it's binder instead."