{-| Naturals represented via ASCII numerals.

A concept which sees occasional use in places where neither speed nor size
efficiency matter.

The tar file format uses it, apparently to sidestep making a decision on byte
ordering. Though digits are encoded "big-endian", so, uh. I don't get it.

I don't really see the usage of these. It seems silly and inefficient, aimed
solely at easing debugging.
-}

{-# LANGUAGE AllowAmbiguousTypes #-}

module Binrep.Type.AsciiNat where

import Binrep
import Binrep.Util ( natVal'' )

import Data.Word ( Word8 )
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import Mason.Builder qualified as Mason
import Data.ByteString qualified as B
import Data.Semigroup ( sconcat )

import GHC.TypeNats ( Natural, KnownNat )
import GHC.Num.Natural ( naturalSizeInBase#, naturalToWord# )

import GHC.Generics ( Generic )
import Data.Data ( Data )
import Numeric ( showOct, showHex, showBin, showInt )

-- | A 'Natural' represented in binary as an ASCII string, where each character
--   a is a digit in the given base (> 1).
--
-- 'Show' instances display the stored number in the given base. If the base has
-- a common prefix (e.g. @0x@ for hex), it is used.
newtype AsciiNat (base :: Natural) = AsciiNat { forall (base :: Natural). AsciiNat base -> Natural
getAsciiNat :: Natural }
    deriving stock (forall (base :: Natural) x. Rep (AsciiNat base) x -> AsciiNat base
forall (base :: Natural) x. AsciiNat base -> Rep (AsciiNat base) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall (base :: Natural) x. Rep (AsciiNat base) x -> AsciiNat base
$cfrom :: forall (base :: Natural) x. AsciiNat base -> Rep (AsciiNat base) x
Generic, AsciiNat base -> DataType
AsciiNat base -> Constr
forall {base :: Natural}. KnownNat base => Typeable (AsciiNat base)
forall (base :: Natural).
KnownNat base =>
AsciiNat base -> DataType
forall (base :: Natural). KnownNat base => AsciiNat base -> Constr
forall (base :: Natural).
KnownNat base =>
(forall b. Data b => b -> b) -> AsciiNat base -> AsciiNat base
forall (base :: Natural) u.
KnownNat base =>
Int -> (forall d. Data d => d -> u) -> AsciiNat base -> u
forall (base :: Natural) u.
KnownNat base =>
(forall d. Data d => d -> u) -> AsciiNat base -> [u]
forall (base :: Natural) r r'.
KnownNat base =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AsciiNat base -> r
forall (base :: Natural) r r'.
KnownNat base =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AsciiNat base -> r
forall (base :: Natural) (m :: * -> *).
(KnownNat base, Monad m) =>
(forall d. Data d => d -> m d)
-> AsciiNat base -> m (AsciiNat base)
forall (base :: Natural) (m :: * -> *).
(KnownNat base, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> AsciiNat base -> m (AsciiNat base)
forall (base :: Natural) (c :: * -> *).
KnownNat base =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (AsciiNat base)
forall (base :: Natural) (c :: * -> *).
KnownNat base =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> AsciiNat base -> c (AsciiNat base)
forall (base :: Natural) (t :: * -> *) (c :: * -> *).
(KnownNat base, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (AsciiNat base))
forall (base :: Natural) (t :: * -> * -> *) (c :: * -> *).
(KnownNat base, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (AsciiNat base))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (AsciiNat base)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> AsciiNat base -> c (AsciiNat base)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> AsciiNat base -> m (AsciiNat base)
$cgmapMo :: forall (base :: Natural) (m :: * -> *).
(KnownNat base, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> AsciiNat base -> m (AsciiNat base)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> AsciiNat base -> m (AsciiNat base)
$cgmapMp :: forall (base :: Natural) (m :: * -> *).
(KnownNat base, MonadPlus m) =>
(forall d. Data d => d -> m d)
-> AsciiNat base -> m (AsciiNat base)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> AsciiNat base -> m (AsciiNat base)
$cgmapM :: forall (base :: Natural) (m :: * -> *).
(KnownNat base, Monad m) =>
(forall d. Data d => d -> m d)
-> AsciiNat base -> m (AsciiNat base)
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> AsciiNat base -> u
$cgmapQi :: forall (base :: Natural) u.
KnownNat base =>
Int -> (forall d. Data d => d -> u) -> AsciiNat base -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> AsciiNat base -> [u]
$cgmapQ :: forall (base :: Natural) u.
KnownNat base =>
(forall d. Data d => d -> u) -> AsciiNat base -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AsciiNat base -> r
$cgmapQr :: forall (base :: Natural) r r'.
KnownNat base =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> AsciiNat base -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AsciiNat base -> r
$cgmapQl :: forall (base :: Natural) r r'.
KnownNat base =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> AsciiNat base -> r
gmapT :: (forall b. Data b => b -> b) -> AsciiNat base -> AsciiNat base
$cgmapT :: forall (base :: Natural).
KnownNat base =>
(forall b. Data b => b -> b) -> AsciiNat base -> AsciiNat base
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (AsciiNat base))
$cdataCast2 :: forall (base :: Natural) (t :: * -> * -> *) (c :: * -> *).
(KnownNat base, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (AsciiNat base))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (AsciiNat base))
$cdataCast1 :: forall (base :: Natural) (t :: * -> *) (c :: * -> *).
(KnownNat base, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (AsciiNat base))
dataTypeOf :: AsciiNat base -> DataType
$cdataTypeOf :: forall (base :: Natural).
KnownNat base =>
AsciiNat base -> DataType
toConstr :: AsciiNat base -> Constr
$ctoConstr :: forall (base :: Natural). KnownNat base => AsciiNat base -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (AsciiNat base)
$cgunfold :: forall (base :: Natural) (c :: * -> *).
KnownNat base =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (AsciiNat base)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> AsciiNat base -> c (AsciiNat base)
$cgfoldl :: forall (base :: Natural) (c :: * -> *).
KnownNat base =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> AsciiNat base -> c (AsciiNat base)
Data)
    deriving (AsciiNat base -> AsciiNat base -> Bool
forall (base :: Natural). AsciiNat base -> AsciiNat base -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AsciiNat base -> AsciiNat base -> Bool
$c/= :: forall (base :: Natural). AsciiNat base -> AsciiNat base -> Bool
== :: AsciiNat base -> AsciiNat base -> Bool
$c== :: forall (base :: Natural). AsciiNat base -> AsciiNat base -> Bool
Eq, AsciiNat base -> AsciiNat base -> Bool
AsciiNat base -> AsciiNat base -> Ordering
AsciiNat base -> AsciiNat base -> AsciiNat base
forall (base :: Natural). Eq (AsciiNat base)
forall (base :: Natural). AsciiNat base -> AsciiNat base -> Bool
forall (base :: Natural).
AsciiNat base -> AsciiNat base -> Ordering
forall (base :: Natural).
AsciiNat base -> AsciiNat base -> AsciiNat base
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 :: AsciiNat base -> AsciiNat base -> AsciiNat base
$cmin :: forall (base :: Natural).
AsciiNat base -> AsciiNat base -> AsciiNat base
max :: AsciiNat base -> AsciiNat base -> AsciiNat base
$cmax :: forall (base :: Natural).
AsciiNat base -> AsciiNat base -> AsciiNat base
>= :: AsciiNat base -> AsciiNat base -> Bool
$c>= :: forall (base :: Natural). AsciiNat base -> AsciiNat base -> Bool
> :: AsciiNat base -> AsciiNat base -> Bool
$c> :: forall (base :: Natural). AsciiNat base -> AsciiNat base -> Bool
<= :: AsciiNat base -> AsciiNat base -> Bool
$c<= :: forall (base :: Natural). AsciiNat base -> AsciiNat base -> Bool
< :: AsciiNat base -> AsciiNat base -> Bool
$c< :: forall (base :: Natural). AsciiNat base -> AsciiNat base -> Bool
compare :: AsciiNat base -> AsciiNat base -> Ordering
$ccompare :: forall (base :: Natural).
AsciiNat base -> AsciiNat base -> Ordering
Ord) via Natural

instance Show (AsciiNat 2)  where showsPrec :: Int -> AsciiNat 2 -> ShowS
showsPrec Int
_ AsciiNat 2
n = String -> ShowS
showString String
"0b" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Integral a, Show a) => a -> ShowS
showBin (forall (base :: Natural). AsciiNat base -> Natural
getAsciiNat AsciiNat 2
n)
instance Show (AsciiNat 8)  where showsPrec :: Int -> AsciiNat 8 -> ShowS
showsPrec Int
_ AsciiNat 8
n = String -> ShowS
showString String
"0o" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Integral a, Show a) => a -> ShowS
showOct (forall (base :: Natural). AsciiNat base -> Natural
getAsciiNat AsciiNat 8
n)
instance Show (AsciiNat 10) where showsPrec :: Int -> AsciiNat 10 -> ShowS
showsPrec Int
_ AsciiNat 10
n = forall a. Integral a => a -> ShowS
showInt (forall (base :: Natural). AsciiNat base -> Natural
getAsciiNat AsciiNat 10
n)
instance Show (AsciiNat 16) where showsPrec :: Int -> AsciiNat 16 -> ShowS
showsPrec Int
_ AsciiNat 16
n = String -> ShowS
showString String
"0x" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Integral a, Show a) => a -> ShowS
showHex (forall (base :: Natural). AsciiNat base -> Natural
getAsciiNat AsciiNat 16
n)

