{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

module Asn.Oid
  ( Oid(..)
  , toShortText
  , fromShortTextDot
  , size
  , index
  , take
  , isPrefixOf
  ) where

import Prelude hiding (take)

import Control.Monad.ST (runST)
import Data.Primitive (PrimArray)
import Data.Text.Short (ShortText)
import Data.Word (Word32)
import Data.ByteString.Short.Internal (ShortByteString(SBS))

import qualified Arithmetic.Nat as Nat
import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Chunks as Chunks
import qualified Data.Bytes.Builder as Builder
import qualified Data.Bytes.Builder.Bounded as Bounded
import qualified Data.Primitive as Prim
import qualified Data.Primitive.Contiguous as C
import qualified Data.Text.Short as ST
import qualified Data.Text.Short.Unsafe as ST
import qualified Data.Bytes.Parser as Parser
import qualified Data.Bytes.Parser.Latin as Latin


newtype Oid = Oid { Oid -> PrimArray Word32
getOid :: PrimArray Word32 }
  deriving newtype (Int -> Oid -> ShowS
[Oid] -> ShowS
Oid -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Oid] -> ShowS
$cshowList :: [Oid] -> ShowS
show :: Oid -> String
$cshow :: Oid -> String
showsPrec :: Int -> Oid -> ShowS
$cshowsPrec :: Int -> Oid -> ShowS
Show)
  deriving newtype (NonEmpty Oid -> Oid
Oid -> Oid -> Oid
forall b. Integral b => b -> Oid -> Oid
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Oid -> Oid
$cstimes :: forall b. Integral b => b -> Oid -> Oid
sconcat :: NonEmpty Oid -> Oid
$csconcat :: NonEmpty Oid -> Oid
<> :: Oid -> Oid -> Oid
$c<> :: Oid -> Oid -> Oid
Semigroup)
  deriving newtype (Semigroup Oid
Oid
[Oid] -> Oid
Oid -> Oid -> Oid
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Oid] -> Oid
$cmconcat :: [Oid] -> Oid
mappend :: Oid -> Oid -> Oid
$cmappend :: Oid -> Oid -> Oid
mempty :: Oid
$cmempty :: Oid
Monoid)
  deriving newtype (Oid -> Oid -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Oid -> Oid -> Bool
$c/= :: Oid -> Oid -> Bool
== :: Oid -> Oid -> Bool
$c== :: Oid -> Oid -> Bool
Eq)
  deriving newtype (Eq Oid
Oid -> Oid -> Bool
Oid -> Oid -> Ordering
Oid -> Oid -> Oid
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 :: Oid -> Oid -> Oid
$cmin :: Oid -> Oid -> Oid
max :: Oid -> Oid -> Oid
$cmax :: Oid -> Oid -> Oid
>= :: Oid -> Oid -> Bool
$c>= :: Oid -> Oid -> Bool
> :: Oid -> Oid -> Bool
$c> :: Oid -> Oid -> Bool
<= :: Oid -> Oid -> Bool
$c<= :: Oid -> Oid -> Bool
< :: Oid -> Oid -> Bool
$c< :: Oid -> Oid -> Bool
compare :: Oid -> Oid -> Ordering
$ccompare :: Oid -> Oid -> Ordering
Ord)

-- | Encode an OID. Encodes the empty OID as empty text even though
-- this is not a valid encoded OID.
toShortText :: Oid -> ShortText
toShortText :: Oid -> ShortText
toShortText (Oid PrimArray Word32
arr) = case Int
sz of
  Int
0 -> ShortText
ST.empty
  Int
_ -> ByteArray -> ShortText
ba2st forall a b. (a -> b) -> a -> b
$ Chunks -> ByteArray
Chunks.concatU forall a b. (a -> b) -> a -> b
$ Int -> Builder -> Chunks
Builder.run Int
256
    ( Word32 -> Builder
Builder.word32Dec (forall a. Prim a => PrimArray a -> Int -> a
Prim.indexPrimArray PrimArray Word32
arr Int
0)
      forall a. Semigroup a => a -> a -> a
<>
      forall (arr :: * -> *) a m.
(Contiguous arr, Element arr a, Monoid m) =>
(a -> m) -> arr a -> m
C.foldMap
        (\Word32
w -> forall (n :: Nat). Nat n -> Builder n -> Builder
Builder.fromBounded forall (n :: Nat). KnownNat n => Nat n
Nat.constant
          (forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
Bounded.append (Char -> Builder 1
Bounded.ascii Char
'.') (Word32 -> Builder 10
Bounded.word32Dec Word32
w))
        ) (forall (arr :: * -> *) a.
(Contiguous arr, Element arr a) =>
arr a -> Int -> Int -> Sliced arr a
C.slice PrimArray Word32
arr Int
1 (Int
sz forall a. Num a => a -> a -> a
- Int
1))
    )
  where
  !sz :: Int
sz = forall a. Prim a => PrimArray a -> Int
Prim.sizeofPrimArray PrimArray Word32
arr

-- | Decode an OID. Returns Nothing if the text is empty.
fromShortTextDot :: ShortText -> Maybe Oid
fromShortTextDot :: ShortText -> Maybe Oid
fromShortTextDot !ShortText
str =
  let !b :: Bytes
