{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}

module Foundation.UUID
    ( UUID(..)
    , newUUID
    , nil
    , fromBinary
    , uuidParser
    ) where

import Data.Maybe (fromMaybe)

import           Basement.Compat.Base
import           Foundation.Collection (Element, Sequential, foldl')
import           Foundation.Class.Storable
import           Foundation.Hashing.Hashable
import           Foundation.Bits
import           Foundation.Parser
import           Foundation.Numerical
import           Foundation.Primitive
import           Basement.Base16
import           Basement.IntegralConv
import           Basement.Types.OffsetSize
import qualified Basement.UArray as UA
import           Foundation.Random (MonadRandom, getRandomBytes)

data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
    deriving (UUID -> UUID -> Bool
(UUID -> UUID -> Bool) -> (UUID -> UUID -> Bool) -> Eq UUID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UUID -> UUID -> Bool
$c/= :: UUID -> UUID -> Bool
== :: UUID -> UUID -> Bool
$c== :: UUID -> UUID -> Bool
Eq,Eq UUID
Eq UUID
-> (UUID -> UUID -> Ordering)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> Bool)
-> (UUID -> UUID -> UUID)
-> (UUID -> UUID -> UUID)
-> Ord UUID
UUID -> UUID -> Bool
UUID -> UUID -> Ordering
UUID -> UUID -> UUID
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 :: UUID -> UUID -> UUID
$cmin :: UUID -> UUID -> UUID
max :: UUID -> UUID -> UUID
$cmax :: UUID -> UUID -> UUID
>= :: UUID -> UUID -> Bool
$c>= :: UUID -> UUID -> Bool
> :: UUID -> UUID -> Bool
$c> :: UUID -> UUID -> Bool
<= :: UUID -> UUID -> Bool
$c<= :: UUID -> UUID -> Bool
< :: UUID -> UUID -> Bool
$c< :: UUID -> UUID -> Bool
compare :: UUID -> UUID -> Ordering
$ccompare :: UUID -> UUID -> Ordering
$cp1Ord :: Eq UUID
Ord,Typeable)
instance Show UUID where
    show :: UUID -> String
show = UUID -> String
toLString
instance NormalForm UUID where
    toNormalForm :: UUID -> ()
toNormalForm !UUID
_ = ()
instance Hashable UUID where
    hashMix :: UUID -> st -> st
hashMix (UUID Word64
a Word64
b) = Word64 -> st -> st
forall a st. (Hashable a, Hasher st) => a -> st -> st
hashMix Word64
a (st -> st) -> (st -> st) -> st -> st
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Word64 -> st -> st
forall a st. (Hashable a, Hasher st) => a -> st -> st
hashMix Word64
b
instance Storable UUID where
    peek :: Ptr UUID -> IO UUID
peek Ptr UUID
p = Word64 -> Word64 -> UUID
UUID (Word64 -> Word64 -> UUID) -> IO Word64 -> IO (Word64 -> UUID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BE Word64 -> Word64
forall a. ByteSwap a => BE a -> a
fromBE (BE Word64 -> Word64) -> IO (BE Word64) -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (BE Word64) -> Offset (BE Word64) -> IO (BE Word64)
forall a. StorableFixed a => Ptr a -> Offset a -> IO a
peekOff Ptr (BE Word64)
ptr Offset (BE Word64)
0)
                  IO (Word64 -> UUID) -> IO Word64 -> IO UUID
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (BE Word64 -> Word64
forall a. ByteSwap a => BE a -> a
fromBE (BE Word64 -> Word64) -> IO (BE Word64) -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (BE Word64) -> Offset (BE Word64) -> IO (BE Word64)
forall a. StorableFixed a => Ptr a -> Offset a -> IO a
peekOff Ptr (BE Word64)
ptr Offset (BE Word64)
1)
      where ptr :: Ptr (BE Word64)
ptr = Ptr UUID -> Ptr (BE Word64)
forall a b. Ptr a -> Ptr b
castPtr Ptr UUID
p :: Ptr (BE Word64)
    poke :: Ptr UUID -> UUID -> IO ()
poke Ptr UUID
p (UUID Word64
a Word64
b) = do
        Ptr (BE Word64) -> Offset (BE Word64) -> BE Word64 -> IO ()
