{-# LANGUAGE CPP #-}
module Marshall where
import MyForeign
import Control.Monad(zipWithM_)
#ifdef VERSION_bytestring
import qualified Foreign as F
import qualified Data.ByteString as BS
#endif
--import Ap

class HasAddr a where
   addrOf :: a -> Addr
   --atAddr :: Addr -> a

freePtr :: a -> IO ()
freePtr a
p = Addr -> IO ()
free (forall a. HasAddr a => a -> Addr
addrOf a
p)

class HasAddr a => IsPtr a where
   nullPtr :: a
   newPtr :: IO a
   newArray :: Int -> IO a

   newPtr = forall a. IsPtr a => Int -> IO a
newArray Int
1

class (Storable h, HasAddr c) => CVar c h | c -> h where
  readCVar :: c -> IO h
  writeCVar :: c -> h -> IO ()
  indexCVar :: c -> Int -> IO h
  writeArray :: c -> [h] -> IO ()
  readArray :: c -> Int -> IO [h]

  readCVar = forall a. Storable a => Addr -> IO a
peek forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasAddr a => a -> Addr
addrOf
  writeCVar = forall a. Storable a => Addr -> a -> IO ()
poke forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasAddr a => a -> Addr
addrOf
  indexCVar = forall a. Storable a => Addr -> Int -> IO a
peekElemOff forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasAddr a => a -> Addr
addrOf
  writeArray c
arr = forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall a. Storable a => Addr -> Int -> a -> IO ()
pokeElemOff (forall a. HasAddr a => a -> Addr
addrOf c
arr)) [Int
0..]
  readArray c
arr Int
n = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall c h. CVar c h => c -> Int -> IO h
indexCVar c
arr) [Int
0..(Int
nforall a. Num a => a -> a -> a
-Int
1)]

toArray :: [h] -> IO (a, Int)
toArray [h]
xs =
  do let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [h]
xs
     a
a <- forall a. IsPtr a => Int -> IO a
newArray Int
n
     forall c h. CVar c h => c -> [h] -> IO ()
writeArray a
a [h]
xs
     forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Int
n)

{-
instance (Storable a,Storable b) => (Storable (a,b)) where
  sizeOf (a,b) = sizeOf a+sizeOf b
  alignment (a,b) = max (alignment a) (alignment b)
  poke p (a,b) = poke p a >> poke (p `plusAddr` sizeOf a) b
  peek p = do a <- peek p
	      b <- peek (p `plusAddr` sizeOf a) p
	      return (a,b)
-}

-------------------
class PrimArg ha pa r | ha->pa where
  --marshall :: haskell -> IO (prim,IO ())
  marshall :: (pa->r)->ha->r

-- marshallM x = marshall return x -- GHC generates buggy code, it seems

instance PrimArg Int Int c where marshall :: (Int -> c) -> Int -> c
marshall = forall a. a -> a
id
instance PrimArg Int32 Int32 c where marshall :: (Int32 -> c) -> Int32 -> c
marshall = forall a. a -> a
id
--instance PrimArg Char Char c where marshall = id
instance PrimArg Bool Bool c where marshall :: (Bool -> c) -> Bool -> c
marshall = forall a. a -> a
id
--instance PrimArg () Int c where marshall f () = f 0
instance PrimArg Addr Addr c where marshall :: (Addr -> c) -> Addr -> c
marshall = forall a. a -> a
id
instance PrimArg CLong CLong c where marshall :: (CLong -> c) -> CLong -> c
marshall = forall a. a -> a
id
instance PrimArg CInt32 CInt32 c where marshall :: (CInt32 -> c) -> CInt32 -> c
marshall = forall a. a -> a
id
instance PrimArg CString CString c where marshall :: (CString -> c) -> CString -> c
marshall = forall a. a -> a
id

class    Bind f                where bind :: IO o->(o->f)->f
				     thn :: f->IO ()-> f
instance Bind (IO a)           where bind :: forall o. IO o -> (o -> IO a) -> IO a
bind = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=)
				     thn :: IO a -> IO () -> IO a
thn IO a
f IO ()
io = do a
r<-IO a
f;IO ()
io;forall (m :: * -> *) a. Monad m => a -> m a
return a
r
instance Bind f => Bind (a->f) where bind :: forall o. IO o -> (o -> a -> f) -> a -> f
bind IO o
ioo o -> a -> f
oaf = forall f o. Bind f => IO o -> (o -> f) -> f
bind IO o
ioo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip o -> a -> f
oaf
				     thn :: (a -> f) -> IO () -> a -> f
thn a -> f
f IO ()
io a
a = a -> f
f a
a forall f. Bind f => f -> IO () -> f
`thn` IO ()
io

instance Bind f => PrimArg String CString f where
  marshall :: (CString -> f) -> String -> f
