diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) [2013] Manuel M T Chakravarty. All rights reserved. +Copyright (c) [2013..2014] Manuel M T Chakravarty. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/Language/C/Inline/Hint.hs b/Language/C/Inline/Hint.hs new file mode 100644 --- /dev/null +++ b/Language/C/Inline/Hint.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TemplateHaskell, GADTs, FlexibleInstances #-} + +-- | +-- Module : Language.C.Inline.Hint +-- Copyright : [2013..2014] Manuel M T Chakravarty +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module provides the definition of marshalling hints. + +module Language.C.Inline.Hint ( + -- * Annotations + Annotated(..), (<:), void, + + -- * Hints + Hint(..), + + -- * Querying of annotated entities + haskellTypeOf, stripAnnotation +) where + + -- common libraries +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 + + +-- |Annotating entities with hints. +-- +data Annotated e where + (:>) :: Hint hint => e -> hint -> Annotated e -- ^explicit marshalling hint + Typed :: Name -> Annotated Name -- ^marshalling implicitly defined by name's type + +-- |We provide additional syntax where the hint is to the left of the annotated entity. +-- +(<:) :: Hint hint => hint -> e -> Annotated e +(<:) = flip (:>) + +-- |Annotation for irrelevant results +-- +void :: e -> Annotated e +void = (''() <:) + +-- Hints imply marshalling strategies, which include source and destination types for marshalling. +-- +class Hint hint where + haskellType :: hint -> Q TH.Type + +instance Hint Name where -- must be a type name + haskellType = conT + +instance Hint (Q TH.Type) where + haskellType = id + +-- |Determine the Haskell type implied for the given annotated entity. +-- +haskellTypeOf :: Annotated e -> Q TH.Type +haskellTypeOf (_ :> hint) = haskellType hint +haskellTypeOf (Typed name) + = do + { info <- reify name + ; case info of + 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 " ++ + show (TH.ppr nonVarInfo) + } + } + +-- |Remove the annotation. +-- +stripAnnotation :: Annotated e -> e +stripAnnotation (e :> hint) = e +stripAnnotation (Typed name) = name 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 @@ -17,20 +17,23 @@ module Foreign.C.Types, CString, CStringLen, CWString, CWStringLen, Errno, -- * Combinators for inline Objective-C - objc_import, objc_interface, objc_implementation, objc, objc_emit + objc_import, objc_interface, objc_implementation, objc, objc_emit, + + -- * Marshalling annotations + Annotated(..), (<:), void ) where -- common libraries import Control.Applicative -import Control.Monad +import Control.Monad hiding (void) import Data.Array import Data.Dynamic import Data.IORef import Data.List -import Foreign.C as C +import Foreign.C as C import Foreign.C.String as C import Foreign.C.Types -import Foreign.Marshal as C +import Foreign.Marshal as C hiding (void) import Language.Haskell.TH as TH import Language.Haskell.TH.Syntax as TH import System.FilePath @@ -43,6 +46,7 @@ -- friends import Language.C.Inline.Error +import Language.C.Inline.Hint import Language.C.Inline.State import Language.C.Inline.ObjC.Marshal @@ -86,18 +90,19 @@ -- the Haskell variable refers to a CAF, it will be a nullary function in C — after all, a thunk may still need to be -- evaluated.) -- -objc_implementation :: [TH.Name] -> [QC.Definition] -> Q [TH.Dec] -objc_implementation vars defs +objc_implementation :: [Annotated TH.Name] -> [QC.Definition] -> Q [TH.Dec] +objc_implementation ann_vars defs = do - { mapM_ exportVar vars + { mapM_ exportVar ann_vars ; stashObjC_m defs ; return [] } where - exportVar var + exportVar ann_var = do { -- Determine the argument and result types of the exported Haskell function - ; (tvs, argTys, inIO, resTy) <- splitHaskellType <$> determineVarType var + ; let var = stripAnnotation ann_var + ; (tvs, argTys, inIO, resTy) <- splitHaskellType <$> haskellTypeOf ann_var -- Determine C types ; cArgTys <- mapM (haskellTypeToCType ObjC) argTys @@ -175,25 +180,26 @@ -- |Inline Objective-C expression. -- -- The inline expression will be wrapped in a C function whose arguments are marshalled versions of the Haskell --- variables given in the first argument and whose return value will be marshalled to the Haskell type given by the --- second argument. +-- variables given in the first argument. The marshalling of the variables and of the result is determined by the +-- marshalling annotations at the variables and the inline expression. -- -objc :: [TH.Name] -> TH.Name -> QC.Exp -> Q TH.Exp -objc vars resTy e +objc :: [Annotated TH.Name] -> Annotated QC.Exp -> Q TH.Exp +objc ann_vars ann_e = {- tryWithPlaceholder $ -} do -- FIXME: catching the 'fail' purges all reported errors :( { -- Sanity check of arguments - ; varTys <- mapM determineVarType vars - ; checkTypeName resTy + ; let vars = map stripAnnotation ann_vars + ; varTys <- mapM haskellTypeOf ann_vars + ; resTy <- haskellTypeOf ann_e -- Determine C types ; cArgTys <- mapM (haskellTypeToCType ObjC) varTys - ; cResTy <- haskellTypeNameToCType ObjC resTy + ; cResTy <- haskellTypeToCType ObjC resTy -- Determine the bridging type and the marshalling code ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- unzip4 <$> zipWithM generateHaskellToCMarshaller varTys cArgTys ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- - generateCToHaskellMarshaller (ConT resTy) cResTy + generateCToHaskellMarshaller resTy cResTy -- Haskell type of the foreign wrapper function ; let hsWrapperTy = haskellWrapperType [] bridgeArgTys bridgeResTy @@ -209,8 +215,8 @@ ; cArgVars <- mapM (newName . nameBase) vars ; let (wrapperProto, wrapperDef) = generateCWrapper cwrapperName cArgTys vars cArgMarshallers cBridgeArgTys cArgVars - e - (ConT resTy) cResTy cResMarshaller cBridgeResTy + (stripAnnotation ann_e) + resTy cResTy cResMarshaller cBridgeResTy ; stashObjC_h wrapperProto ; stashObjC_m wrapperDef 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 @@ -14,11 +14,8 @@ -- FIXME: Some of the code can go into a module for general marshalling, as only some of it is ObjC-specific. module Language.C.Inline.ObjC.Marshal ( - -- * Auxilliary functions - determineVarType, checkTypeName, - -- * Determine corresponding foreign types of Haskell types - haskellTypeToCType, haskellTypeNameToCType, + haskellTypeToCType, -- * Marshaller types HaskellMarshaller, CMarshaller, @@ -45,44 +42,6 @@ -- friends import Language.C.Inline.Error - - --- Auxilliary functions --- -------------------- - --- |Check that the given TH name is that of a Haskell variable and determine its type. --- -determineVarType :: TH.Name -> Q TH.Type -determineVarType vname - = do - { vinfo <- reify vname - ; case vinfo of - VarI _ ty _ _ -> return ty - nonVarInfo -> - do - { reportErrorAndFail QC.ObjC $ - "expected '" ++ show vname ++ "' to be a variable name, but it is " ++ - show (TH.ppr nonVarInfo) - } - } - --- |Check that the given TH name is that of a Haskell type constructor. --- -checkTypeName :: TH.Name -> Q () -checkTypeName tyname - = do - { tyinfo <- reify tyname - ; case tyinfo of - TyConI (DataD {}) -> return () - TyConI (NewtypeD {}) -> return () - TyConI (TySynD {}) -> return () - nonTyInfo -> - do - { reportErrorAndFail QC.ObjC $ - "expected '" ++ show tyname ++ "' to be a type name, but it is " ++ - show (TH.ppr nonTyInfo) - } - } -- Determine foreign types diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,6 +3,8 @@ This library uses Template Haskell and `language-c-quote`, a quasi-quotation library for C-like languages, to provide inline C and Objective-C in Haskell. It extracts the C/Objective-C code automatically, when compiling the Haskell program, and generates marshalling code for common types. The wiki on GitHub details the [motivation](https://github.com/mchakravarty/language-c-inline/wiki/Motivation) for this approach. +For further motivation, have a look at the slides of my YOW! Lambda Jam 2014 talk [Foreign Inline Code in Haskell](https://speakerdeck.com/mchakravarty/foreign-inline-code-in-haskell). + Building -------- @@ -18,14 +20,19 @@ * Execute `cd tests/objc/concept; make`. * Now run the demo executable with `./InlineObjC`. +To build an example class wrapping a Haskell record, do the following: + +* Execute `cd tests/objc/record; make`. +* Now run the demo executable with `./Particle`. + To build the more complex Haskell interpreter app: * Execute `cd tests/objc/app; make`. * Now `open -a HSApp.app`. -I tested it with Haskell Platform 2013.2.0.0 (which includes GHC 7.6.3) and it requires the latest version of `language-c-quote`, which is 0.7.6. +I tested it with Haskell Platform 2013.2.0.0 (which includes GHC 7.6.3) and it requires the latest version of `language-c-quote`, which is currently 0.7.7. Status ====== -The library is still in its early stages. At the moment automatic marshalling support is limited to strings and boxed Haskell values represented as stable pointers in C land. However, it is quite easy to add more types, and I do welcome pull request! +The library is in beta and so far focuses on Objective-C. Automatic marshalling support is still somewhat limited. However, it is quite easy to add more types, and I do welcome pull request! 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.5.0.0 +Version: 0.6.0.0 Cabal-version: >= 1.9.2 -Tested-with: GHC == 7.6.3 +Tested-with: GHC == 7.6.3, GHC == 7.8.2 Build-type: Simple Synopsis: Inline C & Objective-C code in Haskell for language interoperability @@ -10,12 +10,15 @@ without a dedicated bridge or binding. Here is a tiny example: . > nslog :: String -> IO () - > nslog msg = $(objc ['msg] ''() [cexp| NSLog(@"Here is a message from Haskell: %@", msg) |]) + > nslog msg = $(objc ['msg :> ''String] (void [cexp| NSLog(@"Here is a message from Haskell: %@", msg) |])) . For more information, see . . Known bugs: . + * New in 0.6.0.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.4.0.0: Maybe types are marshalled as pointers that may be nil & bug fixes. @@ -61,6 +64,10 @@ Type: git Location: git://github.com/mchakravarty/language-c-inline.git +Flag ManualTests + Description: Enables tests that require manual intervention. + Default: False + Library Build-depends: array, base >= 4.0 && < 5, @@ -73,6 +80,7 @@ Exposed-modules: Language.C.Inline.ObjC Other-modules: Language.C.Inline.Error + Language.C.Inline.Hint Language.C.Inline.State Language.C.Inline.ObjC.Marshal @@ -80,6 +88,11 @@ -- Doesn't work!!! Use the Makefile in the tests/ instead. (How can we get cabal to compile & link the generated ObjC files?) Test-Suite concept + if flag(ManualTests) + Buildable: True + else + Buildable: False + Build-depends: base >= 4.0 && < 5, language-c-quote, language-c-inline diff --git a/tests/objc/app/App.hs b/tests/objc/app/App.hs --- a/tests/objc/app/App.hs +++ b/tests/objc/app/App.hs @@ -13,8 +13,8 @@ main :: IO () -main = $(objc [] ''() - [cexp| NSApplicationMain (0, NULL) |]) - -- 'NSApplicationMain' ignores its argc and argv arguments anyway +main = $(objc [] $ + void [cexp| NSApplicationMain (0, NULL) |]) + -- 'NSApplicationMain' ignores its argc and argv arguments anyway objc_emit 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 @@ -65,7 +65,7 @@ |] -objc_implementation ['launchMsg, 'start, 'evalExpr, 'loadModule] [cunit| +objc_implementation [Typed 'launchMsg, Typed 'start, Typed 'evalExpr, Typed 'loadModule] [cunit| @interface AppDelegate () diff --git a/tests/objc/app/Makefile b/tests/objc/app/Makefile --- a/tests/objc/app/Makefile +++ b/tests/objc/app/Makefile @@ -1,5 +1,6 @@ HC = ghc -CFLAGS = -fobjc-arc -I$(shell $(HC) --print-libdir)/include +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 -package hint \ -framework Cocoa -optl-ObjC -threaded diff --git a/tests/objc/concept/TestInlineObjC.hs b/tests/objc/concept/TestInlineObjC.hs --- a/tests/objc/concept/TestInlineObjC.hs +++ b/tests/objc/concept/TestInlineObjC.hs @@ -11,7 +11,7 @@ dumpURL :: String -> IO () dumpURL urlString = do - { urlData <- $(objc ['urlString] ''String [cexp| + { urlData <- $(objc ['urlString :> ''String] $ ''String <: [cexp| [NSString stringWithContentsOfURL:[NSURL URLWithString:urlString] encoding:NSUTF8StringEncoding error:NULL] diff --git a/tests/objc/minimal/Main.hs b/tests/objc/minimal/Main.hs --- a/tests/objc/minimal/Main.hs +++ b/tests/objc/minimal/Main.hs @@ -3,11 +3,13 @@ import Language.C.Quote.ObjC import Language.C.Inline.ObjC +import Language.Haskell.TH objc_import [""] nslog :: String -> IO () -nslog msg = $(objc ['msg] ''() [cexp| NSLog(@"Here is a message from Haskell: %@", msg) |]) + +nslog msg = $(objc ['msg :> ''String] (void [cexp| NSLog(@"Here is a message from Haskell: %@", msg) |])) objc_emit diff --git a/tests/objc/record/Main.hs b/tests/objc/record/Main.hs --- a/tests/objc/record/Main.hs +++ b/tests/objc/record/Main.hs @@ -6,7 +6,7 @@ objc_import ["", "Particle_objc.h"] go :: IO () -go = $(objc [] ''() [cexp| ({ +go = $(objc [] $ void [cexp| ({ typename Particle *particle = [Particle particleWithMass:1.0]; NSLog(@"The mass is %f", particle.mass); }) |]) diff --git a/tests/objc/record/Makefile b/tests/objc/record/Makefile --- a/tests/objc/record/Makefile +++ b/tests/objc/record/Makefile @@ -1,5 +1,6 @@ HC = ghc -CFLAGS = -fobjc-arc -I$(shell $(HC) --print-libdir)/include +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 @@ -52,7 +52,7 @@ |] -objc_implementation ['newParticle, 'particleMass] [cunit| +objc_implementation [Typed 'newParticle, Typed 'particleMass] [cunit| @interface Particle ()