{-# LANGUAGE Trustworthy #-}

{-# OPTIONS_HADDOCK hide #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-missing-import-lists #-}

module Text.Gigaparsec.Internal.Token.Patterns.IntegerParsers (
  module Text.Gigaparsec.Internal.Token.Patterns.IntegerParsers
) where

import Text.Gigaparsec (Parsec)
import Text.Gigaparsec.Internal.Token.Lexer (natural, integer)




import Control.Monad (forM)
import Data.Bitraversable (bisequence)
import Data.Function (on)
import Data.List (groupBy)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Set (Set)
import Data.Set qualified as Set
import Language.Haskell.TH (
  RuleMatch (FunLike),
  pragInlD,
  sigD,
  varE,
 )
import Text.Gigaparsec.Internal.TH.VersionAgnostic (Name, Dec (..), Exp, Inline (Inline), Phases (AllPhases), Q, Quote (newName), Type, nameBase)
import Text.Gigaparsec.Internal.Token.BitBounds (Bits (..))
import Text.Gigaparsec.Token.Lexer qualified as Lexer

import GHC.Exts (IsList (..))
import Text.Gigaparsec.Internal.TH.DecUtils (funDsingleClause)
import Text.Gigaparsec.Internal.Token.Patterns.LexerCombinators

intLitBaseList :: [IntLitBase]
intLitBaseList :: [IntLitBase]
intLitBaseList = [IntLitBase
Binary, IntLitBase
Octal, IntLitBase
Decimal, IntLitBase
Hexadecimal]

-- | Names of the
integerParsers :: [(Name, IntLitBase)]
integerParsers :: [(Name, IntLitBase)]
integerParsers =
  [ 'Lexer.binary
  , 'Lexer.octal
  , 'Lexer.decimal
  , 'Lexer.hexadecimal
  ]
    [Name] -> [IntLitBase] -> [(Name, IntLitBase)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [IntLitBase]
intLitBaseList

intParsers8Bit :: [(Name, IntLitBase)]
intParsers8Bit :: [(Name, IntLitBase)]
intParsers8Bit =
  [ 'Lexer.binary8
  , 'Lexer.octal8
  , 'Lexer.decimal8
  , 'Lexer.hexadecimal8
  ]
    [Name] -> [IntLitBase] -> [(Name, IntLitBase)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [IntLitBase]
intLitBaseList

intParsers16Bit :: [(Name, IntLitBase)]
intParsers16Bit :: [(Name, IntLitBase)]
intParsers16Bit =
  [ 'Lexer.binary16
  , 'Lexer.octal16
  , 'Lexer.decimal16
  , 'Lexer.hexadecimal16
  ]
    [Name] -> [IntLitBase] -> [(Name, IntLitBase)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [IntLitBase]
intLitBaseList

intParsers32Bit :: [(Name, IntLitBase)]
intParsers32Bit :: [(Name, IntLitBase)]
intParsers32Bit =
  [ 'Lexer.binary32
  , 'Lexer.octal32
  , 'Lexer.decimal32
  , 'Lexer.hexadecimal32
  ]
    [Name] -> [IntLitBase] -> [(Name, IntLitBase)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [IntLitBase]
intLitBaseList

intParsers64Bit :: [(Name, IntLitBase)]
intParsers64Bit :: [(Name, IntLitBase)]
intParsers64Bit =
  [ 'Lexer.binary64
  , 'Lexer.octal64
  , 'Lexer.decimal64
  , 'Lexer.hexadecimal64
  ]
    [Name] -> [IntLitBase] -> [(Name, IntLitBase)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [IntLitBase]
intLitBaseList

{-|
The base of a numeric literal.

Used in `IntegerParserConfig` to specify which parsers for which bases should be generated.

@since 0.4.0.0

-}
type IntLitBase :: *
data IntLitBase
  = Binary
  | Octal
  | Decimal
  | Hexadecimal
  deriving stock (Int -> IntLitBase -> ShowS
[IntLitBase] -> ShowS
IntLitBase -> String
(Int -> IntLitBase -> ShowS)
-> (IntLitBase -> String)
-> ([IntLitBase] -> ShowS)
-> Show IntLitBase
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IntLitBase -> ShowS
showsPrec :: Int -> IntLitBase -> ShowS
$cshow :: IntLitBase -> String
show :: IntLitBase -> String
$cshowList :: [IntLitBase] -> ShowS
showList :: [IntLitBase] -> ShowS
Show, IntLitBase -> IntLitBase -> Bool
(IntLitBase -> IntLitBase -> Bool)
-> (IntLitBase -> IntLitBase -> Bool) -> Eq IntLitBase
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IntLitBase -> IntLitBase -> Bool
== :: IntLitBase -> IntLitBase -> Bool
$c/= :: IntLitBase -> IntLitBase -> Bool
/= :: IntLitBase -> IntLitBase -> Bool
Eq, Eq IntLitBase
Eq IntLitBase =>
(IntLitBase -> IntLitBase -> Ordering)
-> (IntLitBase -> IntLitBase -> Bool)
-> (IntLitBase -> IntLitBase -> Bool)
-> (IntLitBase -> IntLitBase -> Bool)
-> (IntLitBase -> IntLitBase -> Bool)
-> (IntLitBase -> IntLitBase -> IntLitBase)
-> (IntLitBase -> IntLitBase -> IntLitBase)
-> Ord IntLitBase
IntLitBase -> IntLitBase -> Bool
IntLitBase -> IntLitBase -> Ordering
IntLitBase -> IntLitBase -> IntLitBase
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
$ccompare :: IntLitBase -> IntLitBase -> Ordering
compare :: IntLitBase -> IntLitBase -> Ordering
$c< :: IntLitBase -> IntLitBase -> Bool
< :: IntLitBase -> IntLitBase -> Bool
$c<= :: IntLitBase -> IntLitBase -> Bool
<= :: IntLitBase -> IntLitBase -> Bool
$c> :: IntLitBase -> IntLitBase -> Bool
> :: IntLitBase -> IntLitBase -> Bool
$c>= :: IntLitBase -> IntLitBase -> Bool
>= :: IntLitBase -> IntLitBase -> Bool
$cmax :: IntLitBase -> IntLitBase -> IntLitBase
max :: IntLitBase -> IntLitBase -> IntLitBase
$cmin :: IntLitBase -> IntLitBase -> IntLitBase
min :: IntLitBase -> IntLitBase -> IntLitBase
Ord)

{-|
Set of all possible `IntLitBase`s.

@since 0.4.0.0

-}
allBases :: Set IntLitBase
allBases :: Set IntLitBase
allBases = [IntLitBase] -> Set IntLitBase
forall a. Ord a => [a] -> Set a
Set.fromList [IntLitBase
Binary, IntLitBase
Octal, IntLitBase
Decimal, IntLitBase
Hexadecimal]

{-| Determines if the combinators are for 'Signed' or 'Unsigned' int literals.

@since 0.4.0.0

-}
type SignedOrUnsigned :: *
data SignedOrUnsigned = 
    {-| The int literal is signed, so can be negative.
    
    @since 0.4.0.0
    
    -}
    Signed 
  | {-|  The literal is unsigned, so is always non-negative.
    
    @since 0.4.0.0
    
    -}
    Unsigned

{-|
True when `Signed`.

@since 0.4.0.0

-}
isSigned :: SignedOrUnsigned -> Bool
isSigned :: SignedOrUnsigned -> Bool
isSigned SignedOrUnsigned
Signed = Bool
True
isSigned SignedOrUnsigned
Unsigned = Bool
False


{-|
This type describes how to generate numeric parsers with `generateIntegerParsers`.
This includes configuration for which bases and bitwidths to support, and whether to generate
parsers that can handle multiple bases. 

See the 'emptyIntegerParserConfig' smart constructor to define a 'IntegerParserConfig'.

@since 0.4.0.0

-}
type IntegerParserConfig :: *
data IntegerParserConfig = IntegerParserConfig
  { {-|
    The string to prepend to each generated parser's name (except for the `collatedParser`, if specified).
    
    @since 0.4.0.0

    -}
    IntegerParserConfig -> String
prefix :: String
    {-| The fixed bit-widths (8-bit, 16-bit, etc/) for which to generate parsers.

    @since 0.4.0.0

    -}
  , IntegerParserConfig -> Map Bits (Q Type)
widths :: Map Bits (Q Type)
    {-|
    The numeric bases (binary, octal, etc) for which to generate parsers.

    @since 0.4.0.0

    -}
  , IntegerParserConfig -> Set IntLitBase
bases :: Set IntLitBase
    {-|
    When 'True', generate the unbounded integer parsers (e.g. `Text.Gigaparsec.Token.Lexer.decimal`) for each base specified in `bases`.
    
    @since 0.4.0.0

    -}
  , IntegerParserConfig -> Bool
includeUnbounded :: Bool
    {-|
    Generate a generic integer parser with the given name,
    at each width (including unbounded) specified by `widths`, that
    is able to parse each base specified in `bases`.
  
    * If 'Nothing', do not generate such a parser.
    * If @'Just' ""@, then the default name will be @"natural"@  or @"integer"@ when `signedOrUnsigned`
      is `Unsigned` or `Signed`, respectively.

    @since 0.4.0.0

    -}
  , IntegerParserConfig -> Maybe String
collatedParser :: Maybe String
    {-|
    Whether or not the parsers to generate are for 'Signed' or 'Unsigned' integers.

    @since 0.4.0.0
    
    -}
  , IntegerParserConfig -> SignedOrUnsigned
signedOrUnsigned :: SignedOrUnsigned
  }

filterByBase :: Set IntLitBase -> [(a, IntLitBase)] -> [a]
filterByBase :: forall a. Set IntLitBase -> [(a, IntLitBase)] -> [a]
filterByBase Set IntLitBase
bs = ((a, IntLitBase) -> a) -> [(a, IntLitBase)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, IntLitBase) -> a
forall a b. (a, b) -> a
fst ([(a, IntLitBase)] -> [a])
-> ([(a, IntLitBase)] -> [(a, IntLitBase)])
-> [(a, IntLitBase)]
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, IntLitBase) -> Bool) -> [(a, IntLitBase)] -> [(a, IntLitBase)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((IntLitBase -> Set IntLitBase -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set IntLitBase
bs) (IntLitBase -> Bool)
-> ((a, IntLitBase) -> IntLitBase) -> (a, IntLitBase) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, IntLitBase) -> IntLitBase
forall a b. (a, b) -> b
snd)

filterByWidth :: Bits -> [(Bits, a)] -> [a]
filterByWidth :: forall a. Bits -> [(Bits, a)] -> [a]
filterByWidth Bits
b = ((Bits, a) -> a) -> [(Bits, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Bits, a) -> a
forall a b. (a, b) -> b
snd ([(Bits, a)] -> [a])
-> ([(Bits, a)] -> [(Bits, a)]) -> [(Bits, a)] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bits, a) -> Bool) -> [(Bits, a)] -> [(Bits, a)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bits -> Bits -> Bool
forall a. Eq a => a -> a -> Bool
== Bits
b) (Bits -> Bool) -> ((Bits, a) -> Bits) -> (Bits, a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bits, a) -> Bits
forall a b. (a, b) -> a
fst)

-- | Monoidal when; if false, then return `mempty`
mwhen :: (Monoid m) => Bool -> m -> m
mwhen :: forall m. Monoid m => Bool -> m -> m
mwhen Bool
True m
x = m
x
mwhen Bool
False m
_ = m
forall a. Monoid a => a
mempty

groupByBits :: [(Bits, Name)] -> [(Bits, [Name])]
groupByBits :: [(Bits, Name)] -> [(Bits, [Name])]
groupByBits [] = [] -- So that we may assume xs is nonempty in the second line (so we can use head)
groupByBits [(Bits, Name)]
xs = ([(Bits, Name)] -> (Bits, [Name]))
-> [[(Bits, Name)]] -> [(Bits, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map (([(Bits, Name)] -> Bits, [(Bits, Name)] -> [Name])
-> [(Bits, Name)] -> (Bits, [Name])
forall (t :: * -> * -> *) (f :: * -> *) a b.
(Bitraversable t, Applicative f) =>
t (f a) (f b) -> f (t a b)
bisequence ((Bits, Name) -> Bits
forall a b. (a, b) -> a
fst ((Bits, Name) -> Bits)
-> ([(Bits, Name)] -> (Bits, Name)) -> [(Bits, Name)] -> Bits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Bits, Name)] -> (Bits, Name)
forall a. HasCallStack => [a] -> a
head, ((Bits, Name) -> Name) -> [(Bits, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Bits, Name) -> Name
forall a b. (a, b) -> b
snd)) ([[(Bits, Name)]] -> [(Bits, [Name])])
-> [[(Bits, Name)]] -> [(Bits, [Name])]
forall a b. (a -> b) -> a -> b
$ ((Bits, Name) -> (Bits, Name) -> Bool)
-> [(Bits, Name)] -> [[(Bits, Name)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Bits -> Bits -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Bits -> Bits -> Bool)
-> ((Bits, Name) -> Bits) -> (Bits, Name) -> (Bits, Name) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Bits, Name) -> Bits
forall a b. (a, b) -> a
fst) [(Bits, Name)]
xs

{-|
This function automatically generates lexer combinators for handling signed or unsigned integers.

See 'IntegerParserConfig' for how to configure which combinators are generated.

/Note:/ Due to staging restrictions in Template Haskell, the `IntegerParserConfig` must be
defined in a separate module to where this function is used.
Multiple configs can be defined in the same module.

==== __Usage:__
First, the config must be defined in another module.
You can define multiple configs in the same module, as long as they are used in a different module.

> {-# LANGUAGE TemplateHaskell, OverloadedLists #-}
> module IntegerConfigs where
> …
> uIntCfg :: IntegerParserConfig
> uIntCfg = emptyUnsignedIntegerParserConfig {
>     prefix = "u",
>     widths = [(B8, [t| Word8 |]), (B32, [t| Word32 |])],
>     bases = [Hexadecimal, Decimal, Binary],
>     includeUnbounded = False,
>     signedOrUnsigned = Unsigned,
>     collatedParser = Just "natural"
>   }

Then, we can feed this config, along with a quoted lexer, to `generateIntegerParsers`:

> {-# LANGUAGE TemplateHaskell #-}
> module Lexer where
> import IntegerConfigs (uIntCfg)
> …
> lexer :: Lexer
> lexer = …
>
> $(generateIntegerParsers [| lexer |] uIntCfg)

This will generate the following combinators,

>    ubinary8 :: Parsec Word8
>    udecimal8 :: Parsec Word8
>    uhexadecimal8 :: Parsec Word8
>    ubinary32 :: Parsec Word32
>    udecimal3 :: Parsec Word32
>    uhexadecimal32 :: Parsec Word32
>    natural8 :: Parsec Word8
>    natural32 :: Parsec Word32

@since 0.4.0.0

-}
generateIntegerParsers 
  :: Q Exp               -- ^ The quoted 'Text.Gigaparsec.Token.Lexer.Lexer'
  -> IntegerParserConfig -- ^ The configuration describing what numeric combinators to produce.
  -> Q [Dec]             -- ^ The declarations of the specified combinators.
generateIntegerParsers :: Q Exp -> IntegerParserConfig -> Q [Dec]
generateIntegerParsers Q Exp
lexer cfg :: IntegerParserConfig
cfg@IntegerParserConfig{Bool
String
Maybe String
Set IntLitBase
Map Bits (Q Type)
SignedOrUnsigned
collatedParser :: IntegerParserConfig -> Maybe String
prefix :: IntegerParserConfig -> String
widths :: IntegerParserConfig -> Map Bits (Q Type)
bases :: IntegerParserConfig -> Set IntLitBase
includeUnbounded :: IntegerParserConfig -> Bool
signedOrUnsigned :: IntegerParserConfig -> SignedOrUnsigned
prefix :: String
widths :: Map Bits (Q Type)
bases :: Set IntLitBase
includeUnbounded :: Bool
collatedParser :: Maybe String
signedOrUnsigned :: SignedOrUnsigned
..} = do
  (ubNames, concat -> ubDecs) <- [(Name, [Dec])] -> ([Name], [[Dec]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Name, [Dec])] -> ([Name], [[Dec]]))
-> Q [(Name, [Dec])] -> Q ([Name], [[Dec]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Q [(Name, [Dec])] -> Q [(Name, [Dec])]
forall m. Monoid m => Bool -> m -> m
mwhen Bool
includeUnbounded (Q Exp -> IntegerParserConfig -> Q [(Name, [Dec])]
lexerUnboundedParsers Q Exp
lexer IntegerParserConfig
cfg)
  (fwNames, fwBits, concat -> fwDecs) <- unzip3 <$> lexerFixedWidthIntParsers lexer cfg
  let fwBitsNames = [(Bits, Name)] -> [(Bits, [Name])]
groupByBits ([Bits] -> [Name] -> [(Bits, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bits]
fwBits [Name]
fwNames)
  cDecs <- maybe mempty (mkCollatedParsers ubNames fwBitsNames) collatedParser
  return $ ubDecs <> fwDecs <> cDecs
 where
  mkCollatedParser :: [Name] -> String -> Q Type -> Q [Dec]
  mkCollatedParser :: [Name] -> String -> Q Type -> Q [Dec]
mkCollatedParser [] String
_ Q Type
_ = [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  mkCollatedParser (Name
x : [Name]
xs) String
nm Q Type
tp = do
    f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
nm
    let body = (Q Exp -> Name -> Q Exp) -> Q Exp -> [Name] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
e Name
y -> [|$Q Exp
e <|> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y)|]) [|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)|] [Name]
xs
    sequence
      [ pragInlD f Inline FunLike AllPhases
      , sigD f [t|Parsec $tp|]
      , funDsingleClause f body
      ]
  mkCollatedParsers :: [Name] -> [(Bits, [Name])] -> String -> Q [Dec]
  mkCollatedParsers :: [Name] -> [(Bits, [Name])] -> String -> Q [Dec]
mkCollatedParsers [Name]
xs [(Bits, [Name])]
bys String
nm =
    [Name] -> String -> Q Type -> Q [Dec]
mkCollatedParser [Name]
xs String
nm [t|Integer|]
      Q [Dec] -> Q [Dec] -> Q [Dec]
forall a. Semigroup a => a -> a -> a
<> ( [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Bits, [Name])] -> ((Bits, [Name]) -> Q [Dec]) -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
              [(Bits, [Name])]
bys
              ( \(Bits
b, [Name]
nms) ->
                  let tp :: Q Type
tp = Maybe (Q Type) -> Q Type
forall a. HasCallStack => Maybe a -> a
fromJust (Bits -> Map Bits (Q Type) -> Maybe (Q Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Bits
b Map Bits (Q Type)
widths)
                   in [Name] -> String -> Q Type -> Q [Dec]
mkCollatedParser [Name]
nms (Bits -> ShowS
bitsSuffix Bits
b String
nm) Q Type
tp
              )
         )

bitsSuffix :: Bits -> String -> String
bitsSuffix :: Bits -> ShowS
bitsSuffix Bits
B8 = (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"8")
bitsSuffix Bits
B16 = (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"16")
bitsSuffix Bits
B32 = (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"32")
bitsSuffix Bits
B64 = (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"64")

{-| An empty `IntegerParserConfig`, which will generate nothing when given to `generateIntegerParsers`.
Extend this using record updates, to tailor a config to your liking.

By default, the `prefix` field is the empty string, which will likely cause issues if you do not override this.

@since 0.4.0.0

-}
emptyIntegerParserConfig :: IntegerParserConfig
emptyIntegerParserConfig :: IntegerParserConfig
emptyIntegerParserConfig =
  IntegerParserConfig
    { prefix :: String
prefix = String
""
    , widths :: Map Bits (Q Type)
widths = Map Bits (Q Type)
forall k a. Map k a
Map.empty
    , bases :: Set IntLitBase
bases  = Set IntLitBase
forall a. Set a
Set.empty
    , includeUnbounded :: Bool
includeUnbounded = Bool
False
    , signedOrUnsigned :: SignedOrUnsigned
signedOrUnsigned = SignedOrUnsigned
Signed
    , collatedParser :: Maybe String
collatedParser = Maybe String
forall a. Maybe a
Nothing
    }

{-| An empty `IntegerParserConfig` for `Signed` integers, which will generate nothing when given to `generateIntegerParsers`.
Extend this using record updates, to tailor a config to your liking.

By default, the `prefix` field is the empty string, which will likely cause issues if you do not override this.

@since 0.4.0.0

-}
emptySignedIntegerParserConfig :: IntegerParserConfig
emptySignedIntegerParserConfig :: IntegerParserConfig
emptySignedIntegerParserConfig = IntegerParserConfig
emptyIntegerParserConfig{signedOrUnsigned = Signed}

{-| An empty `IntegerParserConfig` for `Unsigned` integers, which will generate nothing when given to `generateIntegerParsers`.
Extend this using record updates, to tailor a config to your liking.

By default, the `prefix` field is the empty string, which will likely cause issues if you do not override this.

@since 0.4.0.0

-}
emptyUnsignedIntegerParserConfig :: IntegerParserConfig
emptyUnsignedIntegerParserConfig :: IntegerParserConfig
emptyUnsignedIntegerParserConfig = IntegerParserConfig
emptyIntegerParserConfig{signedOrUnsigned = Unsigned}

lexerUnboundedParsers ::
  -- | Quoted Lexer
  Q Exp ->
  IntegerParserConfig ->
  -- | The name and definition of each unbounded parsers
  Q [(Name, [Dec])]
lexerUnboundedParsers :: Q Exp -> IntegerParserConfig -> Q [(Name, [Dec])]
lexerUnboundedParsers Q Exp
lexer (IntegerParserConfig{signedOrUnsigned :: IntegerParserConfig -> SignedOrUnsigned
signedOrUnsigned = SignedOrUnsigned
s, String
prefix :: IntegerParserConfig -> String
prefix :: String
prefix, Set IntLitBase
bases :: IntegerParserConfig -> Set IntLitBase
bases :: Set IntLitBase
bases}) = do
  let proj :: Q Exp
proj = if SignedOrUnsigned -> Bool
isSigned SignedOrUnsigned
s then [|integer|] else [|natural|]
  let parsers :: [Name]
parsers = Set IntLitBase -> [(Name, IntLitBase)] -> [Name]
forall a. Set IntLitBase -> [(a, IntLitBase)] -> [a]
filterByBase Set IntLitBase
bases [(Name, IntLitBase)]
integerParsers
  [Name] -> (Name -> Q (Name, [Dec])) -> Q [(Name, [Dec])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
    [Name]
parsers
    ( \Name
p -> do
        newTp <- Name -> Bool -> Q Type
getLexerCombinatorType Name
p Bool
False
        mkLexerCombinatorDecWithProj lexer (prefix ++ nameBase p) p (pure newTp) proj
    )

lexerFixedWidthIntParsers
  :: Q Exp -- ^ The quoted lexer
  -> IntegerParserConfig -- ^ config
  -> Q [(Name, Bits, [Dec])] -- ^ Name, bitwidth and def of each generated combinator.
lexerFixedWidthIntParsers :: Q Exp -> IntegerParserConfig -> Q [(Name, Bits, [Dec])]
lexerFixedWidthIntParsers
  Q Exp
lexer
  (IntegerParserConfig{signedOrUnsigned :: IntegerParserConfig -> SignedOrUnsigned
signedOrUnsigned = SignedOrUnsigned
sign, String
prefix :: IntegerParserConfig -> String
prefix :: String
prefix, Set IntLitBase
bases :: IntegerParserConfig -> Set IntLitBase
bases :: Set IntLitBase
bases, Map Bits (Q Type)
widths :: IntegerParserConfig -> Map Bits (Q Type)
widths :: Map Bits (Q Type)
widths}) =
    let proj :: Q Exp
proj = if SignedOrUnsigned -> Bool
isSigned SignedOrUnsigned
sign then [|integer|] else [|natural|]
     in [(Name, Bits, Q Type)]
-> ((Name, Bits, Q Type) -> Q (Name, Bits, [Dec]))
-> Q [(Name, Bits, [Dec])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
          [(Name, Bits, Q Type)]
parsersToMake
          ( \(Name
old, Bits
bw, Q Type
newTp) -> do
              (nm, decs) <-
                Q Exp -> String -> Name -> Q Type -> Q Exp -> Q (Name, [Dec])
mkLexerCombinatorDecWithProj
                  Q Exp
lexer
                  (String
prefix String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
old)
                  Name
old
                  [t|Parsec $Q Type
newTp|]
                  Q Exp
proj
              return (nm, bw, decs)
          )
   where
    parsersToMake :: [(Name, Bits, Q Type)]
    parsersToMake :: [(Name, Bits, Q Type)]
parsersToMake =
      ((Bits, Q Type) -> [(Name, Bits, Q Type)])
-> [(Bits, Q Type)] -> [(Name, Bits, Q Type)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (\(Bits
b, Q Type
tp) -> (Name -> (Name, Bits, Q Type)) -> [Name] -> [(Name, Bits, Q Type)]
forall a b. (a -> b) -> [a] -> [b]
map (,Bits
b,Q Type
tp) (Bits -> [Name]
parsersAtWidth Bits
b))
        (Map Bits (Q Type) -> [(Bits, Q Type)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Bits (Q Type)
widths)
    parsersAtWidth :: Bits -> [Name]
    parsersAtWidth :: Bits -> [Name]
parsersAtWidth Bits
b = Set IntLitBase -> [(Name, IntLitBase)] -> [Name]
forall a. Set IntLitBase -> [(a, IntLitBase)] -> [a]
filterByBase Set IntLitBase
bases ([(Name, IntLitBase)] -> [Name]) -> [(Name, IntLitBase)] -> [Name]
forall a b. (a -> b) -> a -> b
$ case Bits
b of
      Bits
B8 -> [(Name, IntLitBase)]
intParsers8Bit
      Bits
B16 -> [(Name, IntLitBase)]
intParsers16Bit
      Bits
B32 -> [(Name, IntLitBase)]
intParsers32Bit
      Bits
B64 -> [(Name, IntLitBase)]
intParsers64Bit