module Marshall where
import MyForeign
import Control.Monad(zipWithM_)
--import Ap

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

freePtr :: a -> IO ()
freePtr a
p = Addr -> IO ()
free (a -> Addr
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 = Int -> IO a
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 = Addr -> IO h
forall a. Storable a => Addr -> IO a
peek (Addr -> IO h) -> (c -> Addr) -> c -> IO h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Addr
forall a. HasAddr a => a -> Addr
addrOf
  writeCVar = Addr -> h -> IO ()
forall a. Storable a => Addr -> a -> IO ()
poke (Addr -> h -> IO ()) -> (c -> Addr) -> c -> h -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Addr
forall a. HasAddr a => a -> Addr
addrOf
  indexCVar = Addr -> Int -> IO h
forall a. Storable a => Addr -> Int -> IO a
peekElemOff (Addr -> Int -> IO h) -> (c -> Addr) -> c -> Int -> IO h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Addr
forall a. HasAddr a => a -> Addr
addrOf
  writeArray c
arr = (Int -> h -> IO ()) -> [Int] -> [h] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Addr -> Int -> h -> IO ()
forall a. Storable a => Addr -> Int -> a -> IO ()
pokeElemOff (c -> Addr
forall a. HasAddr a => a -> Addr
addrOf c
arr)) [Int
0..]
  readArray c
arr Int
n = (Int -> IO h) -> [Int] -> IO [h]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (c -> Int -> IO h
forall c h. CVar c h => c -> Int -> IO h
indexCVar c
arr) [Int
0..(Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)]

toArray :: [a] -> IO (a, Int)
toArray [a]
xs =
  do let n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
     a
a <- Int -> IO a
forall a. IsPtr a => Int -> IO a
newArray Int
n
     a -> [a] -> IO ()
forall c h. CVar c h => c -> [h] -> IO ()
writeArray a
a [a]
xs
     (a, Int) -> IO (a, Int)
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 = (Int -> c) -> Int -> c
forall a. a -> a
id
instance PrimArg Int32 Int32 c where marshall :: (Int32 -> c) -> Int32 -> c
marshall = (Int32 -> c) -> Int32 -> c
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 = (Bool -> c) -> Bool -> c
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 = (Addr -> c) -> Addr -> c
forall a. a -> a
id
instance PrimArg CLong CLong c where marshall :: (CLong -> c) -> CLong -> c
marshall = (CLong -> c) -> CLong -> c
forall a. a -> a
id
instance PrimArg CInt32 CInt32 c where marshall :: (CInt32 -> c) -> CInt32 -> c
marshall = (CInt32 -> c) -> CInt32 -> c
forall a. a -> a
id
instance PrimArg CString CString c where marshall :: (CString -> c) -> CString -> c
marshall = (CString -> c) -> CString -> c
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 :: IO o -> (o -> IO a) -> IO a
bind = IO o -> (o -> IO a) -> IO a
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;a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
instance Bind f => Bind (a->f) where bind :: IO o -> (o -> a -> f) -> a -> f
bind IO o
ioo o -> a -> f
oaf = IO o -> (o -> f) -> f
forall f o. Bind f => IO o -> (o -> f) -> f
bind IO o
ioo ((o -> f) -> f) -> (a -> o -> f) -> a -> f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> a -> f) -> a -> o -> f
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 f -> IO () -> f
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 IO CString -> (CString -> f) -> f
forall f o. Bind f => IO o -> (o -> f) -> f
`bind` \ CString
cstr ->
     CString -> f
f CString
cstr f -> IO () -> f
forall f. Bind f => f -> IO () -> f
`thn`
     CString -> IO ()
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 = Bool -> Bool
forall a. a -> a
id
instance PrimResult Char Char where unmarshall :: Char -> Char
unmarshall = Char -> Char
forall a. a -> a
id
instance PrimResult Int Int where unmarshall :: Int -> Int
unmarshall = Int -> Int
forall a. a -> a
id
instance PrimResult Int32 Int32 where unmarshall :: Int32 -> Int32
unmarshall = Int32 -> Int32
forall a. a -> a
id

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

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

