Errors.hs

{-# LANGUAGE Safe #-}
{-# LANGUAGE NoMonomorphismRestriction, BlockArguments, OverloadedLists, OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Text.Gigaparsec.Token.Errors (
    ErrorConfig(
      labelNumericBreakChar, labelIntegerUnsignedDecimal,
      labelIntegerUnsignedHexadecimal, labelIntegerUnsignedOctal,
      labelIntegerUnsignedBinary, labelIntegerUnsignedNumber,
      labelIntegerSignedDecimal,
      labelIntegerSignedHexadecimal, labelIntegerSignedOctal,
      labelIntegerSignedBinary, labelIntegerSignedNumber,
      labelIntegerDecimalEnd,
      labelIntegerHexadecimalEnd, labelIntegerOctalEnd,
      labelIntegerBinaryEnd, labelIntegerNumberEnd,
      filterIntegerOutOfBounds,
      labelNameIdentifier, labelNameOperator,
      unexpectedNameIllegalIdentifier, unexpectedNameIllegalOperator,
      filterNameIllFormedIdentifier, filterNameIllFormedOperator,
      labelCharAscii, labelCharLatin1, labelCharUnicode,
      labelCharAsciiEnd, labelCharLatin1End, labelCharUnicodeEnd,
      labelStringAscii, labelStringLatin1, labelStringUnicode,
      labelStringAsciiEnd, labelStringLatin1End, labelStringUnicodeEnd,
      labelStringCharacter, labelGraphicCharacter, labelEscapeSequence,
      labelEscapeNumeric, labelEscapeNumericEnd, labelEscapeEnd,
      labelStringEscapeEmpty, labelStringEscapeGap, labelStringEscapeGapEnd,
      filterCharNonAscii, filterCharNonLatin1, filterStringNonAscii, filterStringNonLatin1,
      filterEscapeCharRequiresExactDigits, filterEscapeCharNumericSequenceIllegal,
      verifiedCharBadCharsUsedInLiteral, verifiedStringBadCharsUsedInLiteral,
      labelSymbol, labelSymbolEndOfKeyword, labelSymbolEndOfOperator,
      labelSpaceEndOfLineComment, labelSpaceEndOfMultiComment
    ),
    defaultErrorConfig,
    LabelWithExplainConfig, LabelWithExplainConfigurable(..),
    LabelConfig, LabelConfigurable(..),
    ExplainConfig, ExplainConfigurable(..),
    NotConfigurable(..),
    FilterConfig,
    VanillaFilterConfig, VanillaFilterConfigurable(..),
    SpecializedFilterConfig, SpecializedFilterConfigurable(..),
    BasicFilterConfigurable(..),
    VerifiedBadChars, badCharsFail, badCharsReason,
    Unverified(..),
    Bits(B8, B16, B32, B64)
  ) where

import Data.Set (Set)
import Data.Map (Map)
import Data.Map qualified as Map (empty)
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List.NonEmpty qualified as NonEmpty (toList)
import Data.Kind (Constraint)
import Text.Gigaparsec.Internal.Token.BitBounds (Bits(B8, B16, B32, B64))
import Numeric (showIntAtBase)
import Data.Char (intToDigit, ord)
import Text.Gigaparsec.Errors.DefaultErrorBuilder (from, disjunct, toString)
import Text.Gigaparsec.Internal.Token.Errors (
    LabelWithExplainConfig(LELabelAndReason, LELabel, LEHidden, LEReason, LENotConfigured),
    LabelConfig(LLabel, LHidden, LNotConfigured), ExplainConfig(EReason, ENotConfigured),
    FilterConfig(VSBecause, VSUnexpected, VSUnexpectedBecause, VSBasicFilter, VSSpecializedFilter),
    SpecializedFilterConfig(SSpecializedFilter, SBasicFilter),
    VanillaFilterConfig(VBecause, VUnexpected, VUnexpectedBecause, VBasicFilter),
    VerifiedBadChars(BadCharsUnverified, BadCharsFail, BadCharsReason)
  )

type ErrorConfig :: *
data ErrorConfig =
  ErrorConfig { labelNumericBreakChar :: !LabelWithExplainConfig
              , labelIntegerUnsignedDecimal :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerUnsignedHexadecimal :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerUnsignedOctal :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerUnsignedBinary :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerUnsignedNumber :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerSignedDecimal :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerSignedHexadecimal :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerSignedOctal :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerSignedBinary :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerSignedNumber :: Maybe Bits -> LabelWithExplainConfig
              , labelIntegerDecimalEnd :: LabelConfig
              , labelIntegerHexadecimalEnd :: LabelConfig
              , labelIntegerOctalEnd :: LabelConfig
              , labelIntegerBinaryEnd :: LabelConfig
              , labelIntegerNumberEnd :: LabelConfig
              , filterIntegerOutOfBounds :: Integer -> Integer -> Int -> FilterConfig Integer
              , labelNameIdentifier :: String
              , labelNameOperator :: String
              , unexpectedNameIllegalIdentifier :: String -> String
              , unexpectedNameIllegalOperator :: String -> String
              , filterNameIllFormedIdentifier :: FilterConfig String
              , filterNameIllFormedOperator :: FilterConfig String
              , labelCharAscii :: LabelWithExplainConfig
              , labelCharLatin1 :: LabelWithExplainConfig
              , labelCharUnicode :: LabelWithExplainConfig
              , labelCharAsciiEnd :: LabelConfig
              , labelCharLatin1End :: LabelConfig
              , labelCharUnicodeEnd :: LabelConfig
              , labelStringAscii :: Bool -> Bool -> LabelWithExplainConfig
              , labelStringLatin1 :: Bool -> Bool -> LabelWithExplainConfig
              , labelStringUnicode :: Bool -> Bool -> LabelWithExplainConfig
              , labelStringAsciiEnd :: Bool -> Bool -> LabelConfig
              , labelStringLatin1End :: Bool -> Bool -> LabelConfig
              , labelStringUnicodeEnd :: Bool -> Bool -> LabelConfig
              , labelStringCharacter :: LabelConfig
              , labelGraphicCharacter :: LabelWithExplainConfig
              , labelEscapeSequence :: LabelWithExplainConfig
              , labelEscapeNumeric :: Int -> LabelWithExplainConfig
              , labelEscapeNumericEnd :: Char -> Int -> LabelWithExplainConfig
              , labelEscapeEnd :: LabelWithExplainConfig
              , labelStringEscapeEmpty :: LabelConfig
              , labelStringEscapeGap :: LabelConfig
              , labelStringEscapeGapEnd :: LabelConfig
              , filterCharNonAscii :: VanillaFilterConfig Char
              , filterCharNonLatin1 :: VanillaFilterConfig Char
              , filterStringNonAscii :: SpecializedFilterConfig String
              , filterStringNonLatin1 :: SpecializedFilterConfig String
              , filterEscapeCharRequiresExactDigits :: Int -> NonEmpty Word -> SpecializedFilterConfig Word
              , filterEscapeCharNumericSequenceIllegal :: Char -> Int -> SpecializedFilterConfig Integer
              , verifiedCharBadCharsUsedInLiteral :: VerifiedBadChars
              , verifiedStringBadCharsUsedInLiteral :: VerifiedBadChars
              , labelSymbol :: Map String LabelWithExplainConfig
              -- don't bother with these until parsley standardises
              --, defaultSymbolKeyword :: Labeller
              --, defaultSymbolOperator :: Labeller
              --, defaultSymbolPunctuaton :: Labeller
              , labelSymbolEndOfKeyword :: String -> String
              , labelSymbolEndOfOperator :: String -> String
              , labelSpaceEndOfLineComment :: LabelWithExplainConfig
              , labelSpaceEndOfMultiComment :: LabelWithExplainConfig
              }

defaultErrorConfig :: ErrorConfig
defaultErrorConfig = ErrorConfig {..}
  where labelNumericBreakChar = notConfigured
        labelIntegerUnsignedDecimal = const notConfigured
        labelIntegerUnsignedHexadecimal = const notConfigured
        labelIntegerUnsignedOctal = const notConfigured
        labelIntegerUnsignedBinary = const notConfigured
        labelIntegerUnsignedNumber = const notConfigured
        labelIntegerSignedDecimal = const notConfigured
        labelIntegerSignedHexadecimal = const notConfigured
        labelIntegerSignedOctal = const notConfigured
        labelIntegerSignedBinary = const notConfigured
        labelIntegerSignedNumber = const notConfigured
        labelIntegerDecimalEnd = notConfigured
        labelIntegerHexadecimalEnd = notConfigured
        labelIntegerOctalEnd = notConfigured
        labelIntegerBinaryEnd = notConfigured
        labelIntegerNumberEnd = notConfigured
        filterIntegerOutOfBounds small big nativeRadix = specializedFilter
          (outOfBounds small big nativeRadix)
        labelNameIdentifier = "identifier"
        labelNameOperator = "operator"
        unexpectedNameIllegalIdentifier = ("keyword " ++)
        unexpectedNameIllegalOperator = ("reserved operator " ++)
        filterNameIllFormedIdentifier = unexpected ("identifier " ++)
        filterNameIllFormedOperator = unexpected ("operator " ++)
        labelCharAscii = notConfigured
        labelCharLatin1 = notConfigured
        labelCharUnicode = notConfigured
        labelCharAsciiEnd = notConfigured
        labelCharLatin1End = notConfigured
        labelCharUnicodeEnd = notConfigured
        labelStringAscii _ _ = notConfigured
        labelStringLatin1 _ _ = notConfigured
        labelStringUnicode _ _ = notConfigured
        labelStringAsciiEnd _ _ = notConfigured
        labelStringLatin1End _ _ = notConfigured
        labelStringUnicodeEnd _ _ = notConfigured
        labelStringCharacter = label ["string character"]
        labelGraphicCharacter = label ["graphic character"]
        labelEscapeSequence = label ["escape sequence"]
        labelEscapeNumeric _ = notConfigured
        labelEscapeNumericEnd _ _ = notConfigured
        labelEscapeEnd = labelAndReason ["end of escape sequence"] "invalid escape sequence"
        labelStringEscapeEmpty = notConfigured
        labelStringEscapeGap = label ["string gap"]
        labelStringEscapeGapEnd = label ["end of string gap"]
        filterCharNonAscii = because (const "non-ascii character")
        filterCharNonLatin1 = because (const "non-latin1 character")
        filterStringNonAscii =
          specializedFilter (const ["non-ascii characters in string literal, this is not allowed"])
        filterStringNonLatin1 =
          specializedFilter (const ["non-latin1 characters in string literal, this is not allowed"])
        filterEscapeCharRequiresExactDigits _ needed = specializedFilter \got ->
          let ~(Just formatted) = disjunct True (map show (NonEmpty.toList needed))
          in [toString ("numeric escape requires " <> formatted <> "digits, but only got" <> from got)]
        filterEscapeCharNumericSequenceIllegal maxEscape radix =
          let messages :: Integer -> NonEmpty String
              messages c
                | c > toInteger (ord maxEscape) = singleton $
                    showIntAtBase (toInteger radix) intToDigit c
                      (" is greater than the maximum character value of "
                      ++ showIntAtBase (toInteger radix) intToDigit (toInteger (ord maxEscape)) "")
                | otherwise = singleton $ "illegal unicode character: "
                                        ++ showIntAtBase (toInteger radix) intToDigit c ""
          in specializedFilter messages
        verifiedCharBadCharsUsedInLiteral = unverified
        verifiedStringBadCharsUsedInLiteral = unverified
        labelSymbol = Map.empty
        -- defaultSymbolKeyword = Label
        -- defaultSymbolOperator = Label
        -- defaultSymbolOperator = NotConfigured
        labelSymbolEndOfKeyword = ("end of " ++)
        labelSymbolEndOfOperator = ("end of " ++)
        labelSpaceEndOfLineComment = label ["end of comment"]
        labelSpaceEndOfMultiComment = label ["end of comment"]

outOfBounds :: Integer -> Integer -> Int -> Integer -> NonEmpty String
outOfBounds small big radix _n = singleton $
    "literal is not within the range " ++ resign small (" to " ++ resign big "")
  where resign n
          | n < 0 = ('-' :) . showIntAtBase (toInteger radix) intToDigit (abs n)
          | otherwise = showIntAtBase (toInteger radix) intToDigit n

type LabelConfigurable :: * -> Constraint
class LabelConfigurable config where
  label :: Set String -> config
  hidden :: config

instance LabelConfigurable LabelConfig where
  label = LLabel
  hidden = LHidden
instance LabelConfigurable LabelWithExplainConfig where
  label = LELabel
  hidden = LEHidden

type ExplainConfigurable :: * -> Constraint
class ExplainConfigurable config where
  reason :: String -> config

instance ExplainConfigurable ExplainConfig where reason = EReason
instance ExplainConfigurable LabelWithExplainConfig where reason = LEReason

type LabelWithExplainConfigurable :: * -> Constraint
class LabelWithExplainConfigurable config where
  labelAndReason :: Set String -> String -> config

instance LabelWithExplainConfigurable LabelWithExplainConfig where labelAndReason = LELabelAndReason

type NotConfigurable :: * -> Constraint
class NotConfigurable config where
  notConfigured :: config

instance NotConfigurable LabelWithExplainConfig where notConfigured = LENotConfigured
instance NotConfigurable LabelConfig where notConfigured = LNotConfigured
instance NotConfigurable ExplainConfig where notConfigured = ENotConfigured

type VanillaFilterConfigurable :: (* -> *) -> Constraint
class VanillaFilterConfigurable config where
  unexpected :: (a -> String) -> config a
  because :: (a -> String) -> config a
  unexpectedBecause :: (a -> String) -> (a -> String) -> config a

instance VanillaFilterConfigurable FilterConfig where
  unexpected = VSUnexpected
  because = VSBecause
  unexpectedBecause = VSUnexpectedBecause

instance VanillaFilterConfigurable VanillaFilterConfig where
  unexpected = VUnexpected
  because = VBecause
  unexpectedBecause = VUnexpectedBecause

type SpecializedFilterConfigurable :: (* -> *) -> Constraint
class SpecializedFilterConfigurable config where
  specializedFilter :: (a -> NonEmpty String) -> config a

instance SpecializedFilterConfigurable FilterConfig where
  specializedFilter = VSSpecializedFilter
instance SpecializedFilterConfigurable SpecializedFilterConfig where
  specializedFilter = SSpecializedFilter

type BasicFilterConfigurable :: (* -> *) -> Constraint
class BasicFilterConfigurable config where
  basicFilter :: config a

instance BasicFilterConfigurable FilterConfig where basicFilter = VSBasicFilter
instance BasicFilterConfigurable VanillaFilterConfig where basicFilter = VBasicFilter
instance BasicFilterConfigurable SpecializedFilterConfig where basicFilter = SBasicFilter

badCharsFail :: Map Char (NonEmpty String) -> VerifiedBadChars
badCharsFail = BadCharsFail
badCharsReason :: Map Char String -> VerifiedBadChars
badCharsReason = BadCharsReason

type Unverified :: * -> Constraint
class Unverified config where
  unverified :: config

instance Unverified VerifiedBadChars where unverified = BadCharsUnverified

singleton :: a -> NonEmpty a
singleton x = x :| []