{-# LANGUAGE GADTs #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Embedded.Signature where
import Data.Proxy
import Language.C.Monad
import Language.Embedded.Expression
import Language.Embedded.Backend.C.Expression
import Language.C.Quote.C
data Ann exp a where
Empty :: Ann exp a
Native :: (FreePred exp a) => exp len -> Ann exp [a]
Named :: String -> Ann exp a
data Signature exp pred a where
Ret :: pred a => String -> exp a -> Signature exp pred a
Ptr :: pred a => String -> exp a -> Signature exp pred a
Lam :: pred a => Ann exp a -> (Val a -> Signature exp pred b)
-> Signature exp pred (a -> b)
lam :: (pred a, FreeExp exp, FreePred exp a)
=> (exp a -> Signature exp pred b) -> Signature exp pred (a -> b)
lam f = Lam Empty $ \x -> f (valToExp x)
name :: (pred a, FreeExp exp, FreePred exp a)
=> String -> (exp a -> Signature exp pred b) -> Signature exp pred (a -> b)
name s f = Lam (Named s) $ \x -> f (valToExp x)
ret,ptr :: (pred a)
=> String -> exp a -> Signature exp pred a
ret = Ret
ptr = Ptr
arg :: (pred a, FreeExp exp, FreePred exp a)
=> Ann exp a
-> (exp a -> exp b)
-> (exp b -> Signature exp pred c)
-> Signature exp pred (a -> c)
arg s g f = Lam s $ \x -> f $ g $ valToExp x
translateFunction :: forall m exp a. (MonadC m, CompExp exp)
=> Signature exp CType a -> m ()
translateFunction sig = go sig (return ())
where
go :: Signature exp CType d -> m () -> m ()
go (Ret n a) prelude = do
t <- cType a
inFunctionTy t n $ do
prelude
e <- compExp a
addStm [cstm| return $e; |]
go (Ptr n a) prelude = do
t <- cType a
inFunction n $ do
prelude
e <- compExp a
addParam [cparam| $ty:t *out |]
addStm [cstm| *out = $e; |]
go fun@(Lam Empty f) prelude = do
t <- cType (argProxy fun)
v <- freshVar (Proxy :: Proxy CType)
go (f v) $ prelude >> addParam [cparam| $ty:t $id:v |]
go fun@(Lam n@(Native l) f) prelude = do
t <- cType n
i <- freshId
let vi = 'v' : show i
let w = ValComp vi
let n = vi ++ "_buf"
withAlias i ('&':vi) $ go (f w) $ do
prelude
len <- compExp l
addLocal [cdecl| struct array $id:vi = { .buffer = $id:n
, .length=$len
, .elemSize=sizeof($ty:t)
, .bytes=sizeof($ty:t)*$len
}; |]
addParam [cparam| $ty:t * $id:n |]
go fun@(Lam (Named s) f) prelude = do
t <- cType (argProxy fun)
i <- freshId
let w = ValComp ('v' : show i)
withAlias i s $ go (f w) $ prelude >> addParam [cparam| $ty:t $id:s |]
argProxy :: Signature exp pred (b -> c) -> Proxy b
argProxy _ = Proxy