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.Int (Int8, Int16, Int32, Int64)
import Data.Monoid ((<>))
import Data.Typeable (Typeable)
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as VM
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign.C.Types
import Foreign.Ptr (Ptr, FunPtr)
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| CSChar |])
, (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.TypeName "ptrdiff_t", [t| CPtrdiff |])
, (C.TypeName "size_t", [t| CSize |])
, (C.TypeName "wchar_t", [t| CWchar |])
, (C.TypeName "sig_atomic_t", [t| CSigAtomic |])
, (C.LLong C.Signed, [t| CLLong |])
, (C.LLong C.Unsigned, [t| CULLong |])
, (C.TypeName "intptr_t", [t| CIntPtr |])
, (C.TypeName "uintptr_t", [t| CUIntPtr |])
, (C.TypeName "intmax_t", [t| CIntMax |])
, (C.TypeName "uintmax_t", [t| CUIntMax |])
, (C.TypeName "clock_t", [t| CClock |])
, (C.TypeName "time_t", [t| CTime |])
, (C.TypeName "useconds_t", [t| CUSeconds |])
, (C.TypeName "suseconds_t", [t| CSUSeconds |])
, (C.Float, [t| CFloat |])
, (C.Double, [t| CDouble |])
, (C.TypeName "FILE", [t| CFile |])
, (C.TypeName "fpos_t", [t| CFpos |])
, (C.TypeName "jmp_buf", [t| CJmpBuf |])
, (C.TypeName "int8_t", [t| Int8 |])
, (C.TypeName "int16_t", [t| Int16 |])
, (C.TypeName "int32_t", [t| Int32 |])
, (C.TypeName "int64_t", [t| Int64 |])
, (C.TypeName "uint8_t", [t| Word8 |])
, (C.TypeName "uint16_t", [t| Word16 |])
, (C.TypeName "uint32_t", [t| Word32 |])
, (C.TypeName "uint64_t", [t| Word64 |])
]
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 Nothing)), s)
, aqMarshaller = \_purity _cTypes cTy cId -> do
case cTy of
C.Ptr _ (C.TypeSpecifier _ (C.Char Nothing)) -> do
hsTy <- [t| Ptr CChar |]
hsExp <- getHsVariable "bsCtx" cId
hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont 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)"
}