-- | Compare two 'AsciiNat's with arbitrary bases.
asciiNatCompare :: AsciiNat b1 -> AsciiNat b2 -> Ordering
asciiNatCompare :: forall (b1 :: Natural) (b2 :: Natural).
AsciiNat b1 -> AsciiNat b2 -> Ordering
asciiNatCompare (AsciiNat Natural
n1) (AsciiNat Natural
n2) = forall a. Ord a => a -> a -> Ordering
compare Natural
n1 Natural
n2

-- | The bytelength of an 'AsciiNat' is the number of digits in the number in
--   the given base. We can calculate this generically with great efficiency
--   using GHC primitives.
instance KnownNat base => BLen (AsciiNat base) where
    blen :: AsciiNat base -> Int
blen (AsciiNat Natural
n) = forall a. AsBLen a => Word# -> a
wordToBLen# (Word# -> Natural -> Word#
naturalSizeInBase# (Natural -> Word#
naturalToWord# Natural
base) Natural
n)
      where base :: Natural
base = forall (a :: Natural). KnownNat a => Natural
natVal'' @base

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

instance Put (AsciiNat 8) where
    put :: AsciiNat 8 -> Builder
put = (Word8 -> Word8) -> Natural -> Natural -> Builder
natToAsciiBytes (forall a. Num a => a -> a -> a
+ Word8
0x30) Natural
8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (base :: Natural). AsciiNat base -> Natural
getAsciiNat

