{-# LANGUAGE
    OverloadedStrings
  , GeneralizedNewtypeDeriving
  , DataKinds
  , ApplicativeDo
#-}

module UUID
  ( encodeHyphenated
  , builderHyphenated
  , decodeHyphenated
  , parserHyphenated
  , encodeUnhyphenated
  , builderUnhyphenated
  , parserUnhyphenated
  , decodeUnhyphenated
  , decodeLenient
  ) where

import Arithmetic.Nat
import Data.Bits
import Data.Bytes.Builder.Bounded
import Data.Bytes
import Data.Bytes.Parser
import Data.Bytes.Parser.Latin
import Data.Primitive.ByteArray
import Data.WideWord.Word128
import Data.Word

-- | In its canonical textual representation, 
-- the 16 octets of a UUID are represented as 32 hexadecimal (base-16) digits, 
-- displayed in 5 groups separated by hyphens,
-- in the form 8-4-4-4-12 for a total of 36 characters 
-- (32 alphanumeric characters and 4 hyphens)
--
-- UUIDs can also be represented as a base62 encoding of a Word128

encodeHyphenated :: Word128 -> ByteArray
encodeHyphenated :: Word128 -> ByteArray
encodeHyphenated Word128
uuid = Nat 36 -> Builder 36 -> ByteArray
forall (n :: Nat). Nat n -> Builder n -> ByteArray
run Nat 36
forall (n :: Nat). KnownNat n => Nat n
constant (Word128 -> Builder 36
builderHyphenated Word128
uuid)

builderHyphenated :: Word128 -> Builder 36
builderHyphenated :: Word128 -> Builder 36
builderHyphenated Word128
uuid = 
           Word32 -> Builder 8
word32PaddedLowerHex Word32
w1
  Builder 8 -> Builder 28 -> Builder (8 + 28)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Char -> Builder 1
ascii Char
'-'
  Builder 1 -> Builder 27 -> Builder (1 + 27)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Word16 -> Builder 4
word16PaddedLowerHex Word16
w2
  Builder 4 -> Builder 23 -> Builder (4 + 23)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Char -> Builder 1
ascii Char
'-'
  Builder 1 -> Builder 22 -> Builder (1 + 22)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Word16 -> Builder 4
word16PaddedLowerHex Word16
w3
  Builder 4 -> Builder 18 -> Builder (4 + 18)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Char -> Builder 1
ascii Char
'-'
  Builder 1 -> Builder 17 -> Builder (1 + 17)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Word16 -> Builder 4
word16PaddedLowerHex Word16
w4
  Builder 4 -> Builder 13 -> Builder (4 + 13)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Char -> Builder 1
ascii Char
'-'
  Builder 1 -> Builder 12 -> Builder (1 + 12)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Word32 -> Builder 8
word32PaddedLowerHex Word32
w5
  Builder 8 -> Builder 4 -> Builder (8 + 4)
forall (m :: Nat) (n :: Nat).
Builder m -> Builder n -> Builder (m + n)
`append` Word16 -> Builder 4
word16PaddedLowerHex Word16
w6
  where
  (Word32
w1,Word16
w2,Word16
w3,Word16
w4,Word32
w5,Word16
w6) = Word128 -> (Word32, Word16, Word16, Word16, Word32, Word16)
toWords Word128
uuid

decodeHyphenated :: Bytes -> Maybe Word128
decodeHyphenated :: Bytes -> Maybe Word128
decodeHyphenated Bytes
uuid = (forall s. Parser () s Word128) -> Bytes -> Maybe Word128
forall e a. (forall s. Parser e s a) -> Bytes -> Maybe a
parseBytesMaybe (() -> Parser () s Word128
forall e s. e -> Parser e s Word128
parserHyphenated ()) Bytes
uuid

-- | Parser type from @bytesmith@
parserHyphenated :: e -> Parser e s Word128
parserHyphenated :: e -> Parser e s Word128
parserHyphenated e
err = do
  Word32
w1 <- e -> Parser e s Word32
forall e s. e -> Parser e s Word32
hexFixedWord32 e
err
  e -> Char -> Parser e s ()
forall e s. e -> Char -> Parser e s ()
skipChar1 e
err Char
'-'
  Word16
w2 <- e -> Parser e s Word16
forall e s. e -> Parser e s Word16
hexFixedWord16 e
err
  e -> Char -> Parser e s ()
forall e s. e -> Char -> Parser e s ()
skipChar1 e
err Char
'-'
  Word16
w3 <- e -> Parser e s Word16
forall e s. e -> Parser e s Word16
hexFixedWord16 e
err
  e -> Char -> Parser e s ()
forall e s. e -> Char -> Parser e s ()
skipChar1 e
err Char
'-'
  Word16
w4 <- e -> Parser e s Word16
forall e s. e -> Parser e s Word16
hexFixedWord16 e
err
  e -> Char -> Parser e s ()
forall e s. e -> Char -> Parser e s ()
skipChar1 e
err Char
'-'
  Word32
w5 <- e -> Parser e s Word32
forall e s. e -> Parser e s Word32
hexFixedWord32 e
err
  Word16
w6 <- e -> Parser e s Word16
forall e s. e -> Parser e s Word16
hexFixedWord16 e
err
  pure $ Word128 :: Word64 -> Word64 -> Word128
Word128
    { word128Hi64 :: Word64
word128Hi64 = Word32 -> Word16 -> Word16 -> Word64
fromW32W16Word64 Word32
w1 Word16
w2 Word16
w3
    , word128Lo64 :: Word64
word128Lo64 = Word16 -> Word32 -> Word16 -> Word64
fromW16W32W16Word64 Word16
w4 Word32
w5 Word16
w6
    }

toWords :: Word128 -> (Word32,Word16,Word16,Word16,Word32,Word16)
toWords :: Word128 -> (Word32, Word16, Word16, Word16, Word32, Word16)
toWords (Word128 Word64
a Word64
b) =
  -- Note: implementing this as 2 Word64 shifts with 'unsafeShiftR'
  -- is up to 40% faster than using 128-bit shifts on a Word128 value.
  ( Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
unsafeShiftR Word64
a Int
32)
  , Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
unsafeShiftR Word64
a Int
16)
  , Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a
  , Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