b = ShortByteString -> Bytes
Bytes.fromShortByteString (ShortText -> ShortByteString
ST.toShortByteString ShortText
str)
      !maxPossibleParts :: Int
maxPossibleParts = forall a. Integral a => a -> a -> a
div (Bytes -> Int
Bytes.length Bytes
b) Int
2 forall a. Num a => a -> a -> a
+ Int
1
   in forall e a. (forall s. Parser e s a) -> Bytes -> Maybe a
Parser.parseBytesMaybe
        ( do Word32
w0 <- forall e s. e -> Parser e s Word32
Latin.decWord32 ()
             MutablePrimArray s Word32
dst <- forall s a e. ST s a -> Parser e s a
Parser.effect forall a b. (a -> b) -> a -> b
$ do
               MutablePrimArray s Word32
dst <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
Prim.newPrimArray Int
maxPossibleParts
               forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
Prim.writePrimArray MutablePrimArray s Word32
dst Int
0 Word32
w0
               forall (f :: * -> *) a. Applicative f => a -> f a
pure MutablePrimArray s Word32
dst
             let go :: Int -> Parser () s Oid
go !Int
ix = forall e s. Parser e s Bool
Parser.isEndOfInput forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Bool
True -> forall s a e. ST s a -> Parser e s a
Parser.effect forall a b. (a -> b) -> a -> b
$ do
                     forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a -> Int -> m ()
Prim.shrinkMutablePrimArray MutablePrimArray s Word32
dst Int
ix
                     PrimArray Word32
dst' <- forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
Prim.unsafeFreezePrimArray MutablePrimArray s Word32
dst
                     forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimArray Word32 -> Oid
Oid PrimArray Word32
dst')
                   Bool
False -> do
                     forall e s. e -> Char -> Parser e s ()
Latin.char () Char
'.'
                     Word32
w <- forall e s. e -> Parser e s Word32
Latin.decWord32 ()
                     forall s a e. ST s a -> Parser e s a
Parser.effect (forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
Prim.writePrimArray MutablePrimArray s Word32
dst Int
ix Word32
w)
                     Int -> Parser () s Oid
go (Int
ix forall a. Num a => a -> a -> a
+ Int
1)
             Int -> Parser () s Oid
go Int
1
        ) Bytes
b

size :: Oid -> Int
{-# inline size #-}
size :: Oid -> Int
size (Oid PrimArray Word32
ws) = forall a. Prim a => PrimArray a -> Int
Prim.sizeofPrimArray PrimArray Word32
ws

index :: Oid -> Int -> Word32
{-# inline index #-}
index :: Oid -> Int -> Word32
index (Oid PrimArray Word32
arr) = forall a. Prim a => PrimArray a -> Int -> a
Prim.indexPrimArray PrimArray Word32
arr

take :: Oid -> Int -> Oid
take :: Oid -> Int -> Oid
take (Oid !PrimArray Word32
preArr) !Int
len
  | Int
len forall a. Ord a => a -> a -> Bool
>= forall a. Prim a => PrimArray a -> Int
Prim.sizeofPrimArray PrimArray Word32
preArr = PrimArray Word32 -> Oid
Oid PrimArray Word32
preArr
  | Bool
otherwise = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MutablePrimArray s Word32
dst <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
Prim.newPrimArray Int
len
    forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
Prim.copyPrimArray MutablePrimArray s Word32
dst Int
0 PrimArray Word32
preArr Int
0 Int
len
    PrimArray Word32 -> Oid
Oid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
Prim.unsafeFreezePrimArray MutablePrimArray s Word32
dst

isPrefixOf :: Oid -> Oid -> Bool
isPrefixOf :: Oid -> Oid -> Bool
isPrefixOf (Oid PrimArray Word32
preArr) (Oid PrimArray Word32
arr)
  | Int
preSize forall a. Ord a => a -> a -> Bool
> Int
theSize = Bool
False
  | Bool
otherwise = Int -> Bool
go Int
0
  where
  go :: Int -> Bool
go !Int
i
    | Int
i forall a. Ord a => a -> a -> Bool
>= Int
preSize = Bool
True
    | forall a. Prim a => PrimArray a -> Int -> a
Prim.indexPrimArray PrimArray Word32
preArr Int
i forall a. Eq a => a -> a -> Bool
/= forall a. Prim a => PrimArray a -> Int -> a
Prim.indexPrimArray PrimArray Word32
arr Int
i = Bool
False
    | Bool
otherwise = Int -> Bool
go (Int
i forall a. Num a => a -> a -> a
+ Int
1)
  !preSize :: Int
preSize = forall a. Prim a => PrimArray a -> Int
Prim.sizeofPrimArray PrimArray Word32
preArr
  !theSize :: Int
theSize = forall a. Prim a => PrimArray a -> Int
Prim.sizeofPrimArray PrimArray Word32
arr

ba2st :: Prim.ByteArray -> ShortText
{-# inline ba2st #-}
ba2st :: ByteArray -> ShortText
ba2st (Prim.ByteArray ByteArray#
x) = ShortByteString -> ShortText
ST.fromShortByteStringUnsafe (ByteArray# -> ShortByteString
SBS ByteArray#
x)