Numbers.hs

{-# LANGUAGE UnboxedTuples, BinaryLiterals #-}

module FlatParse.Common.Numbers where

import FlatParse.Common.Assorted ( shortInteger )
import Language.Haskell.TH.Syntax (lift)

import GHC.Exts
import GHC.ForeignPtr

import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Internal as B

-- | Parse a non-empty ASCII decimal digit sequence as a 'Word'.
--   Fails on overflow.
anyAsciiDecimalWord# :: Addr# -> Addr# -> (# (##) | (# Word#, Addr# #) #)
anyAsciiDecimalWord# eob s = case anyAsciiDecimalWord_# 0## eob s of
    (# | (# n, s' #) #) | 0# <- eqAddr# s s'
                        -> (# | (# n, s' #) #)
    _                   -> (# (# #) | #)
{-# inline anyAsciiDecimalWord# #-}

-- | Parse a non-empty ASCII decimal digit sequence as a positive 'Int'.
--   Fails on overflow.
anyAsciiDecimalInt# :: Addr# -> Addr# -> (# (##) | (# Int#, Addr# #) #)
anyAsciiDecimalInt# eob s = case anyAsciiDecimalWord_# 0## eob s of
    (# | (# n, s' #) #) | 0# <- eqAddr# s s'
                        , 1# <- leWord# n (int2Word# (unI# maxBound))
                        -> (# | (# word2Int# n, s' #) #)
    _                   -> (# (##) | #)
{-# inline anyAsciiDecimalInt# #-}

anyAsciiDecimalWord_# :: Word# -> Addr# -> Addr# -> (# (##) | (# Word#, Addr# #) #)
anyAsciiDecimalWord_# acc eob s = case eqAddr# s eob of
  1# -> (# | (# acc, s #) #)
  _  -> case indexWord8OffAddr# s 0# of
#if MIN_VERSION_base(4,16,0)
    w | 1# <- leWord8# (wordToWord8# 0x30##) w
      , 1# <- leWord8# w (wordToWord8# 0x39##)
      -> case timesWord2# acc 10## of
          (# 0##, r #) -> case addWordC# r (word8ToWord# w `minusWord#` 0x30##) of
#else
    w | 1# <- leWord# 0x30## w
      , 1# <- leWord# w 0x39##
      -> case timesWord2# acc 10## of
          (# 0##, r #) -> case addWordC# r (w `minusWord#` 0x30##) of
#endif
            (# q, 0# #) -> anyAsciiDecimalWord_# q eob (s `plusAddr#` 1#)
            _           -> (# (##) | #)
          _             -> (# (##) | #)
    _ -> (# | (# acc, s #) #)

--------------------------------------------------------------------------------

-- | Parse a non-empty ASCII decimal digit sequence as a positive 'Int'.
--   May overflow.
anyAsciiDecimalIntOverflow# :: Addr# -> Addr# -> (# (##) | (# Int#, Addr# #) #)
anyAsciiDecimalIntOverflow# eob s = case anyAsciiDecimalIntOverflow_# 0# eob s of
    (# n, s' #) | 0# <- eqAddr# s s'
                -> (# | (# n, s' #) #)

                | otherwise
                -> (# (##) | #)
{-# inline anyAsciiDecimalIntOverflow# #-}

-- | Parse a non-empty ASCII decimal digit sequence as a positive 'Integer'.
anyAsciiDecimalInteger# :: ForeignPtrContents -> Addr# -> Addr# -> (# (##) | (# Integer, Addr# #) #)
anyAsciiDecimalInteger# fp eob s = case anyAsciiDecimalIntOverflow_# 0# eob s of
  (# n, s' #)
    | 1# <- eqAddr# s s'            -> (# (##) | #)

    -- Simple heuristic, using the largest number of digits that can be in an
    -- 'Int#', such that we can use the 'IS' constructor.
    | 1# <- minusAddr# s' s <=# maxDigitsInt -> (# | (# shortInteger n, s' #) #)
    | otherwise -> case BC8.readInteger (B.PS (ForeignPtr s fp) 0 (I# (minusAddr# s' s))) of
        Nothing     -> (# (##) | #)
        Just (i, _) -> (# | (# i, s' #) #)
  where
    maxDigitsInt :: Int#
    !(I# maxDigitsInt) = $(let p e = 10 ^ e - 1 <= toInteger (maxBound :: Int)
                           in  lift $ last $ takeWhile p [0 :: Int ..])
{-# inline anyAsciiDecimalInteger# #-}

-- | Parse a non-empty ASCII decimal digit sequence as a positive 'Int'.
--   May overflow.
anyAsciiDecimalIntOverflow_# :: Int# -> Addr# -> Addr# -> (# Int#, Addr# #)
anyAsciiDecimalIntOverflow_# acc eob s = case eqAddr# s eob of
  1# -> (# acc, s #)
  _  -> case indexWord8OffAddr# s 0# of
#if MIN_VERSION_base(4,16,0)
    w | 1# <- leWord8# (wordToWord8# 0x30##) w, 1# <- leWord8# w (wordToWord8# 0x39##) ->
      anyAsciiDecimalIntOverflow_# (mul10# acc +# (word2Int# (word8ToWord# w) -# 0x30#)) eob (plusAddr# s 1#)
#else
    w | 1# <- leWord# 0x30## w, 1# <- leWord# w 0x39## ->
      anyAsciiDecimalIntOverflow_# (mul10# acc +# (word2Int# w -# 0x30#)) eob (plusAddr# s 1#)
#endif
    _ -> (# acc, s #)

--------------------------------------------------------------------------------

-- | Parse a non-empty, case-insensitive ASCII hexadecimal digit sequence as a
--   'Word'.
--   Fails on overflow.
anyAsciiHexWord# :: Addr# -> Addr# -> (# (##) | (# Word#, Addr# #) #)
anyAsciiHexWord# eob s = case anyAsciiHexWord_# 0## eob s of
    (# | (# n, s' #) #) | 0# <- eqAddr# s s'
                        -> (# | (# n, s' #) #)
    _                   -> (# (# #) | #)
{-# inline anyAsciiHexWord# #-}

-- | Parse a non-empty, case-insensitive ASCII hexadecimal digit sequence as a
--   positive 'Int'.
--   Fails on overflow.
anyAsciiHexInt# :: Addr# -> Addr# -> (# (##) | (# Int#, Addr# #) #)
anyAsciiHexInt# eob s = case anyAsciiHexWord_# 0## eob s of
    (# | (# n, s' #) #) | 0# <- eqAddr# s s'
                        , 1# <- leWord# n (int2Word# (unI# maxBound))
                        -> (# | (# word2Int# n, s' #) #)

                        | otherwise
                        -> (# (##) | #)
    (# (##) | #)        -> (# (##) | #)
{-# inline anyAsciiHexInt# #-}

anyAsciiHexWord_# :: Word# -> Addr# -> Addr# -> (# (##) | (# Word#, Addr# #) #)
anyAsciiHexWord_# acc eob s = case eqAddr# s eob of
  1# -> (# | (# acc, s #) #)
  _  -> case indexWord8OffAddr# s 0# of
#if MIN_VERSION_base(4,16,0)
    w | 1# <- leWord8# (wordToWord8# 0x30##) w
      , 1# <- leWord8# w (wordToWord8# 0x39##)
      -> case timesWord2# acc 16## of
          (# 0##, r #) -> case addWordC# r (word8ToWord# w `minusWord#` 0x30##) of
#else
    w | 1# <- leWord# 0x30## w
      , 1# <- leWord# w 0x39##
      -> case timesWord2# acc 16## of
          (# 0##, r #) -> case addWordC# r (w `minusWord#` 0x30##) of
#endif
            (# q, 0# #) -> anyAsciiHexWord_# q eob (s `plusAddr#` 1#)
            _           -> (# (##) | #)
          _             -> (# (##) | #)
#if MIN_VERSION_base(4,16,0)
      | 1# <- leWord8# (wordToWord8# 0x41##) w
      , 1# <- leWord8# w (wordToWord8# 0x46##)
      -> case timesWord2# acc 16## of
          (# 0##, r #) -> case addWordC# r (word8ToWord# w `minusWord#` 0x37##) of
#else
      | 1# <- leWord# 0x41## w
      , 1# <- leWord# w 0x46##
      -> case timesWord2# acc 16## of
          (# 0##, r #) -> case addWordC# r (w `minusWord#` 0x37##) of
#endif
            (# q, 0# #) -> anyAsciiHexWord_# q eob (s `plusAddr#` 1#)
            _           -> (# (##) | #)
          _             -> (# (##) | #)
#if MIN_VERSION_base(4,16,0)
      | 1# <- leWord8# (wordToWord8# 0x61##) w
      , 1# <- leWord8# w (wordToWord8# 0x66##)
      -> case timesWord2# acc 16## of

          (# 0##, r #) -> case addWordC# r (word8ToWord# w `minusWord#` 0x57##) of
#else
      | 1# <- leWord# 0x61## w
      , 1# <- leWord# w 0x66##
      -> case timesWord2# acc 16## of

          (# 0##, r #) -> case addWordC# r (w `minusWord#` 0x57##) of
#endif
            (# q, 0# #) -> anyAsciiHexWord_# q eob (s `plusAddr#` 1#)
            _           -> (# (##) | #)
          _             -> (# (##) | #)
    _ -> (# | (# acc, s #) #)

--------------------------------------------------------------------------------
-- Zigzag encoding
-- See: https://hackage.haskell.org/package/zigzag-0.0.1.0/docs/src/Data.Word.Zigzag.html

fromZigzagNative :: Word -> Int
fromZigzagNative (W# w#) = I# (fromZigzagNative# w#)
{-# inline fromZigzagNative #-}

-- GHC should optimize to this, but to be sure, here it is
fromZigzagNative# :: Word# -> Int#
fromZigzagNative# w# =
    word2Int# ((w# `uncheckedShiftRL#` 1#) `xor#` (not# (w# `and#` 1##) `plusWord#` 1##))
{-# inline fromZigzagNative# #-}

toZigzagNative :: Int -> Word
toZigzagNative (I# i#) = W# (toZigzagNative# i#)
{-# inline toZigzagNative #-}

-- GHC should optimize to this, but to be sure, here it is
toZigzagNative# :: Int# -> Word#
toZigzagNative# i# = toZigzagNative'# (int2Word# i#)
{-# inline toZigzagNative# #-}

-- GHC should optimize to this, but to be sure, here it is
toZigzagNative'# :: Word# -> Word#
toZigzagNative'# w# =
    (w# `uncheckedShiftL#` 1#) `xor#` (w# `uncheckedShiftRL#` 63#)
{-# inline toZigzagNative'# #-}

--------------------------------------------------------------------------------

-- | protobuf style (LE, redundant, on continues)
anyVarintProtobuf# :: Addr# -> Addr# -> (# (##) | (# Int#, Addr#, Int# #) #)

#if MIN_VERSION_base(4,16,0)

anyVarintProtobuf# end# = go 0# 0#
  where
    word8ToInt# :: Word8# -> Int#
    word8ToInt# w8# = word2Int# (word8ToWord# w8#)
    {-# inline word8ToInt# #-}
    go :: Int# -> Int# -> Addr# -> (# (##) | (# Int#, Addr#, Int# #) #)
    go i# n# s# = case eqAddr# s# end# of
      1# -> (# (##) | #)
      _  ->
        let w8# = indexWord8OffAddr# s# 0#
            w8'# = word8ToInt# (w8# `andWord8#` (wordToWord8# 0b01111111##))
            i'# = i# `orI#` (w8'# `uncheckedIShiftL#` n#)
            s'# = s# `plusAddr#` 1#
            n'# = n# +# 7#
        in  case w8# `geWord8#` wordToWord8# 0b10000000## of
              1# -> go i'# n'# s'#
              _  -> (# | (# i'#, s'#, n'# #) #)

#else

anyVarintProtobuf# end# = go 0# 0#
  where
    go :: Int# -> Int# -> Addr# -> (# (##) | (# Int#, Addr#, Int# #) #)
    go i# n# s# = case eqAddr# s# end# of
      1# -> (# (##) | #)
      _  ->
        let w8# = indexWord8OffAddr# s# 0#
            w8'# = word2Int# (w8# `and#` 0b01111111##)
            i'# = i# `orI#` (w8'# `uncheckedIShiftL#` n#)
            s'# = s# `plusAddr#` 1#
            n'# = n# +# 7#
        in  case w8# `geWord#` 0b10000000## of
              1# -> go i'# n'# s'#
              _  -> (# | (# i'#, s'#, n'# #) #)

#endif

--------------------------------------------------------------------------------

unI# :: Int -> Int#
unI# (I# i) = i
{-# inline unI# #-}

mul10# :: Int# -> Int#
mul10# n = uncheckedIShiftL# n 3# +# uncheckedIShiftL# n 1#
{-# inline mul10# #-}