diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2012, Jinjing Wang + +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 name of Jinjing Wang nor the names of other + contributors 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 AND CONTRIBUTORS +"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 THE COPYRIGHT +OWNER OR CONTRIBUTORS 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/Nemesis b/Nemesis new file mode 100644 --- /dev/null +++ b/Nemesis @@ -0,0 +1,26 @@ +nemesis = do + + clean + [ "**/*.hi" + , "**/*.o" + , "**/*_stub.h" + ] + + desc "prepare cabal dist" + task "dist" - do + sh "cabal clean" + sh "cabal configure" + sh "cabal sdist" + + desc "interactive console" + task "i" - do + sh "ghci -isrc -lobjc -frameworkCocoa src/Main.hs" + + + + desc "run main" + task "run" - do + sh "runghc -isrc -lobjc -frameworkCocoa src/Main.hs" + + + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md diff --git a/known-issues.md b/known-issues.md new file mode 100644 --- /dev/null +++ b/known-issues.md diff --git a/luka.cabal b/luka.cabal new file mode 100644 --- /dev/null +++ b/luka.cabal @@ -0,0 +1,36 @@ +Name: luka +Version: 2012.7.7 +Build-type: Simple +Synopsis: Simple ObjectiveC runtime binding +Description: Simple ObjectiveC runtime binding +License: BSD3 +License-file: LICENSE +Author: Jinjing Wang +Maintainer: Jinjing Wang +Build-Depends: base +Cabal-version: >= 1.2 +category: Language +homepage: https://github.com/nfjinjing/luka +data-files: readme.md + , changelog.md + , known-issues.md + , Nemesis + , src/Main.hs + , src/Init.hs + +Library + + ghc-options: -frameworkCocoa + + build-depends: base < 99 + , air + , libffi + + hs-source-dirs: src + exposed-modules: Language.ObjectiveC.Luka.RunTime + Language.ObjectiveC.Luka.API + Language.ObjectiveC.Luka + + + other-modules: + extra-libraries: objc diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,23 @@ +Simple ObjectiveC runtime binding + +Tutorial +========= + + git clone $this + + cabal install nemesis + + pushd . + + cd vendor/libffi + cabal install + + popd + + nemesis run + + +License: +======== + +BSD3 diff --git a/src/Init.hs b/src/Init.hs new file mode 100644 --- /dev/null +++ b/src/Init.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Init where + +import Foreign hiding (void) +import Foreign.C.Types +import Foreign.C.String + +import Prelude () +import Air.Env +import Control.Monad ((>=>)) + +import Language.ObjectiveC.Luka.RunTime +import Language.ObjectiveC.Luka +import Foreign.LibFFI + + + +main = do + with_pool - do + ns_puts "Hello World!" [] + -- c_NSApplicationMain 0 nullPtr diff --git a/src/Language/ObjectiveC/Luka.hs b/src/Language/ObjectiveC/Luka.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjectiveC/Luka.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Language.ObjectiveC.Luka +( + module Language.ObjectiveC.Luka.API +, module Language.ObjectiveC.Luka.RunTime +) +where + +import Language.ObjectiveC.Luka.API +import Language.ObjectiveC.Luka.RunTime diff --git a/src/Language/ObjectiveC/Luka/API.hs b/src/Language/ObjectiveC/Luka/API.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjectiveC/Luka/API.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Language.ObjectiveC.Luka.API where + +import Foreign hiding (void) +import Foreign.C.Types +import Foreign.C.String + +import Prelude () +import Air.Env +import Control.Monad ((>=>)) + +import Language.ObjectiveC.Luka.RunTime + +import Foreign.LibFFI + + + +get_i :: String -> ID -> IO ID +get_i ivar_name obj = do + object_getInstanceVariable obj ivar_name >>= object_getIvar obj + + +from_ns_string :: ID -> IO String +from_ns_string = msg_cstring "UTF8String" [] >=> peekCString + + + +with_pool :: IO a -> IO () +with_pool _io = do + pool <- class_named "NSAutoreleasePool" >>= msg_obj "alloc" [] >>= msg_obj "init" [] + + _io + + pool .msg "release" [] + + +msg :: String -> [Arg] -> ID -> IO () +msg methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_void obj sel args + +msg_ptr :: String -> [Arg] -> ID -> IO (Ptr ()) +msg_ptr methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_ptr obj sel args + +msg_obj :: String -> [Arg] -> ID -> IO ID +msg_obj methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_obj obj sel args + +msg_cint :: String -> [Arg] -> ID -> IO CInt +msg_cint methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_cint obj sel args + +msg_cuint :: String -> [Arg] -> ID -> IO CUInt +msg_cuint methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_cuint obj sel args + +msg_clong :: String -> [Arg] -> ID -> IO CLong +msg_clong methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_clong obj sel args + +msg_culong :: String -> [Arg] -> ID -> IO CULong +msg_culong methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_culong obj sel args + +msg_cfloat :: String -> [Arg] -> ID -> IO CFloat +msg_cfloat methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_cfloat obj sel args + +msg_cdouble :: String -> [Arg] -> ID -> IO CDouble +msg_cdouble methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_cdouble obj sel args + +msg_cchar :: String -> [Arg] -> ID -> IO CChar +msg_cchar methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_cchar obj sel args + +msg_uchar :: String -> [Arg] -> ID -> IO CUChar +msg_uchar methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_cuchar obj sel args + +msg_cstring :: String -> [Arg] -> ID -> IO CString +msg_cstring methodName args obj = sel_named methodName >>= \sel -> objc_msgSend_cstring obj sel args + + + +sel_named :: String -> IO SEL +sel_named = sel_getUid + + +ns_string :: String -> IO ID +ns_string x = do + class_named "NSString" >>= msg_obj "stringWithUTF8String:" [argString x] + + +class_named :: String -> IO ID +class_named = objc_getClass + +ns_puts :: String -> [Arg] -> IO () +ns_puts x args = do + ns_msg <- ns_string x + ns_log - argPtr ns_msg : args + +set_method :: String -> String -> FunPtr a -> IO (FunPtr ()) +set_method class_name sel_name method_implementation = do + class_pointer <- class_named class_name + cmd <- sel_named sel_name + + method <- class_getInstanceMethod class_pointer cmd + + method_setImplementation method method_implementation + diff --git a/src/Language/ObjectiveC/Luka/RunTime.hs b/src/Language/ObjectiveC/Luka/RunTime.hs new file mode 100644 --- /dev/null +++ b/src/Language/ObjectiveC/Luka/RunTime.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE EmptyDataDecls #-} + + +module Language.ObjectiveC.Luka.RunTime where + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Foreign.LibFFI + + + +foreign import ccall safe "&object_getInstanceVariable" funPtr_object_getInstanceVariable :: FunPtr () +foreign import ccall safe "&object_getIvar" funPtr_object_getIvar :: FunPtr () +foreign import ccall safe "&objc_getClass" funPtr_objc_getClass :: FunPtr () +foreign import ccall safe "&method_setImplementation" funPtr_method_setImplementation :: FunPtr () +foreign import ccall safe "&objc_msgSend" funPtr_objc_msgSend :: FunPtr () +foreign import ccall safe "&sel_registerName" funPtr_sel_registerName :: FunPtr () +foreign import ccall safe "&sel_getUid" funPtr_sel_getUid :: FunPtr () +foreign import ccall safe "&class_createInstance" funPtr_class_createInstance :: FunPtr () +foreign import ccall safe "&object_dispose" funPtr_object_dispose :: FunPtr () +foreign import ccall safe "&objc_allocateClassPair" funPtr_objc_allocateClassPair :: FunPtr () +foreign import ccall safe "&objc_registerClassPair" funPtr_objc_registerClassPair :: FunPtr () +foreign import ccall safe "&class_addMethod" funPtr_class_addMethod :: FunPtr () +foreign import ccall safe "&class_getInstanceMethod" funPtr_class_getInstanceMethod :: FunPtr () + +foreign import ccall safe "&NSLog" funPtr_NSLog :: FunPtr () + + +foreign import ccall safe "NSApplicationMain" c_NSApplicationMain :: CInt -> Ptr (Ptr CChar) -> IO CInt +foreign import ccall safe "method_getTypeEncoding" method_getTypeEncoding :: Ptr a -> IO CString + + + + + +data IDData +type ID = Ptr IDData + +data SELData +type SEL = Ptr SELData + +data IVarData +type IVar = Ptr IVarData + +objc_False :: CChar +objc_False = 0x0 + +objc_True :: CChar +objc_True = 0x1 + +c2b :: CChar -> Bool +c2b = (== 0x1) + + + +retIdPtr :: RetType ID +retIdPtr = fmap castPtr $ retPtr retVoid + +retSelPtr :: RetType SEL +retSelPtr = fmap castPtr $ retPtr retVoid + +retIVarPtr :: RetType IVar +retIVarPtr = fmap castPtr $ retPtr retVoid + +retVoidPtr :: RetType (Ptr ()) +retVoidPtr = fmap castPtr $ retPtr retVoid + + +object_getInstanceVariable :: ID -> String -> IO IVar +object_getInstanceVariable objectPtr instanceName = callFFI funPtr_object_getInstanceVariable retIVarPtr [argPtr objectPtr, argString instanceName] + +object_getIvar :: ID -> IVar -> IO ID +object_getIvar objectPtr ivarPtr = callFFI funPtr_object_getIvar retIdPtr [argPtr objectPtr, argPtr ivarPtr] + + +objc_getClass :: String -> IO ID +objc_getClass className = callFFI funPtr_objc_getClass retIdPtr [argString className] + +method_setImplementation :: Ptr a -> FunPtr b -> IO (FunPtr ()) +method_setImplementation methodPtr funPtr = callFFI funPtr_method_setImplementation (retFunPtr retVoid) [argPtr methodPtr, argFunPtr funPtr] + + +sel_registerName :: String -> IO SEL +sel_registerName methodName = callFFI funPtr_sel_registerName retSelPtr [argString methodName] + +sel_getUid :: String -> IO SEL +sel_getUid methodName = callFFI funPtr_sel_getUid retSelPtr [argString methodName] + + +class_createInstance :: ID -> IO ID +class_createInstance classPtr = callFFI funPtr_class_createInstance retIdPtr [argPtr classPtr, argCSize 0] + +object_dispose :: ID -> IO ID +object_dispose objectPtr = callFFI funPtr_object_dispose retIdPtr [argPtr objectPtr] + + +objc_allocateClassPair :: ID -> String -> IO ID +objc_allocateClassPair super name = callFFI funPtr_objc_allocateClassPair retIdPtr [argPtr super, argString name, argCSize 0] + +objc_registerClassPair :: ID -> IO () +objc_registerClassPair classPtr = callFFI funPtr_objc_registerClassPair retVoid [argPtr classPtr] + +class_addMethod :: ID -> SEL -> FunPtr a -> String -> IO Bool +class_addMethod classPtr methodPtr methodImplPtr types = callFFI funPtr_class_addMethod (fmap c2b retCChar) [argPtr classPtr, argPtr methodPtr, argFunPtr methodImplPtr, argString types] + +ns_log :: [Arg] -> IO () +ns_log = callFFI funPtr_NSLog retVoid + + +class_getInstanceMethod :: Ptr a -> Ptr b -> IO ID +class_getInstanceMethod classPtr selectorPtr = callFFI funPtr_class_getInstanceMethod retIdPtr [argPtr classPtr, argPtr selectorPtr] + + +objc_msgSend_void :: ID -> SEL -> [Arg] -> IO () +objc_msgSend_void objectPtr selPtr args = callFFI funPtr_objc_msgSend retVoid (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_ptr :: ID -> SEL -> [Arg] -> IO (Ptr ()) +objc_msgSend_ptr objectPtr selPtr args = callFFI funPtr_objc_msgSend retVoidPtr (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_obj :: ID -> SEL -> [Arg] -> IO ID +objc_msgSend_obj objectPtr selPtr args = callFFI funPtr_objc_msgSend retIdPtr (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_cint :: ID -> SEL -> [Arg] -> IO CInt +objc_msgSend_cint objectPtr selPtr args = callFFI funPtr_objc_msgSend retCInt (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_cuint :: ID -> SEL -> [Arg] -> IO CUInt +objc_msgSend_cuint objectPtr selPtr args = callFFI funPtr_objc_msgSend retCUInt (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_clong :: ID -> SEL -> [Arg] -> IO CLong +objc_msgSend_clong objectPtr selPtr args = callFFI funPtr_objc_msgSend retCLong (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_culong :: ID -> SEL -> [Arg] -> IO CULong +objc_msgSend_culong objectPtr selPtr args = callFFI funPtr_objc_msgSend retCULong (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_cfloat :: ID -> SEL -> [Arg] -> IO CFloat +objc_msgSend_cfloat objectPtr selPtr args = callFFI funPtr_objc_msgSend retCFloat (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_cdouble :: ID -> SEL -> [Arg] -> IO CDouble +objc_msgSend_cdouble objectPtr selPtr args = callFFI funPtr_objc_msgSend retCDouble (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_cchar :: ID -> SEL -> [Arg] -> IO CChar +objc_msgSend_cchar objectPtr selPtr args = callFFI funPtr_objc_msgSend retCChar (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_cuchar :: ID -> SEL -> [Arg] -> IO CUChar +objc_msgSend_cuchar objectPtr selPtr args = callFFI funPtr_objc_msgSend retCUChar (argPtr objectPtr : argPtr selPtr : args) + +objc_msgSend_cstring :: ID -> SEL -> [Arg] -> IO CString +objc_msgSend_cstring objectPtr selPtr args = callFFI funPtr_objc_msgSend retCString (argPtr objectPtr : argPtr selPtr : args) + + +{- +retCInt :: RetType CInt +retCInt = mkStorableRetType ffi_type_sint +retCUInt :: RetType CUInt +retCUInt = mkStorableRetType ffi_type_uint +retCLong :: RetType CLong +retCLong = mkStorableRetType ffi_type_slong +retCULong :: RetType CULong +retCULong = mkStorableRetType ffi_type_ulong + +retInt :: RetType Int +retInt = mkStorableRetType ffi_type_hs_int +retInt8 :: RetType Int8 +retInt8 = mkStorableRetType ffi_type_sint8 +retInt16 :: RetType Int16 +retInt16 = mkStorableRetType ffi_type_sint16 +retInt32 :: RetType Int32 +retInt32 = mkStorableRetType ffi_type_sint32 +retInt64 :: RetType Int64 +retInt64 = mkStorableRetType ffi_type_sint64 + +retWord :: RetType Word +retWord = mkStorableRetType ffi_type_hs_word +retWord8 :: RetType Word8 +retWord8 = mkStorableRetType ffi_type_uint8 +retWord16 :: RetType Word16 +retWord16 = mkStorableRetType ffi_type_uint16 +retWord32 :: RetType Word32 +retWord32 = mkStorableRetType ffi_type_uint32 +retWord64 :: RetType Word64 +retWord64 = mkStorableRetType ffi_type_uint64 + +retCFloat :: RetType CFloat +retCFloat = mkStorableRetType ffi_type_float +retCDouble :: RetType CDouble +retCDouble = mkStorableRetType ffi_type_double + +retCSize :: RetType CSize +retCSize = mkStorableRetType ffi_type_size +retCTime :: RetType CTime +retCTime = mkStorableRetType ffi_type_time + +retCChar :: RetType CChar +retCChar = mkStorableRetType ffi_type_schar +retCUChar :: RetType CUChar +retCUChar = mkStorableRetType ffi_type_uchar + +retCWchar :: RetType CWchar +retCWchar = mkStorableRetType ffi_type_schar + +retFunPtr :: RetType a -> RetType (FunPtr a) +retFunPtr _ = mkStorableRetType ffi_type_pointer + +retPtr :: RetType a -> RetType (Ptr a) +retPtr _ = mkStorableRetType ffi_type_pointer + +retCString :: RetType CString +retCString = retPtr retCChar +-} diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where + +import qualified Init as Init + +main = Init.main