Types.hs

{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fbang-patterns #-}
module Data.CompactMap.Types where

import Control.Monad
import Foreign
import Foreign.Storable
import Foreign.C

--import Data.Generics hiding ((:+:),GT)
import Data.Char
import Data.Int
import Data.Binary
import Data.Binary.Put
--import Data.Binary.Get (getInthost)
import Data.ByteString.Internal (memcmp,inlinePerformIO)
import qualified Data.ByteString.Unsafe as B

--import qualified Data.CompactString as C
--import qualified Data.CompactString.Unsafe as C

import GHC.IOBase hiding (Buffer)
import GHC.Exts
import GHC.Int

data Buffer = Buffer
    { bufferData :: {-# UNPACK #-} !(IORef (ForeignPtr ()))
    , bufferOld  :: {-# UNPACK #-} !(IORef [ForeignPtr ()])
    , bufferPos  :: {-# UNPACK #-} !FastMutInt
    , bufferSize :: {-# UNPACK #-} !FastMutInt
    }


-- Strict, unboxed IORef
data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
newFastMutInt (I# i) = IO $ \s -> case newByteArray# size s of
                                    (# s, arr #) -> case writeIntArray# arr 0# i s of
                                                      s -> (# s, FastMutInt arr #)
    where I# size = sizeOf (0::Int)
readFastMutInt (FastMutInt arr) = IO $ \s ->
  case readIntArray# arr 0# s of { (# s, i #) ->
  (# s, I# i #) }
writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
  case writeIntArray# arr 0# i s of { s ->
  (# s, () #) }


{-
newtype OptInt = OptInt Int deriving (Eq,Ord,Enum,Typeable,Num,Show)
instance Binary OptInt where
    {-# INLINE put #-}
    put (OptInt i) = putInthost i
    {-# INLINE get #-}
    get = liftM OptInt getInthost
-}
{-
data RawString = RawString {-# UNPACK #-} !Int {-# UNPACK #-} !(Ptr CChar)
instance Binary RawString where
    put (RawString len ptr) = error "put not defined" -- putCString (ptr,len)
    get = error "get not defined" {-do bs <- get
             return $! RawString (B.length bs) (unsafePerformIO $ B.unsafeUseAsCString bs return) -}
instance Ord RawString where
    {-# INLINE compare #-}
    compare (RawString len1 ptr1) (RawString len2 ptr2)
        = inlinePerformIO $
          do n <- memcmp (castPtr $ ptr1) (castPtr ptr2) (fromIntegral $ min len1 len2)
             return $! case n `compare` 0 of
                         EQ -> compare len1 len2
                         x  -> x
instance Show RawString where
    show (RawString len ptr) = show (unsafePerformIO $ B.unsafePackCStringLen (ptr,len))
instance Eq RawString where
    a == b = compare a b == EQ
-}
{-
instance C.Encoding a => Binary (C.CompactString a) where
    {-# INLINE put #-}
    put = put . C.toByteString
    {-# INLINE get #-}
    get = fmap C.unsafeFromByteString get
-}

data KeyCursor
data DataCursor

data Index = Index { indexStart  :: {-# UNPACK #-} !(Ptr IndexItem)
                   , indexBuffer :: {-# UNPACK #-} !Buffer }

data IndexItem = IndexItem {-# UNPACK #-} !(Ptr IndexItem)
                           {-# UNPACK #-} !(Ptr ())
                           {-# UNPACK #-} !(Ptr KeyCursor)
                           {-# UNPACK #-} !(Ptr IndexItem)
                           {-# UNPACK #-} !(Ptr IndexItem) -- Top, size, elem idx, left, right


type IdxInt = Ptr IndexItem
{-# INLINE extractField #-}
-- Get field 'f' out of the n'th IndexItem.
extractField :: Int -> (Ptr IndexItem) -> IO (Ptr IndexItem)
extractField !f !ptr = do v <- peekByteOff ptr ((sizeOf (undefined::IdxInt) * f))
                          return (v::IdxInt)

{-# INLINE putField #-}
-- Put field 'f' in the n'th IndexItem
putField :: Int -> (Ptr IndexItem) -> Ptr IndexItem -> IO ()
putField !f !ptr !v = pokeByteOff ptr ((sizeOf (undefined::IdxInt) * f)) (v :: IdxInt)


instance Storable IndexItem where
    sizeOf _ = sizeOf (undefined :: IdxInt) * 5
    alignment _ = alignment (undefined :: IdxInt)
    {-# INLINE peek #-}
    peek ptr = let ptr' = castPtr ptr
                   get n = (peekElemOff ptr' n :: IO (Ptr a))
               in liftM5 IndexItem (get 0) (get 1) (get 2) (get 3) (get 4)
    {-# INLINE poke #-}
    poke ptr' (IndexItem a b c d e)
        = let ptr = castPtr ptr'
              put n v = pokeElemOff ptr n v
          in put 0 a >> put 1 b >> put 2 c >> put 3 d >> put 4 e