content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveAnyClass #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE ViewPatterns #-}
  
  module RON.UUID (
      UUID (..),
      UuidFields (..),
      build,
      buildX,
      buildY,
      split,
      succValue,
      addValue,
      zero,
      pattern Zero,
  
      -- * Fields as lenses
      variety,
      value,
      variant,
      version,
      origin,
  
      -- * Name
      getName,
      liftName,
      mkName,
      mkScopedName,
  
      -- * Base32 encoding, suitable for file names
      decodeBase32,
      encodeBase32,
  ) where
  
  import RON.Prelude
  
  import Data.Bits (shiftL, shiftR, (.&.), (.|.))
  import Data.ByteString.Char8 qualified as BSC
  import Language.Haskell.TH.Syntax (Exp, Q, liftData)
  import Text.Show qualified
  
  import RON.Base64 qualified as Base64
  import RON.Util.Word (
      Word2,
      Word4,
      Word60,
      leastSignificant2,
      leastSignificant4,
      leastSignificant60,
      safeCast,
      pattern B00,
      pattern B0000,
      pattern B01,
      pattern B10,
      pattern B11,
   )
  
  {- | Universally unique identifier of anything,
  as documented in https://github.com/gritzko/ron/blob/master/uuid.md
  -}
  data UUID = UUID {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
      deriving (Data, Eq, Generic, Hashable, Ord)
  
  -- | RON-Text-encoding
  instance Show UUID where
      -- showsPrec a (UUID x y) =
      --     showParen (a >= 11) $
      --     showString "UUID 0x" . showHex x . showString " 0x" . showHex y
      show this = show serialized
        where
          UUID x y = this
          UuidFields{..} = split this
          serialized = case uuidVariant of
              B00 -> unzipped
              _ -> generic
          unzipped = x' <> y'
          variety' = case uuidVariety of
              B0000 -> ""
              _ -> chr (fromIntegral $ Base64.encodeLetter4 uuidVariety) : "/"
          x' = variety' <> BSC.unpack (Base64.encode60short uuidValue)
          y' = case (uuidVersion, uuidOrigin) of
              (B00, safeCast -> 0 :: Word64) -> ""
              _ -> version' : BSC.unpack (Base64.encode60short uuidOrigin)
          generic = BSC.unpack $ Base64.encode64 x <> Base64.encode64 y
          version' = case uuidVersion of
              B00 -> '$'
              B01 -> '%'
              B10 -> '+'
              B11 -> '-'
  
  -- | UUID split in parts
  data UuidFields = UuidFields
      { uuidVariety :: !Word4
      , uuidValue :: !Word60
      , uuidVariant :: !Word2
      , uuidVersion :: !Word2
      , uuidOrigin :: !Word60
      }
      deriving (Eq, Show)
  
  -- | Split UUID into parts
  split :: UUID -> UuidFields
  split (UUID x y) =
      UuidFields
          { uuidVariety = leastSignificant4 $ x `shiftR` 60
          , uuidValue = leastSignificant60 x
          , uuidVariant = leastSignificant2 $ y `shiftR` 62
          , uuidVersion = leastSignificant2 $ y `shiftR` 60
          , uuidOrigin = leastSignificant60 y
          }
  
  -- | Build UUID from parts
  build :: UuidFields -> UUID
  build UuidFields{..} =
      UUID
          (buildX uuidVariety uuidValue)
          (buildY uuidVariant uuidVersion uuidOrigin)
  
  -- | Build former 64 bits of UUID from parts
  buildX :: Word4 -> Word60 -> Word64
  buildX uuidVariety uuidValue =
      (safeCast uuidVariety `shiftL` 60) .|. safeCast uuidValue
  
  -- | Build latter 64 bits of UUID from parts
  buildY :: Word2 -> Word2 -> Word60 -> Word64
  buildY uuidVariant uuidVersion uuidOrigin =
      (safeCast uuidVariant `shiftL` 62)
          .|. (safeCast uuidVersion `shiftL` 60)
          .|. safeCast uuidOrigin
  
  -- | Make an unscoped (unqualified) name
  mkName ::
      (MonadFail m) =>
      -- | name, max 10 Base64 letters
      ByteString ->
      m UUID
  mkName nam = mkScopedName nam ""
  
  -- | Contruct a UUID name in compile-time
  liftName :: ByteString -> Q Exp
  liftName = mkName >=> liftData
  
  -- TODO(2019-01-11, cblp) typed splice
  
  -- | Make a scoped (qualified) name
  mkScopedName ::
      (MonadFail m) =>
      -- | scope, max 10 Base64 letters
      ByteString ->
      -- | local name, max 10 Base64 letters
      ByteString ->
      m UUID
  mkScopedName scope nam = do
      scope' <- expectBase64x60 "UUID scope" scope $ Base64.decode60 scope
      nam' <- expectBase64x60 "UUID name" nam $ Base64.decode60 nam
      pure $
          build
              UuidFields
                  { uuidVariety = B0000
                  , uuidValue = scope'
                  , uuidVariant = B00
                  , uuidVersion = B00
                  , uuidOrigin = nam'
                  }
    where
      expectBase64x60 field input =
          maybe
              ( fail $
                  field
                      <> ": expected a Base64-encoded 10-character string, got "
                      <> show input
              )
              pure
  
  -- | Convert UUID to a name
  getName ::
      UUID ->
      -- | @(scope, name)@ for a scoped name; @(name, "")@ for a global name
      Maybe (ByteString, ByteString)
  getName uuid =
      case split uuid of
          UuidFields
              { uuidVariety = B0000
              , uuidVariant = B00
              , uuidVersion = B00
              , uuidValue
              , uuidOrigin
              } ->
                  Just (x, y)
                where
                  x = Base64.encode60short uuidValue
                  y = case safeCast uuidOrigin :: Word64 of
                      0 -> ""
                      _ -> Base64.encode60short uuidOrigin
          _ -> Nothing
  
  -- | UUID with all zero fields
  zero :: UUID
  zero = UUID 0 0
  
  -- | UUID with all zero fields
  pattern Zero :: UUID
  pattern Zero = UUID 0 0
  
  -- | Increment field 'uuidValue' of a UUID
  succValue :: UUID -> UUID
  succValue = build . go . split
    where
      go u@UuidFields{uuidValue} =
          u
              { uuidValue =
                  if uuidValue < maxBound then succ uuidValue else uuidValue
              }
  
  -- | Increase field 'uuidValue' of a UUID
  addValue :: UUID -> Word60 -> UUID
  addValue uu v = build u{uuidValue = uuidValue + v}
    where
      u@UuidFields{uuidValue} = split uu
  
  -- | Encode a UUID to a Base32 string
  encodeBase32 :: UUID -> FilePath
  encodeBase32 (UUID x y) =
      BSC.unpack $
          Base64.encode64base32short x <> "-" <> Base64.encode64base32short y
  
  -- | Decode a UUID from a Base32 string
  decodeBase32 :: FilePath -> Maybe UUID
  decodeBase32 fp = do
      let (x, dashy) = span (/= '-') $ map toUpper fp
      ("-", y) <- pure $ splitAt 1 dashy
      UUID
          <$> Base64.decode64base32 (BSC.pack x)
          <*> Base64.decode64base32 (BSC.pack y)
  
  variety :: Lens' UUID Word4
  variety =
      lens
          (\(UUID x _) -> leastSignificant4 $ x `shiftR` 60)
          ( \(UUID x y) v ->
              UUID (x .&. 0x0FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60)) y
          )
  
  value :: Lens' UUID Word60
  value =
      lens
          (\(UUID x _) -> leastSignificant60 x)
          (\(UUID x y) v -> UUID (x .&. 0xF000000000000000 .|. safeCast v) y)
  
  variant :: Lens' UUID Word2
  variant =
      lens
          (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 62)
          ( \(UUID x y) v ->
              UUID x (y .&. 0x3FFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 62))
          )
  
  version :: Lens' UUID Word2
  version =
      lens
          (\(UUID _ y) -> leastSignificant2 $ y `shiftR` 60)
          ( \(UUID x y) v ->
              UUID x (y .&. 0xCFFFFFFFFFFFFFFF .|. (safeCast v `shiftL` 60))
          )
  
  origin :: Lens' UUID Word60
  origin =
      lens
          (\(UUID _ y) -> leastSignificant60 y)
          (\(UUID x y) v -> UUID x (y .&. 0xF000000000000000 .|. safeCast v))
  
  type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t
  
  type Lens' s a = Lens s s a a
  
  lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
  lens sa sbt afb s = sbt s <$> afb (sa s)
  {-# INLINE lens #-}
  