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

    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 (Eq,Ord,Typeable)
    instance Show UUID where
        show = toLString
    instance NormalForm UUID where
        toNormalForm !_ = ()
    instance Hashable UUID where
        hashMix (UUID a b) = hashMix a . hashMix b
    instance Storable UUID where
        peek p = UUID <$> (fromBE <$> peekOff ptr 0)
                      <*> (fromBE <$> peekOff ptr 1)
          where ptr = castPtr p :: Ptr (BE Word64)
        poke p (UUID a b) = do
            pokeOff ptr 0 (toBE a)
            pokeOff ptr 1 (toBE b)
          where ptr = castPtr p :: Ptr (BE Word64)
    instance StorableFixed UUID where
        size      _ = 16
        alignment _ = 8

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

    toLString :: UUID -> [Char]
    toLString uuid = withComponent uuid $ \x1 x2 x3 x4 x5 ->
        hexWord_4 x1 $ addDash $ hexWord_2 x2 $ addDash $ hexWord_2 x3 $ addDash $ hexWord_2 x4 $ addDash $ hexWord64_6 x5 []
      where
        addDash = (:) '-'
        hexWord_2 w l = case hexWord16 w of
                             (c1,c2,c3,c4) -> c1:c2:c3:c4:l
        hexWord_4 w l = case hexWord32 w of
                        (c1,c2,c3,c4,c5,c6,c7,c8) -> c1:c2:c3:c4:c5:c6:c7:c8:l
        hexWord64_6 w l = case word64ToWord32s w of
                            Word32x2 wHigh wLow -> hexWord_2 (integralDownsize wHigh) $ hexWord_4 wLow l

    nil :: UUID
    nil = UUID 0 0

    newUUID :: MonadRandom randomly => randomly UUID
    newUUID = fromMaybe (error "Foundation.UUID.newUUID: the impossible happned")
            . fromBinary
            <$> getRandomBytes 16

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

        b0  = integralUpsize (UA.unsafeIndex ba 0)
        b1  = integralUpsize (UA.unsafeIndex ba 1)
        b2  = integralUpsize (UA.unsafeIndex ba 2)
        b3  = integralUpsize (UA.unsafeIndex ba 3)
        b4  = integralUpsize (UA.unsafeIndex ba 4)
        b5  = integralUpsize (UA.unsafeIndex ba 5)
        b6  = integralUpsize (UA.unsafeIndex ba 6)
        b7  = integralUpsize (UA.unsafeIndex ba 7)
        b8  = integralUpsize (UA.unsafeIndex ba 8)
        b9  = integralUpsize (UA.unsafeIndex ba 9)
        b10 = integralUpsize (UA.unsafeIndex ba 10)
        b11 = integralUpsize (UA.unsafeIndex ba 11)
        b12 = integralUpsize (UA.unsafeIndex ba 12)
        b13 = integralUpsize (UA.unsafeIndex ba 13)
        b14 = integralUpsize (UA.unsafeIndex ba 14)
        b15 = integralUpsize (UA.unsafeIndex ba 15)

    uuidParser :: ( ParserSource input, Element input ~ Char
                  , Sequential (Chunk input), Element input ~ Element (Chunk input)
                  )
               => Parser input UUID
    uuidParser = do
        hex1 <- parseHex (CountOf 8) <* element '-'
        hex2 <- parseHex (CountOf 4) <* element '-'
        hex3 <- parseHex (CountOf 4) <* element '-'
        hex4 <- parseHex (CountOf 4) <* element '-'
        hex5 <- parseHex (CountOf 12)
        return $ UUID (hex1 .<<. 32 .|. hex2 .<<. 16 .|. hex3)
                      (hex4 .<<. 48 .|. hex5)

    parseHex :: ( ParserSource input, Element input ~ Char
                , Sequential (Chunk input), Element input ~ Element (Chunk input)
                )
             => CountOf Char -> Parser input Word64
    parseHex count = do
        r <- toList <$> take count
        unless (and $ isValidHexa <$> r) $
            reportError $ Satisfy $ Just $ "expecting hexadecimal character only: "
                                        <> fromList (show r)
        return $ listToHex 0 r
      where
        listToHex = foldl' (\acc' x -> acc' * 16 + fromHex x)
        isValidHexa :: Char -> Bool
        isValidHexa c = ('0' <= c && c <= '9') || ('a' <= c && c <= 'f') || ('A' <= c && c <= 'F')
        fromHex '0' = 0
        fromHex '1' = 1
        fromHex '2' = 2
        fromHex '3' = 3
        fromHex '4' = 4
        fromHex '5' = 5
        fromHex '6' = 6
        fromHex '7' = 7
        fromHex '8' = 8
        fromHex '9' = 9
        fromHex 'a' = 10
        fromHex 'b' = 11
        fromHex 'c' = 12
        fromHex 'd' = 13
        fromHex 'e' = 14
        fromHex 'f' = 15
        fromHex 'A' = 10
        fromHex 'B' = 11
        fromHex 'C' = 12
        fromHex 'D' = 13
        fromHex 'E' = 14
        fromHex 'F' = 15
        fromHex _   = error "Foundation.UUID.parseUUID: the impossible happened"