unsafeShiftR Word64
b Int
48)
  , Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
unsafeShiftR Word64
b Int
16)
  , Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
b
  )

parserUnhyphenated :: e -> Parser e s Word128
parserUnhyphenated :: e -> Parser e s Word128
parserUnhyphenated e
err = 
      Word64 -> Word64 -> Word128
Word128 
  (Word64 -> Word64 -> Word128)
-> Parser e s Word64 -> Parser e s (Word64 -> Word128)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> e -> Parser e s Word64
forall e s. e -> Parser e s Word64
hexFixedWord64 e
err
  Parser e s (Word64 -> Word128)
-> Parser e s Word64 -> Parser e s Word128
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> e -> Parser e s Word64
forall e s. e -> Parser e s Word64
hexFixedWord64 e
err

decodeUnhyphenated :: Bytes -> Maybe Word128
decodeUnhyphenated :: Bytes -> Maybe Word128
decodeUnhyphenated Bytes
uuid = (forall s. Parser () s Word128) -> Bytes -> Maybe Word128
forall e a. (forall s. Parser e s a) -> Bytes -> Maybe a
parseBytesMaybe (() -> Parser () s Word128
forall e s. e -> Parser e s Word128
parserUnhyphenated ()) Bytes
uuid

builderUnhyphenated :: Word128 -> Builder 32
builderUnhyphenated :: Word128 -> Builder 32
builderUnhyphenated = Word128 -> Builder 32
word128PaddedLowerHex

encodeUnhyphenated :: Word128 -> ByteArray
encodeUnhyphenated :: Word128 -> ByteArray
encodeUnhyphenated Word128
uuid = Nat 32 -> Builder 32 -> ByteArray
forall (n :: Nat). Nat n -> Builder n -> ByteArray
run Nat 32
forall (n :: Nat). KnownNat n => Nat n
constant (Word128 -> Builder 32
builderUnhyphenated Word128
uuid)

parserLenient :: e -> Parser e s Word128
parserLenient :: e -> Parser e s Word128
parserLenient e
err = do
  Word32
w1 <- e -> Parser e s Word32
forall e s. e -> Parser e s Word32
hexFixedWord32 e
err
  Char -> Parser e s ()
forall e s. Char -> Parser e s ()
skipChar Char
'-'
  Word16
w2 <- e -> Parser e s Word16
forall e s. e -> Parser e s Word16
hexFixedWord16 e
err
  Char -> Parser e s ()
forall e s. Char -> Parser e s ()
skipChar Char
'-'
  Word16
w3 <- e -> Parser e s Word16
forall e s. e -> Parser e s Word16
hexFixedWord16 e
err
  Char -> Parser e s ()
forall e s. Char -> Parser e s ()
skipChar Char
'-'
  Word16
w4 <- e -> Parser e s Word16
forall e s. e -> Parser e s Word16
hexFixedWord16 e
err
  Char -> Parser e s ()
forall e s. Char -> Parser e s ()
skipChar Char
'-'
  Word32
w5 <- e -> Parser e s Word32
forall e s. e -> Parser e s Word32
hexFixedWord32 e
err
  Word16
w6 <- e -> Parser e s Word16
forall e s. e -> Parser e s Word16
hexFixedWord16 e
err
  pure $ Word128 :: Word64 -> Word64 -> Word128
Word128
    { word128Hi64 :: Word64
word128Hi64 = Word32 -> Word16 -> Word16 -> Word64
fromW32W16Word64 Word32
w1 Word16
w2 Word16
w3
    , word128Lo64 :: Word64
word128Lo64 = Word16 -> Word32 -> Word16 -> Word64
fromW16W32W16Word64 Word16
w4 Word32
w5 Word16
w6
    }

-- | decodes uuid with out without hyphens
decodeLenient :: Bytes -> Maybe Word128
decodeLenient :: Bytes -> Maybe Word128
decodeLenient Bytes
uuid = (forall s. Parser () s Word128) -> Bytes -> Maybe Word128
forall e a. (forall s. Parser e s a) -> Bytes -> Maybe a
parseBytesMaybe (() -> Parser () s Word128
forall e s. e -> Parser e s Word128
parserLenient ()) Bytes
uuid

fromW32W16Word64 :: Word32 -> Word16 -> Word16 -> Word64
fromW32W16Word64 :: Word32 -> Word16 -> Word16 -> Word64
fromW32W16Word64 Word32
a Word16
b Word16
c =
      Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
a) Int
32
  Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL (Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
b) Int
16
  Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
c)

fromW16W32W16Word64 :: Word16 -> Word32 -> Word16 -> Word64
fromW16W32W16Word64 :: Word16 -> Word32 -> Word16 -> Word64
fromW16W32W16Word64 Word16
a Word32
b Word16
c = 
      Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL (Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
a) Int
48
  Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
b) Int
16
  Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
c)