    {-|
    Module      : Irc.Identifier
    Description : Type and operations for nicknames and channel names
    Copyright   : (c) Eric Mertens, 2016
    License     : ISC
    Maintainer  : emertens@gmail.com

    This module defines support for working with IRC's numeric reply
    codes. Pattern synonyms are provided for each of the possible IRC reply codes.

    Reply code information was extracted from https://www.alien.net.au/irc/irc2numerics.html

    -}
    module Irc.Identifier
      ( Identifier
      , idDenote
      , mkId
      , idText
      , idTextNorm
      , idPrefix
      ) where

    import           Control.Monad.ST
    import           Data.ByteString (ByteString)
    import qualified Data.ByteString as B
    import           Data.Char
    import           Data.Foldable
    import           Data.Hashable
    import           Data.String
    import           Data.Text (Text)
    import qualified Data.Text.Encoding as Text
    import qualified Data.Vector.Primitive as PV
    import qualified Data.Primitive.ByteArray as BA
    import           Data.Primitive.ByteArray (ByteArray)
    import           Data.Word

    -- | Identifier representing channels and nicknames
    data Identifier = Identifier {-# UNPACK #-} !Text
                                 {-# UNPACK #-} !ByteArray

    -- | This indexing function exists to specialize the type
    -- of 'BA.indexByteArray'.
    indexWord8 :: ByteArray -> Int -> Word8
    indexWord8 :: ByteArray -> Int -> Word8
    indexWord8 = ByteArray -> Int -> Word8
    forall a. Prim a => ByteArray -> Int -> a
    BA.indexByteArray

    -- | Equality on normalized identifier
    instance Eq Identifier where
      Identifier Text
    _ ByteArray
    x == :: Identifier -> Identifier -> Bool
    == Identifier Text
    _ ByteArray
    y =
        ByteArray -> Int
    BA.sizeofByteArray ByteArray
    x Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteArray -> Int
    BA.sizeofByteArray ByteArray
    y Bool -> Bool -> Bool
    &&
        (Int -> Bool) -> [Int] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (\Int
    i -> ByteArray -> Int -> Word8
    indexWord8 ByteArray
    x Int
    i Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteArray -> Int -> Word8
    indexWord8 ByteArray
    y Int
    i)
            [Int
    0 .. ByteArray -> Int
    BA.sizeofByteArray ByteArray
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1]

    -- | Show as string literal
    instance Show Identifier where
      show :: Identifier -> String
    show = Text -> String
    forall a. Show a => a -> String
    show (Text -> String) -> (Identifier -> Text) -> Identifier -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Identifier -> Text
    idText

    -- | Read as string literal
    instance Read Identifier where
      readsPrec :: Int -> ReadS Identifier
    readsPrec Int
    p String
    x = [ (Text -> Identifier
    mkId Text
    t, String
    rest) | (Text
    t,String
    rest) <- Int -> ReadS Text
    forall a. Read a => Int -> ReadS a
    readsPrec Int
    p String
    x]

    -- | Comparison on normalized identifier
    instance Ord Identifier where
      compare :: Identifier -> Identifier -> Ordering
    compare (Identifier Text
    _ ByteArray
    x) (Identifier Text
    _ ByteArray
    y) =
        [Ordering] -> Ordering
    forall a. Monoid a => [a] -> a
    mconcat [ ByteArray -> Int -> Word8
    indexWord8 ByteArray
    x Int
    i Word8 -> Word8 -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` ByteArray -> Int -> Word8
    indexWord8 ByteArray
    y Int
    i | Int
    i <- [Int
    0..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1]]
          Ordering -> Ordering -> Ordering
    forall a. Semigroup a => a -> a -> a
    <> (ByteArray -> Int
    BA.sizeofByteArray ByteArray
    x Int -> Int -> Ordering
    forall a. Ord a => a -> a -> Ordering
    `compare` ByteArray -> Int
    BA.sizeofByteArray ByteArray
    y)
        where
          n :: Int
    n = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min (ByteArray -> Int
    BA.sizeofByteArray ByteArray
    x) (ByteArray -> Int
    BA.sizeofByteArray ByteArray
    y)

    -- | Hash on normalized identifier
    instance Hashable Identifier where
      hashWithSalt :: Int -> Identifier -> Int
    hashWithSalt Int
    salt (Identifier Text
    _ b :: ByteArray
    b@(BA.ByteArray ByteArray#
    arr)) =
        ByteArray# -> Int -> Int -> Int -> Int
    hashByteArrayWithSalt ByteArray#
    arr Int
    0 (ByteArray -> Int
    BA.sizeofByteArray ByteArray
    b) Int
    salt

    -- | @'fromString' = 'mkId' . 'fromString'
    instance IsString Identifier where
      fromString :: String -> Identifier
    fromString = Text -> Identifier
    mkId (Text -> Identifier) -> (String -> Text) -> String -> Identifier
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    forall a. IsString a => String -> a
    fromString

    -- | Construct an 'Identifier' from a 'ByteString'
    mkId :: Text -> Identifier
    mkId :: Text -> Identifier
    mkId Text
    x = Text -> ByteArray -> Identifier
    Identifier Text
    x (ByteString -> ByteArray
    ircFoldCase (Text -> ByteString
    Text.encodeUtf8 Text
    x))

    -- | Returns the original 'Text' of an 'Identifier'
    idText :: Identifier -> Text
    idText :: Identifier -> Text
    idText (Identifier Text
    x ByteArray
    _) = Text
    x

    -- | Returns a 'ByteArray' of an 'Identifier'
    -- which is suitable for comparison or hashing
    -- which has been normalized for case.
    idDenote :: Identifier -> ByteArray
    idDenote :: Identifier -> ByteArray
    idDenote (Identifier Text
    _ ByteArray
    x) = ByteArray
    x

    -- | Returns the case-normalized 'Text' for an identifier.
    idTextNorm :: Identifier -> Text
    idTextNorm :: Identifier -> Text
    idTextNorm (Identifier Text
    _ ByteArray
    x) =
      ByteString -> Text
    Text.decodeUtf8
        ([Word8] -> ByteString
    B.pack [ ByteArray -> Int -> Word8
    indexWord8 ByteArray
    x Int
    i | Int
    i <- [Int
    0 .. ByteArray -> Int
    BA.sizeofByteArray ByteArray
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1]])

    -- | Returns 'True' when the first argument is a prefix of the second.
    idPrefix :: Identifier -> Identifier -> Bool
    idPrefix :: Identifier -> Identifier -> Bool
    idPrefix (Identifier Text
    _ ByteArray
    x) (Identifier Text
    _ ByteArray
    y) =
      ByteArray -> Int
    BA.sizeofByteArray ByteArray
    x Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= ByteArray -> Int
    BA.sizeofByteArray ByteArray
    y Bool -> Bool -> Bool
    &&
      (Int -> Bool) -> [Int] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (\Int
    i -> ByteArray -> Int -> Word8
    indexWord8 ByteArray
    x Int
    i Word8 -> Word8 -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteArray -> Int -> Word8
    indexWord8 ByteArray
    y Int
    i)
          [Int
    0 .. ByteArray -> Int
    BA.sizeofByteArray ByteArray
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1]

    -- | Capitalize a string according to RFC 2812
    -- Latin letters are capitalized and {|}~ are mapped to [\]^
    ircFoldCase :: ByteString -> ByteArray
    ircFoldCase :: ByteString -> ByteArray
    ircFoldCase ByteString
    bs = (forall s. ST s ByteArray) -> ByteArray
    forall a. (forall s. ST s a) -> a
    runST ((forall s. ST s ByteArray) -> ByteArray)
    -> (forall s. ST s ByteArray) -> ByteArray
    forall a b. (a -> b) -> a -> b
    $
      do let n :: Int
    n = ByteString -> Int
    B.length ByteString
    bs
         a <- Int -> ST s (MutableByteArray (PrimState (ST s)))
    forall (m :: * -> *).
    PrimMonad m =>
    Int -> m (MutableByteArray (PrimState m))
    BA.newByteArray Int
    n
         for_ [0..n-1] $ \Int
    i ->
           MutableByteArray (PrimState (ST s)) -> Int -> Word8 -> ST s ()
    forall a (m :: * -> *).
    (Prim a, PrimMonad m) =>
    MutableByteArray (PrimState m) -> Int -> a -> m ()
    BA.writeByteArray MutableByteArray s
    MutableByteArray (PrimState (ST s))
    a Int
    i (Vector Word8
    casemap Vector Word8 -> Int -> Word8
    forall a. Prim a => Vector a -> Int -> a
    PV.! Word8 -> Int
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (HasCallStack => ByteString -> Int -> Word8
    ByteString -> Int -> Word8
    B.index ByteString
    bs Int
    i))
         BA.unsafeFreezeByteArray a

    casemap :: PV.Vector Word8
    casemap :: Vector Word8
    casemap
      = [Word8] -> Vector Word8
    forall a. Prim a => [a] -> Vector a
    PV.fromList
      ([Word8] -> Vector Word8) -> [Word8] -> Vector Word8
    forall a b. (a -> b) -> a -> b
    $ (Char -> Word8) -> String -> [Word8]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> Word8
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> Int
    ord)
      (String -> [Word8]) -> String -> [Word8]
    forall a b. (a -> b) -> a -> b
    $ [Char
    '\x00'..Char
    '`'] String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    "ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ [Char
    '\x7f'..Char
    '\xff']