diff --git a/Language/C/Inline/Error.hs b/Language/C/Inline/Error.hs --- a/Language/C/Inline/Error.hs +++ b/Language/C/Inline/Error.hs @@ -13,7 +13,7 @@ module Language.C.Inline.Error ( -- * Error reporting - reportErrorAndFail, + reportErrorWithLang, reportErrorAndFail, -- * Exception handling tryWithPlaceholder, @@ -31,11 +31,23 @@ import Text.PrettyPrint.Mainland as QC +reportErrorWithLang :: QC.Extensions -> String -> Q () +reportErrorWithLang lang msg + = do + { loc <- location + -- FIXME: define a Show instance for 'Loc' and use it to prefix position to error + ; TH.reportError $ "Inline " ++ showLang lang ++ ": " ++ msg + } + reportErrorAndFail :: QC.Extensions -> String -> Q a reportErrorAndFail lang msg + = reportErrorAndFail' $ "Inline " ++ showLang lang ++ ": " ++ msg + +reportErrorAndFail' :: String -> Q a +reportErrorAndFail' msg = do - { reportError' lang msg - ; fail "Failure" + { TH.reportError msg + ; fail "Fatal error due to inline code" } -- reportErrorAndBail :: String -> Q TH.Exp @@ -46,19 +58,12 @@ -- ; return $ VarE undefinedName -- } -reportError' :: QC.Extensions -> String -> Q () -reportError' lang msg - = do - { loc <- location - -- FIXME: define a Show instance for 'Loc' and use it to prefix position to error - ; TH.reportError $ "Inline " ++ showLang lang ++ ": " ++ msg - } - where - showLang QC.Antiquotation = "C" - showLang QC.Gcc = "GCC C" - showLang QC.CUDA = "CUDA C" - showLang QC.OpenCL = "OpenCL" - showLang QC.ObjC = "Objective-C" +showLang :: QC.Extensions -> String +showLang QC.Antiquotation = "C" +showLang QC.Gcc = "GCC C" +showLang QC.CUDA = "CUDA C" +showLang QC.OpenCL = "OpenCL" +showLang QC.ObjC = "Objective-C" -- If the tried computation fails, insert a placeholder expression. -- diff --git a/Language/C/Inline/Hint.hs b/Language/C/Inline/Hint.hs --- a/Language/C/Inline/Hint.hs +++ b/Language/C/Inline/Hint.hs @@ -13,16 +13,17 @@ module Language.C.Inline.Hint ( -- * Annotations - Annotated(..), (<:), void, + Annotated(..), (<:), void, annotatedShowQ, -- * Hints Hint(..), -- * Querying of annotated entities - haskellTypeOf, stripAnnotation + haskellTypeOf, foreignTypeOf, stripAnnotation ) where -- common libraries +import Control.Applicative import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax as TH @@ -49,16 +50,28 @@ void :: e -> Annotated e void = (''() <:) --- Hints imply marshalling strategies, which include source and destination types for marshalling. +-- |Pretty print an annotated entity. -- +annotatedShowQ :: Show e => Annotated e -> Q String +annotatedShowQ (e :> hint) = ((show e ++ " :> ") ++) <$> showQ hint +annotatedShowQ (Typed name) = return $ "Typed " ++ show name + +-- |Hints imply marshalling strategies, which include source and destination types for marshalling. +-- class Hint hint where haskellType :: hint -> Q TH.Type + foreignType :: hint -> Q (Maybe QC.Type) -- ^In case of 'Nothing', the foreign type is determined by the Haskell type. + showQ :: hint -> Q String instance Hint Name where -- must be a type name haskellType = conT + foreignType = const (return Nothing) + showQ = return . show instance Hint (Q TH.Type) where haskellType = id + foreignType = const (return Nothing) + showQ = (show <$>) -- |Determine the Haskell type implied for the given annotated entity. -- @@ -77,6 +90,12 @@ show (TH.ppr nonVarInfo) } } + +-- |Determine the foreign type *directly* implied for the given annotated entity if any. +-- +foreignTypeOf :: Annotated e -> Q (Maybe QC.Type) +foreignTypeOf (_ :> hint) = foreignType hint +foreignTypeOf (Typed name) = return Nothing -- |Remove the annotation. -- diff --git a/Language/C/Inline/ObjC.hs b/Language/C/Inline/ObjC.hs --- a/Language/C/Inline/ObjC.hs +++ b/Language/C/Inline/ObjC.hs @@ -14,25 +14,34 @@ module Language.C.Inline.ObjC ( -- * Re-export types from 'Foreign.C' - module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, + module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, ForeignPtr, castForeignPtr, + -- * Re-export types from Template Haskell + Name, + -- * Combinators for inline Objective-C - objc_import, objc_interface, objc_implementation, objc, objc_emit, + objc_import, objc_interface, objc_implementation, objc_record, objc_marshaller, objc_typecheck, objc, objc_emit, -- * Marshalling annotations - Annotated(..), (<:), void + Annotated(..), (<:), void, Class(..), IsType, + + -- * Property maps + PropertyAccess, (==>), (-->) ) where -- common libraries import Control.Applicative import Control.Monad hiding (void) import Data.Array +import Data.Char import Data.Dynamic import Data.IORef import Data.List +import Data.Maybe import Foreign.C as C import Foreign.C.String as C import Foreign.C.Types +import Foreign.ForeignPtr as C import Foreign.Marshal as C hiding (void) import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax as TH @@ -48,6 +57,8 @@ import Language.C.Inline.Error import Language.C.Inline.Hint import Language.C.Inline.State +import Language.C.Inline.TH +import Language.C.Inline.ObjC.Hint import Language.C.Inline.ObjC.Marshal @@ -105,10 +116,17 @@ ; (tvs, argTys, inIO, resTy) <- splitHaskellType <$> haskellTypeOf ann_var -- Determine C types - ; cArgTys <- mapM (haskellTypeToCType ObjC) argTys - ; cResTy <- haskellTypeToCType ObjC resTy + ; maybe_cArgTys <- mapM (haskellTypeToCType ObjC) argTys + ; maybe_cResTy <- haskellTypeToCType ObjC resTy + ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys) + cArgTys = map maybeErrorCtype maybe_cArgTys + cResTy = maybeErrorCtype maybe_cResTy + + ; if cannotMapAllTypes + then do {str <- annotatedShowQ ann_var; reportErrorWithLang ObjC $ "invalid marshalling: " ++ str} + else do - -- Determine the bridging type and the marshalling code + { -- Determine the bridging type and the marshalling code ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- unzip4 <$> zipWithM generateCToHaskellMarshaller argTys cArgTys ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- generateHaskellToCMarshaller resTy cResTy @@ -145,7 +163,7 @@ |] ++ map makeStaticFunc wrapperDef - } + } } splitHaskellType (ForallT tvs _ctxt ty) -- collect quantified variables (drop the context) = let (tvs', args, inIO, res) = splitHaskellType ty @@ -170,13 +188,225 @@ addStatic (AntiTypeDeclSpec st tqs ts loc) = AntiTypeDeclSpec (Tstatic loc:st) tqs ts loc addStatic declSpec = declSpec +maybeErrorCtype :: Maybe QC.Type -> QC.Type +maybeErrorCtype Nothing = [cty| typename __UNDEFINED_TYPE |] -- placeholder to make progress in the face of errors +maybeErrorCtype (Just ty) = ty + forExpD :: Callconv -> String -> Name -> TypeQ -> DecQ forExpD cc str n ty - = do - { ty' <- ty - ; return $ ForeignD (ExportF cc str n ty') - } + = do + { ty' <- ty + ; return $ ForeignD (ExportF cc str n ty') + } +-- |Maps a quoted property to a quoted projection and a quoted update function in addition to the type of the projected +-- value. +-- +data PropertyAccess = QC.ObjCIfaceDecl :==> (TH.TypeQ, TH.ExpQ, TH.ExpQ) + +-- |Map a property to explicit projection and update functions. +-- +(==>) = (:==>) + +-- |Map a property to a field label. This function assumes that the field name is typed and can be reified. +-- +(-->) :: QC.ObjCIfaceDecl -> Name -> PropertyAccess +prop --> fieldName = prop ==> (fieldTy, + [| $(varE fieldName) |], + [| \s v -> $(recUpdE [|s|] [do { vE <- [|v|]; return (fieldName, vE) }]) |]) + where + fieldTy + = do + { info <- reify fieldName + ; case info of + VarI _ (ArrowT `AppT` _ `AppT` resTy) _ _ -> return resTy + nonVarInfo -> + do + { reportErrorAndFail QC.ObjC $ + "expected '" ++ show fieldName ++ "' to be a typed record field name, but it is " ++ + show (TH.ppr nonVarInfo) + } + } + +-- |Specification of a bridge for a Haskell structure that can be queried and updated from Objective-C. +-- +-- The first argument is the name of the Objective-C class that will be a proxy for the Haskell structure. +-- The second argument the name of the Haskell type of the bridged Haskell structure. +-- +-- The generated class is immutable. When a property is updated, a new instance is allocated. This closely +-- mirrors the behaviour of the Haskell structure for which the class is a proxy. +-- +-- The designated initialiser of the generated class is '[-initWithHsPtr:(HsStablePtr)particleHsPtr]', +-- where '' is the type name of the Haskell structure. This initialiser is generated if it is not +-- explicitly provided. The generated method '[-init]' calls the designated initialiser with 'nil' for the +-- stable pointer. +-- +-- WARNING: This is a very experimental feature and it will SURELY change in the future!!! +-- +--FIXME: don't generate the designated initialiser if it is explicitly provided +objc_record :: String -- ^prefix of the class name + -> String -- ^class name + -> TH.Name -- ^name of the Haskell type of the bridged Haskell structure + -> [Annotated TH.Name] -- ^Haskell variables used in Objective-C code + -> [PropertyAccess] -- ^Objective-C properties with corresponding Haskell projections and update functions + -> [QC.ObjCIfaceDecl] -- ^extra interface declarations + -> [QC.Definition] -- ^extra implementation declarations + -> Q [TH.Dec] +objc_record prefix objcClassName hsTyName ann_vars properties ifaceDecls impDecls + | null objcClassName + = reportErrorAndFail ObjC "empty class name" + | otherwise + = do + { -- Turn projection and update functions into Haskell top-level function definitions + ; let (propTys, propProjFuns, propUpdFuns) = unzip3 [(ty, proj, upd) | (_ :==> (ty, proj, upd)) <- properties] + ; projNames <- sequence [ return . mkName $ "proj" ++ objcClassName ++ show i | (_, i) <- zip propProjFuns [1..]] + ; updNames <- sequence [ return . mkName $ "upd" ++ objcClassName ++ show i | (_, i) <- zip propProjFuns [1..]] + ; let projUpd_defs = [ funD name [clause [] (normalB propFun) []] + | (name, propFun) <- zip projNames propProjFuns ++ zip updNames propUpdFuns] + + -- All new top-level functions are in the set of free variables for the implementation code + ; let all_ann_vars = ann_vars ++ zipWith addProjType projNames propTys ++ zipWith addUpdType updNames propTys + + -- Construct the class interface + ; let propertyDecls = [prop | (prop :==> _) <- properties] + updateMethodDecls = concatMap mkUpdateMethodDecl propertyDecls + iface = [cunit| + @interface $id:prefixedClassName : NSObject + + $ifdecls:propertyDecls + $ifdecls:updateMethodDecls + $ifdecls:ifaceDecls + + @end + |] + + -- Construct the class implementation + ; let updateMethodDefs = concat $ zipWith mkUpdateMethodDef propertyDecls updNames + projectionMethodDefs = concat $ zipWith mkProjectionMethodDef propertyDecls projNames + imp = [cunit| + @interface $id:prefixedClassName () + @property (readonly, assign, nonatomic) typename HsStablePtr $id:hsPtrName; + @end + + @implementation $id:prefixedClassName + + $edecls:updateMethodDefs + $edecls:impDecls + + - (instancetype)init + { + return [self $id:initWithHsPtrName:nil]; + } + + - (instancetype)$id:initWithHsPtrName:(typename HsStablePtr)$id:hsPtrName + { + self = [super init]; + if (self) + $id:("_" ++ hsPtrName) = $id:hsPtrName; + return self; + } + + - (void)dealloc + { + hs_free_stable_ptr($id:("_" ++ hsPtrName)); + } + + $edecls:projectionMethodDefs + + @end + |] + + -- Inline the class interface and class implementation; then, return all new Haskell bindings + ; iface_defs <- objc_interface iface + ; imp_defs <- objc_implementation all_ann_vars imp + ; fun_defs <- sequence projUpd_defs + ; return $ iface_defs ++ imp_defs ++ fun_defs + } + where + addProjType name ty = name :> [t| $(conT hsTyName) -> $ty |] + addUpdType name ty = name :> [t| $(conT hsTyName) -> $ty -> $(conT hsTyName) |] + + prefixedClassName = prefix ++ objcClassName + lowerClassName = toLower (head objcClassName) : tail objcClassName + hsTyNameBase = nameBase hsTyName + lowerHsTyName = toLower (head hsTyNameBase) : tail hsTyNameBase + hsPtrName = lowerHsTyName ++ "HsPtr" + initWithHsPtrName = "initWith" ++ hsTyNameBase ++ "HsPtr" + + mkUpdateMethodDecl propDecl@(ObjCIfaceProp _attrs + (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc) + _) + = [objcifdecls| + + (instancetype)$id:lowerClassName:(typename $id:prefixedClassName *)$id:lowerClassName + $id:("with" ++ upperPropName):($ty:propTy)$id:propName; + |] + where + upperPropName = toUpper (head propName) : tail propName + propTy = QC.Type spec decl loc + + mkUpdateMethodDef propDecl@(ObjCIfaceProp _attrs + (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc) + _) + updName + = [objcimdecls| + + (instancetype)$id:lowerClassName:(typename $id:prefixedClassName *)$id:lowerClassName + $id:("with" ++ upperPropName):($ty:propTy)$id:propName + { + return [[$id:prefixedClassName alloc] $id:initWithHsPtrName:$id:(show updName)($id:lowerClassName.$id:hsPtrName, + $id:propName)]; + } + |] + where + upperPropName = toUpper (head propName) : tail propName + propTy = QC.Type spec decl loc + + mkProjectionMethodDef propDecl@(ObjCIfaceProp _attrs + (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc) + _) + updName + = [objcimdecls| + - ($ty:propTy)$id:propName + { + return $id:(show updName)(self.$id:hsPtrName); + } + |] + where + propTy = QC.Type spec decl loc + +-- |Declare a Haskell<->Objective-C marshaller pair to be used in all subsequent marshalling code generation. +-- +-- On the Objective-C side, the marshallers must use a wrapped foreign pointer to an Objective-C class (just as those +-- of 'Class' hints). The domain and codomain of the two marshallers must be the opposite and both are executing in 'IO'. +-- +objc_marshaller :: TH.Name -> TH.Name -> Q [TH.Dec] +objc_marshaller haskellToObjCName objcToHaskellName + = do + { -- check that the marshallers have compatible types + ; (hsTy1, classTy1) <- argAndResultTy haskellToObjCName + ; (classTy2, hsTy2) <- argAndResultTy objcToHaskellName + ; unless (hsTy1 == hsTy2 && classTy1 == classTy2) $ + reportErrorAndFail QC.ObjC $ + "the two marshallers must map between the same types" + + ; tyconName <- headTyConNameOrError QC.ObjC classTy1 + ; let cTy = [cty| typename $id:(nameBase tyconName) * |] + ; stashMarshaller (hsTy1, classTy1, cTy, haskellToObjCName, objcToHaskellName) + ; return [] + } + where + argAndResultTy name + = do + { info <- reify name + ; case info of + VarI _ (ArrowT `AppT` argTy `AppT` (ConT io `AppT` resTy)) _ _ + | io == ''IO + -> return (argTy, resTy) + VarI _ ty _ _ -> reportErrorAndFail QC.ObjC $ + show name ++ "'s type must match 'a -> IO r'" + other -> reportErrorAndFail QC.ObjC $ + show name ++ " must be a function" + } + -- |Inline Objective-C expression. -- -- The inline expression will be wrapped in a C function whose arguments are marshalled versions of the Haskell @@ -192,10 +422,17 @@ ; resTy <- haskellTypeOf ann_e -- Determine C types - ; cArgTys <- mapM (haskellTypeToCType ObjC) varTys - ; cResTy <- haskellTypeToCType ObjC resTy - - -- Determine the bridging type and the marshalling code + ; maybe_cArgTys <- mapM annotatedHaskellTypeToCType ann_vars + ; maybe_cResTy <- annotatedHaskellTypeToCType ann_e + ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys) + cArgTys = map maybeErrorCtype maybe_cArgTys + cResTy = maybeErrorCtype maybe_cResTy + + ; if cannotMapAllTypes + then failOn [ann_var | (ann_var, Nothing) <- zip ann_vars maybe_cArgTys] maybe_cResTy + else do + + { -- Determine the bridging type and the marshalling code ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- unzip4 <$> zipWithM generateHaskellToCMarshaller varTys cArgTys ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- @@ -205,7 +442,7 @@ ; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy -- FFI setup for the C wrapper - ; cwrapperName <- newName "cwrapper" + ; cwrapperName <- show <$> newName "cwrapper" >>= newName -- Don't ask... ; stashHS [ forImpD CCall Safe (show cwrapperName) cwrapperName hsWrapperTy ] @@ -222,7 +459,7 @@ -- Generate invocation of the C wrapper sandwiched into Haskell-side marshalling ; generateHSCall vars hsArgMarshallers (callThroughTable idx hsWrapperTy) hsResMarshaller True - } + } } where callThroughTable idx ty = do { jumptable <- getForeignTable @@ -231,6 +468,27 @@ (error "InlineObjC: INTERNAL ERROR: type mismatch in jumptable") :: $ty |] } + + failOn err_ann_vars maybe_cResTy + = do + { unless (null err_ann_vars) $ do + { var_strs <- mapM annotatedShowQ err_ann_vars + ; reportErrorWithLang ObjC $ "invalid marshalling: " ++ intercalate ", " var_strs + } + ; unless (isJust maybe_cResTy) $ do + { ty <- haskellTypeOf ann_e + ; reportErrorWithLang ObjC $ "invalid marshalling for result type " ++ show ty + } + ; [| error "error in inline Objective-C expression" |] + } + + annotatedHaskellTypeToCType ann_e + = do + { maybe_objcType <- foreignTypeOf ann_e + ; case maybe_objcType of + Nothing -> haskellTypeOf ann_e >>= haskellTypeToCType ObjC + Just objcType -> return $ Just objcType + } -- Turn a list of argument types and a result type into a Haskell wrapper signature. -- @@ -284,10 +542,16 @@ -- cParams [a1, .., an] [v1, .., vn] = [[cparam| a1 v1 |], .., [cparam| an vn |]] -- +-- * If the list is empty, we will return a singleton 'void' parameter. +-- cParams :: [QC.Type] -> [TH.Name] -> [QC.Param] -cParams [] [] = [] -cParams (argTy:argTys) (var:vars) = [cparam| $ty:argTy $id:(show var) |] : cParams argTys vars +cParams [] [] = [ [cparam| void |] ] +cParams tys names = cParams' tys names + where + cParams' [] [] = [] + cParams' (argTy:argTys) (var:vars) = [cparam| $ty:argTy $id:(show var) |] : cParams' argTys vars + -- Produce a Haskell expression that calls a function with all arguments and the result marshalled with the supplied -- marshallers. -- @@ -327,7 +591,8 @@ ; appendFile objcFname_h (unlines (map mkImport headers) ++ "\n") ; appendFile objcFname_h (show $ QC.ppr objc_h) ; writeFile objcFname_m (info origFname) - ; appendFile objcFname_m ("#import \"" ++ takeFileName objcFname_h ++ "\"\n\n") + ; appendFile objcFname_m ("#import \"" ++ takeFileName objcFname_h ++ "\"\n") + ; appendFile objcFname_m ("#import \"HsFFI.h\"\n\n") ; appendFile objcFname_m (show $ QC.ppr objc_m) } ; objc_jumptable <- getForeignTable @@ -348,3 +613,13 @@ info fname = "// Generated code: DO NOT EDIT\n\ \// generated from '" ++ fname ++ "'\n\ \// by package 'language-c-inline'\n\n" + +-- |Force type checking of all declaration appearing earlier in this module. +-- +-- Template Haskell performs type checking on declaration groups seperated by toplevel splices. In order for a type +-- declaration to be available to an Objective-C inline directive, the type declaration must be in an earlier +-- declaration group than the Objective-C inline directive. A toplevel Objective-C inline directive always is the start +-- of a new declaration group; hence, it can be considered to be implicitly preceded by an 'objc_typecheck'. +-- +objc_typecheck :: Q [TH.Dec] +objc_typecheck = return [] diff --git a/Language/C/Inline/ObjC/Hint.hs b/Language/C/Inline/ObjC/Hint.hs new file mode 100644 --- /dev/null +++ b/Language/C/Inline/ObjC/Hint.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TemplateHaskell, GADTs, FlexibleInstances #-} + +-- | +-- Module : Language.C.Inline.ObjC.Hint +-- Copyright : 2014 Manuel M T Chakravarty +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module provides Objective-C specific hints. + +module Language.C.Inline.ObjC.Hint ( + -- * Class hints + Class(..), IsType +) where + + -- standard libraries +import Language.Haskell.TH as TH +import Language.Haskell.TH.Syntax as TH + + -- quasi-quotation libraries +import Language.C.Quote as QC +import Language.C.Quote.ObjC as QC + + -- friends +import Language.C.Inline.Error +import Language.C.Inline.Hint +import Language.C.Inline.TH + + +-- |Class of entities that can be used as TH types. +-- +class IsType ty where + theType :: ty -> Q TH.Type + +instance IsType TH.Type where + theType = return + +instance IsType (Q TH.Type) where + theType = id + +instance IsType TH.Name where + theType name + = do + { info <- reify name + ; case info of + TyConI _ -> return $ ConT name + PrimTyConI _ _ _ -> return $ ConT name + FamilyI _ _ -> return $ ConT name + _ -> + do + { reportErrorAndFail QC.ObjC $ + "expected '" ++ show name ++ "' to be a type name, but it is " ++ + show (TH.ppr info) + } + } + +-- |Hint indicating to marshal an Objective-C object as a foreign pointer, where the argument is the Haskell type +-- representing the Objective-C class. The Haskell type name must coincide with the Objective-C class name. +-- +data Class where + Class :: IsType t => t -> Class + +instance Hint Class where + haskellType (Class tyish) + = do + { ty <- theType tyish + ; foreignWrapperDatacon ty -- FAILS if the declaration is not a 'ForeignPtr' wrapper + ; return ty + } + foreignType (Class tyish) + = do + { name <- theType tyish >>= headTyConNameOrError QC.ObjC + ; return $ Just [cty| typename $id:(nameBase name) * |] + } + showQ (Class tyish) + = do + { ty <- theType tyish + ; return $ "Class " ++ show ty + } diff --git a/Language/C/Inline/ObjC/Marshal.hs b/Language/C/Inline/ObjC/Marshal.hs --- a/Language/C/Inline/ObjC/Marshal.hs +++ b/Language/C/Inline/ObjC/Marshal.hs @@ -26,11 +26,13 @@ -- common libraries import Data.Map as Map +import Data.Maybe import Data.Word import Foreign.C as C import Foreign.C.String as C import Foreign.Marshal as C import Foreign.Ptr as C +import Foreign.ForeignPtr as C import Foreign.StablePtr as C import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax as TH @@ -42,6 +44,8 @@ -- friends import Language.C.Inline.Error +import Language.C.Inline.State +import Language.C.Inline.TH -- Determine foreign types @@ -49,32 +53,44 @@ -- |Determine the C type that we map a given Haskell type to. -- -haskellTypeToCType :: QC.Extensions -> TH.Type -> Q QC.Type -haskellTypeToCType lang (ForallT _tvs _ctxt ty) -- ignore quantifiers and contexts +haskellTypeToCType :: QC.Extensions -> TH.Type -> Q (Maybe QC.Type) +haskellTypeToCType lang (ForallT _tvs _ctxt ty) -- ignore quantifiers and contexts = haskellTypeToCType lang ty -haskellTypeToCType lang (ListT `AppT` (ConT char)) -- marshal '[Char]' as 'String' - | char == ''Char - = haskellTypeNameToCType lang ''String -haskellTypeToCType lang ty@(ConT maybeC `AppT` argTy) -- encode a 'Maybe' around a pointer type in the pointer - | maybeC == ''Maybe +haskellTypeToCType lang ty = do - { cargTy <- haskellTypeToCType lang argTy - ; if isCPtrType cargTy - then - return cargTy - else - unknownType lang ty + { maybe_marshaller <- lookupMarshaller ty + ; case maybe_marshaller of + Just (_, _, cTy, _, _) -> return $ Just cTy -- use a custom marshaller if one is available for this type + Nothing -> haskellTypeToCType' lang ty -- otherwise, continue below... } -haskellTypeToCType lang (ConT tc) -- nullary type constructors are delegated - = haskellTypeNameToCType lang tc -haskellTypeToCType lang ty@(VarT tv) -- can't marshal an unknown type - = unknownType lang ty -haskellTypeToCType lang ty@(UnboxedTupleT _) -- there is nothing like unboxed tuples in C - = unknownType lang ty -haskellTypeToCType _lang ty -- everything else is marshalled as a stable pointer - = return [cty| typename HsStablePtr |] + where + haskellTypeToCType' lang (ListT `AppT` (ConT char)) -- marshal '[Char]' as 'String' + | char == ''Char + = haskellTypeNameToCType lang ''String + haskellTypeToCType' lang ty@(ConT maybeC `AppT` argTy) -- encode a 'Maybe' around a pointer type in the pointer + | maybeC == ''Maybe + = do + { cargTy <- haskellTypeToCType lang argTy + ; if fmap isCPtrType cargTy == Just True + then + return cargTy + else + unknownType lang ty + } + haskellTypeToCType' lang (ConT tc) -- nullary type constructors are delegated + = haskellTypeNameToCType lang tc + haskellTypeToCType' lang ty@(VarT tv) -- can't marshal an unknown type + = unknownType lang ty + haskellTypeToCType' lang ty@(UnboxedTupleT _) -- there is nothing like unboxed tuples in C + = unknownType lang ty + haskellTypeToCType' _lang ty -- everything else is marshalled as a stable pointer + = return $ Just [cty| typename HsStablePtr |] -unknownType lang ty = reportErrorAndFail lang $ "don't know a foreign type suitable for Haskell type '" ++ TH.pprint ty ++ "'" + unknownType lang ty + = do + { reportErrorWithLang lang $ "don't know a foreign type suitable for Haskell type '" ++ TH.pprint ty ++ "'" + ; return Nothing + } -- |Determine the C type that we map a given Haskell type constructor to — i.e., we map all Haskell types -- whose outermost constructor is the given type constructor to the returned C type. @@ -82,19 +98,22 @@ -- All types representing boxed values that are not explicitly mapped to a specific C type, are mapped to -- stable pointers. -- -haskellTypeNameToCType :: QC.Extensions -> TH.Name -> Q QC.Type +haskellTypeNameToCType :: QC.Extensions -> TH.Name -> Q (Maybe QC.Type) haskellTypeNameToCType ext tyname = case Map.lookup tyname (haskellToCTypeMap ext) of - Just cty -> return cty + Just cty -> return $ Just cty Nothing -> do { info <- reify tyname ; case info of PrimTyConI _ _ True -> unknownUnboxedType - _ -> return [cty| typename HsStablePtr |] + _ -> return $ Just [cty| typename HsStablePtr |] } where - unknownUnboxedType = reportErrorAndFail ext $ - "don't know a foreign type suitable for the unboxed Haskell type '" ++ show tyname ++ "'" + unknownUnboxedType = do + { reportErrorWithLang ext $ + "don't know a foreign type suitable for the unboxed Haskell type '" ++ show tyname ++ "'" + ; return Nothing + } haskellToCTypeMap :: QC.Extensions -> Map TH.Name QC.Type haskellToCTypeMap ObjC @@ -104,9 +123,9 @@ , (''CUChar, [cty| unsigned char |]) , (''CShort, [cty| short |]) , (''CUShort, [cty| unsigned short |]) - , (''Int, [cty| int |]) + , (''Int, [cty| typename NSInteger |]) , (''CInt, [cty| int |]) - , (''Word, [cty| unsigned int |]) + , (''Word, [cty| typename NSUInteger |]) , (''CUInt, [cty| unsigned int |]) , (''CLong, [cty| long |]) , (''CULong, [cty| unsigned long |]) @@ -118,6 +137,7 @@ , (''Double, [cty| double |]) , (''CDouble, [cty| double |]) -- + , (''Bool, [cty| typename BOOL |]) , (''String, [cty| typename NSString * |]) , (''(), [cty| void |]) ] @@ -161,33 +181,75 @@ -- * Generator for the Haskell-side marshalling code. -- * Generator for the C-side marshalling code. -- -generateHaskellToCMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) -generateHaskellToCMarshaller hsTy@(ConT maybe `AppT` argTy) cTy +generateHaskellToCMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) +generateHaskellToCMarshaller hsTy cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _) + | Just name == maybeHeadName -- wrapped ForeignPtr mapped to an Objective-C class + = return ( ptrOfForeignPtrWrapper hsTy + , cTy + , \val cont -> [| C.withForeignPtr ($(unwrapForeignPtrWrapper hsTy) $val) $cont |] + , \argName -> [cexp| $id:(show argName) |] + ) + | otherwise + = do + { maybe_marshaller <- lookupMarshaller hsTy + ; case maybe_marshaller of + Just (_, classTy, cTy', haskellToC, _cToHaskell) + | cTy' == cTy -- custom marshaller mapping to an Objective-C class + -> return ( ptrOfForeignPtrWrapper classTy + , cTy + , \val cont -> [| do + { nsClass <- $(varE haskellToC) $val + ; C.withForeignPtr ($(unwrapForeignPtrWrapper classTy) nsClass) $cont + } |] + , \argName -> [cexp| $id:(show argName) |] + ) + Nothing -- other => continue below + -> generateHaskellToCMarshaller' hsTy cTy + } + where + maybeHeadName = fmap nameBase $ headTyConName hsTy +generateHaskellToCMarshaller hsTy cTy = generateHaskellToCMarshaller' hsTy cTy + +generateHaskellToCMarshaller' :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) +generateHaskellToCMarshaller' hsTy@(ConT maybe `AppT` argTy) cTy | maybe == ''Maybe && isCPtrType cTy = do { (argTy', cTy', hsMarsh, cMarsh) <- generateHaskellToCMarshaller argTy cTy ; ty <- argTy' - ; case ty of - ConT ptr `AppT` _ - | ptr == ''C.Ptr -> return ( argTy' - , cTy' - , \val cont -> [| case $val of - Nothing -> $cont C.nullPtr - Just val' -> $(hsMarsh [|val'|] cont) |] - , cMarsh - ) - | ptr == ''C.StablePtr -> return ( argTy' - , cTy' - , \val cont -> [| case $val of - Nothing -> $cont (C.castPtrToStablePtr C.nullPtr) - Just val' -> $(hsMarsh [|val'|] cont) |] - -- NB: the above cast works for GHC, but is in the grey area - -- of the FFI spec - , cMarsh - ) - _ -> reportErrorAndFail ObjC $ "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" + ; resolve ty argTy' cTy' hsMarsh cMarsh } -generateHaskellToCMarshaller hsTy cTy + where + resolve ty argTy' cTy' hsMarsh cMarsh + = case ty of + ConT ptr `AppT` _ + | ptr == ''C.Ptr -> return ( argTy' + , cTy' + , \val cont -> [| case $val of + Nothing -> $cont C.nullPtr + Just val' -> $(hsMarsh [|val'|] cont) |] + , cMarsh + ) + | ptr == ''C.StablePtr -> return ( argTy' + , cTy' + , \val cont -> [| case $val of + Nothing -> $cont (C.castPtrToStablePtr C.nullPtr) + Just val' -> $(hsMarsh [|val'|] cont) |] + -- NB: the above cast works for GHC, but is in the grey area + -- of the FFI spec + , cMarsh + ) + ConT con + -> do + { info <- reify con + ; case info of + TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh + -- chase type synonyms (only nullary ones at the moment) + _ -> missingErr + } + _ -> missingErr + missingErr = reportErrorAndFail ObjC $ + "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" +generateHaskellToCMarshaller' hsTy cTy | Just hsMarshalTy <- Map.lookup cTy cIntegralMap -- checking whether it is an integral type = return ( hsMarshalTy , cTy @@ -200,11 +262,17 @@ , \val cont -> [| $cont (realToFrac $val) |] , \argName -> [cexp| $id:(show argName) |] ) + | cTy == [cty| typename BOOL |] + = return ( [t| C.CSChar |] + , cTy + , \val cont -> [| $cont (C.fromBool $val) |] + , \argName -> [cexp| ($id:(show argName)) |] + ) | cTy == [cty| typename NSString * |] = return ( [t| C.CString |] , [cty| char * |] , \val cont -> [| C.withCString $val $cont |] - , \argName -> [cexp| [NSString stringWithUTF8String: $id:(show argName)] |] + , \argName -> [cexp| ($id:(show argName)) ? [NSString stringWithUTF8String: $id:(show argName)] : nil |] ) | cTy == [cty| typename HsStablePtr |] = return ( [t| C.StablePtr $(return hsTy) |] @@ -225,7 +293,79 @@ -- * Generator for the C-side marshalling code. -- generateCToHaskellMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) -generateCToHaskellMarshaller hsTy cTy +generateCToHaskellMarshaller hsTy cTy@(Type (DeclSpec _ _ (Tnamed (Id name _) _ _) _) (Ptr _ (DeclRoot _) _) _) + | Just name == maybeHeadName -- ForeignPtr mapped to an Objective-C class + = return ( ptrOfForeignPtrWrapper hsTy + , cTy + , \val cont -> do { let datacon = foreignWrapperDatacon hsTy + ; [| do { fptr <- newForeignPtr_ $val; $cont ($datacon fptr) } |] + } + , \argName -> [cexp| $id:(show argName) |] + ) + | otherwise + = do + { maybe_marshaller <- lookupMarshaller hsTy + ; case maybe_marshaller of + Just (_, classTy, cTy', _haskellToC, cToHaskell) + | cTy' == cTy -- custom marshaller mapping to an Objective-C class + -> return ( ptrOfForeignPtrWrapper classTy + , cTy + , \val cont -> do { let datacon = foreignWrapperDatacon classTy + ; [| do + { fptr <- newForeignPtr_ $val + ; hsVal <- $(varE cToHaskell) ($datacon fptr) + ; $cont hsVal + } |] + } + , \argName -> [cexp| $id:(show argName) |] + ) + Nothing -- other => continue below + -> generateCToHaskellMarshaller' hsTy cTy + } + where + maybeHeadName = fmap nameBase $ headTyConName hsTy +generateCToHaskellMarshaller hsTy cTy = generateCToHaskellMarshaller' hsTy cTy + +generateCToHaskellMarshaller' :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) +generateCToHaskellMarshaller' hsTy@(ConT maybe `AppT` argTy) cTy + | maybe == ''Maybe && isCPtrType cTy + = do + { (argTy', cTy', hsMarsh, cMarsh) <- generateCToHaskellMarshaller argTy cTy + ; ty <- argTy' + ; resolve ty argTy' cTy' hsMarsh cMarsh + } + where + resolve ty argTy' cTy' hsMarsh cMarsh + = case ty of + ConT ptr `AppT` _ + | ptr == ''C.Ptr -> return ( argTy' + , cTy' + , \val cont -> [| if $val == C.nullPtr + then $cont Nothing + else $(hsMarsh val [| $cont . Just |]) |] + , cMarsh + ) + | ptr == ''C.StablePtr -> return ( argTy' + , cTy' + , \val cont -> [| if (C.castStablePtrToPtr $val) == C.nullPtr + then $cont Nothing + else $(hsMarsh val [| $cont . Just |]) |] + -- NB: the above cast works for GHC, but is in the grey area + -- of the FFI spec + , cMarsh + ) + ConT con + -> do + { info <- reify con + ; case info of + TyConI (TySynD _name [] tysyn) -> resolve tysyn argTy' cTy' hsMarsh cMarsh + -- chase type synonyms (only nullary ones at the moment) + _ -> missingErr + } + _ -> missingErr + missingErr = reportErrorAndFail ObjC $ + "missing 'Maybe' marshalling for '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" +generateCToHaskellMarshaller' hsTy cTy | Just hsMarshalTy <- Map.lookup cTy cIntegralMap -- checking whether it is an integral type = return ( hsMarshalTy , cTy @@ -238,6 +378,12 @@ , \val cont -> [| $cont (realToFrac $val) |] , \argName -> [cexp| $id:(show argName) |] ) + | cTy == [cty| typename BOOL |] + = return ( [t| C.CSChar |] + , cTy + , \val cont -> [| $cont (C.toBool $val) |] + , \argName -> [cexp| $id:(show argName) |] + ) | cTy == [cty| typename NSString * |] = return ( [t| C.CString |] , [cty| char * |] @@ -246,12 +392,14 @@ let arg = show argName in [cexp| - ({ typename NSUInteger maxLen = [$id:arg maximumLengthOfBytesUsingEncoding:NSUTF8StringEncoding] + 1; - char *buffer = malloc (maxLen); - if (![$id:arg getCString:buffer maxLength:maxLen encoding:NSUTF8StringEncoding]) - *buffer = '\0'; - buffer; - }) + ( $id:arg ) + ? ({ typename NSUInteger maxLen = [$id:arg maximumLengthOfBytesUsingEncoding:NSUTF8StringEncoding] + 1; + char *buffer = malloc (maxLen); + if (![$id:arg getCString:buffer maxLength:maxLen encoding:NSUTF8StringEncoding]) + *buffer = '\0'; + buffer; + }) + : nil |] ) | cTy == [cty| typename HsStablePtr |] @@ -270,17 +418,19 @@ = reportErrorAndFail ObjC $ "cannot marshall '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" cIntegralMap = Map.fromList - [ ([cty| char |], [t| C.CChar |]) - , ([cty| signed char |], [t| C.CChar |]) - , ([cty| unsigned char |], [t| C.CUChar |]) - , ([cty| short |], [t| C.CShort |]) - , ([cty| unsigned short |], [t| C.CUShort |]) - , ([cty| int |], [t| C.CInt |]) - , ([cty| unsigned int |], [t| C.CUInt |]) - , ([cty| long |], [t| C.CLong |]) - , ([cty| unsigned long |], [t| C.CULong |]) - , ([cty| long long |], [t| C.CLLong |]) - , ([cty| unsigned long long |], [t| C.CULLong |]) + [ ([cty| char |], [t| C.CChar |]) + , ([cty| signed char |], [t| C.CChar |]) + , ([cty| unsigned char |], [t| C.CUChar |]) + , ([cty| short |], [t| C.CShort |]) + , ([cty| unsigned short |], [t| C.CUShort |]) + , ([cty| int |], [t| C.CInt |]) + , ([cty| unsigned int |], [t| C.CUInt |]) + , ([cty| long |], [t| C.CLong |]) + , ([cty| unsigned long |], [t| C.CULong |]) + , ([cty| long long |], [t| C.CLLong |]) + , ([cty| unsigned long long |], [t| C.CULLong |]) + , ([cty| typename NSInteger |], [t| Int |]) + , ([cty| typename NSUInteger |], [t| Word |]) ] cFloatingMap = Map.fromList diff --git a/Language/C/Inline/State.hs b/Language/C/Inline/State.hs --- a/Language/C/Inline/State.hs +++ b/Language/C/Inline/State.hs @@ -16,9 +16,9 @@ State, -- * State query and update operations - setForeignTable, stashHeader, stashObjC_h, stashObjC_m, stashHS, + setForeignTable, stashHeader, stashMarshaller, stashObjC_h, stashObjC_m, stashHS, extendJumpTable, - getForeignTable, getForeignLabels, getHeaders, getHoistedObjC, getHoistedHS + getForeignTable, getForeignLabels, getHeaders, getMarshallers, lookupMarshaller, getHoistedObjC, getHoistedHS ) where -- common libraries @@ -33,11 +33,18 @@ import Language.C.Quote as QC +type CustomMarshaller = ( TH.Type -- Haskell type + , TH.Type -- Haskell-side class type + , QC.Type -- C type + , TH.Name -- Haskell->C marshaller function + , TH.Name) -- C->Haskell marshaller function + data State = State { foreignTable :: Q TH.Exp -- table of foreign labels , foreignLabels :: [Name] -- list of foreign imported names to populate 'foreignTable' , headers :: [String] -- imported Objective-C headers + , marshallers :: [CustomMarshaller] -- User defined marshallers , hoistedObjC_h :: [QC.Definition] -- Objective-C that goes into the .h , hoistedObjC_m :: [QC.Definition] -- Objective-C that goes into the .m , hoistedHS :: [TH.Dec] -- Haskell that goes at the end of the module @@ -48,9 +55,10 @@ state = unsafePerformIO $ newIORef $ State - { foreignTable = error "InlineObjC: internal error: 'foreignTable' undefined" + { foreignTable = error "Language.C.Inline.State: internal error: 'foreignTable' undefined" , foreignLabels = [] , headers = [] + , marshallers = [] , hoistedObjC_h = [] , hoistedObjC_m = [] , hoistedHS = [] @@ -69,6 +77,9 @@ stashHeader :: String -> Q () stashHeader header = modifyState (\s -> s {headers = header : headers s}) +stashMarshaller :: CustomMarshaller -> Q () +stashMarshaller marshaller = modifyState (\s -> s {marshallers = marshaller : marshallers s}) + stashObjC_h :: [QC.Definition] -> Q () stashObjC_h defs = modifyState (\s -> s {hoistedObjC_h = hoistedObjC_h s ++ defs}) @@ -97,6 +108,19 @@ getHeaders :: Q [String] getHeaders = reverse <$> readState headers + +getMarshallers :: Q [CustomMarshaller] +getMarshallers = readState marshallers + +lookupMarshaller :: TH.Type -> Q (Maybe CustomMarshaller) +lookupMarshaller ty + = do + { marshallers <- getMarshallers + ; case filter (\(hsTy, _, _, _, _) -> hsTy == ty) marshallers of + [] -> return Nothing + marshaller:_ -> return $ Just marshaller + } + getHoistedObjC :: Q ([QC.Definition], [QC.Definition]) getHoistedObjC = (,) <$> readState hoistedObjC_h <*> readState hoistedObjC_m diff --git a/Language/C/Inline/TH.hs b/Language/C/Inline/TH.hs new file mode 100644 --- /dev/null +++ b/Language/C/Inline/TH.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE TemplateHaskell, GADTs, FlexibleInstances #-} + +-- | +-- Module : Language.C.Inline.TH +-- Copyright : 2014 Manuel M T Chakravarty +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module provides Template Haskell convenience functions. + +module Language.C.Inline.TH ( + -- * Decompose type expressions + headTyConName, headTyConNameOrError, + + -- * Decompose idiomatic declarations + foreignWrapperDatacon, ptrOfForeignPtrWrapper, unwrapForeignPtrWrapper +) where + + -- standard libraries +import Control.Applicative +import Foreign.Ptr +import Foreign.ForeignPtr +import Language.Haskell.TH as TH +import Language.Haskell.TH.Syntax as TH + + -- quasi-quotation libraries +import Language.C.Quote as QC + + -- friends +import Language.C.Inline.Error + + +-- |Project the name of the head of a type term if it is a type constructor. +-- +headTyConName :: TH.Type -> Maybe TH.Name +headTyConName ty + = case splitAppTy ty of + (ConT name, _) -> Just name + _ -> Nothing + +-- |Like 'headTyConName', but fail if the head is not a type constructor. +-- +headTyConNameOrError :: QC.Extensions -> TH.Type -> Q TH.Name +headTyConNameOrError lang ty + = case headTyConName ty of + Just name -> return name + Nothing -> reportErrorAndFail lang $ "expected the head of '" ++ show ty ++ "' to be a type constructor" + +-- |Decompose an n-ary type application into its head and arguments. +-- +splitAppTy :: TH.Type -> (TH.Type, [TH.Type]) +splitAppTy = split [] + where + split args (ty `AppT` arg) = split (arg:args) ty + split args (SigT ty _) = split args ty + split args ty = (ty, args) + +-- |Obtain the data constructor of the newtype in an idiomatic 'ForeignPtr' wrapper of the form +-- +-- > newtype Wrapper = Wrapper (ForeignPtr (Wrapper )) +-- +foreignWrapperDatacon :: TH.Type -> Q TH.Exp +foreignWrapperDatacon ty + = do + { (datacon, _) <- decomposeForeignPtrWrapper ty + ; return $ ConE datacon + } + +-- |Unwraps a newtype wrapper around a foreign pointer and turns the 'ForeignPtr' into a 'Ptr'. +-- +ptrOfForeignPtrWrapper :: TH.Type -> Q TH.Type +ptrOfForeignPtrWrapper ty = [t| Ptr $(snd <$> decomposeForeignPtrWrapper ty) |] + +-- |Generate code that unwraps the foreign pointer inside the given foreign pointer wrapper type. +-- +unwrapForeignPtrWrapper :: TH.Type -> Q TH.Exp +unwrapForeignPtrWrapper ty + = do + { (datacon, _) <- decomposeForeignPtrWrapper ty + ; v <- newName "v" + ; [| \e -> $(caseE [| e |] [match (conP datacon [varP v]) (normalB $ varE v) []]) |] + } + +-- |Given a type whose head is a newtype wrapper around a foreign pointer of the form +-- +-- > newtype Wrapper = Wrapper (ForeignPtr (Wrapper )) +-- +-- return the name of the wrapper data constructor and type argument of the 'ForeignPtr', where all '' have been +-- substituted by the arguments in the type application constituting the input type (might be nullary). +-- +decomposeForeignPtrWrapper :: TH.Type -> Q (TH.Name, TH.Type) +decomposeForeignPtrWrapper ty + = do + { let (tycon, args) = splitAppTy ty + ; name <- case tycon of + ConT name -> return name + _ -> + do + { reportErrorAndFail QC.ObjC $ + "expected '" ++ show tycon ++ "' be a type constructor of a 'ForeignPtr' wrapper" + } + + ; info <- reify name + ; case info of + TyConI (NewtypeD [] _name tvs (NormalC dataconName [(_strict, ConT fptr `AppT` ptrArg)]) _deriv) + | fptr == ''ForeignPtr + -> return (dataconName, substitute (zip args tvs) ptrArg) + nonForeign -> + do + { reportErrorAndFail QC.ObjC $ + "expected '" ++ show name ++ "' to refer to a 'ForeignPtr' wrapped into a newtype, but it is " ++ + show (TH.ppr nonForeign) + } + } + where + substitute :: [(TH.Type, TH.TyVarBndr)] -> TH.Type -> TH.Type + substitute subst (ForallT boundTvs cxt body) + = ForallT boundTvs (substituteCxt subst' cxt) (substitute subst' body) + where + subst' = filter (`notShadowedBy` map theTV boundTvs) subst + -- + (_, tv) `notShadowedBy` boundTvs = theTV tv `notElem` boundTvs + -- + theTV (PlainTV tv) = tv + theTV (KindedTV tv _) = tv + substitute subst (t1 `AppT` t2) + = (substitute subst t1) `AppT` (substitute subst t2) + substitute subst (SigT ty ki) + = SigT (substitute subst ty) ki + substitute subst (VarT tv) + = substituteName subst tv + substitute _subst ty + = ty + + substituteCxt subst cxt = map (substitutePred subst) cxt + + substitutePred subst (ClassP name tys) = ClassP name (map (substitute subst) tys) + substitutePred subst (EqualP ty1 ty2) = EqualP (substitute subst ty1) (substitute subst ty2) + + substituteName [] tv = VarT tv + substituteName ((arg, tv):args) thisTv + | tv `matches` thisTv = arg + | otherwise = VarT thisTv + + PlainTV name `matches` thisTv = name == thisTv + KindedTV name _ki `matches` thisTv = name == thisTv diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,7 +10,7 @@ To build the library, just use `cabal install` as usual from the source code directory or by installing from Hackage. -You may like to have a look at a [minimal example](blob/master/tests/objc/minimal/Main.hs) of its use, which you can build as follows: +You may like to have a look at a [minimal example](tests/objc/minimal/Main.hs) of its use, which you can build as follows: * Execute `cd tests/objc/minimal; make`. * Now run the demo executable with `./Minimal`. diff --git a/language-c-inline.cabal b/language-c-inline.cabal --- a/language-c-inline.cabal +++ b/language-c-inline.cabal @@ -1,5 +1,5 @@ Name: language-c-inline -Version: 0.6.0.0 +Version: 0.7.6.0 Cabal-version: >= 1.9.2 Tested-with: GHC == 7.6.3, GHC == 7.8.2 Build-type: Simple @@ -16,20 +16,25 @@ . Known bugs: . - * New in 0.6.0.0: Introduction of explicit marshalling hints (for more flexibility and support of + * New in 0.7.6: (1) Record marshalling; (2) foreign pointer-class marshalling; (3) custom type + marshallers. Generated _objc.m files now always include "HsFFI.h" (as the tool can generate type names + declared in that header). Marshals 'Bool' as 'BOOL'. Marshal 'Int' and 'Word' to 'NSInteger' and + 'NSUInteger', respectively. + . + * New in 0.6.0: Introduction of explicit marshalling hints (for more flexibility and support of GHC 7.8's untyped Template Haskell quotations) . - * New in 0.5.0.0: Marshalling of numeric types + * New in 0.5.0: Marshalling of numeric types . - * New in 0.4.0.0: Maybe types are marshalled as pointers that may be nil & bug fixes. + * New in 0.4.0: Maybe types are marshalled as pointers that may be nil & bug fixes. . - * New in 0.3.0.0: Boxed Haskell types without a dedicated type mapping are marshalled using stable + * New in 0.3.0: Boxed Haskell types without a dedicated type mapping are marshalled using stable pointers. . - * New in 0.2.0.0: Support for multiple free variables in one inline expression as well + * New in 0.2.0: Support for multiple free variables in one inline expression as well as for inline code returning 'void'. . - * New in 0.1.0.0: We are just getting started! This is just a ROUGH AND + * New in 0.1.0: We are just getting started! This is just a ROUGH AND HIGHLY EXPERIMENTAL PROTOTYPE. License: BSD3 License-file: LICENSE @@ -73,7 +78,7 @@ base >= 4.0 && < 5, containers >= 0.4, filepath >= 1.2, - language-c-quote >= 0.7, + language-c-quote >= 0.8, mainland-pretty >= 0.2.5, template-haskell @@ -82,6 +87,8 @@ Other-modules: Language.C.Inline.Error Language.C.Inline.Hint Language.C.Inline.State + Language.C.Inline.TH + Language.C.Inline.ObjC.Hint Language.C.Inline.ObjC.Marshal Extensions: TemplateHaskell, QuasiQuotes diff --git a/tests/objc/app/AppDelegate.hs b/tests/objc/app/AppDelegate.hs --- a/tests/objc/app/AppDelegate.hs +++ b/tests/objc/app/AppDelegate.hs @@ -13,7 +13,7 @@ -- friends import Interpreter -objc_import ["", "HsFFI.h"] +objc_import [""] -- Haskell code used from Objective-C. diff --git a/tests/objc/concept/Makefile b/tests/objc/concept/Makefile --- a/tests/objc/concept/Makefile +++ b/tests/objc/concept/Makefile @@ -1,4 +1,6 @@ HC = ghc +LIBDIR = $(shell $(HC) --print-libdir) +CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes HCFLAGS = LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation diff --git a/tests/objc/minimal/Makefile b/tests/objc/minimal/Makefile --- a/tests/objc/minimal/Makefile +++ b/tests/objc/minimal/Makefile @@ -1,4 +1,6 @@ HC = ghc +LIBDIR = $(shell $(HC) --print-libdir) +CFLAGS = -fobjc-arc -I$(LIBDIR)/include -I$(LIBDIR)/../../includes HCFLAGS = LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation diff --git a/tests/objc/record/Particle.hs b/tests/objc/record/Particle.hs --- a/tests/objc/record/Particle.hs +++ b/tests/objc/record/Particle.hs @@ -8,7 +8,7 @@ import Language.C.Quote.ObjC import Language.C.Inline.ObjC -objc_import ["", "HsFFI.h"] +objc_import [""] -- Haskell code used from Objective-C. @@ -31,66 +31,23 @@ newParticle :: Float -> Particle newParticle mass = Particle mass origin zero zero -particleMass :: Particle -> Float -particleMass = mass - - -objc_interface [cunit| - -@interface Particle : NSObject - -@property (readonly) float mass; - -+ (typename instancetype)particleWithMass:(float)mass; - -- (typename instancetype)init; - -- (typename instancetype)initWithMass:(float)mass; - - -@end -|] - - -objc_implementation [Typed 'newParticle, Typed 'particleMass] [cunit| - -@interface Particle () - -@property (readonly, assign, nonatomic) typename HsStablePtr particle; - -@end - -@implementation Particle - -// Initialisation - -+ (typename instancetype)particleWithMass:(float)mass -{ - return [[Particle alloc] initWithMass:mass]; -} - -- (typename instancetype)init -{ - return [self initWithMass:0.0]; -} - -- (typename instancetype)initWithMass:(float)mass -{ - self = [super init]; - if (self) - _particle = newParticle(mass); - return self; -} - -// Getters and setters - -- (float)mass -{ - return particleMass(self.particle); -} - -@end -|] - +objc_record "" "Particle" ''Particle [Typed 'newParticle] + [ [objcprop| @property (readonly) float mass; |] --> 'mass + , [objcprop| @property (readonly) float locX; |] ==> ([t| Float |], + [| fst . loc |], + [| \p locX -> p { loc = (locX, snd . loc $ p) } |]) + , [objcprop| @property (readonly) float locY; |] ==> ([t| Float |], + [| snd . loc |], + [| \p locY -> p { loc = (fst . loc $ p, locY) } |]) + ] + [objcifdecls| + + (instancetype)particleWithMass:(float)mass; + |] + [objcimdecls| + + (instancetype)particleWithMass:(float)mass + { + return [[Particle alloc] initWithParticleHsPtr:newParticle(mass)]; + } + |] objc_emit