├── .gitignore ├── LICENSE ├── README.md ├── example ├── .gitignore ├── hs_src │ └── Example.hs ├── rebar.config └── src │ ├── example.app.src │ └── example.erl ├── hs_src └── Foreign │ └── Erlang │ └── Nif.hsc ├── rebar.config └── src ├── hsnif.app.src └── hsnif.erl /.gitignore: -------------------------------------------------------------------------------- 1 | hs_src/Foreign/Erlang/Nif.hs 2 | ebin/ 3 | *.hi 4 | *.o 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (C) 2013 by Sergey Urbanovich 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Hsnif allows to write Erlang NIF libraries in Haskell. 2 | 3 | Intro 4 | ----- 5 | 6 | Hsnif consists of two parts: 7 | 8 | * Rebar plugin that compilates Haskell code to shared library 9 | * Haskell library which is an interface to functions and types of Erlang NIF library 10 | 11 | Rebar plugin 12 | ------------ 13 | 14 | Rebar plugin implements `compile` and `clean` commands. 15 | 16 | To add rebar plugin to a new project, add following lines to rebar.config: 17 | 18 | ```erlang 19 | {deps, [ 20 | {hsnif, ".*", {git, "https://github.com/urbanserj/hsnif.git", "master"}} 21 | ]}. 22 | {plugin_dir, "deps/hsnif/src"}. 23 | {plugins, [hsnif]}. 24 | ``` 25 | 26 | 27 | For specifying Target, Source and Compilation options (the last is optional) these lines need to be added: 28 | 29 | ```erlang 30 | {hsnif_spec, [ 31 | {"priv/target.so", "hs_src/Source.hs", [ 32 | {cflags, ["-O"]}, 33 | {ldflags, []} 34 | ]} 35 | ]}. 36 | ``` 37 | 38 | 39 | Haskell code 40 | ------------ 41 | 42 | All exported from Source file functions will be NIF functions, and each of them should satisfy the following criteria: 43 | 44 | * Each function's argument and return value should be an instance of the class `ErlTerm` (see below) 45 | * First argument is optional, it should be `ErlNifEnv` 46 | 47 | Example: 48 | 49 | ```haskell 50 | id :: ErlNifTerm -> ErlNifTerm 51 | sum :: Int -> Int -> Int 52 | reverse :: ErlNifEnv -> ErlNifTerm -> IO ErlNifTerm 53 | tratata :: ErlNifEnv -> IO ErlNifTerm 54 | ``` 55 | 56 | 57 | Foreign.Erlang.Nif 58 | ------------------ 59 | 60 | This haskell library is a part of hsnif and it is an interface to functions and types of Erlang NIF library. 61 | 62 | To convert between Erlang and Haskell types class `ErlTerm` is used. Instance of the class `ErlTerm` must implement two functions: 63 | `toErlNifTerm` (haskell to erlang term convertation) and `fromErlNifTerm` (vice versa). 64 | 65 | ```haskell 66 | class ErlTerm a where 67 | toErlNifTerm :: ErlNifEnv -> a -> IO ErlNifTerm 68 | fromErlNifTerm :: ErlNifEnv -> ErlNifTerm -> IO a 69 | ``` 70 | 71 | Following instances already exist in the `Foreign.Erlang.Nif` library: 72 | 73 | ```haskell 74 | ErlTerm Char 75 | ErlTerm Double 76 | ErlTerm Int32 77 | ErlTerm Int64 78 | ErlTerm Word32 79 | ErlTerm Word64 80 | ErlTerm () 81 | Integral a => ErlTerm a 82 | ErlTerm CStringLen 83 | ErlTerm CString 84 | ErlTerm ErlAtom 85 | ErlTerm ErlNifBinary 86 | ErlTerm ErlNifTerm 87 | ErlTerm a => ErlTerm [a] 88 | ErlTerm a => ErlTerm (IO a) 89 | ErlTerm a => ErlTerm (ErlTuple a) 90 | ErlTerm (ErlBinary String) 91 | ErlTerm (ErlBinary CStringLen) 92 | (ErlTerm a, ErlTerm b) => ErlTerm (a, b) 93 | (ErlTerm a, ErlTerm b, ErlTerm c) => ErlTerm (a, b, c) 94 | (ErlTerm a, ErlTerm b, ErlTerm c, ErlTerm d) => ErlTerm (a, b, c, d) 95 | ``` 96 | 97 | To create a new instance of the class `ErlTerm` for arbitrary type add an instance for this type to source file. 98 | 99 | Example: 100 | 101 | ```haskell 102 | import Data.ByteString 103 | import Foreign.C.String 104 | 105 | instance ErlTerm (ByteString) where 106 | toErlNifTerm env x = 107 | useAsCStringLen x $ \cstr -> 108 | toErlNifTerm env (ErlBinary cstr) 109 | fromErlNifTerm env x = do 110 | ErlBinary cstr <- fromErlNifTerm env x :: IO (ErlBinary CStringLen) 111 | packCStringLen cstr 112 | ``` 113 | 114 | onLoad and onUnload 115 | ------------------- 116 | 117 | You can specify two optional functions `onLoad` and `onUnload` in the source file. These functions will be called on loading and on unloading the module respectively and should be one of the following types: 118 | 119 | ```haskell 120 | onLoad :: ErlNifEnv -> Ptr (Ptr ()) -> IO ErlNifTerm 121 | onLoad :: ErlNifEnv -> IO ErlNifTerm 122 | onLoad :: Ptr (Ptr ()) -> IO ErlNifTerm 123 | onLoad :: IO ErlNifTerm 124 | 125 | onUnload :: ErlNifEnv -> Ptr () -> IO () 126 | onUnload :: ErlNifEnv -> IO () 127 | onUnload :: Ptr () -> IO () 128 | onUnload :: IO () 129 | ``` 130 | 131 | Look for semantics of these functions in Erlang NIF documentation. 132 | -------------------------------------------------------------------------------- /example/.gitignore: -------------------------------------------------------------------------------- 1 | HsNif*.hs 2 | HsNif*_stub.h 3 | hsnif*.c 4 | -------------------------------------------------------------------------------- /example/hs_src/Example.hs: -------------------------------------------------------------------------------- 1 | module Example where 2 | 3 | import Foreign.Ptr 4 | import Foreign.Erlang.Nif 5 | import Foreign.Marshal.Alloc (alloca) 6 | import Foreign.Storable (peek) 7 | 8 | id :: ErlNifTerm -> ErlNifTerm 9 | id arg = arg 10 | 11 | reverse :: ErlNifEnv -> ErlNifTerm -> IO ErlNifTerm 12 | reverse env arg = alloca $ \ptr -> do 13 | rc <- enif_make_reverse_list env arg ptr 14 | checkCr env rc $ peek ptr 15 | 16 | tratata :: ErlNifEnv -> IO ErlNifTerm 17 | tratata env = enif_priv_data env >>= peek . castPtr 18 | 19 | sum :: Int -> Int -> Int 20 | sum x y = x + y 21 | 22 | onLoad :: ErlNifEnv -> IO ErlNifTerm 23 | onLoad env = toErlNifTerm env "tratata" 24 | 25 | onUnload :: ErlNifEnv -> Ptr () -> IO () 26 | onUnload _ _ = return () 27 | -------------------------------------------------------------------------------- /example/rebar.config: -------------------------------------------------------------------------------- 1 | {deps, [ 2 | {hsnif, ".*", {git, "https://github.com/urbanserj/hsnif.git", "master"}} 3 | ]}. 4 | {plugin_dir, "deps/hsnif/src"}. 5 | {plugins, [hsnif]}. 6 | 7 | {hsnif_spec, [ 8 | {"priv/example.so", "hs_src/Example.hs", [ 9 | {cflags, ["-O"]}, 10 | {ldflags, []} 11 | ]} 12 | ]}. 13 | -------------------------------------------------------------------------------- /example/src/example.app.src: -------------------------------------------------------------------------------- 1 | {application, example, [{vsn, "0.1"}]}. 2 | -------------------------------------------------------------------------------- /example/src/example.erl: -------------------------------------------------------------------------------- 1 | -module(example). 2 | -export([id/1, reverse/1, tratata/0, sum/2]). 3 | 4 | -on_load(on_load/0). 5 | 6 | -define(NIF_ERROR, erlang:nif_error({not_loaded, [{module, ?MODULE}, {line, ?LINE}]})). 7 | 8 | on_load() -> 9 | BaseDir = case code:priv_dir(?MODULE) of 10 | {error, bad_name} -> 11 | filename:join( [ filename:dirname( code:which(?MODULE) ), "..", "priv" ] ); 12 | Dir -> 13 | Dir 14 | end, 15 | SoName = filename:join(BaseDir, atom_to_list(?MODULE)), 16 | erlang:load_nif(SoName, 0). 17 | 18 | -spec id(A) -> A when A :: any(). 19 | id(_) -> 20 | ?NIF_ERROR. 21 | 22 | -spec reverse(list()) -> list(). 23 | reverse(_) -> 24 | ?NIF_ERROR. 25 | 26 | -spec tratata() -> string(). 27 | tratata() -> 28 | ?NIF_ERROR. 29 | 30 | -spec sum(integer(), integer()) -> integer(). 31 | sum(_, _) -> 32 | ?NIF_ERROR. 33 | -------------------------------------------------------------------------------- /hs_src/Foreign/Erlang/Nif.hsc: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | ForeignFunctionInterface, GeneralizedNewtypeDeriving, FlexibleInstances, 3 | UndecidableInstances, OverlappingInstances, TemplateHaskell #-} 4 | 5 | module Foreign.Erlang.Nif where 6 | 7 | import Data.Word 8 | import Data.Int 9 | import Foreign.C.Types 10 | import Foreign.Ptr 11 | import Foreign.Storable 12 | import Foreign.C.String 13 | import Foreign.Marshal.Array 14 | import Foreign.Marshal.Alloc 15 | 16 | #include 17 | #include 18 | 19 | newtype ErlNifTerm = ErlNifTerm #{type ERL_NIF_TERM} 20 | deriving (Storable) 21 | newtype ErlNifEnv = ErlNifEnv (Ptr ()) 22 | newtype ErlNifPid = ErlNifPid (Ptr ()) 23 | newtype ErlNifBinary = ErlNifBinary (Ptr ()) 24 | newtype ErlAtom = ErlAtom String deriving (Eq, Show) 25 | newtype ErlBinary a = ErlBinary a 26 | newtype ErlTuple a = ErlTuple [a] deriving (Eq, Show) 27 | 28 | type ErlNifCharEncoding = #{type int} 29 | #{enum ErlNifCharEncoding, , erl_nif_latin1=ERL_NIF_LATIN1} 30 | 31 | data ErlNifSysInfo = ErlNifSysInfo { 32 | driver_major_version :: Int, 33 | driver_minor_version :: Int, 34 | erts_version :: String, 35 | otp_release :: String, 36 | thread_support :: Bool, 37 | smp_support :: Bool, 38 | async_threads :: Int, 39 | scheduler_threads :: Int, 40 | nif_major_version :: Int, 41 | nif_minor_version :: Int 42 | } deriving (Show) 43 | 44 | 45 | foreign import ccall unsafe enif_priv_data :: ErlNifEnv -> IO (Ptr ()) 46 | foreign import ccall unsafe enif_alloc :: #{type size_t} -> IO (Ptr ()) 47 | foreign import ccall unsafe enif_free :: Ptr () -> IO () 48 | foreign import ccall unsafe enif_is_atom :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 49 | foreign import ccall unsafe enif_is_binary :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 50 | foreign import ccall unsafe enif_is_ref :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 51 | foreign import ccall unsafe enif_inspect_binary :: ErlNifEnv -> ErlNifTerm -> ErlNifBinary -> IO #{type int} 52 | foreign import ccall unsafe enif_alloc_binary :: #{type size_t} -> ErlNifBinary -> IO #{type int} 53 | foreign import ccall unsafe enif_realloc_binary :: ErlNifBinary -> #{type size_t} -> IO #{type int} 54 | foreign import ccall unsafe enif_release_binary :: ErlNifBinary -> IO () 55 | foreign import ccall unsafe enif_get_int :: ErlNifEnv -> ErlNifTerm -> Ptr (#type int) -> IO #{type int} 56 | foreign import ccall unsafe enif_get_ulong :: ErlNifEnv -> ErlNifTerm -> Ptr (#type unsigned long) -> IO #{type int} 57 | foreign import ccall unsafe enif_get_double :: ErlNifEnv -> ErlNifTerm -> Ptr (#type double) -> IO #{type int} 58 | foreign import ccall unsafe enif_get_list_cell :: ErlNifEnv -> ErlNifTerm -> Ptr (ErlNifTerm) -> Ptr (ErlNifTerm) -> IO #{type int} 59 | foreign import ccall unsafe enif_get_tuple :: ErlNifEnv -> ErlNifTerm -> Ptr (#type int) -> Ptr (Ptr ErlNifTerm) -> IO #{type int} 60 | foreign import ccall unsafe enif_is_identical :: ErlNifTerm -> ErlNifTerm -> IO #{type int} 61 | foreign import ccall unsafe enif_compare :: ErlNifTerm -> ErlNifTerm -> IO #{type int} 62 | foreign import ccall unsafe enif_make_binary :: ErlNifEnv -> ErlNifBinary -> IO ErlNifTerm 63 | foreign import ccall unsafe enif_make_badarg :: ErlNifEnv -> IO ErlNifTerm 64 | foreign import ccall unsafe enif_make_int :: ErlNifEnv -> #{type int} -> IO ErlNifTerm 65 | foreign import ccall unsafe enif_make_ulong :: ErlNifEnv -> #{type unsigned long} -> IO ErlNifTerm 66 | foreign import ccall unsafe enif_make_double :: ErlNifEnv -> #{type double} -> IO ErlNifTerm 67 | foreign import ccall unsafe enif_make_atom :: ErlNifEnv -> CString -> IO ErlNifTerm 68 | foreign import ccall unsafe enif_make_existing_atom :: ErlNifEnv -> CString -> Ptr ErlNifTerm -> IO #{type int} 69 | foreign import ccall unsafe enif_make_list_cell :: ErlNifEnv -> ErlNifTerm -> ErlNifTerm -> IO ErlNifTerm 70 | foreign import ccall unsafe enif_make_string :: ErlNifEnv -> CString -> ErlNifCharEncoding -> IO ErlNifTerm 71 | foreign import ccall unsafe enif_make_ref :: ErlNifEnv -> IO ErlNifTerm 72 | foreign import ccall unsafe enif_realloc :: Ptr () -> #{type size_t} -> IO (Ptr ()) 73 | foreign import ccall unsafe enif_system_info :: Ptr ErlNifSysInfo -> #{type size_t} -> IO () 74 | foreign import ccall unsafe enif_inspect_iolist_as_binary :: ErlNifEnv -> ErlNifTerm -> ErlNifBinary -> IO #{type int} 75 | foreign import ccall unsafe enif_make_sub_binary :: ErlNifEnv -> ErlNifTerm -> #{type size_t} -> #{type size_t} -> IO ErlNifTerm 76 | foreign import ccall unsafe enif_get_string :: ErlNifEnv -> ErlNifTerm -> CString -> #{type unsigned} -> ErlNifCharEncoding -> IO #{type int} 77 | foreign import ccall unsafe enif_get_atom :: ErlNifEnv -> ErlNifTerm -> CString -> #{type unsigned} -> ErlNifCharEncoding -> IO #{type int} 78 | foreign import ccall unsafe enif_is_fun :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 79 | foreign import ccall unsafe enif_is_pid :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 80 | foreign import ccall unsafe enif_is_port :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 81 | foreign import ccall unsafe enif_get_uint :: ErlNifEnv -> ErlNifTerm -> Ptr (#type unsigned) -> IO #{type int}; 82 | foreign import ccall unsafe enif_get_long :: ErlNifEnv -> ErlNifTerm -> Ptr (#type long) -> IO #{type int}; 83 | foreign import ccall unsafe enif_make_uint :: ErlNifEnv -> #{type unsigned} -> IO ErlNifTerm 84 | foreign import ccall unsafe enif_make_long :: ErlNifEnv -> #{type long} -> IO ErlNifTerm 85 | foreign import ccall unsafe enif_make_tuple_from_array :: ErlNifEnv -> Ptr ErlNifTerm -> #{type unsigned} -> IO ErlNifTerm 86 | foreign import ccall unsafe enif_make_list_from_array :: ErlNifEnv -> Ptr ErlNifTerm -> #{type unsigned} -> IO ErlNifTerm 87 | foreign import ccall unsafe enif_is_empty_list :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 88 | -- ERL_NIF_API_FUNC_DECL(ErlNifResourceType*,enif_open_resource_type,(ErlNifEnv*, const char* module_str, const char* name_str, void (*dtor)(ErlNifEnv*,void *), ErlNifResourceFlags flags, ErlNifResourceFlags* tried)); 89 | -- ERL_NIF_API_FUNC_DECL(void*,enif_alloc_resource,(ErlNifResourceType* type, size_t size)); 90 | -- ERL_NIF_API_FUNC_DECL(void,enif_release_resource,(void* obj)); 91 | -- ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_resource,(ErlNifEnv*, void* obj)); 92 | -- ERL_NIF_API_FUNC_DECL(int,enif_get_resource,(ErlNifEnv*, ERL_NIF_TERM term, ErlNifResourceType* type, void** objp)); 93 | -- ERL_NIF_API_FUNC_DECL(size_t,enif_sizeof_resource,(void* obj)); 94 | -- ERL_NIF_API_FUNC_DECL(void,enif_keep_resource,(void* obj)); 95 | -- ERL_NIF_API_FUNC_DECL(ERL_NIF_TERM,enif_make_resource_binary,(ErlNifEnv*,void* obj,const void* data, size_t size)); 96 | foreign import ccall unsafe enif_make_new_binary :: ErlNifEnv -> #{type size_t} -> Ptr ErlNifTerm -> IO (Ptr #{type unsigned char}) 97 | foreign import ccall unsafe enif_is_list :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 98 | foreign import ccall unsafe enif_is_tuple :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 99 | foreign import ccall unsafe enif_get_atom_length :: ErlNifEnv -> ErlNifTerm -> Ptr #{type unsigned} -> ErlNifCharEncoding -> IO #{type int} 100 | foreign import ccall unsafe enif_get_list_length :: ErlNifEnv -> ErlNifTerm -> Ptr #{type unsigned} -> IO #{type int} 101 | foreign import ccall unsafe enif_make_atom_len :: ErlNifEnv -> CString -> #{type size_t} -> IO ErlNifTerm 102 | foreign import ccall unsafe enif_make_existing_atom_len :: ErlNifEnv -> CString -> #{type size_t} -> Ptr ErlNifTerm -> ErlNifCharEncoding -> IO #{type int} 103 | foreign import ccall unsafe enif_make_string_len :: ErlNifEnv -> CString -> #{type size_t} -> ErlNifCharEncoding -> IO ErlNifTerm 104 | foreign import ccall unsafe enif_alloc_env :: IO ErlNifEnv 105 | foreign import ccall unsafe enif_free_env :: ErlNifEnv -> IO () 106 | foreign import ccall unsafe enif_clear_env :: ErlNifEnv -> IO () 107 | foreign import ccall unsafe enif_send :: ErlNifEnv -> ErlNifPid -> ErlNifEnv -> ErlNifTerm -> IO #{type int} 108 | foreign import ccall unsafe enif_make_copy :: ErlNifEnv -> ErlNifTerm -> IO ErlNifEnv 109 | foreign import ccall unsafe enif_self :: ErlNifEnv -> ErlNifPid -> IO (ErlNifPid) 110 | foreign import ccall unsafe enif_get_local_pid:: ErlNifEnv -> ErlNifTerm -> ErlNifPid -> IO #{type int} 111 | #if SIZEOF_LONG != 8 112 | foreign import ccall unsafe enif_get_int64 :: ErlNifEnv -> ErlNifTerm -> Ptr #{type ErlNifSInt64} -> IO #{type int} 113 | foreign import ccall unsafe enif_get_uint64 :: ErlNifEnv -> ErlNifTerm -> Ptr #{type ErlNifUInt64} -> IO #{type int} 114 | foreign import ccall unsafe enif_make_int64 :: ErlNifEnv -> #{type ErlNifSInt64} -> IO ErlNifTerm 115 | foreign import ccall unsafe enif_make_uint64 :: ErlNifEnv -> #{type ErlNifUInt64} -> IO ErlNifTerm 116 | #endif 117 | foreign import ccall unsafe enif_is_exception :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 118 | foreign import ccall unsafe enif_make_reverse_list :: ErlNifEnv -> ErlNifTerm -> Ptr ErlNifTerm -> IO #{type int} 119 | foreign import ccall unsafe enif_is_number :: ErlNifEnv -> ErlNifTerm -> IO #{type int} 120 | #if ERL_NIF_MAJOR_VERSION >= 2 && ERL_NIF_MINOR_VERSION >=4 121 | foreign import ccall unsafe enif_consume_timeslice :: ErlNifEnv -> #{type int} -> IO #{type int} 122 | #endif 123 | 124 | 125 | class ErlTerm a where 126 | toErlNifTerm :: ErlNifEnv -> a -> IO ErlNifTerm 127 | fromErlNifTerm :: ErlNifEnv -> ErlNifTerm -> IO a 128 | 129 | instance (ErlTerm a) => ErlTerm (IO a) where 130 | toErlNifTerm env x = x >>= toErlNifTerm env 131 | fromErlNifTerm = undefined 132 | 133 | 134 | instance ErlTerm ErlNifTerm where 135 | toErlNifTerm _ x = return x 136 | fromErlNifTerm _ x = return x 137 | 138 | instance ErlTerm #{type int} where 139 | toErlNifTerm = enif_make_int 140 | fromErlNifTerm env x = alloca $ \ptr -> do 141 | ret <- enif_get_int env x ptr 142 | checkRc ret $ peek ptr 143 | 144 | instance ErlTerm #{type uint} where 145 | toErlNifTerm = enif_make_uint 146 | fromErlNifTerm env x = alloca $ \ptr -> do 147 | ret <- enif_get_uint env x ptr 148 | checkRc ret $ peek ptr 149 | 150 | #if SIZEOF_INT != SIZEOF_LONG 151 | instance ErlTerm #{type long} where 152 | toErlNifTerm = enif_make_long 153 | fromErlNifTerm env x = alloca $ \ptr -> do 154 | ret <- enif_get_long env x ptr 155 | checkRc ret $ peek ptr 156 | 157 | instance ErlTerm #{type unsigned long} where 158 | toErlNifTerm = enif_make_ulong 159 | fromErlNifTerm env x = alloca $ \ptr -> do 160 | ret <- enif_get_ulong env x ptr 161 | checkRc ret $ peek ptr 162 | #endif 163 | 164 | instance ErlTerm #{type double} where 165 | toErlNifTerm = enif_make_double 166 | fromErlNifTerm env x = alloca $ \ptr -> do 167 | ret <- enif_get_double env x ptr 168 | checkRc ret $ peek ptr 169 | 170 | #if SIZEOF_LONG != 8 171 | instance ErlTerm #{type ErlNifSInt64} where 172 | toErlNifTerm = enif_make_int64 173 | fromErlNifTerm env x = alloca $ \ptr -> do 174 | ret <- enif_get_int64 env x ptr 175 | checkRc ret $ peek ptr 176 | 177 | instance ErlTerm #{type ErlNifUInt64} where 178 | toErlNifTerm = enif_make_uint64 179 | fromErlNifTerm env x = alloca $ \ptr -> do 180 | ret <- enif_get_uint64 env x ptr 181 | checkRc ret $ peek ptr 182 | #endif 183 | 184 | instance (Integral a) => ErlTerm a where 185 | toErlNifTerm env x 186 | #if SIZEOF_IMT != 4 187 | | toInteger x >= toInteger (minBound::Int32) && toInteger x <= toInteger (maxBound::Int32) 188 | = toErlNifTerm env (fromIntegral x :: Int32) 189 | #endif 190 | | toInteger x >= toInteger (minBound::Int64) && toInteger x <= toInteger (maxBound::Int64) 191 | = toErlNifTerm env (fromIntegral x :: Int64) 192 | | otherwise 193 | = enif_make_badarg env 194 | fromErlNifTerm env x = fmap fromIntegral (fromErlNifTerm env x :: IO Int64) 195 | 196 | 197 | instance ErlTerm CStringLen where 198 | toErlNifTerm env (str, len) = enif_make_string_len env str (fromIntegral len) erl_nif_latin1 199 | fromErlNifTerm env x = 200 | let size = 4096 in 201 | allocaBytes size $ \pbuf -> do 202 | rc <- enif_get_string env x pbuf (fromIntegral size) erl_nif_latin1 203 | checkRc rc $ if rc > 0 204 | then return (pbuf, fromIntegral rc) 205 | else (fromErlNifTerm env x :: IO String) >>= newCStringLen >>= \(str, len) -> return (str, len-1) 206 | 207 | 208 | instance ErlTerm CString where 209 | toErlNifTerm env x = enif_make_string env x erl_nif_latin1 210 | fromErlNifTerm env x = do 211 | (str, size) <- fromErlNifTerm env x :: IO CStringLen 212 | checkNullTermination str size 213 | return str 214 | where 215 | checkNullTermination :: CString -> Int -> IO Int 216 | checkNullTermination _ (-1) = return 1 217 | checkNullTermination str size = do 218 | ch <- peekElemOff str size 219 | checkRc ch $ checkNullTermination str (size - 1) 220 | 221 | 222 | instance ErlTerm Char where 223 | toErlNifTerm env x = toErlNifTerm env (fromEnum x) 224 | fromErlNifTerm env x = fmap toEnum (fromErlNifTerm env x :: IO Int) 225 | 226 | 227 | instance (ErlTerm a) => ErlTerm [a] where 228 | toErlNifTerm env xs = do 229 | ys <- mapM (toErlNifTerm env) xs 230 | withArrayLen ys $ \cnt ptr -> 231 | enif_make_list_from_array env ptr (fromIntegral cnt) 232 | fromErlNifTerm env xs = do 233 | rc <- enif_is_list env xs 234 | checkRc rc $ enif_get_list_loop env xs [] >>= 235 | mapM (fromErlNifTerm env) >>= return . reverse 236 | where 237 | enif_get_list_loop :: ErlNifEnv -> ErlNifTerm -> [ErlNifTerm] -> IO [ErlNifTerm] 238 | enif_get_list_loop env xs acc = 239 | alloca $ \phead -> alloca $ \ptail -> do 240 | rc <- enif_get_list_cell env xs phead ptail 241 | if rc == 0 242 | then return acc 243 | else do 244 | head <- peek phead 245 | tail <- peek ptail 246 | enif_get_list_loop env tail (head : acc) 247 | 248 | 249 | instance (ErlTerm a) => ErlTerm (ErlTuple a) where 250 | toErlNifTerm env (ErlTuple xs) = do 251 | ys <- mapM (toErlNifTerm env) xs 252 | withArrayLen ys $ \cnt ptr -> 253 | enif_make_tuple_from_array env ptr (fromIntegral cnt) 254 | fromErlNifTerm env x = do 255 | alloca $ \parity -> 256 | allocaBytes (#size ERL_NIF_TERM*) $ \parray -> do 257 | ret <- enif_get_tuple env x parity parray 258 | checkRc ret $ do 259 | arity <- peek parity; array <- peek parray 260 | xs <- peekArray (fromIntegral arity) array 261 | ys <- mapM (fromErlNifTerm env) xs 262 | return $ ErlTuple ys 263 | 264 | instance ErlTerm () where 265 | toErlNifTerm env () = toErlNifTerm env $ (ErlTuple [] :: ErlTuple ErlNifTerm) 266 | fromErlNifTerm env x = do 267 | xs <- (fromErlNifTerm env x :: IO (ErlTuple ErlNifTerm)) 268 | let ErlTuple ys = xs 269 | checkRt (length ys == 0) $ return () 270 | 271 | instance (ErlTerm a, ErlTerm b) => ErlTerm (a, b) where 272 | toErlNifTerm env (a0, a1) = do 273 | sequence [toErlNifTerm env a0, toErlNifTerm env a1] >>= \t -> 274 | toErlNifTerm env $ ErlTuple t 275 | fromErlNifTerm env x = do 276 | xs <- (fromErlNifTerm env x :: IO (ErlTuple ErlNifTerm)) 277 | let ErlTuple ys = xs 278 | checkRt (length ys == 2) $ do 279 | let (a0:a1:[]) = ys 280 | b0 <- fromErlNifTerm env a0 281 | b1 <- fromErlNifTerm env a1 282 | return (b0, b1) 283 | 284 | instance (ErlTerm a, ErlTerm b, ErlTerm c) => ErlTerm (a, b, c) where 285 | toErlNifTerm env (a0, a1, a2) = 286 | sequence 287 | [toErlNifTerm env a0, toErlNifTerm env a1, toErlNifTerm env a2] >>= \t -> 288 | toErlNifTerm env $ ErlTuple t 289 | fromErlNifTerm env x = do 290 | xs <- (fromErlNifTerm env x :: IO (ErlTuple ErlNifTerm)) 291 | let ErlTuple ys = xs 292 | checkRt (length ys == 3) $ do 293 | let (a0:a1:a2:[]) = ys 294 | b0 <- fromErlNifTerm env a0 295 | b1 <- fromErlNifTerm env a1 296 | b2 <- fromErlNifTerm env a2 297 | return (b0, b1, b2) 298 | 299 | instance (ErlTerm a, ErlTerm b, ErlTerm c, ErlTerm d) => ErlTerm (a, b, c, d) where 300 | toErlNifTerm env (a0, a1, a2, a3) = 301 | sequence 302 | [toErlNifTerm env a0, toErlNifTerm env a1, 303 | toErlNifTerm env a2, toErlNifTerm env a3] >>= \t -> 304 | toErlNifTerm env $ ErlTuple t 305 | fromErlNifTerm env x = do 306 | xs <- (fromErlNifTerm env x :: IO (ErlTuple ErlNifTerm)) 307 | let ErlTuple ys = xs 308 | checkRt (length ys == 3) $ do 309 | let (a0:a1:a2:a3:[]) = ys 310 | b0 <- fromErlNifTerm env a0 311 | b1 <- fromErlNifTerm env a1 312 | b2 <- fromErlNifTerm env a2 313 | b3 <- fromErlNifTerm env a3 314 | return (b0, b1, b2, b3) 315 | 316 | 317 | instance ErlTerm ErlAtom where 318 | toErlNifTerm env (ErlAtom str) = withCAStringLen str $ 319 | \(pstr, len) -> enif_make_atom_len env pstr $ fromIntegral len 320 | fromErlNifTerm env x = do 321 | len <- alloca $ \plen -> do 322 | ret <- enif_get_atom_length env x plen erl_nif_latin1 323 | checkRc ret $ peek plen 324 | allocaBytes (fromIntegral $ len + 1) $ \ptr -> do 325 | ret <- enif_get_atom env x ptr len erl_nif_latin1 326 | checkRc ret $ do 327 | atom <- peekCString ptr 328 | return $ ErlAtom atom 329 | 330 | 331 | withErlNifBinary :: ErlNifBinary -> (CStringLen -> IO a) -> IO a 332 | withErlNifBinary (ErlNifBinary ptr) func = do 333 | bin_size <- (#peek ErlNifBinary, size) ptr 334 | bin_data <- (#peek ErlNifBinary, data) ptr 335 | func (bin_data, fromIntegral (bin_size :: #{type size_t})) 336 | 337 | allocaErlNifBinary :: (ErlNifBinary -> IO a) -> IO a 338 | allocaErlNifBinary func = allocaBytes (#size ErlNifBinary) $ func . ErlNifBinary 339 | 340 | 341 | instance ErlTerm ErlNifBinary where 342 | toErlNifTerm = enif_make_binary 343 | fromErlNifTerm env x = 344 | allocaErlNifBinary $ \bin -> do 345 | rc <- enif_inspect_iolist_as_binary env x bin 346 | checkRc rc $ return bin 347 | 348 | 349 | instance ErlTerm (ErlBinary CStringLen) where 350 | toErlNifTerm env (ErlBinary (pstr, len)) = 351 | allocaErlNifBinary $ \bin -> do 352 | rc <- enif_alloc_binary (fromIntegral len) bin 353 | checkCr env rc $ do 354 | withErlNifBinary bin $ \(bin_data, _) -> do 355 | copyArray bin_data pstr len 356 | toErlNifTerm env bin 357 | fromErlNifTerm env x = do 358 | bin <- fromErlNifTerm env x :: IO (ErlNifBinary) 359 | withErlNifBinary bin $ return . ErlBinary 360 | 361 | 362 | instance ErlTerm (ErlBinary String) where 363 | toErlNifTerm env (ErlBinary str) = 364 | withCAStringLen str $ toErlNifTerm env . ErlBinary 365 | fromErlNifTerm env x = do 366 | (ErlBinary cstr) <- (fromErlNifTerm env x :: IO (ErlBinary CStringLen)) 367 | peekCAStringLen cstr >>= return . ErlBinary 368 | 369 | 370 | instance Storable ErlNifSysInfo where 371 | alignment _ = alignment (undefined :: CDouble) 372 | sizeOf _ = #size ErlNifSysInfo 373 | peek ptr = do 374 | driver_major_version <- (#peek ErlNifSysInfo, driver_major_version) ptr :: IO #{type int} 375 | driver_minor_version <- (#peek ErlNifSysInfo, driver_minor_version) ptr :: IO #{type int} 376 | erts_version <- (#peek ErlNifSysInfo, erts_version) ptr >>= peekCString 377 | otp_release <- (#peek ErlNifSysInfo, otp_release) ptr >>= peekCString 378 | thread_support <- (#peek ErlNifSysInfo, thread_support) ptr :: IO #{type int} 379 | smp_support <- (#peek ErlNifSysInfo, smp_support) ptr :: IO #{type int} 380 | async_threads <- (#peek ErlNifSysInfo, async_threads) ptr :: IO #{type int} 381 | scheduler_threads <- (#peek ErlNifSysInfo, scheduler_threads) ptr :: IO #{type int} 382 | nif_major_version <- (#peek ErlNifSysInfo, nif_major_version) ptr :: IO #{type int} 383 | nif_minor_version <- (#peek ErlNifSysInfo, nif_minor_version) ptr :: IO #{type int} 384 | return $ ErlNifSysInfo 385 | (fromIntegral driver_major_version) 386 | (fromIntegral driver_minor_version) 387 | erts_version 388 | otp_release 389 | (thread_support /= 0) 390 | (smp_support /= 0) 391 | (fromIntegral async_threads) 392 | (fromIntegral scheduler_threads) 393 | (fromIntegral nif_major_version) 394 | (fromIntegral nif_minor_version) 395 | poke = undefined 396 | 397 | getErlNifSysInfo :: IO ErlNifSysInfo 398 | getErlNifSysInfo = alloca $ \ptr -> 399 | enif_system_info ptr #{size ErlNifSysInfo} >> peek ptr 400 | 401 | 402 | checkRc :: (Num a, Eq a) => a -> b -> b 403 | checkRc 0 _ = error "" 404 | checkRc _ x = x 405 | 406 | checkCr :: ErlNifEnv -> #{type int} -> IO ErlNifTerm -> IO ErlNifTerm 407 | checkCr env 0 _ = enif_make_badarg env 408 | checkCr _ _ x = x 409 | 410 | checkRt :: Bool -> b -> b 411 | checkRt True x = x 412 | checkRt False x = checkRc 0 x 413 | 414 | -- ex: ft=haskell 415 | -------------------------------------------------------------------------------- /rebar.config: -------------------------------------------------------------------------------- 1 | {plugin_dir, "src"}. 2 | {plugins, [hsnif]}. 3 | -------------------------------------------------------------------------------- /src/hsnif.app.src: -------------------------------------------------------------------------------- 1 | {application, hsnif, [{vsn, "0.1.1"}]}. 2 | -------------------------------------------------------------------------------- /src/hsnif.erl: -------------------------------------------------------------------------------- 1 | -module(hsnif). 2 | -export([compile/2, clean/2]). 3 | 4 | -include_lib("kernel/include/file.hrl"). 5 | 6 | -type funspec() :: {string(), non_neg_integer(), boolean()}. 7 | 8 | compile(Config, _AppFile) -> 9 | Specs = rebar_config:get_local(Config, hsnif_spec, []), 10 | lists:foreach(fun build/1, Specs). 11 | 12 | 13 | clean(Config, _AppFile) -> 14 | Specs = rebar_config:get_local(Config, hsnif_spec, []), 15 | [ begin 16 | Target = element(1, Spec), 17 | Source = element(2, Spec), 18 | HsDir = filename:dirname(Source), 19 | SourceModule = hs_module_name(Source), 20 | TempFiles = [ filename:join(HsDir, File) || File <- [ 21 | "HsNif" ++ SourceModule ++ ".hs", 22 | "HsNif" ++ SourceModule ++ "_stub.h", 23 | "hsnif" ++ string:to_lower(SourceModule) ++ ".c" 24 | ] ], 25 | [ file:delete(File) || File <- find(HsDir, ["*.o", "*.hi"]) ], 26 | [ file:delete(File) || File <- TempFiles ], 27 | file:delete(Target) 28 | end || Spec <- Specs ], 29 | [ file:delete( filename:rootname(File) ++ ".hs" ) 30 | || File <- find("hs_src", ["*.hsc"]) ], 31 | [ file:delete(File) || File <- 32 | find("hs_src", ["*.o", "*.hi", "*_stub.h"]) ], 33 | ok. 34 | 35 | 36 | -spec build({file:name(), file:name()} | 37 | {file:name(), file:name(), list()}) -> ok. 38 | build({Target, Source}) -> 39 | build({Target, Source, []}); 40 | build({Target, Source, Opts}) -> 41 | try 42 | {ok, SourceFI} = file:read_file_info(Source), 43 | {ok, TargetFI} = file:read_file_info(Target), 44 | case TargetFI#file_info.mtime =:= SourceFI#file_info.mtime of 45 | true -> rebar_log:log(info, "Skipped ~s~n", [Source]) 46 | end 47 | catch 48 | _:_ -> do_build(Target, Source, Opts) 49 | end. 50 | 51 | -spec do_build(file:name(), file:name(), list()) -> ok. 52 | do_build(Target, Source, Opts) -> 53 | PluginDir = filename:dirname(filename:dirname(code:which(?MODULE))), 54 | PluginHsDir = filename:join(PluginDir, "hs_src") ++ "/", 55 | [ command(["hsc2hs", File]) || File <- find(PluginHsDir, ["*.hsc"]) ], 56 | GhcOpts = ["-i" ++ PluginHsDir], 57 | CFlags = GhcOpts ++ proplists:get_value(cflags, Opts, []), 58 | LDFlags = CFlags ++ proplists:get_value(ldflags, Opts, []), 59 | 60 | command(["ghc", Source | CFlags]), 61 | Exports = export_funs(Source, GhcOpts), 62 | rebar_log:log(info, "export: ~s~n", [ 63 | string:join([Fun || {Fun,_,_} <- Exports], ", ") 64 | ]), 65 | 66 | FFIModuleFile = hs_module(Source, Exports), 67 | CModuleFile = c_module(Source, Target, Exports), 68 | 69 | TargetDir = filename:dirname(Target), 70 | file:make_dir(TargetDir), 71 | command(["ghc", "--make", CModuleFile, FFIModuleFile, Source, 72 | "-shared", "-lHSrts", "-lffi", "-o", Target | LDFlags]), 73 | {ok, SourceFileInfo} = file:read_file_info(Source), 74 | file:write_file_info(Target, 75 | #file_info{mtime=SourceFileInfo#file_info.mtime}), 76 | io:format("Compiled ~s~n", [Source]). 77 | 78 | 79 | -spec export_funs(file:name(), [string()]) -> [funspec()]. 80 | export_funs(Source, GhcOpts) -> 81 | QSource = lists:flatten( io_lib:format("~p", [Source]) ), 82 | SourceModule = hs_module_name(Source), 83 | SourceExportRaw = command(["ghc", 84 | "-e", ":load " ++ QSource, 85 | "-e", ":browse " ++ SourceModule 86 | | GhcOpts]), 87 | SourceExportList = lists:foldl( 88 | fun(" " ++ _ = Str, Acc) -> 89 | [hd(Acc) ++ Str|tl(Acc)]; 90 | (Str, Acc) -> 91 | [Str|Acc] end, 92 | [], string:tokens(SourceExportRaw, "\n")), 93 | FT = [ {function_name(F, SourceModule), Type} || X <- SourceExportList, 94 | [F, Type] <- [re:split(X, "\s*::\s*", [{return, list}, {parts,2}])], 95 | lists:member($ , F) =:= false ], 96 | TypesInfo = command(["ghc", "-XTemplateHaskell", 97 | "-e", ":load " ++ QSource, 98 | "-e", "import Foreign.Erlang.Nif", 99 | "-e", "import Language.Haskell.TH", 100 | "-e", "import Language.Haskell.TH.Syntax", 101 | "-e", "let 102 | count ((ArrowT `AppT` x) `AppT` y) = 1 + count y; 103 | count (ForallT _ _ x) = count x; 104 | count _ = 0 105 | ", "-e", "let 106 | first ((ArrowT `AppT` x) `AppT` _) = x; 107 | first (ForallT _ _ x) = first x; 108 | first x = x 109 | ", "-e", "let info x = do 110 | t <- runQ x; 111 | e <- runQ [t| Foreign.Erlang.Nif.ErlNifEnv |]; 112 | Prelude.putStr . show $ e == first t; 113 | Prelude.putStr \" \"; 114 | Prelude.putStrLn . show $ count t 115 | ", "-e", " 116 | " ++ listjoin(["info [t| " ++ Type ++ " |]" || {_F, Type} <- FT], 117 | " >> 118 | ") 119 | | GhcOpts]), 120 | [ case Info of 121 | "True " ++ Arity -> {Fun, list_to_integer(Arity) - 1, true}; 122 | "False " ++ Arity -> {Fun, list_to_integer(Arity), false} 123 | end || {Info, Fun} <- lists:zip( 124 | string:tokens(TypesInfo, "\n"), 125 | [element(1, X) || X <- FT] 126 | ) ]. 127 | 128 | 129 | -spec hs_module(file:name(), funspec()) -> file:name(). 130 | hs_module(Source, Exports) -> 131 | SourceModule = hs_module_name(Source), 132 | FunPrefix = "hsnif" ++ string:to_lower(SourceModule), 133 | FFIModule = "HsNif" ++ SourceModule, 134 | FFIModuleText = [ " 135 | {-# LANGUAGE ForeignFunctionInterface #-} 136 | 137 | module ", FFIModule, " where 138 | 139 | import Foreign.Ptr 140 | import Foreign.C.Types 141 | import Foreign.Storable 142 | import Foreign.Erlang.Nif 143 | import Foreign.Marshal.Alloc 144 | import Control.Exception as C 145 | import qualified ", SourceModule, " 146 | 147 | exhandler :: ErlNifEnv -> SomeException -> IO ErlNifTerm 148 | exhandler env _ = enif_make_badarg env 149 | 150 | ", 151 | [ hs_fun(SourceModule, FunPrefix, {Fun, Arity, Env}) 152 | || {Fun, Arity, Env} <- Exports, 153 | Fun =/= "onLoad", Fun =/= "onUnload" ], 154 | 155 | case lists:keyfind("onLoad", 1, Exports) of 156 | false -> []; 157 | Spec -> hs_onload(SourceModule, FunPrefix, Spec) 158 | end, 159 | case lists:keyfind("onUnload", 1, Exports) of 160 | false -> []; 161 | Spec -> hs_onunload(SourceModule, FunPrefix, Spec) 162 | end 163 | ], 164 | HsDir = filename:dirname(Source), 165 | FFIModuleFile = filename:join(HsDir, FFIModule ++ ".hs"), 166 | ok = file:write_file(FFIModuleFile, FFIModuleText), 167 | FFIModuleFile. 168 | 169 | 170 | -spec c_module(file:name(), file:name(), [funspec()]) -> file:name(). 171 | c_module(Source, Target, Exports) -> 172 | SourceModule = hs_module_name(Source), 173 | FunPrefix = "hsnif" ++ string:to_lower(SourceModule), 174 | QTarget = io_lib:format("~p", [Target]), 175 | MTarget = filename:basename(Target, ".so"), 176 | CModuleText = [" 177 | #include 178 | #include 179 | ", 180 | [ ["extern ERL_NIF_TERM ", FunPrefix, Fun, 181 | "(ErlNifEnv*, int, const ERL_NIF_TERM*);", "\n"] 182 | || {Fun, _Arity, _Env} <- Exports, 183 | Fun =/= "onLoad", Fun =/= "onUnload" ], 184 | case lists:keyfind("onLoad", 1, Exports) of 185 | false -> ""; 186 | _True -> ["extern int ", FunPrefix, "OnLoad(ErlNifEnv*, void**, ERL_NIF_TERM);\n"] 187 | end, 188 | case lists:keyfind("onUnload", 1, Exports) of 189 | false -> ""; 190 | _True -> ["extern void ", FunPrefix, "OnUnload(ErlNifEnv*, void*);\n"] 191 | end, " 192 | 193 | int load(ErlNifEnv* env, void** priv_data, ERL_NIF_TERM load_info) { 194 | static char *argv[] = { ", QTarget, ", NULL }, **argv_ = argv; 195 | static int argc = 1; 196 | hs_init(&argc, &argv_); 197 | ", 198 | case lists:keyfind("onLoad", 1, Exports) of 199 | false -> "return 0;"; 200 | _True -> [FunPrefix, "OnLoad(env, priv_data, load_info);"] 201 | end, 202 | " 203 | } 204 | 205 | void unload(ErlNifEnv* env, void* priv_data) {", 206 | case lists:keyfind("onUnload", 1, Exports) of 207 | false -> ""; 208 | _True -> [" 209 | ", FunPrefix, "OnUnload(env, priv_data);"] 210 | end, 211 | case lists:keyfind("onLoad", 1, Exports) of 212 | false -> ""; 213 | _True -> " 214 | enif_free(priv_data);" 215 | end, " 216 | hs_exit(); 217 | } 218 | 219 | static ErlNifFunc nif_funcs[] = { 220 | ", 221 | listjoin([ 222 | [" {\"", Fun, "\", ", integer_to_list(Arity), 223 | ", ", FunPrefix, Fun, "}"] 224 | || {Fun, Arity, _Env} <- Exports, 225 | Fun =/= "onLoad", Fun =/= "onUnload" 226 | ], ",\n"), " 227 | }; 228 | ERL_NIF_INIT(", MTarget, ",nif_funcs,&load,NULL,NULL,&unload) 229 | "], 230 | HsDir = filename:dirname(Source), 231 | CModuleFile = filename:join(HsDir, FunPrefix ++ ".c"), 232 | ok = file:write_file(CModuleFile, CModuleText), 233 | CModuleFile. 234 | 235 | 236 | -spec hs_module_name(file:name()) -> string(). 237 | hs_module_name(Source) -> 238 | ModuleName = case get(Source) of 239 | undefined -> 240 | QSource = lists:flatten( io_lib:format("~p", [Source]) ), 241 | command(["ghc", 242 | "-e", ":m Language.Haskell.Parser Language.Haskell.Syntax", 243 | "-e", "readFile " ++ QSource ++ " >>= \\content -> 244 | let ParseOk (HsModule _ (Module name) _ _ _) = 245 | parseModule content 246 | in putStr name"]); 247 | Mn -> Mn 248 | end, 249 | put(Source, ModuleName), 250 | ModuleName. 251 | 252 | 253 | -spec hs_fun(string(), string(), funspec()) -> iolist(). 254 | hs_fun(SourceModule, FunPrefix, {Fun, Arity, Env}) -> 255 | Arities = [integer_to_list(A) || A <- lists:seq(0, Arity - 1)], [ 256 | FunPrefix, Fun, " :: ErlNifEnv -> CInt -> Ptr ErlNifTerm -> IO ErlNifTerm\n", 257 | FunPrefix, Fun, " env ", integer_to_list(Arity), " argv =", 258 | " (flip C.catch) (exhandler env) $ do", [[" 259 | a", A, " <- peekElemOff argv ", A, " >>= fromErlNifTerm env" 260 | ] || A <- Arities], " 261 | toErlNifTerm env $ ", SourceModule, ".", Fun, 262 | case Env of true -> " env"; false -> "" end, 263 | [" a" ++ A || A <- Arities], "\n", 264 | FunPrefix, Fun, " env _ _ = enif_make_badarg env\n", 265 | "foreign export ccall ", FunPrefix, Fun, 266 | " :: ErlNifEnv -> CInt -> Ptr ErlNifTerm -> IO ErlNifTerm 267 | 268 | "]. 269 | 270 | -spec hs_onload(string(), string(), funspec()) -> iolist(). 271 | hs_onload(SourceModule, FunPrefix, {"onLoad", Arity, Env}) -> [ 272 | FunPrefix, "OnLoad :: ErlNifEnv -> Ptr (Ptr ()) -> ErlNifTerm -> IO CInt\n", 273 | FunPrefix, "OnLoad env priv_data load_info = (flip C.catch) exhandler $ do 274 | x <- ", SourceModule, ".onLoad", 275 | case Env of true -> " env"; false -> "" end, 276 | case Arity of 0 -> ""; 1 -> " load_info" end, " 277 | ptr <- enif_alloc $ fromIntegral $ sizeOf x 278 | poke (castPtr ptr) x 279 | poke priv_data $ castPtr ptr 280 | return 0 281 | where 282 | exhandler :: SomeException -> IO CInt 283 | exhandler _ = return 1 284 | ", "foreign export ccall ", FunPrefix, "OnLoad", 285 | " :: ErlNifEnv -> Ptr (Ptr ()) -> ErlNifTerm -> IO CInt 286 | 287 | "]. 288 | 289 | -spec hs_onunload(string(), string(), funspec()) -> iolist(). 290 | hs_onunload(SourceModule, FunPrefix, {"onUnload", Arity, Env}) -> [ 291 | FunPrefix, "OnUnload :: ErlNifEnv -> Ptr () -> IO ()\n", 292 | FunPrefix, "OnUnload env priv_data = (flip C.catch) exhandler $ 293 | ", SourceModule, ".onUnload", 294 | case Env of true -> " env"; false -> "" end, 295 | case Arity of 0 -> ""; 1 -> " priv_data" end, " 296 | where 297 | exhandler :: SomeException -> IO () 298 | exhandler _ = return () 299 | ", "foreign export ccall ", FunPrefix, "OnUnload", 300 | " :: ErlNifEnv -> Ptr () -> IO () 301 | 302 | "]. 303 | 304 | -spec function_name(string(), string()) -> string(). 305 | function_name(Function, SourceModule) -> 306 | case string:tokens(Function, ".") of 307 | [SourceModule, F] -> F; 308 | [F] -> F 309 | end. 310 | 311 | 312 | -spec find(file:name(), [string()]) -> [string()]. 313 | find(Dir, Patterns) -> 314 | {ok, List} = file:list_dir(Dir), 315 | L0 = [ filename:join(Dir, File) || Pattern <- Patterns, 316 | File <- filelib:wildcard(Pattern, Dir) ], 317 | L1 = lists:concat( [find(SubDir, Patterns) || L <- List, 318 | SubDir <- [filename:join(Dir, L)], filelib:is_dir(SubDir)] ), 319 | L0 ++ L1. 320 | 321 | 322 | -spec command([string()]) -> string(). 323 | command(Args) -> 324 | Port = open_port({spawn_executable, "/usr/bin/env"}, 325 | [{args, Args}, exit_status, binary, stderr_to_stdout]), 326 | command_loop(Args, Port, <<>>). 327 | 328 | -spec command_loop([string()], port(), binary()) -> string(). 329 | command_loop(Args, Port, Buffer) -> 330 | receive 331 | {Port, {exit_status, Status}} -> 332 | Level = case Status of 333 | 0 -> debug; 334 | _ -> error 335 | end, 336 | rebar_log:log(Level, "~s~n~s~n", [string:join(Args, " "), Buffer]), 337 | case Status of 338 | 0 -> binary_to_list(Buffer); 339 | _ -> rebar_utils:abort() 340 | end; 341 | {Port, {data, Data}} -> 342 | command_loop(Args, Port, <>); 343 | Msg -> 344 | rebar_log:log(info, "~p~n", [Msg]), 345 | command_loop(Args, Port, Buffer) 346 | end. 347 | 348 | 349 | -spec listjoin([string()], string()) -> iolist(). 350 | listjoin([], _Sep) -> 351 | []; 352 | listjoin([H|T], Sep) -> 353 | [H | [[Sep, X] || X <- T]]. 354 | --------------------------------------------------------------------------------