language-c-inline 0.7.10.0 → 0.7.11.0
raw patch · 7 files changed
+101/−94 lines, 7 filesdep ~language-c-quotedep ~mainland-pretty
Dependency ranges changed: language-c-quote, mainland-pretty
Files
- Language/C/Inline/Error.hs +4/−3
- Language/C/Inline/Hint.hs +10/−10
- Language/C/Inline/ObjC.hs +61/−60
- Language/C/Inline/TH.hs +14/−14
- language-c-inline.cabal +4/−4
- tests/objc/app/AppDelegate.hs +7/−1
- tests/objc/app/Interpreter.hs +1/−2
Language/C/Inline/Error.hs view
@@ -26,9 +26,10 @@ import Language.Haskell.TH.Syntax as TH -- quasi-quotation libraries-import Language.C.Quote as QC-import Language.C.Quote.ObjC as QC-import Text.PrettyPrint.Mainland as QC+import Language.C.Quote as QC+import Language.C.Quote.ObjC as QC+import Text.PrettyPrint.Mainland as QC+import Text.PrettyPrint.Mainland.Class as QC reportErrorWithLang :: QC.Extensions -> String -> Q ()
Language/C/Inline/Hint.hs view
@@ -14,10 +14,10 @@ module Language.C.Inline.Hint ( -- * Annotations Annotated(..), (<:), void, annotatedShowQ,- + -- * Hints- Hint(..), - + Hint(..),+ -- * Querying of annotated entities haskellTypeOf, foreignTypeOf, newForeignPtrOf, stripAnnotation ) where@@ -66,13 +66,13 @@ foreignType :: hint -> Q (Maybe QC.Type) -- ^In case of 'Nothing', the foreign type is determined by the Haskell type. showQ :: hint -> Q String newForeignPtrName :: hint -> Q (Maybe TH.Name)- + instance Hint Name where -- must be a type name haskellType = conT foreignType = const (return Nothing) showQ = return . show newForeignPtrName = const (return Nothing)- + instance Hint (Q TH.Type) where haskellType = id foreignType = const (return Nothing)@@ -87,12 +87,12 @@ = do { info <- reify name ; case info of- ClassOpI _ ty _ _ -> return ty- VarI _ ty _ _ -> return ty- nonVarInfo -> + ClassOpI _ ty _ -> return ty+ VarI _ ty _ -> return ty+ nonVarInfo -> do- { reportErrorAndFail QC.ObjC $ - "expected '" ++ show name ++ "' to be a typed variable name, but it is " ++ + { reportErrorAndFail QC.ObjC $+ "expected '" ++ show name ++ "' to be a typed variable name, but it is " ++ show (TH.ppr nonVarInfo) } }
Language/C/Inline/ObjC.hs view
@@ -15,17 +15,17 @@ -- * Re-export types from 'Foreign.C' module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, ForeignPtr, castForeignPtr,- + -- * Re-export types from Template Haskell Name, -- * Objective-C memory management support objc_retain, objc_release, objc_release_ptr, newForeignClassPtr, newForeignStructPtr,- - -- * Combinators for inline Objective-C - objc_import, objc_interface, objc_implementation, objc_record, objc_marshaller, objc_class_marshaller, ++ -- * Combinators for inline Objective-C+ objc_import, objc_interface, objc_implementation, objc_record, objc_marshaller, objc_class_marshaller, objc_struct_marshaller, objc_typecheck, objc, objc_emit,- + -- * Marshalling annotations Annotated(..), (<:), void, Class(..), Struct(..), IsType, @@ -42,7 +42,7 @@ import Data.IORef import Data.List import Data.Maybe-import Foreign.C as C +import Foreign.C as C import Foreign.C.String as C import Foreign.C.Types import Foreign.ForeignPtr as C@@ -53,9 +53,10 @@ import System.IO.Unsafe (unsafePerformIO) -- quasi-quotation libraries-import Language.C.Quote as QC-import Language.C.Quote.ObjC as QC-import Text.PrettyPrint.Mainland as QC+import Language.C.Quote as QC+import Language.C.Quote.ObjC as QC+import Text.PrettyPrint.Mainland as QC+import Text.PrettyPrint.Mainland.Class as QC -- friends import Language.C.Inline.Error@@ -66,7 +67,7 @@ import Language.C.Inline.ObjC.Marshal --- Combinators for inline Objective-C +-- Combinators for inline Objective-C -- ---------------------------------- -- |Specify imported Objective-C files. Needs to be spliced where an import declaration can appear. (Just put it@@ -133,14 +134,14 @@ ; let cannotMapAllTypes = Nothing `elem` (maybe_cResTy : maybe_cArgTys) cArgTys = map maybeErrorCtype maybe_cArgTys cResTy = maybeErrorCtype maybe_cResTy- - ; if cannotMapAllTypes ++ ; if cannotMapAllTypes then do {str <- annotatedShowQ ann_var; reportErrorWithLang ObjC $ "invalid marshalling: " ++ str} else do { -- Determine the bridging type and the marshalling code ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <-- unzip4 <$> zipWithM (generateCToHaskellMarshaller Nothing) argTys cArgTys + unzip4 <$> zipWithM (generateCToHaskellMarshaller Nothing) argTys cArgTys ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- generateHaskellToCMarshaller resTy cResTy -- Haskell type of the foreign wrapper function@@ -189,18 +190,18 @@ = ([], [], True, res) splitHaskellType res = ([], [], False, res)- + makeStaticFunc (FuncDef (Func dspec f decl ps body loc1) loc2) = FuncDef (Func (addStatic dspec) f decl ps body loc1) loc2 makeStaticFunc (FuncDef (OldFunc dspec f decl ps ig body loc1) loc2) = FuncDef (OldFunc (addStatic dspec) f decl ps ig body loc1) loc2 makeStaticFunc def = def- + addStatic (DeclSpec st tqs ts loc) = DeclSpec (Tstatic loc:st) tqs ts loc addStatic (AntiTypeDeclSpec st tqs ts loc) = AntiTypeDeclSpec (Tstatic loc:st) tqs ts loc addStatic declSpec = declSpec -maybeErrorCtype :: Maybe QC.Type -> QC.Type +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 @@ -223,19 +224,19 @@ -- |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) |], +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 -> + 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 " ++ + { reportErrorAndFail QC.ObjC $+ "expected '" ++ show fieldName ++ "' to be a typed record field name, but it is " ++ show (TH.ppr nonVarInfo) } }@@ -273,7 +274,7 @@ ; 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) []] + ; 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@@ -282,13 +283,13 @@ -- Construct the class interface ; let propertyDecls = [prop | (prop :==> _) <- properties] updateMethodDecls = concatMap mkUpdateMethodDecl propertyDecls- iface = [cunit| + iface = [cunit| @interface $id:prefixedClassName : NSObject- + $ifdecls:propertyDecls $ifdecls:updateMethodDecls $ifdecls:ifaceDecls- + @end |] @@ -299,17 +300,17 @@ @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];@@ -317,7 +318,7 @@ $id:("_" ++ hsPtrName) = $id:hsPtrName; return self; }- + - (void)dealloc { hs_free_stable_ptr($id:("_" ++ hsPtrName));@@ -327,7 +328,7 @@ @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@@ -337,7 +338,7 @@ 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@@ -345,23 +346,23 @@ hsPtrName = lowerHsTyName ++ "HsPtr" initWithHsPtrName = "initWith" ++ hsTyNameBase ++ "HsPtr" - mkUpdateMethodDecl propDecl@(ObjCIfaceProp _attrs + 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; + = [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 ++ mkUpdateMethodDef propDecl@(ObjCIfaceProp _attrs (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc) _) updName- = [objcimdecls| - + (instancetype)$id:lowerClassName:(typename $id:prefixedClassName *)$id:lowerClassName + = [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,@@ -372,11 +373,11 @@ upperPropName = toUpper (head propName) : tail propName propTy = QC.Type spec decl loc - mkProjectionMethodDef propDecl@(ObjCIfaceProp _attrs + mkProjectionMethodDef propDecl@(ObjCIfaceProp _attrs (FieldGroup spec [Field (Just (Id propName _)) (Just decl) _exp _] loc) _) updName- = [objcimdecls| + = [objcimdecls| - ($ty:propTy)$id:propName { return $id:(show updName)(self.$id:hsPtrName);@@ -414,9 +415,9 @@ ; (hsTy1, classTy1) <- argAndResultTy haskellToObjCName ; (classTy2, hsTy2) <- argAndResultTy objcToHaskellName ; unless (hsTy1 == hsTy2 && classTy1 == classTy2) $- reportErrorAndFail QC.ObjC $ + 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, newForeignPtrFun)@@ -427,13 +428,13 @@ = do { info <- reify name ; case info of- VarI _ (ArrowT `AppT` argTy `AppT` (ConT io `AppT` resTy)) _ _+ 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"+ 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.@@ -457,16 +458,16 @@ ; 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) <-- generateCToHaskellMarshaller newFP resTy cResTy + generateCToHaskellMarshaller newFP resTy cResTy -- Haskell type of the foreign wrapper function ; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy@@ -500,7 +501,7 @@ (error "InlineObjC: INTERNAL ERROR: type mismatch in jumptable") :: $ty |] }- + failOn err_ann_vars maybe_cResTy = do { unless (null err_ann_vars) $ do@@ -513,7 +514,7 @@ } ; [| error "error in inline Objective-C expression" |] }- + annotatedHaskellTypeToCType ann_e = do { maybe_objcType <- foreignTypeOf ann_e@@ -622,11 +623,11 @@ do { writeFile objcFname_h (info origFname) ; appendFile objcFname_h (unlines (map mkImport headers) ++ "\n")- ; appendFile objcFname_h (show $ QC.ppr objc_h)+ ; appendFile objcFname_h (pretty 80 $ QC.ppr objc_h) ; writeFile objcFname_m (info origFname) ; appendFile objcFname_m ("#import \"" ++ takeFileName objcFname_h ++ "\"\n") ; appendFile objcFname_m (mkImport hsFFIHeader ++ "\n\n")- ; appendFile objcFname_m (show $ QC.ppr objc_m)+ ; appendFile objcFname_m (pretty 80 $ QC.ppr objc_m) } ; objc_jumptable <- getForeignTable ; labels <- getForeignLabels@@ -641,7 +642,7 @@ } where hsFFI = "HsFFI.h" -- Haskell C FFI header as prescribed in the standard- + -- If the user supplies the FFI header (presumably at a non-standard location), use that; otherwise, we include -- the header without a path. (The FFI header should by default only be included into the .m file; otherwise, we -- get into problems with framework modules.)@@ -649,7 +650,7 @@ = case break ((== hsFFI) . takeFileName) headers of (before, []) -> (hsFFI, before) (before, ffi:after) -> (ffi, before ++ after)- + mkImport h@('<':_) = "#import " ++ h ++ "" mkImport h = "#import \"" ++ h ++ "\"" @@ -658,7 +659,7 @@ \// 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
Language/C/Inline/TH.hs view
@@ -14,10 +14,10 @@ module Language.C.Inline.TH ( -- * Decompose type expressions headTyConName, headTyConNameOrError,- + -- * Decompose idiomatic declarations foreignWrapperDatacon, ptrOfForeignPtrWrapper, unwrapForeignPtrWrapper- + ) where -- standard libraries@@ -67,7 +67,7 @@ -- foreignWrapperDatacon :: TH.Type -> Q TH.Exp foreignWrapperDatacon ty- = do + = do { (datacon, _) <- decomposeForeignPtrWrapper ty ; return $ ConE datacon }@@ -80,7 +80,7 @@ -- |Generate code that unwraps the foreign pointer inside the given foreign pointer wrapper type. -- unwrapForeignPtrWrapper :: TH.Type -> Q TH.Exp-unwrapForeignPtrWrapper ty +unwrapForeignPtrWrapper ty = do { (datacon, _) <- decomposeForeignPtrWrapper ty ; v <- newName "v"@@ -96,25 +96,25 @@ -- decomposeForeignPtrWrapper :: TH.Type -> Q (TH.Name, TH.Type) decomposeForeignPtrWrapper ty- = do + = do { let (tycon, args) = splitAppTy ty ; name <- case tycon of ConT name -> return name- _ -> + _ -> do- { reportErrorAndFail QC.ObjC $ + { 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) + TyConI (NewtypeD [] _name tvs _kind (NormalC dataconName [(_strict, ConT fptr `AppT` ptrArg)]) _deriv) | fptr == ''ForeignPtr -> return (dataconName, substitute (zip args tvs) ptrArg)- nonForeign -> + nonForeign -> do- { reportErrorAndFail QC.ObjC $ - "expected '" ++ show name ++ "' to refer to a 'ForeignPtr' wrapped into a newtype, but it is " ++ + { reportErrorAndFail QC.ObjC $+ "expected '" ++ show name ++ "' to refer to a 'ForeignPtr' wrapped into a newtype, but it is " ++ show (TH.ppr nonForeign) } }@@ -137,13 +137,13 @@ = substituteName subst tv substitute _subst ty = ty- + substituteCxt subst cxt = map (substitute subst) cxt- + 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
language-c-inline.cabal view
@@ -1,7 +1,7 @@ Name: language-c-inline-Version: 0.7.10.0+Version: 0.7.11.0 Cabal-version: >= 1.9.2-Tested-with: GHC == 7.10.3+Tested-with: GHC == 8.0.2 Build-type: Simple Synopsis: Inline C & Objective-C code in Haskell for language interoperability@@ -82,8 +82,8 @@ base >= 4.0 && < 5, containers >= 0.4, filepath >= 1.2,- language-c-quote >= 0.8 && < 0.9,- mainland-pretty >= 0.2.5,+ language-c-quote >= 0.12.1,+ mainland-pretty >= 0.6 && < 0.7, template-haskell Exposed-modules: Language.C.Inline.ObjC
tests/objc/app/AppDelegate.hs view
@@ -92,7 +92,13 @@ // IBAction - (void)textFieldDidSend:(typename NSTextField *)sender {- [self appendOutput:evalExpr(self.interpreterSession, [sender stringValue])];+ typename NSString *result;+ NSLog(@"expression: %@", [sender stringValue]);+ result = evalExpr(self.interpreterSession, [sender stringValue]);+ NSLog(@"result: %@", result);+ [self appendOutput:result];+// [self appendOutput:evalExpr(self.interpreterSession, [sender stringValue])];+ NSLog(@"reset sender"); [sender setStringValue:@""]; }
tests/objc/app/Interpreter.hs view
@@ -19,9 +19,8 @@ import Prelude hiding (catch) import Control.Applicative import Control.Concurrent-import Control.Exception (SomeException, evaluate)+import Control.Exception (SomeException, evaluate, catch) import Control.Monad-import Control.Monad.Catch import System.IO