module Language.C.Inline.Context
(
TypesTable
, Purity(..)
, convertType
, CArray
, isTypeName
, AntiQuoter(..)
, AntiQuoterId
, SomeAntiQuoter(..)
, AntiQuoters
, Context(..)
, baseCtx
, funCtx
, vecCtx
, VecCtx(..)
, bsCtx
) where
import Control.Applicative ((<|>))
import Control.Monad (mzero)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Typeable (Typeable)
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as VM
import Foreign.C.Types
import Foreign.Ptr (Ptr, FunPtr, castPtr)
import Foreign.Storable (Storable)
import qualified Language.Haskell.TH as TH
import qualified Text.Parser.Token as Parser
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif
import Language.C.Inline.FunPtr
import qualified Language.C.Types as C
type TypesTable = Map.Map C.TypeSpecifier TH.TypeQ
data Purity
= Pure
| IO
deriving (Eq, Show)
data AntiQuoter a = AntiQuoter
{ aqParser :: forall m. C.CParser m => m (String, C.Type, a)
, aqMarshaller :: Purity -> TypesTable -> C.Type -> a -> TH.Q (TH.Type, TH.Exp)
}
type AntiQuoterId = String
data SomeAntiQuoter = forall a. (Eq a, Typeable a) => SomeAntiQuoter (AntiQuoter a)
type AntiQuoters = Map.Map AntiQuoterId SomeAntiQuoter
data Context = Context
{ ctxTypesTable :: TypesTable
, ctxAntiQuoters :: AntiQuoters
, ctxFileExtension :: Maybe String
, ctxOutput :: Maybe (String -> String)
}
instance Monoid Context where
mempty = Context
{ ctxTypesTable = mempty
, ctxAntiQuoters = mempty
, ctxFileExtension = Nothing
, ctxOutput = Nothing
}
mappend ctx2 ctx1 = Context
{ ctxTypesTable = ctxTypesTable ctx1 <> ctxTypesTable ctx2
, ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2
, ctxFileExtension = ctxFileExtension ctx1 <|> ctxFileExtension ctx2
, ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2
}
baseCtx :: Context
baseCtx = mempty
{ ctxTypesTable = baseTypesTable
}
baseTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ
baseTypesTable = Map.fromList
[ (C.Void, [t| () |])
, (C.Char Nothing, [t| CChar |])
, (C.Char (Just C.Signed), [t| CChar |])
, (C.Char (Just C.Unsigned), [t| CUChar |])
, (C.Short C.Signed, [t| CShort |])
, (C.Short C.Unsigned, [t| CUShort |])
, (C.Int C.Signed, [t| CInt |])
, (C.Int C.Unsigned, [t| CUInt |])
, (C.Long C.Signed, [t| CLong |])
, (C.Long C.Unsigned, [t| CULong |])
, (C.LLong C.Signed, [t| CLLong |])
, (C.LLong C.Unsigned, [t| CULLong |])
, (C.Float, [t| CFloat |])
, (C.Double, [t| CDouble |])
]
type CArray = Ptr
convertType
:: Purity
-> TypesTable
-> C.Type
-> TH.Q (Maybe TH.Type)
convertType purity cTypes = runMaybeT . go
where
goDecl = go . C.parameterDeclarationType
go :: C.Type -> MaybeT TH.Q TH.Type
go cTy = case cTy of
C.TypeSpecifier _specs cSpec ->
case Map.lookup cSpec cTypes of
Nothing -> mzero
Just ty -> lift ty
C.Ptr _quals (C.Proto retType pars) -> do
hsRetType <- go retType
hsPars <- mapM goDecl pars
lift [t| FunPtr $(buildArr hsPars hsRetType) |]
C.Ptr _quals cTy' -> do
hsTy <- go cTy'
lift [t| Ptr $(return hsTy) |]
C.Array _mbSize cTy' -> do
hsTy <- go cTy'
lift [t| CArray $(return hsTy) |]
C.Proto _retType _pars -> do
mzero
buildArr [] hsRetType =
case purity of
Pure -> [t| $(return hsRetType) |]
IO -> [t| IO $(return hsRetType) |]
buildArr (hsPar : hsPars) hsRetType =
[t| $(return hsPar) -> $(buildArr hsPars hsRetType) |]
isTypeName :: TypesTable -> C.Identifier -> Bool
isTypeName cTypes id' = Map.member (C.TypeName id') cTypes
getHsVariable :: String -> String -> TH.ExpQ
getHsVariable err s = do
mbHsName <- TH.lookupValueName s
case mbHsName of
Nothing -> error $ "Cannot capture Haskell variable " ++ s ++
", because it's not in scope. (" ++ err ++ ")"
Just hsName -> TH.varE hsName
convertType_ :: String -> Purity -> TypesTable -> C.Type -> TH.Q TH.Type
convertType_ err purity cTypes cTy = do
mbHsType <- convertType purity cTypes cTy
case mbHsType of
Nothing -> error $ "Cannot convert C type (" ++ err ++ ")"
Just hsType -> return hsType
funCtx :: Context
funCtx = mempty
{ ctxAntiQuoters = Map.fromList [("fun", SomeAntiQuoter funPtrAntiQuoter)]
}
funPtrAntiQuoter :: AntiQuoter String
funPtrAntiQuoter = AntiQuoter
{ aqParser = do
cTy <- Parser.parens C.parseParameterDeclaration
case C.parameterDeclarationId cTy of
Nothing -> error "Every captured function must be named (funCtx)"
Just id' -> do
let s = C.unIdentifier id'
return (s, C.parameterDeclarationType cTy, s)
, aqMarshaller = \purity cTypes cTy cId -> do
hsTy <- convertType_ "funCtx" purity cTypes cTy
hsExp <- getHsVariable "funCtx" cId
case hsTy of
TH.AppT (TH.ConT n) hsTy' | n == ''FunPtr -> do
hsExp' <- [| \cont -> cont =<< $(mkFunPtr (return hsTy')) $(return hsExp) |]
return (hsTy, hsExp')
_ -> error "The `fun' marshaller captures function pointers only"
}
vecCtx :: Context
vecCtx = mempty
{ ctxAntiQuoters = Map.fromList
[ ("vec-ptr", SomeAntiQuoter vecPtrAntiQuoter)
, ("vec-len", SomeAntiQuoter vecLenAntiQuoter)
]
}
class VecCtx a where
type VecCtxScalar a :: *
vecCtxLength :: a -> Int
vecCtxUnsafeWith :: a -> (Ptr (VecCtxScalar a) -> IO b) -> IO b
instance Storable a => VecCtx (V.Vector a) where
type VecCtxScalar (V.Vector a) = a
vecCtxLength = V.length
vecCtxUnsafeWith = V.unsafeWith
instance Storable a => VecCtx (VM.IOVector a) where
type VecCtxScalar (VM.IOVector a) = a
vecCtxLength = VM.length
vecCtxUnsafeWith = VM.unsafeWith
vecPtrAntiQuoter :: AntiQuoter String
vecPtrAntiQuoter = AntiQuoter
{ aqParser = do
cTy <- Parser.parens C.parseParameterDeclaration
case C.parameterDeclarationId cTy of
Nothing -> error "Every captured vector must be named (vecCtx)"
Just id' -> do
let s = C.unIdentifier id'
return (s, C.parameterDeclarationType cTy, s)
, aqMarshaller = \purity cTypes cTy cId -> do
hsTy <- convertType_ "vecCtx" purity cTypes cTy
hsExp <- getHsVariable "vecCtx" cId
hsExp' <- [| vecCtxUnsafeWith $(return hsExp) |]
return (hsTy, hsExp')
}
vecLenAntiQuoter :: AntiQuoter String
vecLenAntiQuoter = AntiQuoter
{ aqParser = do
cId <- C.parseIdentifier
let s = C.unIdentifier cId
return (s, C.TypeSpecifier mempty (C.Long C.Signed), s)
, aqMarshaller = \_purity _cTypes cTy cId -> do
case cTy of
C.TypeSpecifier _ (C.Long C.Signed) -> do
hsExp <- getHsVariable "vecCtx" cId
hsExp' <- [| fromIntegral (vecCtxLength $(return hsExp)) |]
hsTy <- [t| CLong |]
hsExp'' <- [| \cont -> cont $(return hsExp') |]
return (hsTy, hsExp'')
_ -> do
error "impossible: got type different from `long' (vecCtx)"
}
bsCtx :: Context
bsCtx = mempty
{ ctxAntiQuoters = Map.fromList
[ ("bs-ptr", SomeAntiQuoter bsPtrAntiQuoter)
, ("bs-len", SomeAntiQuoter bsLenAntiQuoter)
]
}
bsPtrAntiQuoter :: AntiQuoter String
bsPtrAntiQuoter = AntiQuoter
{ aqParser = do
cId <- C.parseIdentifier
let s = C.unIdentifier cId
return (s, C.Ptr [] (C.TypeSpecifier mempty (C.Char (Just C.Unsigned))), s)
, aqMarshaller = \_purity _cTypes cTy cId -> do
case cTy of
C.Ptr _ (C.TypeSpecifier _ (C.Char (Just C.Unsigned))) -> do
hsTy <- [t| Ptr CUChar |]
hsExp <- getHsVariable "bsCtx" cId
hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont (castPtr ptr) |]
return (hsTy, hsExp')
_ ->
error "impossible: got type different from `unsigned char' (bsCtx)"
}
bsLenAntiQuoter :: AntiQuoter String
bsLenAntiQuoter = AntiQuoter
{ aqParser = do
cId <- C.parseIdentifier
let s = C.unIdentifier cId
return (s, C.TypeSpecifier mempty (C.Long C.Signed), s)
, aqMarshaller = \_purity _cTypes cTy cId -> do
case cTy of
C.TypeSpecifier _ (C.Long C.Signed) -> do
hsExp <- getHsVariable "bsCtx" cId
hsExp' <- [| fromIntegral (BS.length $(return hsExp)) |]
hsTy <- [t| CLong |]
hsExp'' <- [| \cont -> cont $(return hsExp') |]
return (hsTy, hsExp'')
_ -> do
error "impossible: got type different from `long' (bsCtx)"
}