diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,23 @@ +Copyright (c) [2013] 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: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the names of the contributors nor of their affiliations may + be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Language/C/Inline/Error.hs b/Language/C/Inline/Error.hs new file mode 100644 --- /dev/null +++ b/Language/C/Inline/Error.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +-- | +-- Module : Language.C.Inline.Error +-- Copyright : [2013] Manuel M T Chakravarty +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module provides support for error reporting. + +module Language.C.Inline.Error ( + -- * Error reporting + reportErrorAndFail, + + -- * Exception handling + tryWithPlaceholder, + + -- * Pretty printing for error messages + prettyQC +) where + +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 +import Text.PrettyPrint.Mainland as QC + + +reportErrorAndFail :: QC.Extensions -> String -> Q a +reportErrorAndFail lang msg + = do + { reportError' lang msg + ; fail "Failure" + } + +-- reportErrorAndBail :: String -> Q TH.Exp +-- reportErrorAndBail msg +-- = do +-- { reportError msg +-- ; Just undefinedName <- TH.lookupValueName "Prelude.undefined" +-- ; 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" + +-- If the tried computation fails, insert a placeholder expression. +-- +-- We report all errors explicitly. Failing would just duplicate errors. +-- +tryWithPlaceholder :: Q TH.Exp -> Q TH.Exp +tryWithPlaceholder = ([| error "language-c-quote: internal error: tryWithPlaceholder" |] `recover`) + +prettyQC :: QC.Pretty a => a -> String +prettyQC = QC.pretty 80 . QC.ppr diff --git a/Language/C/Inline/ObjC.hs b/Language/C/Inline/ObjC.hs new file mode 100644 --- /dev/null +++ b/Language/C/Inline/ObjC.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +-- | +-- Module : Language.C.Inline.ObjC +-- Copyright : [2013] Manuel M T Chakravarty +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module exports the principal API for inline Objective-C. + +module Language.C.Inline.ObjC ( + objc_import, objc_interface, objc_implementation, objc, objc_emit +) where + + -- common libraries +import Control.Applicative +import Control.Monad +import Data.Array +import Data.Dynamic +import Data.IORef +import Data.List +import Foreign.C as C +import Foreign.C.String as C +import Foreign.Marshal as C +import Language.Haskell.TH as TH +import Language.Haskell.TH.Syntax as TH +import System.FilePath +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 + + -- friends +import Language.C.Inline.Error +import Language.C.Inline.State +import Language.C.Inline.ObjC.Marshal + + +-- |Specify imported Objective-C files. Needs to be spliced where an import declaration can appear. (Just put it +-- straight after all the import statements in the module.) +-- +-- FIXME: need to use TH.addDependentFile on each of the imported ObjC files & read headers +-- +objc_import :: [FilePath] -> Q [TH.Dec] +objc_import headers + = do + { mapM_ stashHeader headers + ; objc_jumptable <- newName "objc_jumptable" + ; setForeignTable $ varE objc_jumptable + ; sequence $ [ sigD objc_jumptable [t|IORef (Array Int Dynamic)|] + , pragInlD objc_jumptable NoInline FunLike AllPhases -- reqs template-haskell 2.8.0.0 + -- , pragInlD objc_jumptable (inlineSpecNoPhase False False) + , valD (varP objc_jumptable) (normalB [|unsafePerformIO $ newIORef (array (0, 0) [])|]) [] + ] + -- ; return $ [d|import Language.C.Quote as ObjC; + -- import Language.C.Quote.ObjC as ObjC; + -- import Foreign.C as C + -- |] + } + -- FIXME: Should this also add the Language.C.Quote imports? (We might not need to generate any imports at all?!?) + +-- |Inline Objective-C top-level definitions for a header file ('.h'). +-- +objc_interface :: [QC.Definition] -> Q [TH.Dec] +objc_interface defs + = do + { stashObjC_h defs + ; return [] + } + +-- |Inline Objective-C top-level definitions for an implementation file ('.m'). +-- +-- The top-level Haskell variables given in the first argument will be foreign exported to be accessed from the +-- generated Objective-C code. In C, these Haskell variables will always be represented as functions. (In particular, if +-- 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 + = do + { mapM_ exportVar vars + ; stashObjC_m defs + ; return [] + } + where + exportVar var + = do + { -- Determine the argument and result types of the exported Haskell function + ; (argTys, inIO, resTy) <- splitHaskellType <$> determineVarType var + + -- Determine C types + ; cArgTys <- mapM (haskellTypeToCType ObjC) argTys + ; cResTy <- haskellTypeToCType ObjC resTy + + -- Determine the bridging type and the marshalling code + ; (bridgeArgTys, cBridgeArgTys, hsArgMarshallers, cArgMarshallers) <- + unzip4 <$> zipWithM generateCToHaskellMarshaller argTys cArgTys + ; (bridgeResTy, cBridgeResTy, hsResMarshaller, cResMarshaller) <- generateHaskellToCMarshaller resTy cResTy + + -- Haskell type of the foreign wrapper function + ; let hsWrapperTy = haskellWrapperType bridgeArgTys bridgeResTy + + -- Generate the Haskell wrapper + ; let cwrapperName = mkName . nameBase $ var + ; hswrapperName <- newName (nameBase var ++ "_hswrapper") + ; hsArgVars <- mapM (const $ newName "arg") bridgeArgTys + ; stashHS + [ forExpD CCall (show hswrapperName) hswrapperName hsWrapperTy + , sigD hswrapperName hsWrapperTy + , funD hswrapperName + [ clause (map varP hsArgVars) + (normalB $ generateHSCall hsArgVars hsArgMarshallers (varE var) hsResMarshaller inIO) + [] + ] + ] + + -- Generate the C wrapper code (both prototype and definition) + ; cArgVars <- mapM (\n -> newName $ "arg" ++ show n) [1..length cBridgeArgTys] + ; let cArgVarExps = [ [cexp| $id:(nameBase var) |] | var <- cArgVars] + call = [cexp| $id:(show hswrapperName) ( $args:cArgVarExps ) |] + (_wrapperProto, wrapperDef) + = generateCWrapper cwrapperName cBridgeArgTys cArgVars cArgMarshallers cArgTys cArgVars + call + resTy cBridgeResTy cResMarshaller cResTy + ; stashObjC_m $ + -- C prototype of the foreign exported Haskell-side wrapper + [cunit| + $ty:cBridgeResTy $id:(show hswrapperName) ($params:(cParams cBridgeArgTys cArgVars)); + |] + ++ + wrapperDef + } + + splitHaskellType (ArrowT `AppT` arg `AppT` res) + = let (args, inIO, res') = splitHaskellType res + in + (arg:args, inIO, res') + splitHaskellType (ConT io `AppT` res) | io == ''IO + = ([], True, res) + splitHaskellType res + = ([], False, res) + +forExpD :: Callconv -> String -> Name -> TypeQ -> DecQ +forExpD cc str n ty + = do + { ty' <- ty + ; return $ ForeignD (ExportF cc str n ty') + } + +-- |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. +-- +objc :: [TH.Name] -> TH.Name -> QC.Exp -> Q TH.Exp +objc vars resTy e + = {- tryWithPlaceholder $ -} do -- FIXME: catching the 'fail' purges all reported errors :( + { -- Sanity check of arguments + ; varTys <- mapM determineVarType vars + ; checkTypeName resTy + + -- Determine C types + ; cArgTys <- mapM (haskellTypeToCType ObjC) varTys + ; cResTy <- haskellTypeNameToCType 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 + + -- Haskell type of the foreign wrapper function + ; let hsWrapperTy = haskellWrapperType bridgeArgTys bridgeResTy + + -- FFI setup for the C wrapper + ; cwrapperName <- newName "cwrapper" + ; stashHS + [ forImpD CCall Safe (show cwrapperName) cwrapperName hsWrapperTy + ] + ; idx <- extendJumpTable cwrapperName + + -- Generate the C wrapper code (both prototype and definition) + ; cArgVars <- mapM (newName . nameBase) vars + ; let (wrapperProto, wrapperDef) + = generateCWrapper cwrapperName cArgTys vars cArgMarshallers cBridgeArgTys cArgVars + e + (ConT resTy) cResTy cResMarshaller cBridgeResTy + ; stashObjC_h wrapperProto + ; stashObjC_m wrapperDef + + -- 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 + ; [|fromDyn + ((unsafePerformIO $ readIORef $jumptable) ! $(TH.lift idx)) + (error "InlineObjC: INTERNAL ERROR: type mismatch in jumptable") + :: $ty |] + } + +-- Turn a list of argument types and a result type into a Haskell wrapper signature. +-- +-- > haskellWrapperType [a1, .., an] r = [| a1 -> .. -> an -> IO r |] +-- +haskellWrapperType :: [TH.TypeQ] -> TH.TypeQ -> TH.TypeQ +haskellWrapperType [] resTy = [t| IO $resTy |] +haskellWrapperType (argTy:argTys) resTy = [t| $argTy -> $(haskellWrapperType argTys resTy) |] + +-- Generate the prototype of and function definition of a C marshalling wrapper. +-- +-- Given a C expression to be executed, this generator produces a C function that executes the expression with all +-- arguments and the result marshalled using the provided marshallers. +-- +generateCWrapper :: TH.Name + -> [QC.Type] + -> [TH.Name] -- name of arguments after marshalling (will be the original name without unique) + -> [CMarshaller] + -> [QC.Type] + -> [TH.Name] + -> QC.Exp -- C expression containing occurences of the arguments (using names without uniques) + -> TH.Type + -> QC.Type + -> CMarshaller + -> QC.Type + -> ([QC.Definition], [QC.Definition]) +generateCWrapper cwrapperName argTys vars argMarshallers cWrapperArgTys argVars e hsResTy resTy resMarshaller cWrapperResTy + = let cMarshalling = [ [citem| $ty:argTy $id:(nameBase var) = $exp:(argMarshaller argVar); |] + | (argTy, var, argMarshaller, argVar) <- zip4 argTys vars argMarshallers argVars] + resultName = mkName "result" + cInvocation | hsResTy == (ConT ''()) = [citem| $exp:e; |] -- void result + | otherwise = [citem| { + $ty:resTy $id:(show resultName) = $exp:e; // non-void result... + return $exp:(resMarshaller resultName); // ...marshalled to Haskell + }|] + in + ([cunit| + $ty:cWrapperResTy $id:(show cwrapperName) ($params:(cParams cWrapperArgTys argVars)); + |], + [cunit| + $ty:cWrapperResTy $id:(show cwrapperName) ($params:(cParams cWrapperArgTys argVars)) + { + $items:cMarshalling + $item:cInvocation + } + |]) + +-- cParams [a1, .., an] [v1, .., vn] = [[cparam| a1 v1 |], .., [cparam| an vn |]] +-- +cParams :: [QC.Type] -> [TH.Name] -> [QC.Param] +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. +-- +generateHSCall :: [TH.Name] + -> [HaskellMarshaller] + -> TH.ExpQ + -> HaskellMarshaller + -> Bool + -> TH.ExpQ +generateHSCall vars hsArgMarshallers f hsResMarshaller inIO + = invoke [hsArgMarshaller (varE var) | (var, hsArgMarshaller) <- zip vars hsArgMarshallers] + f + (if inIO then [| \call -> do { cresult <- call ; $(hsResMarshaller [|cresult|] [|return|]) } |] + else [| \call -> do { let {cresult = call}; $(hsResMarshaller [|cresult|] [|return|]) } |]) + where + -- invoke [v1, .., vn] [a1, .., an] call r = [| a1 (\v1 -> .. -> an (\vn -> r (call v1 .. vn))..) |] + invoke :: [TH.ExpQ -> TH.ExpQ] -> TH.ExpQ -> TH.ExpQ -> TH.ExpQ + invoke [] call ret = [| $ret $call |] + invoke (arg:args) call ret = arg [| \name -> $(invoke args [| $call name |] ret)|] + +-- |Emit the Objective-C file and return the foreign declarations. Needs to be the last use of an 'objc...' function. +-- (Just put it at the end of the Haskell module.) +-- +objc_emit :: Q [TH.Dec] +objc_emit + = do + { loc <- location + ; let origFname = loc_filename loc + objcFname = dropExtension origFname ++ "_objc" + objcFname_h = objcFname `addExtension` "h" + objcFname_m = objcFname `addExtension` "m" + ; headers <- getHeaders + ; (objc_h, objc_m) <- getHoistedObjC + ; runIO $ + do + { writeFile objcFname_h (info origFname) + ; 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 \"" ++ objcFname_h ++ "\"\n\n") + ; appendFile objcFname_m (show $ QC.ppr objc_m) + } + ; objc_jumptable <- getForeignTable + ; labels <- getForeignLabels + ; initialize <- [d|objc_initialise :: IO () + objc_initialise + = -- unsafePerformIO $ + writeIORef $objc_jumptable $ + listArray ($(lift (1::Int)), $(lift $ length labels)) $ + $(listE [ [|toDyn $(varE label)|] | label <- labels]) + |] + ; (initialize ++) <$> getHoistedHS + } + where + mkImport h@('<':_) = "#import " ++ h ++ "" + mkImport h = "#import \"" ++ h ++ "\"" + + info fname = "// Generated code: DO NOT EDIT\n\ + \// generated from '" ++ fname ++ "'\n\ + \// by package 'language-c-inline'\n\n" diff --git a/Language/C/Inline/ObjC/Marshal.hs b/Language/C/Inline/ObjC/Marshal.hs new file mode 100644 --- /dev/null +++ b/Language/C/Inline/ObjC/Marshal.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +-- | +-- Module : Language.C.Inline.ObjC.Marshal +-- Copyright : [2013] Manuel M T Chakravarty +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Objective-C-specific marshalling functions. +-- +-- 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, + + -- * Marshaller types + HaskellMarshaller, CMarshaller, + + -- * Compute bridging types and marshallers + generateHaskellToCMarshaller, generateCToHaskellMarshaller +) where + + -- common libraries +import Foreign.C as C +import Foreign.C.String as C +import Foreign.Marshal as C +import Foreign.StablePtr as C +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 +import Text.PrettyPrint.Mainland as QC + + -- 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 +-- ----------------------- + +-- Determine the C type that we map a given Haskell type to. +-- +haskellTypeToCType :: QC.Extensions -> TH.Type -> Q QC.Type +haskellTypeToCType lang (ListT `AppT` (ConT char)) + | char == ''Char + = haskellTypeNameToCType lang ''String +haskellTypeToCType lang (ConT tc) + = haskellTypeNameToCType lang tc +haskellTypeToCType _lang ty + = return [cty| typename HsStablePtr |] + +-- Determine the C type that we map a given Haskell type constructor to — i.e., we map all Haskell +-- whose outermost constructor is the given type constructor to the returned C type.. +-- +haskellTypeNameToCType :: QC.Extensions -> TH.Name -> Q QC.Type +haskellTypeNameToCType ObjC tyname + | tyname == ''String = return [cty| typename NSString * |] + | tyname == ''() = return [cty| void |] +haskellTypeNameToCType _lang tyname + = return [cty| typename HsStablePtr |] + + +-- Determine marshallers and their bridging types +-- ---------------------------------------------- + +-- Constructs Haskell code to marshal a value (used to marshal arguments and results). +-- +-- * The first argument is the code referring to the value to be marshalled. +-- * The second argument is the continuation that gets the marshalled value as an argument. +-- +type HaskellMarshaller = TH.ExpQ -> TH.ExpQ -> TH.ExpQ + +-- Constructs C code to marshal an argument (used to marshal arguments and results). +-- +-- * The argument is the identifier of the value to be marshalled. +-- * The result of the generated expression is the marshalled value. +-- +type CMarshaller = TH.Name -> QC.Exp + +-- Generate the type-specific marshalling code for Haskell to C land marshalling for a Haskell-C type pair. +-- +-- The result has the following components: +-- +-- * Haskell type after Haskell-side marshalling. +-- * C type before C-side marshalling. +-- * 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 cTy + | cTy == [cty| typename NSString * |] + = return ( [t| C.CString |] + , [cty| char * |] + , \val cont -> [| C.withCString $val $cont |] + , \argName -> [cexp| [NSString stringWithUTF8String: $id:(show argName)] |] + ) + | cTy == [cty| typename HsStablePtr |] + = return ( [t| C.StablePtr $(return hsTy) |] + , cTy + , \val cont -> [| do { C.newStablePtr $val >>= $cont } |] + , \argName -> [cexp| $id:(show argName) |] + ) + | otherwise + = reportErrorAndFail ObjC $ "cannot marshal '" ++ TH.pprint hsTy ++ "' to '" ++ prettyQC cTy ++ "'" + +-- Generate the type-specific marshalling code for Haskell to C land marshalling for a C-Haskell type pair. +-- +-- The result has the following components: +-- +-- * Haskell type after Haskell-side marshalling. +-- * C type before C-side marshalling. +-- * Generator for the Haskell-side marshalling code. +-- * Generator for the C-side marshalling code. +-- +generateCToHaskellMarshaller :: TH.Type -> QC.Type -> Q (TH.TypeQ, QC.Type, HaskellMarshaller, CMarshaller) +generateCToHaskellMarshaller hsTy cTy + | cTy == [cty| typename NSString * |] + = return ( [t| C.CString |] + , [cty| char * |] + , \val cont -> [| do { str <- C.peekCString $val; C.free $val; $cont str } |] + , \argName -> + 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; + }) + |] + ) + | cTy == [cty| typename HsStablePtr |] + = return ( [t| C.StablePtr $(return hsTy) |] + , cTy + , \val cont -> [| do { C.deRefStablePtr $val >>= $cont } |] + , \argName -> [cexp| $id:(show argName) |] + ) + | cTy == [cty| void |] + = return ( [t| () |] + , [cty| void |] + , \val cont -> [| $cont $val |] + , \argName -> [cexp| $id:(show argName) |] + ) + | otherwise + = reportErrorAndFail ObjC $ "cannot marshall '" ++ prettyQC cTy ++ "' to '" ++ TH.pprint hsTy ++ "'" + diff --git a/Language/C/Inline/State.hs b/Language/C/Inline/State.hs new file mode 100644 --- /dev/null +++ b/Language/C/Inline/State.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +-- | +-- Module : Language.C.Inline.State +-- Copyright : [2013] Manuel M T Chakravarty +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module manages the state accumulated during the compilation of one module. + +module Language.C.Inline.State ( + -- * Abstract application state + State, + + -- * State query and update operations + setForeignTable, stashHeader, stashObjC_h, stashObjC_m, stashHS, + extendJumpTable, + getForeignTable, getForeignLabels, getHeaders, getHoistedObjC, getHoistedHS +) where + + -- common libraries +import Control.Applicative +import Data.IORef +import Foreign.C as C +import Language.Haskell.TH as TH +import Language.Haskell.TH.Syntax as TH +import System.IO.Unsafe (unsafePerformIO) + + -- quasi-quotation libraries +import Language.C.Quote as QC + + +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 + , 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 + } + +state :: IORef State +{-# NOINLINE state #-} +state = unsafePerformIO $ + newIORef $ + State + { foreignTable = error "InlineObjC: internal error: 'foreignTable' undefined" + , foreignLabels = [] + , headers = [] + , hoistedObjC_h = [] + , hoistedObjC_m = [] + , hoistedHS = [] + } + +readState :: (State -> a) -> Q a +readState read = runIO $ read <$> readIORef state + +modifyState :: (State -> State) -> Q () +modifyState modify = runIO $ modifyIORef state modify + -- atomic??? + +setForeignTable :: Q TH.Exp -> Q () +setForeignTable e = modifyState (\s -> s {foreignTable = e}) + +stashHeader :: String -> Q () +stashHeader header = modifyState (\s -> s {headers = header : headers s}) + +stashObjC_h :: [QC.Definition] -> Q () +stashObjC_h defs = modifyState (\s -> s {hoistedObjC_h = hoistedObjC_h s ++ defs}) + +stashObjC_m :: [QC.Definition] -> Q () +stashObjC_m defs = modifyState (\s -> s {hoistedObjC_m = hoistedObjC_m s ++ defs}) + +stashHS :: [TH.DecQ] -> Q () +stashHS decQs + = do + { decs <- sequence decQs + ; modifyState (\s -> s {hoistedHS = hoistedHS s ++ decs}) + } + +extendJumpTable :: Name -> Q Int +extendJumpTable foreignName + = do + { modifyState (\s -> s {foreignLabels = foreignLabels s ++ [foreignName]}) -- FIXME: *urgh* + ; length <$> readState foreignLabels + } + +getForeignTable :: Q (Q TH.Exp) +getForeignTable = readState foreignTable + +getForeignLabels :: Q [Name] +getForeignLabels = readState foreignLabels + +getHeaders :: Q [String] +getHeaders = reverse <$> readState headers + +getHoistedObjC :: Q ([QC.Definition], [QC.Definition]) +getHoistedObjC = (,) <$> readState hoistedObjC_h <*> readState hoistedObjC_m + +getHoistedHS :: Q [TH.Dec] +getHoistedHS = readState hoistedHS diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +Inline C & Objective-C in Haskell +===================================== + +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. + +Building +-------- + +To build the library, just use `cabal install` as usual. To build the proof of concept example, do the following + +* Execute `cd tests/objc/concept; make`. +* Now run the demo executable with `./InlineObjC`. + +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. + +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! diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/language-c-inline.cabal b/language-c-inline.cabal new file mode 100644 --- /dev/null +++ b/language-c-inline.cabal @@ -0,0 +1,86 @@ +Name: language-c-inline +Version: 0.3.0.0 +Cabal-version: >= 1.9.2 +Tested-with: GHC == 7.6.3 +Build-type: Simple + +Synopsis: Inline C & Objective-C code in Haskell for language interoperability +Description: This library provides inline C & Objective-C code using GHC's support for + quasi-quotation. In particular, it enables the use of foreign libraries + without a dedicated bridge or binding. Here is a tiny example: + . + > log :: String -> IO () + > log msg = $(objc 'msg [cexp| NSLog (@"Here is a message from Haskell: %@", msg) |]) + . + For more information, see . + . + Known bugs: + . + * New in 0.3.0.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 + as for inline code returning 'void'. + . + * New in 0.1.0.0: We are just getting started! This is just a ROUGH AND + HIGHLY EXPERIMENTAL PROTOTYPE. +License: BSD3 +License-file: LICENSE +Author: Manuel M T Chakravarty +Maintainer: Manuel M T Chakravarty +Homepage: https://github.com/mchakravarty/language-c-inline/ +Bug-reports: https://github.com/mchakravarty/language-c-inline/issues + +Category: Language, Foreign +Stability: Experimental + +Extra-source-files: README.md + tests/objc/concept/Makefile + tests/objc/app/App.hs + tests/objc/app/AppDelegate.hs + tests/objc/app/Interpreter.hs + tests/objc/app/Main.hs + tests/objc/app/Makefile + tests/objc/app/Readme.md + tests/objc/app/HSApp.app/Contents/Info.plist + tests/objc/app/HSApp.app/Contents/MacOS/.gitkeep + tests/objc/app/HSApp.app/Contents/Resources/en.lproj/Credits.rtf + tests/objc/app/HSApp.app/Contents/Resources/en.lproj/InfoPlist.strings + tests/objc/app/HSApp.app/Contents/Resources/en.lproj/MainMenu.nib + +Source-repository head + Type: git + Location: git://github.com/mchakravarty/language-c-inline.git + +Library + Build-depends: array, + base >= 4.0 && < 5, + filepath >= 1.2, + language-c-quote >= 0.7, + mainland-pretty >= 0.2.5, + template-haskell + + Exposed-modules: Language.C.Inline.ObjC + + Other-modules: Language.C.Inline.Error + Language.C.Inline.State + Language.C.Inline.ObjC.Marshal + + Extensions: TemplateHaskell, QuasiQuotes + +-- 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 + Build-depends: base >= 4.0 && < 5, + language-c-quote, + language-c-inline + + Frameworks: Foundation + + Type: exitcode-stdio-1.0 + + Hs-source-dirs: tests/objc/concept + + Main-is: MainInlineObjC.hs + + Other-modules: TestInlineObjC + diff --git a/tests/objc/app/App.hs b/tests/objc/app/App.hs new file mode 100644 --- /dev/null +++ b/tests/objc/app/App.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +-- HSApp: a simple Cocoa app in Haskell +-- +-- Main application module entering AppKit's application framework + +module App (main, objc_initialise) where + +import Language.C.Quote.ObjC +import Language.C.Inline.ObjC + +objc_import [""] + + +main :: IO () +main = $(objc [] ''() + [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 new file mode 100644 --- /dev/null +++ b/tests/objc/app/AppDelegate.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +-- HSApp: a simple Cocoa app in Haskell +-- +-- Application delegate object, abused as a view controller + +module AppDelegate (objc_initialise) where + + -- language-c-inline +import Language.C.Quote.ObjC +import Language.C.Inline.ObjC + + -- friends +import Interpreter + +objc_import ["", "HsFFI.h"] + + +-- Haskell code used from Objective-C. + +launchMsg :: String +launchMsg = "HSApp did finish launching!" + +evalExpr :: Session -> String -> IO String +evalExpr _session "" + = return "" +evalExpr session input@(':' : withCommand) + = case break (== ' ') withCommand of + ("type", expr) -> do + { result <- typeOf session expr + ; return $ formatResult input result + } + (command, _) -> return $ "Haskell> " ++ input ++ "\nUnknown command" ++ command ++ "\n" +evalExpr session expr + = do + { result <- eval session expr + ; return $ formatResult expr result + } + where + +loadModule :: Session -> String -> IO String +loadModule session mname + = do + { result <- load session mname + ; return $ formatResult "" result + } + +formatResult :: String -> Result -> String +formatResult input result = (if null input then "" else "Haskell> " ++ input ++ "\n") ++ showResult result ++ "\n" + where + showResult (Result res) = res + showResult (Error err) = "ERROR: " ++ err + + +objc_interface [cunit| + +@interface AppDelegate : NSResponder + +// IBOutlets +@property (weak, nonatomic) typename NSWindow *window; +@property (weak, nonatomic) typename NSScrollView *scrollView; +@property (weak, nonatomic) typename NSTextField *textField; + +@end +|] + + +objc_implementation ['launchMsg, 'start, 'evalExpr, 'loadModule] [cunit| + +@interface AppDelegate () + +// The NSTextView in the UI. +@property (nonatomic) typename NSTextView *textView; + +// Reference to the interpreter session in Haskell land. +@property (assign) typename HsStablePtr interpreterSession; + +- (void)appendOutput:(typename NSString *)text; + +@end + +@implementation AppDelegate + +- (void)applicationDidFinishLaunching:(typename NSNotification *)aNotification +{ + [[self.textField cell] setPlaceholderString:@"Enter an expression, or use the :type command"]; + self.textView = self.scrollView.documentView; + self.interpreterSession = start(); + NSLog(@"%@", launchMsg()); +} + +// IBAction +- (void)textFieldDidSend:(typename NSTextField *)sender +{ + [self appendOutput:evalExpr(self.interpreterSession, [sender stringValue])]; + [sender setStringValue:@""]; +} + +- (void)appendOutput:(typename NSString *)text +{ + typename NSFont *menlo13 = [NSFont fontWithName:@"Menlo-Regular" size:13]; + typename NSAttributedString *attrText = [[NSAttributedString alloc] initWithString:text + attributes:@{ NSFontAttributeName : menlo13 }]; + [self.textView.textStorage appendAttributedString:attrText]; + [self.textView scrollRangeToVisible:NSMakeRange([self.textView.textStorage length], 0)]; +} + +- (void)openDocument:(id)sender +{ + typename NSOpenPanel* panel = [NSOpenPanel openPanel]; + [panel setMessage:@"Select a Haskell module to load."]; + [panel setAllowedFileTypes:@[@"hs", @"lhs"]]; + [panel beginSheetModalForWindow:self.window completionHandler:^(typename NSInteger result){ + if (result == NSFileHandlingPanelOKButton) { + + typename NSArray* urls = [panel URLs]; + [self appendOutput:loadModule(self.interpreterSession, [[urls firstObject] path])]; + + } + + }]; +} + +@end +|] + + +objc_emit diff --git a/tests/objc/app/HSApp.app/Contents/Info.plist b/tests/objc/app/HSApp.app/Contents/Info.plist new file mode 100644 --- /dev/null +++ b/tests/objc/app/HSApp.app/Contents/Info.plist @@ -0,0 +1,50 @@ + + + + + BuildMachineOSBuild + 13B3116 + CFBundleDevelopmentRegion + en + CFBundleExecutable + HSApp + CFBundleIdentifier + org.justtesting.HSApp + CFBundleInfoDictionaryVersion + 6.0 + CFBundleName + HSApp + CFBundlePackageType + APPL + CFBundleShortVersionString + 1.0 + CFBundleSignature + ???? + CFBundleVersion + 1 + DTCompiler + com.apple.compilers.llvm.clang.1_0 + DTPlatformBuild + 5A3005 + DTPlatformVersion + GM + DTSDKBuild + 13A595 + DTSDKName + macosx10.9 + DTXcode + 0502 + DTXcodeBuild + 5A3005 + LSApplicationCategoryType + public.app-category.developer-tools + LSMinimumSystemVersion + 10.8 + NSHumanReadableCopyright + Written by Manuel M T Chakravarty. + NSMainNibFile + MainMenu + NSPrincipalClass + NSApplication + + diff --git a/tests/objc/app/HSApp.app/Contents/MacOS/.gitkeep b/tests/objc/app/HSApp.app/Contents/MacOS/.gitkeep new file mode 100644 --- /dev/null +++ b/tests/objc/app/HSApp.app/Contents/MacOS/.gitkeep diff --git a/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/Credits.rtf b/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/Credits.rtf new file mode 100644 --- /dev/null +++ b/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/Credits.rtf @@ -0,0 +1,12 @@ +{\rtf1\ansi\ansicpg1252\cocoartf1187\cocoasubrtf370 +\cocoascreenfonts1{\fonttbl\f0\fswiss\fcharset0 Helvetica;} +{\colortbl;\red255\green255\blue255;} +\paperw11900\paperh16840\vieww9600\viewh8400\viewkind0 +\pard\tx560\tx1120\tx1680\tx2240\tx2800\tx3360\tx3920\tx4480\tx5040\tx5600\tx6160\tx6720 + +\f0\b\fs24 \cf0 Inline Objective-C in Haskell example app +\b0 \ +\ +It demonstrates how to use in Objective-C\ +in tandem with Haskell to write Cocoa apps.\ +} diff --git a/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/InfoPlist.strings b/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/InfoPlist.strings new file mode 100644 Binary files /dev/null and b/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/InfoPlist.strings differ diff --git a/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/MainMenu.nib b/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/MainMenu.nib new file mode 100644 Binary files /dev/null and b/tests/objc/app/HSApp.app/Contents/Resources/en.lproj/MainMenu.nib differ diff --git a/tests/objc/app/Interpreter.hs b/tests/objc/app/Interpreter.hs new file mode 100644 --- /dev/null +++ b/tests/objc/app/Interpreter.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} + +-- HSApp: a simple Cocoa app in Haskell +-- +-- Management of GHC interpreter sessions through the 'hint' package. +-- +-- Interpreter sessions run in their own thread. They receive interpreter commands as monadic 'Interpreter' computations +-- via an inlet 'MVar'. These commands return the result of command execution via another 'MVar' specifically used only +-- for this one command. +-- + +module Interpreter ( + Session, Result(..), + start, stop, eval, typeOf, load +) where + + -- standard libraries +import Prelude hiding (catch) +import Control.Applicative +import Control.Concurrent +import Control.Exception (SomeException, evaluate) +import Control.Monad +import "MonadCatchIO-mtl" + Control.Monad.CatchIO +import Control.Monad.Error + +import System.IO + + -- hint +import qualified Language.Haskell.Interpreter as Interp + + +-- |Abstract handle of an interpreter session. +-- +newtype Session = Session (MVar (Maybe (Interp.Interpreter ()))) + +-- |Possible results of executing an interpreter action. +-- +data Result = Result String + | Error String + +-- |Start a new interpreter session. +-- +start :: IO Session +start + = do + { inlet <- newEmptyMVar + ; forkIO $ void $ Interp.runInterpreter (startSession inlet) + ; return $ Session inlet + } + where + startSession inlet = Interp.setImports ["Prelude"] >> session inlet + + session inlet + = do + { maybeCommand <- Interp.lift $ takeMVar inlet + ; case maybeCommand of + Nothing -> return () + Just command -> + do + { command + ; session inlet + } + } + +-- Terminate an interpreter session. +-- +stop :: Session -> IO () +stop (Session inlet) = putMVar inlet Nothing + +-- Evaluate a Haskell expression in the given interpreter session, 'show'ing its result. +-- +-- If GHC raises an error, we pretty print it. +-- +eval :: Session -> String -> IO Result +eval (Session inlet) e + = do + { resultMV <- newEmptyMVar + ; putMVar inlet $ Just $ -- the interpreter command we send over to the interpreter thread + do + { -- demand the result to force any contained exceptions + ; result <- (do { !result <- Interp.eval e + ; return result } + `catchError` (return . pprError)) + `catch` (return . (show :: SomeException -> String)) + ; Interp.lift $ putMVar resultMV (Result result) + } + ; takeMVar resultMV + } + +-- Infer the type of a Haskell expression in the given interpreter session. +-- +-- If GHC raises an error, we pretty print it. +-- +typeOf :: Session -> String -> IO Result +typeOf (Session inlet) e + = do + { resultMV <- newEmptyMVar + ; putMVar inlet $ Just $ -- the interpreter command we send over to the interpreter thread + do + { -- demand the result to force any contained exceptions + ; result <- (do { !result <- Interp.typeOf e + ; return result } + `catchError` (return . pprError)) + `catch` (return . (show :: SomeException -> String)) + ; Interp.lift $ putMVar resultMV (Result result) + } + ; takeMVar resultMV + } + +-- Load a module into in the given interpreter session. +-- +-- If GHC raises an error, we pretty print it. +-- +load :: Session -> String -> IO Result +load (Session inlet) mname + = do + { resultMV <- newEmptyMVar + ; putMVar inlet $ Just $ -- the interpreter command we send over to the interpreter thread + do + { -- demand the result to force any contained exceptions + ; result <- (do { Interp.loadModules [mname] + ; mods <- Interp.getLoadedModules + ; Interp.setTopLevelModules mods + ; return ("Successfully loaded '" ++ mname ++ "'") } + `catchError` (return . pprError)) + `catch` (return . (show :: SomeException -> String)) + ; Interp.lift $ putMVar resultMV (Result result) + } + ; takeMVar resultMV + } + +pprError :: Interp.InterpreterError -> String +pprError (Interp.UnknownError msg) = msg +pprError (Interp.WontCompile errs) = "Compile time error: \n" ++ concatMap Interp.errMsg errs +pprError (Interp.NotAllowed msg) = "Permission denied: " ++ msg +pprError (Interp.GhcException msg) = "Internal error: " ++ msg diff --git a/tests/objc/app/Main.hs b/tests/objc/app/Main.hs new file mode 100644 --- /dev/null +++ b/tests/objc/app/Main.hs @@ -0,0 +1,14 @@ +-- HSApp: a simple Cocoa app in Haskell +-- +-- Tying all components together + +import qualified App as App +import qualified AppDelegate as Delegate + +main :: IO () +main + = do + { App.objc_initialise + ; Delegate.objc_initialise + ; App.main + } diff --git a/tests/objc/app/Makefile b/tests/objc/app/Makefile new file mode 100644 --- /dev/null +++ b/tests/objc/app/Makefile @@ -0,0 +1,32 @@ +HC = ghc +CFLAGS = -fobjc-arc -I$(shell $(HC) --print-libdir)/include +HCFLAGS = +LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -package hint \ + -framework Cocoa -optl-ObjC -threaded + +OBJS = Main.o App.o App_objc.o AppDelegate.o AppDelegate_objc.o Interpreter.o + +default: HSApp.app/Contents/MacOS/HSApp + +%.o: %.hs + $(HC) -c $< $(HCFLAGS) + +Interpreter.o: +AppDelegate.o: Interpreter.o +App.o: +Main.o: App.o AppDelegate.o + +App_objc.m: App.o +AppDelegate_objc.m: AppDelegate.o + +HSApp: $(OBJS) + $(HC) -o $@ $^ $(LDFLAGS) + +HSApp.app/Contents/MacOS/HSApp: HSApp + cp $< $@ + +.PHONY: clean + +clean: + rm -f *.o *.hi App_objc.[hm] AppDelegate_objc.[hm] *_stub.h HSApp HSApp.app/Contents/MacOS/HSApp + diff --git a/tests/objc/app/Readme.md b/tests/objc/app/Readme.md new file mode 100644 --- /dev/null +++ b/tests/objc/app/Readme.md @@ -0,0 +1,5 @@ +This example application implements a simple GUI around interactive GHC sessions. + +The GUI is done with Xcode (via a .xib). The corresponding Xcode project is in the subdirectory `HSApp-xcode-proj`. This, however, is not used to build the project. Instead, we have got a simple Makefile, that invokes GHC and clang to compile the various components, and finally, copies the binary into a pre-populated `.app` bundle. + +Currently, if you change the `.xib` in the Xcode project, you need to manually copy it into the appropriate location in the `.app` bundle. diff --git a/tests/objc/concept/MainInlineObjC.hs b/tests/objc/concept/MainInlineObjC.hs new file mode 100644 --- /dev/null +++ b/tests/objc/concept/MainInlineObjC.hs @@ -0,0 +1,8 @@ +import TestInlineObjC + +main :: IO () +main + = do + { objc_initialise + ; dumpURL "https://raw.github.com/mchakravarty/language-c-inline/master/tests/objc/TestInlineObjC.hs" + } diff --git a/tests/objc/concept/Makefile b/tests/objc/concept/Makefile new file mode 100644 --- /dev/null +++ b/tests/objc/concept/Makefile @@ -0,0 +1,23 @@ +HC = ghc +HCFLAGS = +LDFLAGS = -package template-haskell -package language-c-quote -package language-c-inline -framework Foundation + +OBJS = TestInlineObjC.o TestInlineObjC_objc.o MainInlineObjC.o + +default: InlineObjC + +%.o: %.hs + $(HC) -c $< $(HCFLAGS) + +TestInlineObjC.o: +MainInlineObjC.o: TestInlineObjC.o + +TestInlineObjC_objc.m: TestInlineObjC.o + +InlineObjC: $(OBJS) + $(HC) -o $@ $^ $(LDFLAGS) + +.PHONY: clean + +clean: + rm -f *.o *.hi TestInlineObjC_objc.[hm] InlineObjC diff --git a/tests/objc/concept/TestInlineObjC.hs b/tests/objc/concept/TestInlineObjC.hs new file mode 100644 --- /dev/null +++ b/tests/objc/concept/TestInlineObjC.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +module TestInlineObjC (objc_initialise, dumpURL) where + +import Language.C.Quote.ObjC +import Language.C.Inline.ObjC + +objc_import [""] + + +dumpURL :: String -> IO () +dumpURL urlString + = do + { urlData <- $(objc ['urlString] ''String [cexp| + [NSString stringWithContentsOfURL:[NSURL URLWithString:urlString] + encoding:NSUTF8StringEncoding + error:NULL] + |]) + ; putStr urlData + } + +objc_emit