marshall CString -> f
f String
str =
     String -> IO CString
marshallString String
str forall f o. Bind f => IO o -> (o -> f) -> f
`bind` \ CString
cstr ->
     CString -> f
f CString
cstr forall f. Bind f => f -> IO () -> f
`thn`
     forall {a}. HasAddr a => a -> IO ()
freePtr CString
cstr

class PrimResult prim haskell where
  unmarshall :: prim -> haskell

instance PrimResult () () where unmarshall :: () -> ()
unmarshall = forall a. a -> a
id
instance PrimResult Bool Bool where unmarshall :: Bool -> Bool
unmarshall = forall a. a -> a
id
instance PrimResult Char Char where unmarshall :: Char -> Char
unmarshall = forall a. a -> a
id
instance PrimResult Int Int where unmarshall :: Int -> Int
unmarshall = forall a. a -> a
id
instance PrimResult Int32 Int32 where unmarshall :: Int32 -> Int32
unmarshall = forall a. a -> a
id

--instance PrimResult Int (IO Int) where unmarshall = return

instance PrimResult (IO ()) (IO ()) where unmarshall :: IO () -> IO ()
unmarshall = forall a. a -> a
id
instance PrimResult (IO Int) (IO Int) where unmarshall :: IO Int -> IO Int
unmarshall = forall a. a -> a
id
instance PrimResult (IO Int32) (IO Int32) where unmarshall :: IO Int32 -> IO Int32
unmarshall = forall a. a -> a
id
instance PrimResult (IO Bool) (IO Bool) where unmarshall :: IO Bool -> IO Bool
unmarshall = forall a. a -> a
id
instance PrimResult (IO CString) (IO CString) where unmarshall :: IO CString -> IO CString
unmarshall = forall a. a -> a
id

unmarshallM :: m a -> m b
unmarshallM m a
m = forall prim haskell. PrimResult prim haskell => prim -> haskell
unmarshall forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m a
m
unmarshallArray :: c -> Int -> IO [b]
unmarshallArray c
a Int
n = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall prim haskell. PrimResult prim haskell => prim -> haskell
unmarshall forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall c h. CVar c h => c -> Int -> IO [h]
readArray c
a Int
n

instance PrimResult (IO CString) (IO (Maybe String)) where
  unmarshall :: IO CString -> IO (Maybe String)
unmarshall IO CString
addrIO =
    do CString
cstr <- IO CString
addrIO
       if forall a. HasAddr a => a -> Addr
addrOf CString
cstrforall a. Eq a => a -> a -> Bool
==Addr
nullAddr
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        else forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall prim haskell. PrimResult prim haskell => prim -> haskell
unmarshall CString
cstr

instance PrimResult CString (IO String) where unmarshall :: CString -> IO String
unmarshall = CString -> IO String
unmarshallString
instance PrimResult (IO CString) (IO String) where unmarshall :: IO CString -> IO String
unmarshall = forall {m :: * -> *} {a} {b}.
(Monad m, PrimResult a (m b)) =>
m a -> m b
unmarshallM

instance (PrimArg ha pa pb,PrimResult pb hb) => PrimResult (pa->pb) (ha->hb) where
    -- have: marshall      :: (pa->pb)->(ha->pb)
    -- have: unmarshall    :: pb->hb
    -- produce: unmarshall :: (pa->pb)->(ha->hb)
    unmarshall :: (pa -> pb) -> ha -> hb
unmarshall pa -> pb
papb ha
ha = forall prim haskell. PrimResult prim haskell => prim -> haskell
unmarshall (forall ha pa r. PrimArg ha pa r => (pa -> r) -> ha -> r
marshall pa -> pb
papb ha
ha)

--- Primitive marshalling

newtype CString = CString Addr deriving (CString -> CString -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CString -> CString -> Bool
$c/= :: CString -> CString -> Bool
== :: CString -> CString -> Bool
$c== :: CString -> CString -> Bool
Eq)
instance HasAddr CString where addrOf :: CString -> Addr
addrOf (CString Addr
a) = Addr
a --; atAddr = CString
instance CVar CString CString
instance Storable CString where
  sizeOf :: CString -> Int
sizeOf (CString Addr
a) = forall a. Storable a => a -> Int
sizeOf Addr
a
  alignment :: CString -> Int
alignment (CString Addr
a) = forall a. Storable a => a -> Int
alignment Addr
a
  peek :: Addr -> IO CString
peek Addr
p = Addr -> CString
CString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Addr -> IO a
peek Addr
p
  poke :: Addr -> CString -> IO ()
poke Addr
p (CString Addr
a) = forall a. Storable a => Addr -> a -> IO ()
poke Addr
p Addr
a

nullStr :: CString
nullStr = Addr -> CString
CString Addr
nullAddr

