{-|
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
     MutableByteArray s
a <- Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
BA.newByteArray Int
n
     [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \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 (ByteString -> Int -> Word8
B.index ByteString
bs Int
i))
     MutableByteArray (PrimState (ST s)) -> ST s ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
BA.unsafeFreezeByteArray MutableByteArray s
MutableByteArray (PrimState (ST s))
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']