unmarshallM :: m prim -> m b
unmarshallM m prim
m = prim -> m b
forall prim haskell. PrimResult prim haskell => prim -> haskell
unmarshall (prim -> m b) -> m prim -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m prim
m
unmarshallArray :: c -> Int -> IO [b]
unmarshallArray c
a Int
n = (prim -> IO b) -> [prim] -> IO [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM prim -> IO b
forall prim haskell. PrimResult prim haskell => prim -> haskell
unmarshall ([prim] -> IO [b]) -> IO [prim] -> IO [b]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< c -> Int -> IO [prim]
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 CString -> Addr
forall a. HasAddr a => a -> Addr
addrOf CString
cstrAddr -> Addr -> Bool
forall a. Eq a => a -> a -> Bool
==Addr
nullAddr
        then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
        else String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO String
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 = IO CString -> IO String
forall (m :: * -> *) prim b.
(Monad m, PrimResult prim (m b)) =>
m prim -> 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 = pb -> hb
forall prim haskell. PrimResult prim haskell => prim -> haskell
unmarshall ((pa -> pb) -> ha -> pb
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
(CString -> CString -> Bool)
-> (CString -> CString -> Bool) -> Eq CString
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) = Addr -> Int
forall a. Storable a => a -> Int
sizeOf Addr
a
  alignment :: CString -> Int
alignment (CString Addr
a) = Addr -> Int
forall a. Storable a => a -> Int
alignment Addr
a
  peek :: Addr -> IO CString
peek Addr
p = Addr -> CString
CString (Addr -> CString) -> IO Addr -> IO CString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr -> IO Addr
forall a. Storable a => Addr -> IO a
peek Addr
p
  poke :: Addr -> CString -> IO ()
poke Addr
p (CString Addr
a) = Addr -> Addr -> IO ()
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 (String -> Int
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 <- Char -> Int -> IO Addr
forall a. Storable a => a -> Int -> IO Addr
mallocElems (String -> Char
forall a. [a] -> a
head String
s) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
     (Int -> Char -> IO ()) -> [Int] -> String -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Addr -> Int -> Char -> IO ()
forall a. Storable a => Addr -> Int -> a -> IO ()
pokeElemOff Addr
a) [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] String
s
     Addr -> Int -> Char -> IO ()
forall a. Storable a => Addr -> Int -> a -> IO ()
pokeElemOff Addr
a Int
n Char
'\0'
     CString -> IO CString
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 <- Addr -> Int -> IO Char
forall a. Storable a => Addr -> Int -> IO a
peekElemOff Addr
addr Int
i
	 if Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\0'
	  then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return []
	  else (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO String
get (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              
unmarshallString' :: CString -> Int -> IO String
unmarshallString' :: CString -> Int -> IO String
unmarshallString' (CString Addr
addr) Int
n = Int -> IO String
forall a. Storable a => Int -> IO [a]
get Int
0
  where
    get :: Int -> IO [a]
get Int
i =
      if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n
      then (:) (a -> [a] -> [a]) -> IO a -> IO ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Addr -> Int -> IO a
forall a. Storable a => Addr -> Int -> IO a
peekElemOff Addr
addr Int
i IO ([a] -> [a]) -> IO [a] -> IO [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO [a]
get (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
      else [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
     

---

-- | 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 (Addr -> CLong) -> IO Addr -> IO CLong
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Addr
forall a. Storable a => a -> IO Addr
mallocElem (Int
0::Int)
  newArray :: Int -> IO CLong
newArray Int
n = Addr -> CLong
CLong (Addr -> CLong) -> IO Addr -> IO CLong
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO Addr
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 (Addr -> CXID) -> IO Addr -> IO CXID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Addr
forall a. Storable a => a -> IO Addr
mallocElem (Int
0::Int)
  newArray :: Int -> IO CXID
newArray Int
n = Addr -> CXID
CXID (Addr -> CXID) -> IO Addr -> IO CXID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO Addr
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 (Addr -> CInt32) -> IO Addr -> IO CInt32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> IO Addr
forall a. Storable a => a -> IO Addr
mallocElem (Int32
0::Int32)
  newArray :: Int -> IO CInt32
newArray Int
n = Addr -> CInt32
CInt32 (Addr -> CInt32) -> IO Addr -> IO CInt32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> Int -> IO Addr
forall a. Storable a => a -> Int -> IO Addr
mallocElems (Int32
0::Int32) Int
n

instance CVar CInt32 Int32