marshallString :: String -> IO CString
marshallString :: String -> IO CString
marshallString String
s = String -> Int -> IO CString
marshallString' String
s (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)

marshallString' :: String -> Int -> IO CString
marshallString' :: String -> Int -> IO CString
marshallString' String
s Int
n = 
  do Addr
a <- forall {a}. Storable a => a -> Int -> IO Addr
mallocElems (forall a. [a] -> a
head String
s) (Int
nforall a. Num a => a -> a -> a
+Int
1)
     forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall a. Storable a => Addr -> Int -> a -> IO ()
pokeElemOff Addr
a) [Int
0..Int
nforall a. Num a => a -> a -> a
-Int
1] String
s
     forall a. Storable a => Addr -> Int -> a -> IO ()
pokeElemOff Addr
a Int
n Char
'\0'
     forall (m :: * -> *) a. Monad m => a -> m a
return (Addr -> CString
CString Addr
a)


unmarshallString :: CString -> IO String
unmarshallString :: CString -> IO String
unmarshallString (CString Addr
addr) = Int -> IO String
get Int
0
  where 
    get :: Int -> IO String
get Int
i =
      do Char
c <- forall a. Storable a => Addr -> Int -> IO a
peekElemOff Addr
addr Int
i
	 if Char
cforall a. Eq a => a -> a -> Bool
==Char
'\0'
	  then forall (m :: * -> *) a. Monad m => a -> m a
return []
	  else (Char
cforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO String
get (Int
iforall a. Num a => a -> a -> a
+Int
1)
              
unmarshallString' :: CString -> Int -> IO String
unmarshallString' :: CString -> Int -> IO String
unmarshallString' (CString Addr
addr) Int
n = forall {a}. Storable a => Int -> IO [a]
get Int
0
  where
    get :: Int -> IO [a]
get Int
i =
      if Int
iforall a. Ord a => a -> a -> Bool
<Int
n
      then (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Addr -> Int -> IO a
peekElemOff Addr
addr Int
i forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO [a]
get (Int
iforall a. Num a => a -> a -> a
+Int
1)
      else forall (m :: * -> *) a. Monad m => a -> m a
return []

#ifdef VERSION_bytestring
unmarshallByteString' :: CString -> Int -> IO ByteString
unmarshallByteString' (CString (Addr Ptr Word8
addr)) Int
n =
    CStringLen -> IO ByteString
BS.packCStringLen (forall a b. Ptr a -> Ptr b
F.castPtr Ptr Word8
addr,Int
n)
#endif

---

-- | Pointer to long int (same size as pointers, 64 bits on 64-bit systems)
newtype CLong = CLong Addr
newtype CXID = CXID Addr

instance HasAddr CLong where addrOf :: CLong -> Addr
addrOf (CLong Addr
a) = Addr
a --;atAddr = CLong
instance HasAddr CXID where addrOf :: CXID -> Addr
addrOf (CXID Addr
a) = Addr
a --;atAddr = CLong

instance IsPtr CLong where
  nullPtr :: CLong
nullPtr = Addr -> CLong
CLong Addr
nullAddr
  newPtr :: IO CLong
newPtr = Addr -> CLong
CLong forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Storable a => a -> IO Addr
mallocElem (Int
0::Int)
  newArray :: Int -> IO CLong
newArray Int
n = Addr -> CLong
CLong forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Storable a => a -> Int -> IO Addr
mallocElems (Int
0::Int) Int
n

instance IsPtr CXID where
  nullPtr :: CXID
nullPtr = Addr -> CXID
CXID Addr
nullAddr
  newPtr :: IO CXID
newPtr = Addr -> CXID
CXID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Storable a => a -> IO Addr
mallocElem (Int
0::Int)
  newArray :: Int -> IO CXID
newArray Int
n = Addr -> CXID
CXID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Storable a => a -> Int -> IO Addr
mallocElems (Int
0::Int) Int
n

instance CVar CLong Int

-- | Pointer to C int (32 bits even on 64-bit system)
newtype CInt32 = CInt32 Addr

instance HasAddr CInt32 where addrOf :: CInt32 -> Addr
addrOf (CInt32 Addr
a) = Addr
a --;atAddr = CInt

instance IsPtr CInt32 where
  nullPtr :: CInt32
nullPtr = Addr -> CInt32
CInt32 Addr
nullAddr
  newPtr :: IO CInt32
newPtr = Addr -> CInt32
CInt32 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Storable a => a -> IO Addr
mallocElem (Int32
0::Int32)
  newArray :: Int -> IO CInt32
newArray Int
n = Addr -> CInt32
CInt32 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. Storable a => a -> Int -> IO Addr
mallocElems (Int32
0::Int32) Int
n

instance CVar CInt32 Int32