forall a. StorableFixed a => Ptr a -> Offset a -> a -> IO ()
pokeOff Ptr (BE Word64)
ptr Offset (BE Word64)
0 (Word64 -> BE Word64
forall a. ByteSwap a => a -> BE a
toBE Word64
a)
        Ptr (BE Word64) -> Offset (BE Word64) -> BE Word64 -> IO ()
forall a. StorableFixed a => Ptr a -> Offset a -> a -> IO ()
pokeOff Ptr (BE Word64)
ptr Offset (BE Word64)
1 (Word64 -> BE Word64
forall a. ByteSwap a => a -> BE a
toBE Word64
b)
      where ptr :: Ptr (BE Word64)
ptr = Ptr UUID -> Ptr (BE Word64)
forall a b. Ptr a -> Ptr b
castPtr Ptr UUID
p :: Ptr (BE Word64)
instance StorableFixed UUID where
    size :: proxy UUID -> CountOf Word8
size      proxy UUID
_ = CountOf Word8
16
    alignment :: proxy UUID -> CountOf Word8
alignment proxy UUID
_ = CountOf Word8
8

withComponent :: UUID -> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a) -> a
withComponent :: UUID -> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a) -> a
withComponent (UUID Word64
a Word64
b) Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a
f = Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a
f Word32
x1 Word16
x2 Word16
x3 Word16
x4 Word64
x5
  where
    !x1 :: Word32
x1 = Word64 -> Word32
forall a b. IntegralDownsize a b => a -> b
integralDownsize (Word64
a Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.>>. Int
32)
    !x2 :: Word16
x2 = Word64 -> Word16
forall a b. IntegralDownsize a b => a -> b
integralDownsize ((Word64
a Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.>>. Int
16) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xffff)
    !x3 :: Word16
x3 = Word64 -> Word16
forall a b. IntegralDownsize a b => a -> b
integralDownsize (Word64
a Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xffff)
    !x4 :: Word16
x4 = Word64 -> Word16
forall a b. IntegralDownsize a b => a -> b
integralDownsize (Word64
b Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.>>. Int
48)
    !x5 :: Word64
x5 = (Word64
b Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x0000ffffffffffff)
{-# INLINE withComponent #-}

toLString :: UUID -> [Char]
toLString :: UUID -> String
toLString UUID
uuid = UUID
-> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> String)
-> String
forall a.
UUID -> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> a) -> a
withComponent UUID
uuid ((Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> String)
 -> String)
-> (Word32 -> Word16 -> Word16 -> Word16 -> Word64 -> String)
-> String
forall a b. (a -> b) -> a -> b
$ \Word32
x1 Word16
x2 Word16
x3 Word16
x4 Word64
x5 ->
    Word32 -> ShowS
hexWord_4 Word32
x1 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
addDash ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Word16 -> ShowS
hexWord_2 Word16
x2 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
addDash ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Word16 -> ShowS
hexWord_2 Word16
x3 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
addDash ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Word16 -> ShowS
hexWord_2 Word16
x4 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShowS
addDash ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Word64 -> ShowS
hexWord64_6 Word64
x5 []
  where
    addDash :: ShowS
addDash = (:) Char
'-'
    hexWord_2 :: Word16 -> ShowS
hexWord_2 Word16
w String
l = case Word16 -> (Char, Char, Char, Char)
hexWord16 Word16
w of
                         (Char
c1,Char
c2,Char
c3,Char
c4) -> Char
c1Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c2Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c3Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c4Char -> ShowS
forall a. a -> [a] -> [a]
:String
l
    hexWord_4 :: Word32 -> ShowS
hexWord_4 Word32
w String
l = case Word32 -> (Char, Char, Char, Char, Char, Char, Char, Char)
hexWord32 Word32
w of
                    (Char
c1,Char
c2,Char
c3,Char
c4,Char
c5,Char
c6,Char
c7,Char
c8) -> Char
c1Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c2Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c3Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c4Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c5Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c6Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c7Char -> ShowS
forall a. a -> [a] -> [a]
:Char
c8Char -> ShowS
forall a. a -> [a] -> [a]
:String
l
    hexWord64_6 :: Word64 -> ShowS
hexWord64_6 Word64
w String
l = case Word64 -> Word32x2
word64ToWord32s Word64
w of
                        Word32x2 Word32
wHigh Word32
wLow -> Word16 -> ShowS
hexWord_2 (Word32 -> Word16
forall a b. IntegralDownsize a b => a -> b
integralDownsize Word32
wHigh) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Word32 -> ShowS
hexWord_4 Word32
wLow String
l

