{-# LANGUAGE Safe #-}
{-# LANGUAGE OverloadedLists, NamedFieldPuns #-}
{-# OPTIONS_HADDOCK hide #-}
module Text.Gigaparsec.Internal.Token.Generic (module Text.Gigaparsec.Internal.Token.Generic) where

import Text.Gigaparsec ((<|>), many, Parsec, ($>), (<:>))
import Text.Gigaparsec.Char (satisfy, char, digit, hexDigit, octDigit, bit)
import Text.Gigaparsec.Combinator (optional)
import Text.Gigaparsec.Errors.Combinator ((<?>), hide)
import Text.Gigaparsec.Token.Descriptions (
    BreakCharDesc(BreakCharSupported, NoBreakChar),
    NumericDesc(NumericDesc, literalBreakChar, leadingZerosAllowed)
  )

import Data.Char (isDigit, isHexDigit, isOctDigit, digitToInt)
import Data.List (foldl')
import Text.Gigaparsec.Token.Errors (ErrorConfig (labelNumericBreakChar))
import Text.Gigaparsec.Internal.Token.Errors (annotate, LabelConfig)

type GenericNumeric :: *
data GenericNumeric = Generic { GenericNumeric -> LabelConfig -> Parsec Integer
zeroAllowedDecimal :: LabelConfig -> Parsec Integer
                              , GenericNumeric -> LabelConfig -> Parsec Integer
zeroAllowedHexadecimal :: LabelConfig -> Parsec Integer
                              , GenericNumeric -> LabelConfig -> Parsec Integer
zeroAllowedOctal :: LabelConfig -> Parsec Integer
                              , GenericNumeric -> LabelConfig -> Parsec Integer
zeroAllowedBinary :: LabelConfig -> Parsec Integer
                              , GenericNumeric -> LabelConfig -> Parsec Integer
zeroNotAllowedDecimal :: LabelConfig -> Parsec Integer
                              , GenericNumeric -> LabelConfig -> Parsec Integer
zeroNotAllowedHexadecimal :: LabelConfig -> Parsec Integer
                              , GenericNumeric -> LabelConfig -> Parsec Integer
zeroNotAllowedOctal :: LabelConfig -> Parsec Integer
                              , GenericNumeric -> LabelConfig -> Parsec Integer
zeroNotAllowedBinary :: LabelConfig -> Parsec Integer
                              , GenericNumeric -> NumericDesc -> LabelConfig -> Parsec Integer
plainDecimal :: NumericDesc -> LabelConfig -> Parsec Integer
                              , GenericNumeric -> NumericDesc -> LabelConfig -> Parsec Integer
plainHexadecimal :: NumericDesc -> LabelConfig -> Parsec Integer
                              , GenericNumeric -> NumericDesc -> LabelConfig -> Parsec Integer
plainOctal :: NumericDesc -> LabelConfig -> Parsec Integer
                              , GenericNumeric -> NumericDesc -> LabelConfig -> Parsec Integer
plainBinary :: NumericDesc -> LabelConfig -> Parsec Integer
                              }

mkGeneric :: ErrorConfig -> GenericNumeric
mkGeneric :: ErrorConfig -> GenericNumeric
mkGeneric !ErrorConfig
err = Generic {LabelConfig -> Parsec Integer
NumericDesc -> LabelConfig -> Parsec Integer
zeroAllowedDecimal :: LabelConfig -> Parsec Integer
zeroAllowedHexadecimal :: LabelConfig -> Parsec Integer
zeroAllowedOctal :: LabelConfig -> Parsec Integer
zeroAllowedBinary :: LabelConfig -> Parsec Integer
zeroNotAllowedDecimal :: LabelConfig -> Parsec Integer
zeroNotAllowedHexadecimal :: LabelConfig -> Parsec Integer
zeroNotAllowedOctal :: LabelConfig -> Parsec Integer
zeroNotAllowedBinary :: LabelConfig -> Parsec Integer
plainDecimal :: NumericDesc -> LabelConfig -> Parsec Integer
plainHexadecimal :: NumericDesc -> LabelConfig -> Parsec Integer
plainOctal :: NumericDesc -> LabelConfig -> Parsec Integer
plainBinary :: NumericDesc -> LabelConfig -> Parsec Integer
zeroAllowedDecimal :: LabelConfig -> Parsec Integer
zeroAllowedHexadecimal :: LabelConfig -> Parsec Integer
zeroAllowedOctal :: LabelConfig -> Parsec Integer
zeroAllowedBinary :: LabelConfig -> Parsec Integer
zeroNotAllowedDecimal :: LabelConfig -> Parsec Integer
zeroNotAllowedHexadecimal :: LabelConfig -> Parsec Integer
zeroNotAllowedOctal :: LabelConfig -> Parsec Integer
zeroNotAllowedBinary :: LabelConfig -> Parsec Integer
plainDecimal :: NumericDesc -> LabelConfig -> Parsec Integer
plainHexadecimal :: NumericDesc -> LabelConfig -> Parsec Integer
plainOctal :: NumericDesc -> LabelConfig -> Parsec Integer
plainBinary :: NumericDesc -> LabelConfig -> Parsec Integer
..}
  where ofRadix1 :: Integer -> Parsec Char -> LabelConfig -> Parsec Integer
        ofRadix1 :: Integer -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix1 Integer
radix Parsec Char
dig = Integer
-> Parsec Char -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix2 Integer
radix Parsec Char
dig Parsec Char
dig
        ofRadix2 :: Integer -> Parsec Char -> Parsec Char -> LabelConfig -> Parsec Integer
        ofRadix2 :: Integer
-> Parsec Char -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix2 Integer
radix Parsec Char
startDig Parsec Char
dig LabelConfig
label =
          (Integer -> Char -> Integer) -> Integer -> [Char] -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Integer -> Integer -> Char -> Integer
withDigit Integer
radix) Integer
0 ([Char] -> Integer) -> Parsec [Char] -> Parsec Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parsec Char
startDig Parsec Char -> Parsec [Char] -> Parsec [Char]
forall a. Parsec a -> Parsec [a] -> Parsec [a]
<:> Parsec Char -> Parsec [Char]
forall a. Parsec a -> Parsec [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (LabelConfig -> Parsec Char -> Parsec Char
forall config a. Annotate config => config -> Parsec a -> Parsec a
forall a. LabelConfig -> Parsec a -> Parsec a
annotate LabelConfig
label Parsec Char
dig)) --TODO: improve

        ofRadixBreak1 :: Integer -> Parsec Char -> Char -> LabelConfig -> Parsec Integer
        ofRadixBreak1 :: Integer -> Parsec Char -> Char -> LabelConfig -> Parsec Integer
ofRadixBreak1 Integer
radix Parsec Char
dig = Integer
-> Parsec Char
-> Parsec Char
-> Char
-> LabelConfig
-> Parsec Integer
ofRadixBreak2 Integer
radix Parsec Char
dig Parsec Char
dig
        ofRadixBreak2 :: Integer -> Parsec Char -> Parsec Char -> Char -> LabelConfig -> Parsec Integer
        ofRadixBreak2 :: Integer
-> Parsec Char
-> Parsec Char
-> Char
-> LabelConfig
-> Parsec Integer
ofRadixBreak2 Integer
radix Parsec Char
startDig Parsec Char
dig Char
breakChar LabelConfig
label =
          (Integer -> Char -> Integer) -> Integer -> [Char] -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Integer -> Integer -> Char -> Integer
withDigit Integer
radix) Integer
0 ([Char] -> Integer) -> Parsec [Char] -> Parsec Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parsec Char
startDig Parsec Char -> Parsec [Char] -> Parsec [Char]
forall a. Parsec a -> Parsec [a] -> Parsec [a]
<:> Parsec Char -> Parsec [Char]
forall a. Parsec a -> Parsec [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parsec Char -> Parsec ()
forall a. Parsec a -> Parsec ()
optional (LabelWithExplainConfig -> Parsec Char -> Parsec Char
forall config a. Annotate config => config -> Parsec a -> Parsec a
forall a. LabelWithExplainConfig -> Parsec a -> Parsec a
annotate (ErrorConfig -> LabelWithExplainConfig
labelNumericBreakChar ErrorConfig
err) (LabelConfig -> Parsec Char -> Parsec Char
forall config a. Annotate config => config -> Parsec a -> Parsec a
forall a. LabelConfig -> Parsec a -> Parsec a
annotate LabelConfig
label (Char -> Parsec Char
char Char
breakChar))) Parsec () -> Parsec Char -> Parsec Char
forall a b. Parsec a -> Parsec b -> Parsec b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LabelConfig -> Parsec Char -> Parsec Char
forall config a. Annotate config => config -> Parsec a -> Parsec a
forall a. LabelConfig -> Parsec a -> Parsec a
annotate LabelConfig
label Parsec Char
dig)) --TODO: improve

        nonZeroDigit :: Parsec Char
nonZeroDigit = (Char -> Bool) -> Parsec Char
satisfy (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0') Parsec Char -> Set [Char] -> Parsec Char
forall a. Parsec a -> Set [Char] -> Parsec a
<?> [[Char]
Item (Set [Char])
"digit"]
        nonZeroHexDigit :: Parsec Char
nonZeroHexDigit = (Char -> Bool) -> Parsec Char
satisfy (\Char
c -> Char -> Bool
isHexDigit Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0') Parsec Char -> Set [Char] -> Parsec Char
forall a. Parsec a -> Set [Char] -> Parsec a
<?> [[Char]
Item (Set [Char])
"hexadecimal digit"]
        nonZeroOctDigit :: Parsec Char
nonZeroOctDigit = (Char -> Bool) -> Parsec Char
satisfy (\Char
c -> Char -> Bool
isOctDigit Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0') Parsec Char -> Set [Char] -> Parsec Char
forall a. Parsec a -> Set [Char] -> Parsec a
<?> [[Char]
Item (Set [Char])
"octal digit"]
        nonZeroBit :: Parsec Char
nonZeroBit = Char -> Parsec Char
char Char
'1' Parsec Char -> Set [Char] -> Parsec Char
forall a. Parsec a -> Set [Char] -> Parsec a
<?> [[Char]
Item (Set [Char])
"bit"]
        -- why secret? so that the above digits can be marked as digits without "non-zero or zero digit"
        secretZero :: Parsec Integer
        secretZero :: Parsec Integer
secretZero = Parsec Char -> Parsec Char
forall a. Parsec a -> Parsec a
hide (Char -> Parsec Char
char Char
'0') Parsec Char -> Integer -> Parsec Integer
forall a b. Parsec a -> b -> Parsec b
$> Integer
0

        zeroAllowedDecimal :: LabelConfig -> Parsec Integer
zeroAllowedDecimal = Integer -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix1 Integer
10 Parsec Char
digit
        zeroAllowedHexadecimal :: LabelConfig -> Parsec Integer
zeroAllowedHexadecimal = Integer -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix1 Integer
16 Parsec Char
hexDigit
        zeroAllowedOctal :: LabelConfig -> Parsec Integer
zeroAllowedOctal = Integer -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix1 Integer
8 Parsec Char
octDigit
        zeroAllowedBinary :: LabelConfig -> Parsec Integer
zeroAllowedBinary = Integer -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix1 Integer
2 Parsec Char
bit

        zeroNotAllowedDecimal :: LabelConfig -> Parsec Integer
zeroNotAllowedDecimal LabelConfig
label = Integer
-> Parsec Char -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix2 Integer
10 Parsec Char
nonZeroDigit Parsec Char
digit LabelConfig
label Parsec Integer -> Parsec Integer -> Parsec Integer
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Integer
secretZero
        zeroNotAllowedHexadecimal :: LabelConfig -> Parsec Integer
zeroNotAllowedHexadecimal LabelConfig
label = Integer
-> Parsec Char -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix2 Integer
16 Parsec Char
nonZeroHexDigit Parsec Char
hexDigit LabelConfig
label Parsec Integer -> Parsec Integer -> Parsec Integer
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Integer
secretZero
        zeroNotAllowedOctal :: LabelConfig -> Parsec Integer
zeroNotAllowedOctal LabelConfig
label = Integer
-> Parsec Char -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix2 Integer
8 Parsec Char
nonZeroOctDigit Parsec Char
octDigit LabelConfig
label Parsec Integer -> Parsec Integer -> Parsec Integer
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Integer
secretZero
        zeroNotAllowedBinary :: LabelConfig -> Parsec Integer
zeroNotAllowedBinary LabelConfig
label = Integer
-> Parsec Char -> Parsec Char -> LabelConfig -> Parsec Integer
ofRadix2 Integer
2 Parsec Char
nonZeroBit Parsec Char
bit LabelConfig
label Parsec Integer -> Parsec Integer -> Parsec Integer
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Integer
secretZero

        plainDecimal :: NumericDesc -> LabelConfig -> Parsec Integer
plainDecimal NumericDesc{Bool
leadingZerosAllowed :: NumericDesc -> Bool
leadingZerosAllowed :: Bool
leadingZerosAllowed, BreakCharDesc
literalBreakChar :: NumericDesc -> BreakCharDesc
literalBreakChar :: BreakCharDesc
literalBreakChar} LabelConfig
label = case BreakCharDesc
literalBreakChar of
          BreakCharDesc
NoBreakChar | Bool
leadingZerosAllowed            -> LabelConfig -> Parsec Integer
zeroAllowedDecimal LabelConfig
label
          BreakCharDesc
NoBreakChar                                  -> LabelConfig -> Parsec Integer
zeroNotAllowedDecimal LabelConfig
label
          BreakCharSupported Char
c Bool
_ | Bool
leadingZerosAllowed -> Integer -> Parsec Char -> Char -> LabelConfig -> Parsec Integer
ofRadixBreak1 Integer
10 Parsec Char
digit Char
c LabelConfig
label
          BreakCharSupported Char
c Bool
_                       -> Integer
-> Parsec Char
-> Parsec Char
-> Char
-> LabelConfig
-> Parsec Integer
ofRadixBreak2 Integer
10 Parsec Char
nonZeroDigit Parsec Char
digit Char
c LabelConfig
label Parsec Integer -> Parsec Integer -> Parsec Integer
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Integer
secretZero

        plainHexadecimal :: NumericDesc -> LabelConfig -> Parsec Integer
plainHexadecimal NumericDesc{Bool
leadingZerosAllowed :: NumericDesc -> Bool
leadingZerosAllowed :: Bool
leadingZerosAllowed, BreakCharDesc
literalBreakChar :: NumericDesc -> BreakCharDesc
literalBreakChar :: BreakCharDesc
literalBreakChar} LabelConfig
label = case BreakCharDesc
literalBreakChar of
          BreakCharDesc
NoBreakChar | Bool
leadingZerosAllowed            -> LabelConfig -> Parsec Integer
zeroAllowedDecimal LabelConfig
label
          BreakCharDesc
NoBreakChar                                  -> LabelConfig -> Parsec Integer
zeroNotAllowedDecimal LabelConfig
label
          BreakCharSupported Char
c Bool
_ | Bool
leadingZerosAllowed -> Integer -> Parsec Char -> Char -> LabelConfig -> Parsec Integer
ofRadixBreak1 Integer
16 Parsec Char
hexDigit Char
c LabelConfig
label
          BreakCharSupported Char
c Bool
_                       -> Integer
-> Parsec Char
-> Parsec Char
-> Char
-> LabelConfig
-> Parsec Integer
ofRadixBreak2 Integer
16 Parsec Char
nonZeroHexDigit Parsec Char
hexDigit Char
c LabelConfig
label Parsec Integer -> Parsec Integer -> Parsec Integer
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Integer
secretZero

        plainOctal :: NumericDesc -> LabelConfig -> Parsec Integer
plainOctal NumericDesc{Bool
leadingZerosAllowed :: NumericDesc -> Bool
leadingZerosAllowed :: Bool
leadingZerosAllowed, BreakCharDesc
literalBreakChar :: NumericDesc -> BreakCharDesc
literalBreakChar :: BreakCharDesc
literalBreakChar} LabelConfig
label = case BreakCharDesc
literalBreakChar of
          BreakCharDesc
NoBreakChar | Bool
leadingZerosAllowed            -> LabelConfig -> Parsec Integer
zeroAllowedDecimal LabelConfig
label
          BreakCharDesc
NoBreakChar                                  -> LabelConfig -> Parsec Integer
zeroNotAllowedDecimal LabelConfig
label
          BreakCharSupported Char
c Bool
_ | Bool
leadingZerosAllowed -> Integer -> Parsec Char -> Char -> LabelConfig -> Parsec Integer
ofRadixBreak1 Integer
8 Parsec Char
octDigit Char
c LabelConfig
label
          BreakCharSupported Char
c Bool
_                       -> Integer
-> Parsec Char
-> Parsec Char
-> Char
-> LabelConfig
-> Parsec Integer
ofRadixBreak2 Integer
8 Parsec Char
nonZeroOctDigit Parsec Char
octDigit Char
c LabelConfig
label Parsec Integer -> Parsec Integer -> Parsec Integer
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Integer
secretZero

        plainBinary :: NumericDesc -> LabelConfig -> Parsec Integer
plainBinary NumericDesc{Bool
leadingZerosAllowed :: NumericDesc -> Bool
leadingZerosAllowed :: Bool
leadingZerosAllowed, BreakCharDesc
literalBreakChar :: NumericDesc -> BreakCharDesc
literalBreakChar :: BreakCharDesc
literalBreakChar} LabelConfig
label = case BreakCharDesc
literalBreakChar of
          BreakCharDesc
NoBreakChar | Bool
leadingZerosAllowed            -> LabelConfig -> Parsec Integer
zeroAllowedDecimal LabelConfig
label
          BreakCharDesc
NoBreakChar                                  -> LabelConfig -> Parsec Integer
zeroNotAllowedDecimal LabelConfig
label
          BreakCharSupported Char
c Bool
_ | Bool
leadingZerosAllowed -> Integer -> Parsec Char -> Char -> LabelConfig -> Parsec Integer
ofRadixBreak1 Integer
2 Parsec Char
bit Char
c LabelConfig
label
          BreakCharSupported Char
c Bool
_                       -> Integer
-> Parsec Char
-> Parsec Char
-> Char
-> LabelConfig
-> Parsec Integer
ofRadixBreak2 Integer
2 Parsec Char
nonZeroBit Parsec Char
bit Char
c LabelConfig
label Parsec Integer -> Parsec Integer -> Parsec Integer
forall a. Parsec a -> Parsec a -> Parsec a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Integer
secretZero

withDigit :: Integer -> Integer -> Char -> Integer
withDigit :: Integer -> Integer -> Char -> Integer
withDigit Integer
radix Integer
n Char
d = Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
radix Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
d)