Identifier.hs

{-|
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 = BA.indexByteArray

-- | Equality on normalized identifier
instance Eq Identifier where
  Identifier _ x == Identifier _ y =
    BA.sizeofByteArray x == BA.sizeofByteArray y &&
    all (\i -> indexWord8 x i == indexWord8 y i)
        [0 .. BA.sizeofByteArray x - 1]

-- | Show as string literal
instance Show Identifier where
  show = show . idText

-- | Read as string literal
instance Read Identifier where
  readsPrec p x = [ (mkId t, rest) | (t,rest) <- readsPrec p x]

-- | Comparison on normalized identifier
instance Ord Identifier where
  compare (Identifier _ x) (Identifier _ y) =
    mconcat [ indexWord8 x i `compare` indexWord8 y i | i <- [0..n-1]]
      <> (BA.sizeofByteArray x `compare` BA.sizeofByteArray y)
    where
      n = min (BA.sizeofByteArray x) (BA.sizeofByteArray y)

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

-- | @'fromString' = 'mkId' . 'fromString'
instance IsString Identifier where
  fromString = mkId . fromString

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

-- | Returns the original 'Text' of an 'Identifier'
idText :: Identifier -> Text
idText (Identifier x _) = 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 _ x) = x

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

-- | Returns 'True' when the first argument is a prefix of the second.
idPrefix :: Identifier -> Identifier -> Bool
idPrefix (Identifier _ x) (Identifier _ y) =
  BA.sizeofByteArray x <= BA.sizeofByteArray y &&
  all (\i -> indexWord8 x i == indexWord8 y i)
      [0 .. BA.sizeofByteArray x - 1]

-- | Capitalize a string according to RFC 2812
-- Latin letters are capitalized and {|}~ are mapped to [\]^
ircFoldCase :: ByteString -> ByteArray
ircFoldCase bs = runST $
  do let n = B.length bs
     a <- BA.newByteArray n
     for_ [0..n-1] $ \i ->
       BA.writeByteArray a i (casemap PV.! fromIntegral (B.index bs i))
     BA.unsafeFreezeByteArray a

casemap :: PV.Vector Word8
casemap
  = PV.fromList
  $ map (fromIntegral . ord)
  $ ['\x00'..'`'] ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^" ++ ['\x7f'..'\xff']