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 @@ -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 () 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 @@ -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) } } 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 @@ -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 diff --git a/Language/C/Inline/TH.hs b/Language/C/Inline/TH.hs --- a/Language/C/Inline/TH.hs +++ b/Language/C/Inline/TH.hs @@ -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 diff --git a/language-c-inline.cabal b/language-c-inline.cabal --- a/language-c-inline.cabal +++ b/language-c-inline.cabal @@ -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 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 @@ -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:@""]; } diff --git a/tests/objc/app/Interpreter.hs b/tests/objc/app/Interpreter.hs --- a/tests/objc/app/Interpreter.hs +++ b/tests/objc/app/Interpreter.hs @@ -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