Overlapping instances

RawStorable.hs

class RawStorable a where
  storeMemRaw ::
    (AllocationContext b z t r, AllocationType t r) =>
    a -> b -> t -> IO (Ptr a)
  loadMemRaw :: Ptr a -> IO a

instance RawStorable Int where
  storeMemRaw el ctx typ = storeMemRaw (WrapStorable el) ctx typ >>= return . castPtr
  loadMemRaw ptr = loadMemRaw (castPtr ptr) >>= return . unwrap

instance RawStorable Double where
  storeMemRaw el ctx typ = storeMemRaw (WrapStorable el) ctx typ >>= return . castPtr
  loadMemRaw ptr = loadMemRaw (castPtr ptr) >>= return . unwrap

instance RawStorable Bool where
  storeMemRaw el ctx typ = storeMemRaw (WrapStorable el) ctx typ >>= return . castPtr
  loadMemRaw ptr = loadMemRaw (castPtr ptr) >>= return . unwrap

instance {-# OVERLAPPABLE  #-} Storable a => RawStorable (WrapStorable a) where
  storeMemRaw (WrapStorable el) ctx typ = do
    c <- withUpdatingInfo ctx typ $ \info dat -> do
      ((_, ptr), newInfo) <- newMaybeExternAlloc info $ sizeOf el
      let cptr = castPtr ptr
      poke (castPtr cptr) el
      return (ptr, Just $ newInfo, dat)
    return $ castPtr c
  loadMemRaw ptr = peek (castPtr ptr) >>= return . WrapStorable

instance {-# OVERLAPPABLE  #-} (
      RawStorable a
    , Traversable t
    , Monoid (t a)
    , Applicative t) =>
    RawStorable (t a) where
  storeMemRaw el ctx typ = do
    elPtrs <- mapM (\i -> storeMemRaw i ctx typ) el
    withUpdatingInfo ctx typ $ \info dat -> do
      let len = length elPtrs
          ptrSize = sizeOf nullPtr
          align x a = case rem x a of
                        0 -> x
                        n -> x + (a - n)
          headSize = (len + 1) * ptrSize
      (head, newInfo) <- newMaybeExternAlloc info headSize
      let (_, headPtr) = head
          cptr = castPtr headPtr :: Ptr (t a)
      end <- foldM (\ptr el -> do
        poke ptr el
        return $ plusPtr ptr ptrSize) (castPtr cptr) elPtrs
      poke end nullPtr
      return (cptr, Just newInfo, dat)
  loadMemRaw ptr = return mempty