nil :: UUID
nil :: UUID
nil = Word64 -> Word64 -> UUID
UUID Word64
0 Word64
0

newUUID :: MonadRandom randomly => randomly UUID
newUUID :: randomly UUID
newUUID = UUID -> Maybe UUID -> UUID
forall a. a -> Maybe a -> a
fromMaybe (String -> UUID
forall a. HasCallStack => String -> a
error String
"Foundation.UUID.newUUID: the impossible happned")
        (Maybe UUID -> UUID)
-> (UArray Word8 -> Maybe UUID) -> UArray Word8 -> UUID
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UArray Word8 -> Maybe UUID
fromBinary
        (UArray Word8 -> UUID) -> randomly (UArray Word8) -> randomly UUID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CountOf Word8 -> randomly (UArray Word8)
forall (m :: * -> *).
MonadRandom m =>
CountOf Word8 -> m (UArray Word8)
getRandomBytes CountOf Word8
16

fromBinary :: UA.UArray Word8 -> Maybe UUID
fromBinary :: UArray Word8 -> Maybe UUID
fromBinary UArray Word8
ba
    | UArray Word8 -> CountOf Word8
forall ty. UArray ty -> CountOf ty
UA.length UArray Word8
ba CountOf Word8 -> CountOf Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= CountOf Word8
16 = Maybe UUID
forall a. Maybe a
Nothing
    | Bool
otherwise          = UUID -> Maybe UUID
forall a. a -> Maybe a
Just (UUID -> Maybe UUID) -> UUID -> Maybe UUID
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> UUID
UUID Word64
w0 Word64
w1
  where
    w0 :: Word64
w0 = (Word64
b15 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
56) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b14 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
48) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b13 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
40) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b12 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
         (Word64
b11 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
24) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b10 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
16) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b9 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
8)   Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
b8
    w1 :: Word64
w1 = (Word64
b7 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
56) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b6 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
48) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b5 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
40) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b4 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|.
         (Word64
b3 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
24) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b2 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
16) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
b1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
8)  Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
b0

    b0 :: Word64
b0  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
0)
    b1 :: Word64
b1  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
1)
    b2 :: Word64
b2  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
2)
    b3 :: Word64
b3  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
3)
    b4 :: Word64
b4  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
4)
    b5 :: Word64
b5  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
5)
    b6 :: Word64
b6  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
6)
    b7 :: Word64
b7  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
7)
    b8 :: Word64
b8  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
8)
    b9 :: Word64
b9  = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
9)
    b10 :: Word64
b10 = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
10)
    b11 :: Word64
b11 = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
11)
    b12 :: Word64
b12 = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
12)
    b13 :: Word64
b13 = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
13)
    b14 :: Word64
b14 = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
14)
    b15 :: Word64
b15 = Word8 -> Word64
forall a b. IntegralUpsize a b => a -> b
integralUpsize (UArray Word8 -> Offset Word8 -> Word8
forall ty. PrimType ty => UArray ty -> Offset ty -> ty
UA.unsafeIndex UArray Word8
ba Offset Word8
15)

uuidParser :: ( ParserSource input, Element input ~ Char
              , Sequential (Chunk input), Element input ~ Element (Chunk input)
              )
           => Parser input UUID
uuidParser :: Parser input UUID
uuidParser = do
    Word64
hex1 <- CountOf Char -> Parser input Word64
forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (Int -> CountOf Char
forall ty. Int -> CountOf ty
CountOf Int
8) Parser input Word64 -> Parser input () -> Parser input Word64
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Element input -> Parser input ()
forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
Element input
'-'
    Word64
hex2 <- CountOf Char -> Parser input Word64
forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (Int -> CountOf Char
forall ty. Int -> CountOf ty
CountOf Int
4) Parser input Word64 -> Parser input () -> Parser input Word64
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Element input -> Parser input ()
forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
Element input
'-'
    Word64
hex3 <- CountOf Char -> Parser input Word64
forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (Int -> CountOf Char
forall ty. Int -> CountOf ty
CountOf Int
4) Parser input Word64 -> Parser input () -> Parser input Word64
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Element input -> Parser input ()
forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
Element input
'-'
    Word64
hex4 <- CountOf Char -> Parser input Word64
forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (Int -> CountOf Char
forall ty. Int -> CountOf ty
CountOf Int
4) Parser input Word64 -> Parser input () -> Parser input Word64
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Element input -> Parser input ()
forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
Element input
'-'
    Word64
