{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module RON.Text.Serialize.UUID (
    serializeUuid,
    serializeUuidAtom,
    serializeUuidKey,
    uuidToString,
    uuidToText,
) where

import           RON.Prelude

import           Data.Bits (countLeadingZeros, shiftL, xor)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import           Data.Foldable (minimumBy)
import qualified Data.Text as Text

import qualified RON.Base64 as Base64
import           RON.Util.Word (pattern B00, pattern B0000, pattern B01,
                                pattern B10, pattern B11, Word2, Word60, ls60,
                                safeCast)
import           RON.UUID (UUID (..), UuidFields (..), split, zero)

-- | Serialize UUID without context (used for test)
serializeUuid :: UUID -> ByteStringL
serializeUuid :: UUID -> ByteStringL
serializeUuid UUID
this =
    ByteString -> ByteStringL
BSL.fromStrict (ByteString -> ByteStringL) -> ByteString -> ByteStringL
forall a b. (a -> b) -> a -> b
$ case Word2
uuidVariant of
        Word2
B00 -> UuidFields -> ByteString
unzipped UuidFields
thisFields
        Word2
_   -> UUID -> ByteString
serializeUuidGeneric UUID
this
  where
    thisFields :: UuidFields
thisFields@UuidFields{Word60
Word4
Word2
uuidOrigin :: UuidFields -> Word60
uuidVersion :: UuidFields -> Word2
uuidVariant :: UuidFields -> Word2
uuidValue :: UuidFields -> Word60
uuidVariety :: UuidFields -> Word4
uuidOrigin :: Word60
uuidVersion :: Word2
uuidValue :: Word60
uuidVariety :: Word4
uuidVariant :: Word2
..} = UUID -> UuidFields
split UUID
this

uuidToString :: UUID -> String
uuidToString :: UUID -> String
uuidToString = ByteStringL -> String
BSLC.unpack (ByteStringL -> String) -> (UUID -> ByteStringL) -> UUID -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> ByteStringL
serializeUuid

uuidToText :: UUID -> Text
uuidToText :: UUID -> Text
uuidToText = String -> Text
Text.pack (String -> Text) -> (UUID -> String) -> UUID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> String
uuidToString

-- | Serialize UUID in op key context
serializeUuidKey
    :: UUID  -- ^ same key in the previous op (default is 'zero')
    -> UUID  -- ^ previous key of the same op (default is 'zero')
    -> UUID  -- ^ this
    -> ByteStringL
serializeUuidKey :: UUID -> UUID -> UUID -> ByteStringL
serializeUuidKey UUID
prevKey UUID
prev UUID
this =
    ByteString -> ByteStringL
BSL.fromStrict (ByteString -> ByteStringL) -> ByteString -> ByteStringL
forall a b. (a -> b) -> a -> b
$ case UuidFields -> Word2
uuidVariant UuidFields
thisFields of
        Word2
B00 -> [ByteString] -> ByteString
forall (f :: * -> *). Foldable f => f ByteString -> ByteString
minimumByLength ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
                UuidFields -> ByteString
unzipped UuidFields
thisFields
            ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:   UUID -> UUID -> [ByteString]
zipIfDefaultVariant UUID
prevKey UUID
this
            [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++  [ByteString
"`" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
z | UUID
prev UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
/= UUID
zero, ByteString
z <- UUID -> UUID -> [ByteString]
zipIfDefaultVariant UUID
prev UUID
this]
        Word2
_ -> UUID -> ByteString
serializeUuidGeneric UUID
this
  where
    thisFields :: UuidFields
thisFields = UUID -> UuidFields
split UUID
this

-- | Serialize UUID in op value (atom) context
serializeUuidAtom
    :: UUID  -- ^ previous
    -> UUID  -- ^ this
    -> ByteStringL
serializeUuidAtom :: UUID -> UUID -> ByteStringL
serializeUuidAtom UUID
prev UUID
this =
    ByteString -> ByteStringL
BSL.fromStrict (ByteString -> ByteStringL) -> ByteString -> ByteStringL
forall a b. (a -> b) -> a -> b
$ case UuidFields -> Word2
uuidVariant UuidFields
thisFields of
        Word2
B00 -> [ByteString] -> ByteString
forall (f :: * -> *). Foldable f => f ByteString -> ByteString
minimumByLength ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
                UuidFields -> ByteString
unzipped UuidFields
thisFields
            ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:   (Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (UUID
prev UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
/= UUID
zero) [()] -> [ByteString] -> [ByteString]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> UUID -> UUID -> [ByteString]
zipIfDefaultVariant UUID
prev UUID
this)
        Word2
_ -> UUID -> ByteString
serializeUuidGeneric UUID
this
  where
    thisFields :: UuidFields
thisFields = UUID -> UuidFields
split UUID
this

zipIfDefaultVariant :: UUID -> UUID -> [ByteString]
zipIfDefaultVariant :: UUID -> UUID -> [ByteString]
zipIfDefaultVariant UUID
prev UUID
this =
    [ ByteString
z
    | UuidFields -> Word2
uuidVariant (UUID -> UuidFields
split UUID
prev) Word2 -> Word2 -> Bool
forall a. Eq a => a -> a -> Bool
== Word2
B00
    , Just ByteString
z <- [UuidFields -> UuidFields -> Maybe ByteString
zipUuid (UUID -> UuidFields
split UUID
prev) (UUID -> UuidFields
split UUID
this)]
    ]

unzipped :: UuidFields -> ByteString
unzipped :: UuidFields -> ByteString
unzipped UuidFields{Word60
Word4
Word2
uuidOrigin :: Word60
uuidVersion :: Word2
uuidVariant :: Word2
uuidValue :: Word60
uuidVariety :: Word4
uuidOrigin :: UuidFields -> Word60
uuidVersion :: UuidFields -> Word2
uuidVariant :: UuidFields -> Word2
uuidValue :: UuidFields -> Word60
uuidVariety :: UuidFields -> Word4
..} = ByteString
x' ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
y'
  where
    variety :: ByteString
variety = case Word4
uuidVariety of
        Word4
B0000 -> ByteString
""
        Word4
_     -> Word8 -> ByteString
BS.singleton (Word4 -> Word8
Base64.encodeLetter4 Word4
uuidVariety) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/"
    x' :: ByteString
x' = ByteString
variety ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word60 -> ByteString
Base64.encode60short Word60
uuidValue
    y' :: ByteString
y' = case (Word2
uuidVersion, Word60
uuidOrigin) of
        (Word2
B00, Word60 -> Word64
forall v w. SafeCast v w => v -> w
safeCast -> Word64
0 :: Word64) -> ByteString
""
        (Word2, Word60)
_ ->
            Word2 -> Char
serializeVersion Word2
uuidVersion
            Char -> ByteString -> ByteString
`BSC.cons` Word60 -> ByteString
Base64.encode60short Word60
uuidOrigin

zipUuid :: UuidFields -> UuidFields -> Maybe ByteString
zipUuid :: UuidFields -> UuidFields -> Maybe ByteString
zipUuid UuidFields
prev UuidFields
this
    | UuidFields
prev UuidFields -> UuidFields -> Bool
forall a. Eq a => a -> a -> Bool
== UuidFields
this  = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
""
    | Bool
canReuseValue = Maybe ByteString
valueZip
    | Bool
otherwise     = Maybe ByteString
forall a. Maybe a
Nothing
  where
    canReuseValue :: Bool
canReuseValue = UuidFields
prev{uuidValue :: Word60
uuidValue = UuidFields -> Word60
uuidValue UuidFields
this} UuidFields -> UuidFields -> Bool
forall a. Eq a => a -> a -> Bool
== UuidFields
this
    valueZip :: Maybe ByteString
valueZip = Word60 -> Word60 -> Maybe ByteString
zipPrefix (UuidFields -> Word60
uuidValue UuidFields
prev) (UuidFields -> Word60
uuidValue UuidFields
this)

zipPrefix :: Word60 -> Word60 -> Maybe ByteString
zipPrefix :: Word60 -> Word60 -> Maybe ByteString
zipPrefix Word60
prev Word60
this
    | Int
commonBits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 = ByteString -> Maybe ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
""
    | Int
commonBits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
*  Int
9 = Char -> Int -> Maybe ByteString
forall (f :: * -> *). Applicative f => Char -> Int -> f ByteString
ok Char
')' Int
9
    | Int
commonBits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
*  Int
8 = Char -> Int -> Maybe ByteString
forall (f :: * -> *). Applicative f => Char -> Int -> f ByteString
ok Char
']' Int
8
    | Int
commonBits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
*  Int
7 = Char -> Int -> Maybe ByteString
forall (f :: * -> *). Applicative f => Char -> Int -> f ByteString
ok Char
'}' Int
7
    | Int
commonBits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
*  Int
6 = Char -> Int -> Maybe ByteString
forall (f :: * -> *). Applicative f => Char -> Int -> f ByteString
ok Char
'{' Int
6
    | Int
commonBits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
*  Int
5 = Char -> Int -> Maybe ByteString
forall (f :: * -> *). Applicative f => Char -> Int -> f ByteString
ok Char
'[' Int
5
    | Int
commonBits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
*  Int
4 = Char -> Int -> Maybe ByteString
forall (f :: * -> *). Applicative f => Char -> Int -> f ByteString
ok Char
'(' Int
4
    | Bool
otherwise        = Maybe ByteString
forall a. Maybe a
Nothing
  where
    ok :: Char -> Int -> f ByteString
ok Char
c Int
n = ByteString -> f ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> f ByteString) -> ByteString -> f ByteString
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> ByteString
BSC.cons Char
c (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> ByteString
encode60short' (Word64 -> ByteString) -> Word64 -> ByteString
forall a b. (a -> b) -> a -> b
$ Word60 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word60
this Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` (Int
6 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n)
    commonBits :: Int
commonBits =
        Word64 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros (Word60 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word60
prev Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word60 -> Word64
forall v w. SafeCast v w => v -> w
safeCast Word60
this :: Word64) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4
    encode60short' :: Word64 -> ByteString
encode60short' = \case
        Word64
0 -> ByteString
""
        Word64
w -> Word60 -> ByteString
Base64.encode60short (Word60 -> ByteString) -> Word60 -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> Word60
ls60 Word64
w

serializeVersion :: Word2 -> Char
serializeVersion :: Word2 -> Char
serializeVersion = \case
    Word2
B00 -> Char
'$'
    Word2
B01 -> Char
'%'
    Word2
B10 -> Char
'+'
    Word2
B11 -> Char
'-'

serializeUuidGeneric :: UUID -> ByteString
serializeUuidGeneric :: UUID -> ByteString
serializeUuidGeneric (UUID Word64
x Word64
y) = Word64 -> ByteString
Base64.encode64 Word64
x ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word64 -> ByteString
Base64.encode64 Word64
y

-- | XXX Partial for lists!
minimumByLength :: Foldable f => f ByteString -> ByteString
minimumByLength :: f ByteString -> ByteString
minimumByLength = (ByteString -> ByteString -> Ordering)
-> f ByteString -> ByteString
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((ByteString -> ByteString -> Ordering)
 -> f ByteString -> ByteString)
-> (ByteString -> ByteString -> Ordering)
-> f ByteString
-> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> Int) -> ByteString -> ByteString -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ByteString -> Int
BS.length