instance Get (AsciiNat 8) where
    get :: Getter (AsciiNat 8)
get = do
        ByteString
bs <- forall a. Get a => Getter a
get
        case (Word8 -> Maybe Word8)
-> Natural -> ByteString -> Either Word8 Natural
asciiBytesToNat Word8 -> Maybe Word8
octalFromAsciiDigit Natural
8 ByteString
bs of
          Left  Word8
w -> forall a. EBase -> Getter a
eBase forall a b. (a -> b) -> a -> b
$ String -> ByteString -> Word8 -> EBase
EFailParse String
"hex ASCII natural" ByteString
bs Word8
w
          Right Natural
n -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (base :: Natural). Natural -> AsciiNat base
AsciiNat Natural
n

octalFromAsciiDigit :: Word8 -> Maybe Word8
octalFromAsciiDigit :: Word8 -> Maybe Word8
octalFromAsciiDigit = \case
  Word8
0x30 -> forall a. a -> Maybe a
Just Word8
0
  Word8
0x31 -> forall a. a -> Maybe a
Just Word8
1
  Word8
0x32 -> forall a. a -> Maybe a
Just Word8
2
  Word8
0x33 -> forall a. a -> Maybe a
Just Word8
3
  Word8
0x34 -> forall a. a -> Maybe a
Just Word8
4
  Word8