hex5 <- CountOf Char -> Parser input Word64
forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
CountOf Char -> Parser input Word64
parseHex (Int -> CountOf Char
forall ty. Int -> CountOf ty
CountOf Int
12)
    UUID -> Parser input UUID
forall (m :: * -> *) a. Monad m => a -> m a
return (UUID -> Parser input UUID) -> UUID -> Parser input UUID
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> UUID
UUID (Word64
hex1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
32 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
hex2 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
16 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
hex3)
                  (Word64
hex4 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
.<<. Int
48 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
hex5)


parseHex :: ( ParserSource input, Element input ~ Char
            , Sequential (Chunk input), Element input ~ Element (Chunk input)
            )
         => CountOf Char -> Parser input Word64
parseHex :: CountOf Char -> Parser input Word64
parseHex CountOf Char
count = do
    String
r <- Chunk input -> String
forall l. IsList l => l -> [Item l]
toList (Chunk input -> String)
-> Parser input (Chunk input) -> Parser input String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CountOf (Element (Chunk input)) -> Parser input (Chunk input)
forall input.
(ParserSource input, Sequential (Chunk input),
 Element input ~ Element (Chunk input)) =>
CountOf (Element (Chunk input)) -> Parser input (Chunk input)
take CountOf Char
CountOf (Element (Chunk input))
count
    Bool -> Parser input () -> Parser input ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isValidHexa (Char -> Bool) -> String -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
r) (Parser input () -> Parser input ())
-> Parser input () -> Parser input ()
forall a b. (a -> b) -> a -> b
$
        ParseError input -> Parser input ()
forall input a. ParseError input -> Parser input a
reportError (ParseError input -> Parser input ())
-> ParseError input -> Parser input ()
forall a b. (a -> b) -> a -> b
$ Maybe String -> ParseError input
forall input. Maybe String -> ParseError input
Satisfy (Maybe String -> ParseError input)
-> Maybe String -> ParseError input
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"expecting hexadecimal character only: "
                                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Item String] -> String
forall l. IsList l => [Item l] -> l
fromList (ShowS
forall a. Show a => a -> String
show String
r)
    Word64 -> Parser input Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> Parser input Word64) -> Word64 -> Parser input Word64
forall a b. (a -> b) -> a -> b
$ Word64 -> String -> Word64
listToHex Word64
0 String
r
  where
    listToHex :: Word64 -> String -> Word64
listToHex = (Word64 -> Element String -> Word64) -> Word64 -> String -> Word64
forall collection a.
Foldable collection =>
(a -> Element collection -> a) -> a -> collection -> a
foldl' (\Word64
acc' Element String
x -> Word64
acc' Word64 -> Word64 -> Word64
forall a. Multiplicative a => a -> a -> a
* Word64
16 Word64 -> Word64 -> Word64
forall a. Additive a => a -> a -> a
+ Char -> Word64
forall p. Integral p => Char -> p
fromHex Char
Element String
x)
    isValidHexa :: Char -> Bool
    isValidHexa :: Char -> Bool
isValidHexa Char
c = (Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9') Bool -> Bool -> Bool
|| (Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f') Bool -> Bool -> Bool
|| (Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'F')
    fromHex :: Char -> p
fromHex Char
'0' = p
0
    fromHex Char
'1' = p
1
    fromHex Char
'2' = p
2
    fromHex Char
'3' = p
3
    fromHex Char
'4' = p
4
    fromHex Char
'5' = p
5
    fromHex Char
'6' = p
6
    fromHex Char
'7' = p
7
    fromHex Char
'8' = p
8
    fromHex Char
'9' = p
9
    fromHex Char
'a' = p
10
    fromHex Char
'b' = p
11
    fromHex Char
'c' = p
12
    fromHex Char
'd' = p
13
    fromHex Char
'e' = p
14
    fromHex Char
'f' = p
15
    fromHex Char
'A' = p
10
    fromHex Char
'B' = p
11
    fromHex Char
'C' = p
12
    fromHex Char
'D' = p
13
    fromHex Char
'E' = p
14
    fromHex Char
'F' = p
15
    fromHex Char
_   = String -> p
forall a. HasCallStack => String -> a
error String
"Foundation.UUID.parseUUID: the impossible happened"