ID.hs

{-# OPTIONS_GHC -fno-full-laziness -fno-cse -cpp #-}

module Pugs.Compat.ID (
    ID, bufToID, hashNew,
    __, (+++), nullID, 
) where

import StringTable.Atom
import Pugs.Compat.Cast
import Data.Int
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.HashTable as H

type ID = Atom

bufToID :: ByteString -> ID
bufToID = toAtom

{-# INLINE hashNew #-}
hashNew :: IO (H.HashTable ByteString a)
hashNew = H.new (==) hashByteString

hashByteString :: ByteString -> Int32
hashByteString = BS.foldl' f golden
    where
    f m c = fromIntegral c * magic + hashInt32 m
    magic = 0xdeadbeef
    golden :: Int32
    golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32
    hashInt32 :: Int32 -> Int32
    hashInt32 x = mulHi x golden + x
    mulHi a b = fromIntegral (r `shiftR` 32)
        where
        r :: Int64
        r = fromIntegral a * fromIntegral b

{-
-- XXX - Under GHCI, our global _BufToID table could be refreshed into
--       nonexistence, so we need to compare IDs based on the actual buffer,
--       not its unique key.
data ID = MkID
#ifdef PUGS_UNDER_GHCI
    { idBuf :: !ByteString, idKey :: !Int }
#else
    { idKey :: !Int, idBuf :: !ByteString }
#endif
    deriving (Typeable, Data)

instance Eq ID where
    MkID x _ == MkID y _ = x == y
    MkID x _ /= MkID y _ = x /= y

instance Ord ID where
    compare (MkID x _) (MkID y _) = compare x y
    MkID x _ <= MkID y _ = x <= y
    MkID x _ >= MkID y _ = x >= y
    MkID x _ < MkID y _ = x < y
    MkID x _ > MkID y _ = x > y

instance Show ID where
    showsPrec x MkID{ idBuf = buf } = showsPrec x buf

instance Read ID where
    readsPrec p s = [ (unsafePerformIO (bufToID (UTF8.pack x)), y) | (x, y) <- readsPrec p s]
-}

{-# NOINLINE nullID #-}
nullID :: ID
nullID = _cast ""

{-# INLINE __ #-}
__ :: String -> ByteString
__ = UTF8.fromString

{-# INLINE (+++) #-}
(+++) :: ByteString -> ByteString -> ByteString
(+++) = BS.append

instance ((:>:) ID) String where
    cast = toAtom

instance ((:>:) String) ID where
    cast = fromAtom

instance ((:<:) String) ID where
    castBack = toAtom

instance ((:<:) ID) ByteString where
    castBack = fromAtom

instance ((:<:) ByteString) ID where
    castBack = toAtom