0x35 -> forall a. a -> Maybe a
Just Word8
5
  Word8
0x36 -> forall a. a -> Maybe a
Just Word8
6
  Word8
0x37 -> forall a. a -> Maybe a
Just Word8
7
  Word8
_    -> forall a. Maybe a
Nothing

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

natToAsciiBytes :: (Word8 -> Word8) -> Natural -> Natural -> Builder
natToAsciiBytes :: (Word8 -> Word8) -> Natural -> Natural -> Builder
natToAsciiBytes Word8 -> Word8
f Natural
base =
    forall a. Semigroup a => NonEmpty a -> a
sconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Word8
w -> Word8 -> Builder
Mason.word8 Word8
w) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Word8
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (Integral a, Integral b) => a -> a -> NonEmpty b
digits @Word8 Natural
base

asciiBytesToNat :: (Word8 -> Maybe Word8) -> Natural -> B.ByteString -> Either Word8 Natural
asciiBytesToNat :: (Word8 -> Maybe Word8)
-> Natural -> ByteString -> Either Word8 Natural
asciiBytesToNat Word8 -> Maybe Word8
f Natural
base ByteString
bs =
    case forall a. (Word8 -> a -> a) -> a -> ByteString -> a
B.foldr Word8
-> Either Word8 (Natural, Natural)
-> Either Word8 (Natural, Natural)
go (forall a b. b -> Either a b
Right (Natural
0, Natural
0)) ByteString
bs of
      Left Word8
w -> forall a b. a -> Either a b
Left Word8
w
      Right (Natural
n, Natural
_) -> forall a b. b -> Either a b
Right Natural
n
  where
    go :: Word8 -> Either Word8 (Natural, Natural) -> Either Word8 (Natural, Natural)
    go :: Word8
-> Either Word8 (Natural, Natural)
-> Either Word8 (Natural, Natural)
go Word8
_ (Left Word8
w) = forall a b. a -> Either a b
Left Word8
w
    go Word8
w (Right (Natural
n, Natural
expo)) =
        case Word8 -> Maybe Word8
f Word8
w of
          Maybe Word8
Nothing -> forall a b. a -> Either a b
Left Word8
w
          Just Word8
d  -> forall a b. b -> Either a b
Right (Natural
n forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
d forall a. Num a => a -> a -> a
* Natural
baseforall a b. (Num a, Integral b) => a -> b -> a
^Natural
expo, Natural
expoforall a. Num a => a -> a -> a
+Natural
1)

digits :: forall b a. (Integral a, Integral b) => a -> a -> NonEmpty b
digits :: forall b a. (Integral a, Integral b) => a -> a -> NonEmpty b
digits a
base = [b] -> a -> NonEmpty b
go []
  where
    go :: [b] -> a -> NonEmpty b
go [b]
s a
x = NonEmpty b -> a -> NonEmpty b
loop (b
head' forall a. a -> [a] -> NonEmpty a
:| [b]
s) a
tail'
      where
        head' :: b
head' = forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
x forall a. Integral a => a -> a -> a
`mod` a
base)
        tail' :: a
tail' = a
x forall a. Integral a => a -> a -> a
`div` a
base
    loop :: NonEmpty b -> a -> NonEmpty b
loop s :: NonEmpty b
s@(b
r :| [b]
rs) = \case
        a
0 -> NonEmpty b
s
        a
x -> [b] -> a -> NonEmpty b
go (b
r forall a. a -> [a] -> [a]
: [b]
rs) a
x