├── .gitignore ├── LICENSE ├── Readme.md ├── Setup.hs ├── examples ├── .gitignore ├── test_primitives │ ├── MainC.idr │ ├── MainErl.idr │ ├── other_file │ ├── output │ └── test_file └── test_special_ctors │ └── MainErl.idr ├── idris-erlang.cabal ├── irts ├── idris_erlang_conc.erl └── idris_erlang_rts.erl ├── libs └── erlang │ ├── ErlPrelude.idr │ ├── Erlang │ └── Process.idr │ └── erlang.ipkg ├── src ├── IRTS │ ├── CodegenErlang.hs │ └── CodegenErlang │ │ └── Foreign.hs └── Main.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | .cabal-sandbox 4 | cabal.sandbox.config 5 | *.ibc 6 | *.o 7 | *.a 8 | *.so 9 | *.dll 10 | *.dylib 11 | *.swp 12 | *~ 13 | .DS_Store 14 | .hpc 15 | *.tix 16 | custom.mk 17 | tags 18 | TAGS 19 | src/Version_idris.hs 20 | *.beam 21 | .*.el 22 | *.S 23 | *.core 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Archibald Samuel Elliott 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Archibald Samuel Elliott nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | idris-erlang 2 | ============ 3 | 4 | Idris to Erlang Compiler and Libraries. 5 | 6 | I started using Stackage, so these instructions now use stackage. 7 | 8 | - Install Stack 9 | - Install Erlang 10 | - Checkout this repository and cd into its toplevel directory 11 | - Compile the runtime support using `(cd irts; erlc *.erl)` 12 | - Build this package with `stack build` 13 | - Install the erlang package using `(cd libs/erlang; stack exec idris -- --install erlang.ipkg)` 14 | 15 | You're up and running. To invoke the compiler, use 16 | 17 | ``` 18 | $ stack exec idris -- --codegen=erlang --package=erlang Main.idr -o main.erl 19 | ``` 20 | 21 | Then run the program using 22 | 23 | ``` 24 | $ escript main.erl 25 | ``` 26 | 27 | If everything has worked, then you should be able to compile and run 28 | all the examples. If not, `¯\_(ツ)_/¯` 29 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | */*.erl 2 | */*.out 3 | -------------------------------------------------------------------------------- /examples/test_primitives/MainC.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | 4 | testFiles : IO () 5 | testFiles = do putStrLn "testFiles" 6 | h <- openFile "test_file" Read 7 | putStrLn $ "read char from file: " ++ singleton !(fgetc h) 8 | putStrLn $ "read from file: " ++ !(fread h) 9 | if !(feof h) then putStrLn "EOF" else putStrLn "Not EOF" 10 | closeFile h 11 | h' <- openFile "other_file" Write 12 | fwrite h' "test" 13 | closeFile h' 14 | 15 | -- testProcesses : IO () 16 | -- testProcesses = do putStrLn "testProcesses" 17 | -- h <- popen "echo 'foo'" Read 18 | -- putStrLn $ "read from echo: " ++ !(fread h) 19 | -- pclose h 20 | 21 | 22 | testStrings : IO () 23 | testStrings = do putStrLn "testStrings" 24 | s <- return "" 25 | if !(nullStr s) then putStrLn "null" else putStrLn "not null" 26 | 27 | main : IO () 28 | main = do testFiles 29 | -- testProcesses 30 | testStrings 31 | -------------------------------------------------------------------------------- /examples/test_primitives/MainErl.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import ErlPrelude 4 | 5 | testFiles : EIO () 6 | testFiles = do putStrLn "testFiles" 7 | h <- openFile "test_file" Read 8 | putStrLn $ "read char from file: " ++ singleton !(fgetc h) 9 | putStrLn $ "read from file: " ++ !(fread h) 10 | if !(feof h) then putStrLn "EOF" else putStrLn "Not EOF" 11 | closeFile h 12 | h' <- openFile "other_file" Write 13 | fwrite h' "test" 14 | closeFile h' 15 | 16 | -- testProcesses : IO () 17 | -- testProcesses = do putStrLn "testProcesses" 18 | -- h <- popen "echo 'foo'" Read 19 | -- putStrLn $ "read from echo: " ++ !(fread h) 20 | -- pclose h 21 | 22 | 23 | testStrings : EIO () 24 | testStrings = do putStrLn "testStrings" 25 | s <- return "" 26 | if !(nullStr s) then putStrLn "null" else putStrLn "not null" 27 | 28 | 29 | main : EIO () 30 | main = do testFiles 31 | -- testProcesses 32 | testStrings 33 | -------------------------------------------------------------------------------- /examples/test_primitives/other_file: -------------------------------------------------------------------------------- 1 | test -------------------------------------------------------------------------------- /examples/test_primitives/output: -------------------------------------------------------------------------------- 1 | testFiles 2 | read from file: wat wat wat 3 | 4 | Not EOF 5 | testProcesses 6 | read from echo: foo 7 | 8 | testStrings 9 | null 10 | -------------------------------------------------------------------------------- /examples/test_primitives/test_file: -------------------------------------------------------------------------------- 1 | wat wat wat 2 | wat wat wat 3 | -------------------------------------------------------------------------------- /examples/test_special_ctors/MainErl.idr: -------------------------------------------------------------------------------- 1 | module Main 2 | 3 | import ErlPrelude 4 | 5 | print_raw : a -> EIO () 6 | print_raw x = do print_raw' (MkERaw x) 7 | return () 8 | where print_raw' : (ErlRaw a) -> EIO () 9 | print_raw' r = foreign FFI_Erl "io:format" (String -> List (ErlRaw a) -> EIO ()) "~p~n" [r] 10 | 11 | lists_reverse : List Int -> EIO (List Int) 12 | lists_reverse = foreign FFI_Erl "lists:reverse" (List Int -> EIO (List Int)) 13 | 14 | lists_map : (Int -> EIO Char) -> List Int -> EIO (List Char) 15 | lists_map f = foreign FFI_Erl "lists:map" ((ErlFn (Int -> EIO Char)) -> List Int -> EIO (List Char)) (MkErlFun f) 16 | 17 | 18 | main : EIO () 19 | main = do printLn (the (List Int) []) 20 | print_raw (the (List Int) [1,2,3,4]) 21 | x <- lists_reverse [1,2,3,4] 22 | print_raw x 23 | 24 | print_raw "astring" 25 | print_raw 3 26 | print_raw 3.54 27 | 28 | print_raw () 29 | 30 | y <- lists_map (\x => getChar) x 31 | print_raw y 32 | -------------------------------------------------------------------------------- /idris-erlang.cabal: -------------------------------------------------------------------------------- 1 | -- TODO: add idris --install to install steps 2 | 3 | name: idris-erlang 4 | version: 0.0.3.0 5 | synopsis: Erlang Backend for the Idris Compiler 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Archibald Samuel Elliott 9 | maintainer: sam@lenary.co.uk 10 | category: Compilers/Interpreters, Dependent Types 11 | build-type: Simple 12 | cabal-version: >=1.8 13 | 14 | data-files: irts/*.erl 15 | , irts/*.beam 16 | 17 | executable idris-codegen-erlang 18 | main-is: Main.hs 19 | hs-source-dirs: src 20 | other-modules: IRTS.CodegenErlang 21 | , IRTS.CodegenErlang.Foreign 22 | 23 | build-depends: base >=4 && <5 24 | , containers 25 | , idris >=1 && <1.1 26 | , mtl 27 | , transformers 28 | , directory 29 | 30 | if os(linux) 31 | cpp-options: -DLINUX 32 | build-depends: unix < 2.8 33 | if os(freebsd) 34 | cpp-options: -DFREEBSD 35 | build-depends: unix < 2.8 36 | if os(dragonfly) 37 | cpp-options: -DDRAGONFLY 38 | build-depends: unix < 2.8 39 | if os(darwin) 40 | cpp-options: -DMACOSX 41 | build-depends: unix < 2.8 42 | if os(windows) 43 | cpp-options: -DWINDOWS 44 | build-depends: Win32 < 2.4 45 | 46 | ghc-prof-options: -auto-all -caf-all 47 | ghc-options: -threaded -rtsopts -funbox-strict-fields 48 | -------------------------------------------------------------------------------- /irts/idris_erlang_conc.erl: -------------------------------------------------------------------------------- 1 | -module(idris_erlang_conc). 2 | 3 | -export([receive_any/0, receive_any_from/1, receive_any_msg/1, receive_from/1, send/2]). 4 | -export([rpc_send_req/2, rpc_recv_rep/1, rpc_recv_req/0, rpc_send_rep/2]). 5 | 6 | %%% Messages 7 | 8 | -define(IDRIS_MSG(From,Msg), {'$idris_rts_msg', From, Msg}). 9 | 10 | % This is ugly, but required for messaging beneath. I could add a 11 | % timeout to make it safer, but then race conditions and no blocking, 12 | % so nope. Maybe I'll work out a better way. 13 | -spec receive_any() -> {'$idris_rts_any', pid(), any()}. 14 | receive_any() -> 15 | receive ?IDRIS_MSG(From,Msg) -> {From,Msg} end. 16 | 17 | receive_any_from({'$idris_rts_any', From, _Msg}) -> 18 | From. 19 | 20 | receive_any_msg({'$idris_rts_any', _From, Msg}) -> 21 | Msg. 22 | 23 | -spec receive_from(pid()) -> any(). 24 | receive_from(Process) -> 25 | receive ?IDRIS_MSG(Process,Msg) -> Msg end. 26 | 27 | -spec send(pid(), any()) -> any(). 28 | send(Process, Msg) -> 29 | Process ! ?IDRIS_MSG(self(), Msg), 30 | {}. 31 | 32 | %%% RPC 33 | 34 | -define(IDRIS_RPC_REQ(From, Message), {'$idris_rts_rpc_req', From, Message}). 35 | -define(IDRIS_RPC_REP(Tag, Message), {'$idris_rts_rpc_rep', Tag, Message}). 36 | 37 | -type from() :: {pid(),reference()}. 38 | 39 | -spec rpc_send_req(pid(),any()) -> reference(). 40 | rpc_send_req(Pid, Request) -> 41 | UniqueRef = make_ref(), 42 | Pid ! ?IDRIS_RPC_REQ({self(),UniqueRef}, Request), 43 | UniqueRef. 44 | 45 | -spec rpc_recv_rep(reference()) -> any(). 46 | rpc_recv_rep(UniqueRef) -> 47 | receive ?IDRIS_RPC_REP(UniqueRef, Reply) -> Reply end. 48 | 49 | -spec rpc_recv_req() -> {from(),any()}. 50 | rpc_recv_req() -> 51 | receive ?IDRIS_RPC_REQ(From,Request) -> {From,Request} end. 52 | 53 | -spec rpc_send_rep(from(),any()) -> {}. 54 | rpc_send_rep(From, Reply) -> 55 | {Pid, UniqueRef} = From, 56 | Pid ! ?IDRIS_RPC_REP(UniqueRef, Reply), 57 | {}. 58 | -------------------------------------------------------------------------------- /irts/idris_erlang_rts.erl: -------------------------------------------------------------------------------- 1 | -module(idris_erlang_rts). 2 | 3 | -define(TRUE, 1). 4 | -define(FALSE, 0). 5 | 6 | -export([project/2]). 7 | -export([floor/1, ceil/1]). 8 | -export([bool_cast/1]). 9 | -export([str_index/2, str_null/1]). 10 | -export([ptr_null/1, ptr_eq/2, register_ptr/2]). 11 | 12 | -export([write_str/1, write_file/2, read_str/0, read_file/1, read_chr/1]). 13 | -export([file_open/2, file_close/1, file_flush/1, file_eof/1]). 14 | 15 | -type idr_bool() :: ?TRUE | ?FALSE. 16 | 17 | %%% This is a set of helper wrappers for the Idris Runtime System Most 18 | %%% are used for primitives, but there's some other helpers in here 19 | %%% too. 20 | 21 | %% Erlang Doesn't have Floor and Ceil, so we have our own 22 | %% implementations from 23 | %% http://erlangcentral.org/wiki/index.php/Floating_Point_Rounding 24 | 25 | %% This has to be able to deal with Special-casing as done in the 26 | %% compiler. 27 | %% 28 | %% We special-case booleans, unit, lists, and zero-argument 29 | %% constructors. All others become tuples 30 | %% 31 | %% Booleans, Unit and zero-argument constructors cannot be indexed In 32 | %% the case of lists, we need to project out the head and the tail, 33 | %% which are the zeroeth and first fields respectively. 34 | %% 35 | %% All others we index into the tuple. Unfortunately, element/2 uses 36 | %% 1-indexes, whereas we're provided a zero-index. Also, we put the 37 | %% name of the constructor into the start of the tuple, so we must add 38 | %% two to the zero-index to get the right field of the tuple. 39 | -spec project(any(), non_neg_integer()) -> term(). 40 | project([Hd|_], 0) -> Hd; 41 | project([_|Tl], 1) -> Tl; 42 | project(T, Idx) when is_tuple(T) -> 43 | element(Idx+2, T). 44 | 45 | 46 | 47 | -spec floor(number()) -> integer(). 48 | floor(X) when X < 0 -> 49 | T = trunc(X), 50 | case X - T == 0 of 51 | true -> T; 52 | false -> T - 1 53 | end; 54 | floor(X) -> 55 | trunc(X). 56 | 57 | -spec ceil(number()) -> integer(). 58 | ceil(X) when X < 0 -> 59 | trunc(X); 60 | ceil(X) -> 61 | T = trunc(X), 62 | case X - T == 0 of 63 | true -> T; 64 | false -> T + 1 65 | end. 66 | 67 | -spec bool_cast(boolean()) -> idr_bool(). 68 | bool_cast(true) -> ?TRUE; 69 | bool_cast(_) -> ?FALSE. 70 | 71 | %% Strings 72 | 73 | % Just prevents some hacks in the code generator 74 | -spec str_index(string(), integer()) -> integer(). 75 | str_index(Str, Idx) -> 76 | lists:nth(Idx+1, Str). 77 | 78 | -spec str_null(string()) -> idr_bool(). 79 | str_null([]) -> 80 | ?TRUE; 81 | str_null(_) -> 82 | ?FALSE. 83 | 84 | %% Pointers 85 | 86 | -spec ptr_null(any()) -> idr_bool(). 87 | ptr_null(undefined) -> 88 | ?TRUE; 89 | ptr_null(_) -> 90 | ?FALSE. 91 | 92 | -spec ptr_eq(any(), any()) -> idr_bool(). 93 | ptr_eq(A,B) -> 94 | bool_cast(A =:= B). 95 | 96 | -spec register_ptr(any(), integer()) -> any(). 97 | register_ptr(Ptr, _Length) -> 98 | Ptr. 99 | 100 | 101 | %% IO Things. Mostly files, maybe some ports 102 | 103 | -type handle() :: file:io_device() | undefined. 104 | 105 | % Print a string exactly as it's provided, to a certain handle 106 | -spec write_file(handle(), string()) -> idr_bool(). 107 | write_file(undefined, _) -> 108 | ?FALSE; 109 | write_file(Handle, Str) -> 110 | case file:write(Handle, Str) of 111 | ok -> ?TRUE; 112 | _ -> ?FALSE 113 | end. 114 | 115 | -spec write_str(string()) -> idr_bool(). 116 | write_str(Str) -> 117 | write_file(standard_io, Str). 118 | 119 | -spec read_file(handle()) -> string(). 120 | read_file(undefined) -> 121 | ""; 122 | read_file(Handle) -> 123 | case file:read_line(Handle) of 124 | {ok, Data} -> Data; 125 | _ -> "" 126 | end. 127 | 128 | %% Read a line from the handle 129 | -spec read_str() -> string(). 130 | read_str() -> 131 | read_file(standard_io). 132 | 133 | -spec read_chr(handle()) -> integer(). 134 | read_chr(undefined) -> 135 | -1; 136 | read_chr(Handle) -> 137 | case file:read(Handle, 1) of 138 | {ok, [Chr]} -> Chr; 139 | _ -> -1 140 | end. 141 | 142 | -spec file_open(string(), string()) -> handle(). 143 | file_open(Name, Mode) -> 144 | ModeOpts = case Mode of 145 | "r" -> [read]; 146 | "w" -> [write]; 147 | "r+" -> [read, write] 148 | end, 149 | case file:open(Name, ModeOpts) of 150 | {ok, Handle} -> Handle; 151 | _ -> undefined 152 | end. 153 | 154 | -spec file_close(handle()) -> idr_bool(). 155 | file_close(undefined) -> 156 | ?FALSE; 157 | file_close(Handle) -> 158 | case file:close(Handle) of 159 | ok -> ?TRUE; 160 | _ -> ?FALSE 161 | end. 162 | 163 | -spec file_flush(handle()) -> idr_bool(). 164 | file_flush(undefined) -> 165 | ?FALSE; 166 | file_flush(Handle) -> 167 | case file:sync(Handle) of 168 | ok -> ?TRUE; 169 | _ -> ?FALSE 170 | end. 171 | 172 | % This is really hacky. We have to do a read to find out if we're at 173 | % the EOF, so we do a 1-char read, then scan back by one char. If the 174 | % read or the scan fail, we say we're at the end, otherwise we use 175 | % real info to see if we're at the eof. 176 | -spec file_eof(handle()) -> idr_bool(). 177 | file_eof(undefined) -> 178 | ?TRUE; %% Null is at EOF 179 | file_eof(Handle) -> 180 | case file:read(Handle,1) of 181 | eof -> ?TRUE; %% At EOF 182 | {ok, _} -> case file:position(Handle, {cur, -1}) of 183 | {ok, _} -> ?FALSE; %% Not at EOF 184 | {error, _} -> ?TRUE %% Error Scanning Back -> EOF 185 | end; 186 | {error, _} -> ?TRUE %% Error -> EOF 187 | end. 188 | -------------------------------------------------------------------------------- /libs/erlang/ErlPrelude.idr: -------------------------------------------------------------------------------- 1 | module ErlPrelude 2 | 3 | %access export 4 | 5 | data ErlFn : Type -> Type where 6 | MkErlFun : (x : t) -> ErlFn t 7 | %used MkErlFun x 8 | 9 | public export 10 | data ErlRaw : Type -> Type where 11 | MkERaw : (x:t) -> ErlRaw t 12 | %used MkERaw x 13 | 14 | data Atom : Type 15 | 16 | data Erl_NumTypes: Type -> Type where 17 | Erl_IntChar : Erl_NumTypes Char 18 | Erl_IntNative : Erl_NumTypes Int 19 | Erl_Double : Erl_NumTypes Double 20 | 21 | mutual 22 | data Erl_FunTypes : Type -> Type where 23 | Erl_Fun : Erl_Types s -> Erl_FunTypes t -> Erl_FunTypes (s -> t) 24 | Erl_FunIO : Erl_Types t -> Erl_FunTypes (EIO t) 25 | Erl_FunBase : Erl_Types t -> Erl_FunTypes t 26 | 27 | public export 28 | data Erl_Types : Type -> Type where 29 | Erl_Str : Erl_Types String 30 | Erl_Atom : Erl_Types Atom 31 | Erl_Ptr : Erl_Types Ptr 32 | Erl_Unit : Erl_Types () 33 | Erl_List : Erl_Types a -> Erl_Types (List a) 34 | Erl_FunT : Erl_FunTypes a -> Erl_Types (ErlFn a) 35 | Erl_NumT : Erl_NumTypes t -> Erl_Types t 36 | Erl_Raw : Erl_Types (ErlRaw a) 37 | 38 | public export 39 | FFI_Erl : FFI 40 | FFI_Erl = MkFFI Erl_Types String String 41 | 42 | public export 43 | -- Make your "Old MacDonald" jokes here please 44 | EIO : Type -> Type 45 | EIO = IO' FFI_Erl 46 | 47 | %inline 48 | public export 49 | erlcall : (fname : String) -> (ty : Type) -> {auto fty : FTy FFI_Erl [] ty} -> ty 50 | erlcall fname ty = foreign FFI_Erl fname ty 51 | 52 | %inline 53 | public export 54 | Erl_Export : Type 55 | Erl_Export = FFI_Export FFI_Erl "" [] 56 | 57 | ErlPid : Type 58 | ErlPid = Ptr 59 | 60 | -- Annoyingly, the File struct is abstract so we can't use it. I guess 61 | -- this helps prevent people mixing the two kinds of files... not that 62 | -- it would even be possible. 63 | data EFile = EHandle Ptr 64 | 65 | namespace Erl 66 | stdin : EFile 67 | stdin = EHandle prim__stdin 68 | 69 | stdout : EFile 70 | stdout = EHandle prim__stdout 71 | 72 | stderr : EFile 73 | stderr = EHandle prim__stderr 74 | 75 | openFile : String -> Mode -> EIO EFile 76 | openFile filename mode = do p <- open filename (modeStr mode) 77 | pure (EHandle p) 78 | where modeStr : Mode -> String 79 | modeStr Read = "r" 80 | modeStr Write = "w" 81 | modeStr ReadWrite = "rw" 82 | 83 | open : String -> String -> EIO Ptr 84 | open = foreign FFI_Erl "idris_erlang_rts:file_open" (String -> String -> EIO Ptr) 85 | 86 | 87 | closeFile : EFile -> EIO () 88 | closeFile (EHandle p) = do x <- close p 89 | pure () 90 | where close : Ptr -> EIO Int 91 | close = foreign FFI_Erl "idris_erlang_rts:file_close" (Ptr -> EIO Int) 92 | 93 | 94 | fgetc' : EFile -> EIO (Maybe Char) 95 | fgetc' (EHandle h) = do c <- getChar h 96 | pure $ if (c < 0) 97 | then Nothing 98 | else (Just (cast c)) 99 | where getChar : Ptr -> EIO Int 100 | getChar = foreign FFI_Erl "idris_erlang_rts:read_chr" (Ptr -> EIO Int) 101 | 102 | fgetc : EFile -> EIO Char 103 | fgetc (EHandle h) = do c <- getChar h 104 | pure (cast c) 105 | where getChar : Ptr -> EIO Int 106 | getChar = foreign FFI_Erl "idris_erlang_rts:read_chr" (Ptr -> EIO Int) 107 | 108 | 109 | fread : EFile -> EIO String 110 | fread (EHandle h) = prim_fread h 111 | 112 | fwrite : EFile -> String -> EIO () 113 | fwrite (EHandle h) s = do writeFile h s 114 | pure () 115 | where writeFile : Ptr -> String -> EIO Int 116 | writeFile = foreign FFI_Erl "idris_erlang_rts:write_file" (Ptr -> String -> EIO Int) 117 | 118 | feof : EFile -> EIO Bool 119 | feof (EHandle h) = do res <- fileEOF h 120 | pure (res /= 0) 121 | where fileEOF : Ptr -> EIO Int 122 | fileEOF = foreign FFI_Erl "idris_erlang_rts:file_eof" (Ptr -> EIO Int) 123 | 124 | fflush : EFile -> EIO () 125 | fflush (EHandle h) = do fileFlush h 126 | pure () 127 | where fileFlush : Ptr -> EIO Int 128 | fileFlush = foreign FFI_Erl "idris_erlang_rts:file_flush" (Ptr -> EIO Int) 129 | 130 | 131 | putChar : Char -> EIO () 132 | putChar c = putStr' (singleton c) 133 | 134 | getChar : EIO Char 135 | getChar = fgetc stdin 136 | 137 | nullStr : String -> EIO Bool 138 | nullStr s = do res <- strIsNull s 139 | pure (res /= 0) 140 | where strIsNull : String -> EIO Int 141 | strIsNull = foreign FFI_Erl "idris_erlang_rts:str_null" (String -> EIO Int) 142 | 143 | 144 | nullPtr : Ptr -> EIO Bool 145 | nullPtr p = do res <- isNull p 146 | pure (res /= 0) 147 | where isNull : Ptr -> EIO Int 148 | isNull = foreign FFI_Erl "idris_erlang_rts:ptr_null" (Ptr -> EIO Int) 149 | 150 | eqPtr : Ptr -> Ptr -> EIO Bool 151 | eqPtr x y = do res <- ptrIsEq x y 152 | pure (res /= 0) 153 | where ptrIsEq : Ptr -> Ptr -> EIO Int 154 | ptrIsEq = foreign FFI_Erl "idris_erlang_rts:ptr_eq" (Ptr -> Ptr -> EIO Int) 155 | 156 | validFile : EFile -> EIO Bool 157 | validFile (EHandle h) = do res <- nullPtr h 158 | pure (not res) 159 | 160 | partial 161 | readFile : String -> EIO String 162 | readFile fn = do f <- openFile fn Read 163 | c <- readFile' f "" 164 | closeFile f 165 | pure c 166 | where 167 | partial 168 | readFile' : EFile -> String -> EIO String 169 | readFile' f contents = do res <- feof f 170 | if (not res) 171 | then do l <- fread f 172 | readFile' f (contents ++ l) 173 | else pure contents 174 | 175 | atom : String -> EIO Atom 176 | atom = foreign FFI_Erl "list_to_atom" (String -> EIO Atom) 177 | -------------------------------------------------------------------------------- /libs/erlang/Erlang/Process.idr: -------------------------------------------------------------------------------- 1 | module Erlang.Process 2 | 3 | import ErlPrelude 4 | 5 | -- ProcRef l is a process that wants messages of type l. 6 | data ProcRef : Type -> Type where 7 | MkProcRef : Ptr -> ProcRef l 8 | 9 | -- Process l is a process that receives messages of type l. 10 | data Process : (l:Type) -> Type -> Type where 11 | MkProc : (EIO a) -> Process l a 12 | 13 | lift : EIO a -> Process l a 14 | lift = MkProc 15 | 16 | run : Process l a -> EIO a 17 | run (MkProc p) = p 18 | 19 | implementation Functor (Process l) where 20 | map f (MkProc p) = MkProc (map f p) 21 | 22 | implementation Applicative (Process l) where 23 | pure a = MkProc (pure a) 24 | (MkProc f) <*> (MkProc a) = MkProc (f <*> a) 25 | 26 | implementation Monad (Process l) where 27 | (MkProc a) >>= p = MkProc (a >>= (\as => case p as of (MkProc b) => b)) 28 | 29 | self : Process l (ProcRef l) 30 | self = do pid <- lift $ self' 31 | pure $ MkProcRef pid 32 | where self' : EIO Ptr 33 | self' = foreign FFI_Erl "self" (EIO Ptr) 34 | 35 | spawn : Process l () -> Process l' (ProcRef l) 36 | spawn (MkProc p) = do p <- lift $ fork p 37 | pure $ MkProcRef p 38 | 39 | receive_from : ProcRef l' -> Process l l 40 | receive_from (MkProcRef p) = do (MkERaw rec) <- lift $ receive_from' p 41 | pure rec 42 | where receive_from' : Ptr -> EIO (ErlRaw l) 43 | receive_from' = foreign FFI_Erl "idris_erlang_conc:receive_from" (Ptr -> EIO (ErlRaw l)) 44 | 45 | receive_with_from : Process l (Ptr,l) 46 | receive_with_from = do msg <- lift $ receive_with_from' 47 | p <- lift $ receive_get_from msg 48 | (MkERaw rec) <- lift $ receive_get_rec msg 49 | pure (p,rec) 50 | where receive_with_from' : EIO Ptr 51 | receive_with_from' = foreign FFI_Erl "idris_erlang_conc:receive_any" (EIO Ptr) 52 | receive_get_from : Ptr -> EIO Ptr 53 | receive_get_from = foreign FFI_Erl "idris_erlang_conc:receive_any_from" (Ptr -> EIO Ptr) 54 | receive_get_rec : Ptr -> EIO (ErlRaw l) 55 | receive_get_rec = foreign FFI_Erl "idris_erlang_conc:receive_any_msg" (Ptr -> EIO (ErlRaw l)) 56 | 57 | receive : Process l l 58 | receive = do (_, msg) <- receive_with_from 59 | pure msg 60 | 61 | send : ProcRef l' -> l' -> Process l () 62 | send (MkProcRef pid) msg = do lift $ send' pid (MkERaw msg) 63 | pure () 64 | where 65 | send' : Ptr -> ErlRaw l' -> EIO () 66 | send' = foreign FFI_Erl "idris_erlang_conc:send" (Ptr -> (ErlRaw l') -> EIO ()) 67 | -------------------------------------------------------------------------------- /libs/erlang/erlang.ipkg: -------------------------------------------------------------------------------- 1 | package erlang 2 | 3 | opts = "--total" 4 | 5 | modules = ErlPrelude, 6 | Erlang.Process 7 | -------------------------------------------------------------------------------- /src/IRTS/CodegenErlang.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module IRTS.CodegenErlang (codegenErlang) where 3 | 4 | import Idris.Core.TT 5 | import IRTS.Lang 6 | import IRTS.CodegenCommon 7 | import IRTS.Defunctionalise 8 | 9 | import Control.Applicative ((<$>)) 10 | import Control.Monad.Except 11 | import Control.Monad.Trans.State 12 | 13 | import Data.Char (isPrint, toUpper, isUpper, isLower, isDigit, isAlpha) 14 | import Data.List (intercalate, insertBy, partition) 15 | import qualified Data.Map.Strict as Map 16 | import Data.Ord (comparing) 17 | 18 | import System.Directory (getPermissions, setPermissions, setOwnerExecutable) 19 | import System.Exit (exitSuccess,exitFailure) 20 | 21 | import Paths_idris_erlang (getDataFileName) 22 | 23 | import IRTS.CodegenErlang.Foreign 24 | 25 | -- TODO: Exports 26 | 27 | debugErlang :: Bool 28 | debugErlang = False 29 | 30 | -- Everything actually happens in `generateErl`. This is just a bit of 31 | -- glue code. 32 | codegenErlang :: CodeGenerator 33 | codegenErlang ci = do let outfile = outputFile ci 34 | eitherEcg <- runErlCodeGen generateErl (defunDecls ci) (exportDecls ci) 35 | case eitherEcg of 36 | Left err -> do putStrLn ("Error: " ++ err) 37 | exitFailure 38 | Right ecg -> do data_dir <- getDataFileName "irts" 39 | let erlout = header outfile data_dir 40 | ++ exports_section (exports ecg) 41 | ++ ["", ""] 42 | ++ Map.elems (forms ecg) 43 | writeFile outfile $ "\n" `intercalate` erlout ++ "\n" 44 | 45 | if null (exportDecls ci) 46 | then do p <- getPermissions outfile 47 | setPermissions outfile $ setOwnerExecutable True p 48 | return () 49 | else return () 50 | 51 | putStrLn ("Compilation Succeeded: " ++ outfile) 52 | exitSuccess 53 | 54 | 55 | 56 | -- Erlang files have to have a `-module().` annotation that matches 57 | -- their filename (without the extension). Given we're making this, we 58 | -- should be curteous and give coders a warning that this file was 59 | -- autogenerated, rather than hand-coded. 60 | header :: String -> String -> [String] 61 | header filename data_dir 62 | = ["%% -*- erlang -*-", 63 | "%%! -smp enable -pa " ++ data_dir ++ "", 64 | "%% Generated by the Idris -> Erlang Compiler (idris-erlang).", 65 | "", 66 | "-module(" ++ modulename ++ ").", 67 | "", 68 | if debugErlang then "" else "-compile(inline). %% Enable Inlining", 69 | if debugErlang then "" else "-compile({inline_size,1100}). %% Turn Inlining up to 11", 70 | "-compile(export_all).", 71 | "", 72 | if debugErlang then "-mode(compile)." else "", 73 | if debugErlang then "-include_lib(\"stdlib/include/ms_transform.hrl\")." else "", 74 | ""] 75 | where modulename = takeWhile (/='.') filename 76 | 77 | exports_section :: [(String,Int)] -> [String] 78 | exports_section = map (\(f,a) -> "-export(["++ f ++"/"++ show a ++"]).") 79 | 80 | -- exportCompileTag 81 | 82 | -- Erlang Codegen State Monad 83 | data ErlCodeGen = ECG { 84 | forms :: Map.Map (String,Int) String, -- name and arity to form 85 | decls :: [(Name,DDecl)], 86 | records :: [(Name,Int)], 87 | exports :: [(String,Int)], 88 | checked_fns :: Map.Map (String,Int) Int 89 | } deriving (Show) 90 | 91 | initECG :: ErlCodeGen 92 | initECG = ECG { forms = Map.empty 93 | , decls = [] 94 | , records = [] 95 | , exports = [] 96 | , checked_fns = Map.empty 97 | } 98 | 99 | type ErlCG = StateT ErlCodeGen (ExceptT String IO) 100 | 101 | runErlCodeGen :: ([(Name, DDecl)] -> [ExportIFace] -> ErlCG ()) -> [(Name,DDecl)] -> [ExportIFace] -> IO (Either String ErlCodeGen) 102 | runErlCodeGen ecg ddecls eifaces = runExceptT $ execStateT (ecg ddecls eifaces) initECG 103 | 104 | emitForm :: (String, Int) -> String -> ErlCG () 105 | emitForm fa form = modify (\ecg -> ecg { forms = Map.insert fa form (forms ecg)}) 106 | 107 | emitExport :: (String, Int) -> ErlCG () 108 | emitExport fa = modify (\ecg -> ecg { exports = fa : (exports ecg)}) 109 | 110 | addRecord :: Name -> Int -> ErlCG () 111 | addRecord name arity = do records <- gets records 112 | let records1 = insertBy (comparing fst) (name,arity) records 113 | modify (\ecg -> ecg { records = records1 }) 114 | 115 | -- We want to be able to compare the length of constructor arguments 116 | -- to the arity of that record constructor, so this returns the 117 | -- arity. If we can't find the record, then -1 is alright to return, 118 | -- as no list will have that length. 119 | recordArity :: Name -> ErlCG Int 120 | recordArity name = do records <- gets records 121 | case lookup name records of 122 | Just i -> return i 123 | Nothing -> return (-1) 124 | 125 | isRecord :: Name -> Int -> ErlCG Bool 126 | isRecord nm ar = do records <- gets records 127 | case lookup nm records of 128 | Just ar -> return True 129 | _ -> return False 130 | 131 | getVar :: LVar -> ErlCG String 132 | getVar (Glob name) = return $ erlVar name 133 | getVar (Loc i) = throwError "Local Variables not supported" 134 | 135 | getNextCheckedFnName :: String -> Int -> ErlCG String 136 | getNextCheckedFnName fn arity = 137 | do checked <- gets checked_fns 138 | case Map.lookup (fn,arity) checked of 139 | Nothing -> do modify (\ecg -> ecg { checked_fns = Map.insert (fn,arity) 1 checked }) 140 | return . strAtom $ "checked_" ++ fn ++ "_" ++ show 0 141 | Just x -> do modify (\ecg -> ecg {checked_fns = Map.update (Just . (+1)) (fn,arity) checked }) 142 | return . strAtom $ "checked_" ++ fn ++ "_" ++ show x 143 | 144 | 145 | {- The Code Generator: 146 | 147 | Takes in a Name and a DDecl, and hopefully emits some Forms. 148 | 149 | Some Definitions: 150 | 151 | - Form : the syntax for top-level Erlang function in an Erlang module 152 | 153 | - Module : a group of Erlang functions 154 | 155 | - Record : Erlang has n-arity tuples, and they're used for 156 | datastructures, in which case it's usual for the first element in the 157 | tuple to be the name of the datastructure. We'll be using these for 158 | most constructors. 159 | 160 | More when I realise they're needed. 161 | -} 162 | 163 | generateErl :: [(Name,DDecl)] -> [ExportIFace] -> ErlCG () 164 | generateErl alldecls exportifaces = 165 | let (ctors, funs) = (isCtor . snd) `partition` alldecls 166 | in do mapM_ (\(_,DConstructor name _ arity) -> generateCtor name arity) ctors 167 | mapM_ (\(_,DFun name args exp) -> generateFun name args exp) funs 168 | generateExports exportifaces 169 | 170 | where isCtor (DFun _ _ _) = False 171 | isCtor (DConstructor _ _ _) = True 172 | 173 | 174 | generateExports :: [ExportIFace] -> ErlCG () 175 | generateExports [] = generateMain 176 | generateExports exports = mapM_ (\(Export name file exports) -> generateExportIFace name file exports) exports 177 | 178 | generateMain :: ErlCG () 179 | generateMain = do erlExp <- generateExp $ DApp False mainName [] 180 | emitForm ("main", 1) ("main(_Args) -> \n" ++ dbgStmt ++ erlExp ++ ".") 181 | emitExport ("main", 1) 182 | where 183 | dbgStmt = if debugErlang 184 | then "dbg:tracer(), dbg:p(self(), c), dbg:tpl(?MODULE, dbg:fun2ms(fun(_) -> return_trace() end)),\n" 185 | else "" 186 | 187 | mainName :: Name 188 | mainName = sMN 0 "runMain" 189 | 190 | generateFun :: Name -> [Name] -> DExp -> ErlCG () 191 | generateFun _ _ DNothing = return () 192 | generateFun name args exp = do erlExp <- generateExp exp 193 | emitForm (erlAtom name, length args) ((erlAtom name) ++ "(" ++ argsStr ++ ") -> "++ erlExp ++".") 194 | where args' = map erlVar args 195 | argsStr = ", " `intercalate` args' 196 | 197 | generateCtor :: Name -> Int -> ErlCG () 198 | generateCtor name arity = addRecord name arity 199 | 200 | generateExportIFace :: Name -> String -> [Export] -> ErlCG () 201 | generateExportIFace _ _ exports = mapM_ generateExport exports 202 | 203 | generateExport :: Export -> ErlCG () 204 | generateExport (ExportData _) = return () -- Literally just string names of types, can't do anything with them. 205 | generateExport (ExportFun fn (FStr enm) ret args) = do liftIO . putStrLn $ erlAtom fn 206 | return () 207 | --emitForm (enm, length args) $ 208 | -- checkedExport enm 209 | 210 | 211 | generateExp :: DExp -> ErlCG String 212 | generateExp (DV lv) = getVar lv 213 | 214 | generateExp (DApp _ name exprs) = do res <- isRecord name (length exprs) 215 | exprs' <- mapM generateExp exprs 216 | if res 217 | then specialCaseCtor name exprs' 218 | else return $ erlCall (erlAtom name) exprs' 219 | 220 | generateExp (DLet vn exp inExp) = do exp' <- generateExp exp 221 | inExp' <- generateExp inExp 222 | return $ (erlVar vn) ++ " = begin " ++ exp' ++ " end, "++ inExp' 223 | 224 | -- These are never generated by the compiler right now 225 | generateExp (DUpdate _ exp) = generateExp exp 226 | 227 | generateExp (DProj exp n) = do exp' <- generateExp exp 228 | return $ erlCallIRTS "project" [exp', show n] 229 | 230 | 231 | generateExp (DC _ _ name exprs) = do res <- isRecord name (length exprs) 232 | exprs' <- mapM generateExp exprs 233 | if res 234 | then specialCaseCtor name exprs' 235 | else throwError $ "Constructor not found: " ++ show name ++ " with " ++ show (length exprs) ++ "arguments" 236 | 237 | generateExp (DCase _ exp alts) = generateCase exp alts 238 | generateExp (DChkCase exp alts) = generateCase exp alts 239 | 240 | generateExp (DConst c) = generateConst c 241 | 242 | generateExp (DOp op exprs) = do exprs' <- mapM generateExp exprs 243 | generatePrim op exprs' 244 | 245 | generateExp DNothing = return "undefined" 246 | generateExp (DError str) = return ("erlang:error("++ show str ++")") 247 | 248 | generateExp (DForeign ret nm args) = generateForeign ret nm args 249 | 250 | -- Case Statements 251 | generateCase :: DExp -> [DAlt] -> ErlCG String 252 | -- In the naive case, lots of case statements that look like the following get generated: 253 | -- 254 | -- case bool_cast(x OP y) of 255 | -- 0 -> false; 256 | -- _ -> true 257 | -- end 258 | -- 259 | -- This is annoying, as bool_cast has already changed `x OP y` from 260 | -- returning a bool to returning an integer, so we special-case these 261 | -- case statements into just generating the bool again. 262 | generateCase (DOp op exprs) [DConstCase (I 0) false, DDefaultCase true] 263 | | isBoolOp op && isFalseCtor false && isTrueCtor true = do exprs' <- mapM generateExp exprs 264 | simpleBoolOp op exprs' 265 | where isFalseCtor (DC _ _ (NS (UN "False") ["Bool", "Prelude"]) []) = True 266 | isFalseCtor _ = False 267 | isTrueCtor (DC _ _ (NS (UN "True") ["Bool", "Prelude"]) []) = True 268 | isTrueCtor _ = False 269 | generateCase expr alts = do expr' <- generateExp expr 270 | alts' <- mapM generateCaseAlt alts 271 | return $ "case " ++ expr' ++ " of\n" ++ (";\n" `intercalate` alts') ++ "\nend" 272 | 273 | -- Case Statement Clauses 274 | generateCaseAlt :: DAlt -> ErlCG String 275 | generateCaseAlt (DConCase _ name args expr) = do res <- isRecord name (length args) 276 | let args' = map erlVar args 277 | if res 278 | then do expr' <- generateExp expr 279 | ctor <- specialCaseCtor name args' 280 | return $ ctor ++ " -> " ++ expr' 281 | else throwError "No Constructor to Match With" 282 | generateCaseAlt (DConstCase con expr) = do con' <- generateConst con 283 | expr' <- generateExp expr 284 | return $ con' ++ " -> " ++ expr' 285 | generateCaseAlt (DDefaultCase expr) = do expr' <- generateExp expr 286 | return $ "_ -> " ++ expr' 287 | 288 | 289 | -- Foreign Calls 290 | -- 291 | generateForeign :: FDesc -> FDesc -> [(FDesc,DExp)] -> ErlCG String 292 | generateForeign Erl_Atom (FStr "list_to_atom") [(Erl_Str,DConst (Str s))] = return $ strAtom s 293 | generateForeign rety (FStr nm) args = do checkedNm <- getNextCheckedFnName nm (length args) 294 | args' <- mapM (generateExp . snd) args 295 | 296 | emitForm (checkedNm, length args) $ 297 | checkedFnCall checkedNm nm rety (map fst args) 298 | 299 | return $ erlCall checkedNm args' 300 | 301 | -- Some Notes on Constants 302 | -- 303 | -- - All Erlang's numbers are arbitrary precision. The VM copes with 304 | -- what size they really are underneath, including whether they're a 305 | -- float. 306 | -- 307 | -- - Characters are just numbers. However, there's also a nice syntax 308 | -- for them, which is $ is the number of that character. So, if 309 | -- the char is printable, it's best to use the $ notation than 310 | -- the number. 311 | -- 312 | -- - Strings are actually lists of numbers. However the nicer syntax 313 | -- is within double quotes. Some things will fail, but it's just 314 | -- easier to assume all strings are full of printables, if they're 315 | -- constant. 316 | generateConst :: Const -> ErlCG String 317 | generateConst TheWorld = return "the_world" 318 | generateConst c | constIsType c = return $ strAtom (show c) 319 | generateConst (I i) = return $ show i 320 | generateConst (BI i) = return $ show i 321 | generateConst (B8 w) = return $ show w 322 | generateConst (B16 w) = return $ show w 323 | generateConst (B32 w) = return $ show w 324 | generateConst (B64 w) = return $ show w 325 | generateConst (Fl f) = return $ show f 326 | -- Accurate Enough for now 327 | generateConst (Ch c) | c == '\\' = return "$\\\\" 328 | | isPrint c = return ['$',c] 329 | | otherwise = return $ show (fromEnum c) 330 | -- Accurate Enough for Now 331 | generateConst (Str s) | any (== '\\') s = do chars <- sequence $ map (generateConst . Ch) s 332 | return $ "[" ++ (", " `intercalate` chars) ++ "]" 333 | | all isPrint s = return $ show s 334 | | otherwise = do chars <- sequence $ map (generateConst . Ch) s 335 | return $ "[" ++ (", " `intercalate` chars) ++ "]" 336 | 337 | generateConst c = throwError $ "Unknown Constant " ++ show c 338 | 339 | -- Some Notes on Primitive Operations 340 | -- 341 | -- - Official Docs: 342 | -- http://www.erlang.org/doc/reference_manual/expressions.html#id78907 343 | -- http://www.erlang.org/doc/reference_manual/expressions.html#id78646 344 | -- 345 | -- - Oh look, because we only have one number type, all mathematical 346 | -- operations are really easy. The only thing to note is this: `div` 347 | -- is explicitly integer-only, so is worth using whenever integer 348 | -- division is asked for (to avoid everything becoming floaty). '/' is 349 | -- for any number, so we just use that on floats. 350 | -- 351 | -- 352 | generatePrim :: PrimFn -> [String] -> ErlCG String 353 | generatePrim (LPlus _) [x,y] = return $ erlBinOp "+" x y 354 | generatePrim (LMinus _) [x,y] = return $ erlBinOp "-" x y 355 | generatePrim (LTimes _) [x,y] = return $ erlBinOp "*" x y 356 | generatePrim (LUDiv _) [x,y] = return $ erlBinOp "div" x y 357 | generatePrim (LSDiv ATFloat) [x,y] = return $ erlBinOp "/" x y 358 | generatePrim (LSDiv _) [x,y] = return $ erlBinOp "div" x y 359 | generatePrim (LURem _) [x,y] = return $ erlBinOp "rem" x y 360 | generatePrim (LSRem _) [x,y] = return $ erlBinOp "rem" x y 361 | generatePrim (LAnd _) [x,y] = return $ erlBinOp "band" x y 362 | generatePrim (LOr _) [x,y] = return $ erlBinOp "bor" x y 363 | generatePrim (LXOr _) [x,y] = return $ erlBinOp "bxor" x y 364 | generatePrim (LCompl _) [x] = return $ erlBinOp "bnot" "" x -- hax 365 | generatePrim (LSHL _) [x,y] = return $ erlBinOp "bsl" x y 366 | generatePrim (LASHR _) [x,y] = return $ erlBinOp "bsr" x y 367 | generatePrim (LLSHR _) [x,y] = return $ erlBinOp "bsr" x y -- using an arithmetic shift when we should use a logical one. 368 | generatePrim (LEq _) [x,y] = return $ erlBoolOp "=:=" x y 369 | generatePrim (LLt _) [x,y] = return $ erlBoolOp "<" x y 370 | generatePrim (LLe _) [x,y] = return $ erlBoolOp "=<" x y 371 | generatePrim (LGt _) [x,y] = return $ erlBoolOp ">" x y 372 | generatePrim (LGe _) [x,y] = return $ erlBoolOp ">=" x y 373 | generatePrim (LSLt _) [x,y] = return $ erlBoolOp "<" x y 374 | generatePrim (LSLe _) [x,y] = return $ erlBoolOp "=<" x y 375 | generatePrim (LSGt _) [x,y] = return $ erlBoolOp ">" x y 376 | generatePrim (LSGe _) [x,y] = return $ erlBoolOp ">=" x y 377 | generatePrim (LSExt _ _) [x] = return $ x -- Not sure if correct 378 | generatePrim (LZExt _ _) [x] = return $ x -- Not sure if correct 379 | generatePrim (LTrunc _ _) [x] = return $ x -- Not sure if correct 380 | 381 | generatePrim (LIntFloat _) [x] = return $ erlBinOp "+" x "0.0" 382 | generatePrim (LFloatInt _) [x] = return $ erlCall "trunc" [x] 383 | generatePrim (LIntStr _) [x] = return $ erlCall "integer_to_list" [x] 384 | generatePrim (LStrInt _) [x] = return $ erlCall "list_to_integer" [x] 385 | generatePrim (LFloatStr) [x] = return $ erlCall "float_to_list" [x, "[compact, {decimals, 20}]"] 386 | generatePrim (LStrFloat) [x] = return $ erlCall "list_to_float" [x] 387 | generatePrim (LChInt _) [x] = return $ x -- Chars are just Integers anyway. 388 | generatePrim (LIntCh _) [x] = return $ x 389 | generatePrim (LBitCast _ _) [x] = return $ x 390 | 391 | generatePrim (LFExp) [x] = return $ erlCallMFA "math" "exp" [x] 392 | generatePrim (LFLog) [x] = return $ erlCallMFA "math" "log" [x] 393 | generatePrim (LFSin) [x] = return $ erlCallMFA "math" "sin" [x] 394 | generatePrim (LFCos) [x] = return $ erlCallMFA "math" "cos" [x] 395 | generatePrim (LFTan) [x] = return $ erlCallMFA "math" "tan" [x] 396 | generatePrim (LFASin) [x] = return $ erlCallMFA "math" "asin" [x] 397 | generatePrim (LFACos) [x] = return $ erlCallMFA "math" "acos" [x] 398 | generatePrim (LFATan) [x] = return $ erlCallMFA "math" "atan" [x] 399 | generatePrim (LFSqrt) [x] = return $ erlCallMFA "math" "sqrt" [x] 400 | generatePrim (LFFloor) [x] = return $ erlCallIRTS "ceil" [x] 401 | generatePrim (LFCeil) [x] = return $ erlCallIRTS "floor" [x] 402 | generatePrim (LFNegate) [x] = return $ "-" ++ x 403 | 404 | generatePrim (LStrHead) [x] = return $ erlCall "hd" [x] 405 | generatePrim (LStrTail) [x] = return $ erlCall "tl" [x] 406 | generatePrim (LStrCons) [x,y] = return $ "["++x++"|"++y++"]" 407 | generatePrim (LStrIndex) [x,y] = return $ erlCallIRTS "str_index" [x,y] 408 | generatePrim (LStrRev) [x] = return $ erlCallMFA "lists" "reverse" [x] 409 | generatePrim (LStrConcat) [x,y] = return $ erlBinOp "++" x y 410 | generatePrim (LStrLt) [x,y] = return $ erlBoolOp "<" x y 411 | generatePrim (LStrEq) [x,y] = return $ erlBoolOp "=:=" x y 412 | generatePrim (LStrLen) [x] = return $ erlCall "length" [x] 413 | 414 | generatePrim (LReadStr) [_] = return $ erlCallIRTS "read_str" [] 415 | generatePrim (LWriteStr) [_,s] = return $ erlCallIRTS "write_str" [s] 416 | 417 | generatePrim (LSystemInfo) _ = throwError "System Info not supported" -- TODO 418 | 419 | generatePrim (LFork) [e] = return $ "spawn(fun() -> "++ erlCall (erlAtom evalName) [e] ++" end)" 420 | 421 | generatePrim (LPar) [e] = return e 422 | 423 | generatePrim (LExternal nm) args = generateExternalPrim nm args 424 | 425 | generatePrim p a = do liftIO . putStrLn $ "No Primitive: " ++ show p ++ " on " ++ show (length a) ++ " args." 426 | throwError "generatePrim: Unknown Op, or incorrect arity" 427 | 428 | 429 | generateExternalPrim :: Name -> [String] -> ErlCG String 430 | generateExternalPrim nm _ | nm == sUN "prim__stdin" = return $ "standard_io" 431 | | nm == sUN "prim__stdout" = return $ "standard_io" 432 | | nm == sUN "prim__stderr" = return $ "standard_io" 433 | | nm == sUN "prim__vm" = return $ "undefined" 434 | | nm == sUN "prim__null" = return $ "undefined" 435 | generateExternalPrim nm [_,h] | nm == sUN "prim__readFile" = return $ erlCallIRTS "read_file" [h] 436 | generateExternalPrim nm [_,h,s] | nm == sUN "prim__writeFile" = return $ erlCallIRTS "write_file" [h,s] 437 | generateExternalPrim nm [p1,p2] | nm == sUN "prim__eqPtr" = return $ erlCallIRTS "ptr_eq" [p1,p2] 438 | generateExternalPrim nm [p1,p2] | nm == sUN "prim__eqManagedPtr" = return $ erlCallIRTS "ptr_eq" [p1,p2] 439 | generateExternalPrim nm [p,l] | nm == sUN "prim__registerPtr" = return $ erlCallIRTS "register_ptr" [p,l] 440 | generateExternalPrim nm args = do liftIO . putStrLn $ "Unknown External Primitive: " ++ show nm ++ " on " ++ show (length args) ++ " args." 441 | throwError "generatePrim: Unknown External Primitive" 442 | 443 | 444 | 445 | erlBinOp :: String -> String -> String -> String 446 | erlBinOp op a b = concat ["(",a," ",op," ",b,")"] 447 | 448 | -- Erlang Atoms can contain quite a lot of chars, so let's see how they cope 449 | erlAtom :: Name -> String 450 | erlAtom n = strAtom (showCG n) 451 | 452 | strAtom :: String -> String 453 | strAtom s = "\'" ++ concatMap atomchar s ++ "\'" 454 | where atomchar '\'' = "\\'" 455 | atomchar '\\' = "\\\\" 456 | atomchar '{' = "" 457 | atomchar '}' = "" 458 | atomchar x | isPrint x = [x] 459 | | otherwise = "_" ++ show (fromEnum x) ++ "_" 460 | 461 | 462 | -- Erlang Variables have a more restricted set of chars, and must 463 | -- start with a capital letter (erased can start with an underscore) 464 | erlVar :: Name -> String 465 | erlVar n = 'I':(concatMap varchar (showCG n)) 466 | where varchar '_' = "_" 467 | varchar '{' = "" 468 | varchar '}' = "" 469 | varchar x | isAlpha x = [x] 470 | | isDigit x = [x] 471 | | otherwise = "_" ++ show (fromEnum x) ++ "_" 472 | 473 | erlTuple :: [String] -> String 474 | erlTuple elems = "{" ++ (", " `intercalate` elems) ++ "}" 475 | 476 | erlCall :: String -> [String] -> String 477 | erlCall fun args = fun ++ "("++ (", " `intercalate` args) ++")" 478 | 479 | erlCallMFA :: String -> String -> [String] -> String 480 | erlCallMFA mod fun args = mod ++ ":" ++ erlCall fun args 481 | 482 | erlCallIRTS :: String -> [String] -> String 483 | erlCallIRTS f a = erlCallMFA "idris_erlang_rts" f a 484 | 485 | erlBoolOp :: String -> String -> String -> String 486 | erlBoolOp op x y = erlCallIRTS "bool_cast" [concat [x, " ", op, " ", y]] 487 | 488 | isBoolOp :: PrimFn -> Bool 489 | isBoolOp (LEq _) = True 490 | isBoolOp (LLt _) = True 491 | isBoolOp (LLe _) = True 492 | isBoolOp (LGt _) = True 493 | isBoolOp (LGe _) = True 494 | isBoolOp (LSLt _) = True 495 | isBoolOp (LSLe _) = True 496 | isBoolOp (LSGt _) = True 497 | isBoolOp (LSGe _) = True 498 | isBoolOp (LStrLt) = True 499 | isBoolOp (LStrEq) = True 500 | isBoolOp _ = False 501 | 502 | simpleBoolOp :: PrimFn -> [String] -> ErlCG String 503 | simpleBoolOp (LEq _) [x,y] = return $ erlBinOp "=:=" x y 504 | simpleBoolOp (LLt _) [x,y] = return $ erlBinOp "<" x y 505 | simpleBoolOp (LLe _) [x,y] = return $ erlBinOp "=<" x y 506 | simpleBoolOp (LGt _) [x,y] = return $ erlBinOp ">" x y 507 | simpleBoolOp (LGe _) [x,y] = return $ erlBinOp ">=" x y 508 | simpleBoolOp (LSLt _) [x,y] = return $ erlBinOp "<" x y 509 | simpleBoolOp (LSLe _) [x,y] = return $ erlBinOp "=<" x y 510 | simpleBoolOp (LSGt _) [x,y] = return $ erlBinOp ">" x y 511 | simpleBoolOp (LSGe _) [x,y] = return $ erlBinOp ">=" x y 512 | simpleBoolOp (LStrLt) [x,y] = return $ erlBinOp "<" x y 513 | simpleBoolOp (LStrEq) [x,y] = return $ erlBinOp "=:=" x y 514 | simpleBoolOp _ _ = throwError "Unknown Boolean Primitive Operation, this shouldn't ever happen" 515 | 516 | 517 | -- This is where we special case various constructors. 518 | -- 519 | -- * Prelude.List.Nil gets turned into [] 520 | -- * Prelude.List.(::) gets turned into [head|tail] 521 | -- * MkUnit () gets turned into {} 522 | -- * Prelude.Bool.True gets turned into true 523 | -- * Prelude.Bool.False gets turned into false 524 | -- 525 | specialCaseCtor :: Name -> [String] -> ErlCG String 526 | specialCaseCtor (NS (UN "Nil") ["List", "Prelude"]) [] = return "[]" 527 | specialCaseCtor (NS (UN "::") ["List", "Prelude"]) [hd,tl] = return $ "["++ hd ++ "|"++ tl ++"]" 528 | specialCaseCtor (UN "MkUnit") [] = return "{}" 529 | specialCaseCtor (NS (UN "True") ["Bool", "Prelude"]) [] = return "true" 530 | specialCaseCtor (NS (UN "False") ["Bool", "Prelude"]) [] = return "false" 531 | specialCaseCtor nm args = return $ "{"++ (", " `intercalate` (erlAtom nm : args)) ++"}" 532 | -------------------------------------------------------------------------------- /src/IRTS/CodegenErlang/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | {-# LANGUAGE OverloadedStrings#-} 4 | module IRTS.CodegenErlang.Foreign where 5 | 6 | import Idris.Core.TT 7 | import IRTS.Lang 8 | import IRTS.CodegenCommon 9 | import IRTS.Defunctionalise 10 | 11 | import Data.List (intercalate) 12 | import Data.Maybe 13 | 14 | evalName, applyName :: Name 15 | evalName = sMN 0 "EVAL" 16 | applyName = sMN 0 "APPLY" 17 | 18 | data ErlT = EString 19 | | EAtom 20 | | EUnit 21 | | EInt 22 | | EDouble 23 | | EPtr -- Something Erlang understands, and Idris doesn't 24 | | ERaw -- Something Idris understands, and Erlang doesn't 25 | | EList ErlT 26 | | EFun Bool ErlT [ErlT] -- (x,y,z) -> a (Bool is if a is an IO thing we should unwrap) 27 | deriving (Show, Eq) 28 | 29 | 30 | erlFun :: ErlT -> Bool 31 | erlFun (EFun _ _ _) = True 32 | erlFun _ = False 33 | 34 | -- I am so fucking tired of Idris names... fuck this shit. 35 | -- Especially as everywhere names include their namespace, except for here. OF COURSE! 36 | pattern Erl_Str = FCon (UN "Erl_Str") 37 | pattern Erl_Atom = FCon (UN "Erl_Atom") 38 | pattern Erl_Ptr = FCon (UN "Erl_Ptr") 39 | pattern Erl_Unit = FCon (UN "Erl_Unit") 40 | 41 | pattern Erl_List a <- FApp (UN "Erl_List") [_, a] 42 | pattern Erl_Int <- FApp (UN "Erl_NumT") [_, FCon (UN "Erl_IntNative")] 43 | pattern Erl_Char <- FApp (UN "Erl_NumT") [_, FCon (UN "Erl_IntChar")] 44 | pattern Erl_Double <- FApp (UN "Erl_NumT") [_, FCon (UN "Erl_Double")] 45 | pattern Erl_Raw <- FApp (UN "Erl_Raw") [_] 46 | pattern Erl_FunT f <- FApp (UN "Erl_FunT") [_, f] 47 | 48 | pattern Erl_Fun t f <- FApp (UN "Erl_Fun") [_, _, t, f] 49 | pattern Erl_FunBase t <- FApp (UN "Erl_FunBase") [_, t] 50 | pattern Erl_FunIO t <- FApp (UN "Erl_FunIO") [_, t] 51 | 52 | 53 | fdesc_to_erlt :: FDesc -> ErlT 54 | fdesc_to_erlt Erl_Str = EString 55 | fdesc_to_erlt Erl_Atom = EAtom 56 | fdesc_to_erlt Erl_Unit = EUnit 57 | fdesc_to_erlt Erl_Ptr = EPtr 58 | fdesc_to_erlt Erl_Raw = ERaw 59 | fdesc_to_erlt Erl_Int = EInt 60 | fdesc_to_erlt Erl_Char = EInt -- We represent chars as integers 61 | fdesc_to_erlt Erl_Double = EDouble 62 | fdesc_to_erlt (Erl_List a) = EList (fdesc_to_erlt a) 63 | fdesc_to_erlt (Erl_FunT f) = fun_fdesc_to_erlt f [] 64 | where fun_fdesc_to_erlt (Erl_Fun t f) args = fun_fdesc_to_erlt f (fdesc_to_erlt t:args) 65 | fun_fdesc_to_erlt (Erl_FunBase t) args = EFun False (fdesc_to_erlt t) (reverse args) 66 | fun_fdesc_to_erlt (Erl_FunIO t) args = EFun True (fdesc_to_erlt t) (reverse args) 67 | fun_fdesc_to_erlt _ args = ERaw 68 | fdesc_to_erlt _ = ERaw 69 | 70 | 71 | check_t :: ErlT -> String -> Maybe String 72 | check_t EString exp = Just $ "true = lists:all(fun erlang:is_number/1, "++ exp ++")" 73 | check_t EAtom exp = Just $ "true = is_atom("++ exp ++")" 74 | check_t EUnit exp = Nothing 75 | check_t EPtr exp = Nothing 76 | check_t ERaw exp = Nothing 77 | check_t EInt exp = Just $ "true = is_integer("++ exp ++")" 78 | check_t EDouble exp = Just $ "true = is_float("++ exp ++")" 79 | check_t (EList a) exp = case check_t' a of 80 | Just fn -> Just $ "true = lists:all("++ fn ++", "++ exp ++")" 81 | Nothing -> Nothing 82 | check_t _ exp = Nothing 83 | 84 | check_t' :: ErlT -> Maybe String 85 | check_t' EString = Just "fun(S) -> true = lists:all(fun erlang:is_number/1, S) end" 86 | check_t' EAtom = Just "fun erlang:is_atom/1" 87 | check_t' EUnit = Just "fun(U) -> true = ({} =:= U) end" 88 | check_t' EInt = Just "fun erlang:is_integer/1" 89 | check_t' EDouble = Just "fun erlang:is_float/1" 90 | check_t' (EList a) = case check_t' a of 91 | Just fn -> Just $ "fun(L) -> true = lists:all("++ fn ++", L) end" 92 | Nothing -> Nothing 93 | check_t' _ = Nothing 94 | 95 | 96 | checkedFnCall :: String -> String -> FDesc -> [FDesc] -> String 97 | checkedFnCall nm orig rety args = let argtys = map fdesc_to_erlt args 98 | argNms = argNames argtys 99 | decl = fndecl nm argNms 100 | cbks = checkedCallbackFuns (zip argtys argNms) 101 | reschk = checkedResult orig (fdesc_to_erlt rety) (zip argtys argNms) 102 | in concat $ [decl] ++ cbks ++ [reschk, "."] 103 | 104 | argNames :: [ErlT] -> [String] 105 | argNames tys = let itys = zip tys [1..] 106 | in map argName itys 107 | where argName (ty, ix) = (if erlFun ty then "CB" else "FC") ++ show ix 108 | 109 | fndecl :: String -> [String] -> String 110 | fndecl nm args = nm ++ "(" ++ (", " `intercalate` args) ++ ") ->\n" 111 | 112 | checkedCallbackFuns :: [(ErlT,String)] -> [String] 113 | checkedCallbackFuns = mapMaybe (uncurry checkedCallBack) 114 | 115 | 116 | checkedCallBack :: ErlT -> String -> Maybe String 117 | checkedCallBack ty _ | not (erlFun ty) = Nothing 118 | checkedCallBack (EFun unwrap ret args) nm = Just $ "Chkd_"++nm++" = fun("++ argstr ++") -> "++ body ++"end,\n" 119 | where args' = map (\(ty,ix) -> (ty,nm ++ "_" ++ show ix)) (zip args [1..]) 120 | argstr = ", " `intercalate` (map snd args') 121 | chks = mapMaybe (uncurry check_t) args' 122 | finalcall True xs = "'APPLY0'("++ finalcall False xs ++", the_world)" 123 | finalcall False [] = nm 124 | finalcall False (x:xs) = "'APPLY0'("++ finalcall False xs ++", "++ x ++")" 125 | 126 | body = ",\n" `intercalate` (chks ++ [""++finalcall unwrap (reverse (map snd args'))++""]) 127 | 128 | checkedResult :: String -> ErlT -> [(ErlT,String)] -> String 129 | checkedResult orig rety args = concat (catMaybes [Just ("Res = "++ orig ++ "("++ call_args ++"),\n") 130 | ,fmap (++ ",\n") $ check_t rety "Res" 131 | ,Just "Res\n"]) 132 | where args' = map (\(ty,nm) -> if erlFun ty then "Chkd_" ++ nm else nm) args 133 | call_args = ", " `intercalate` args' 134 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Idris.AbsSyntax 4 | import Idris.Core.TT 5 | import Idris.ElabDecls 6 | import Idris.Main 7 | import Idris.ModeCommon 8 | import Idris.REPL 9 | 10 | import IRTS.Compiler 11 | import IRTS.CodegenErlang 12 | 13 | import System.Environment 14 | import System.Exit 15 | 16 | import Control.Monad (liftM) 17 | 18 | import Paths_idris_erlang 19 | 20 | data Opts = Opts { inputs :: [FilePath], 21 | output :: FilePath, 22 | show_path :: Bool, 23 | interface :: Bool } 24 | 25 | erlDefaultOpts :: Opts 26 | erlDefaultOpts = Opts { inputs = [], output = "main.erl", show_path = False, interface = False} 27 | 28 | showUsage = do putStrLn "Usage: idris-erlang [--interface] [--path] [-o ]" 29 | exitWith ExitSuccess 30 | 31 | getOpts :: IO Opts 32 | getOpts = do xs <- getArgs 33 | return $ process erlDefaultOpts xs 34 | where 35 | process opts ("--interface":xs) = process (opts { interface = True }) xs 36 | process opts ("--path":_) = opts {show_path = True} 37 | process opts ("-o":o:xs) = process (opts {output = o}) xs 38 | process opts (x:xs) = process (opts {inputs = x:inputs opts}) xs 39 | process opts [] = opts 40 | 41 | erl_main :: Opts -> Idris () 42 | erl_main opts = do elabPrims 43 | loadInputs (inputs opts) Nothing 44 | mainProg <- if interface opts 45 | then return Nothing 46 | else liftM Just elabMain 47 | ir <- compile (Via IBCFormat "erlang") (output opts) mainProg 48 | runIO $ codegenErlang ir 49 | 50 | main :: IO () 51 | main = do opts <- getOpts 52 | data_dir <- getDataFileName "irts" 53 | if (show_path opts) 54 | then putStrLn ("-pa " ++ data_dir ++ "") >> exitWith ExitSuccess 55 | else return () 56 | if (null (inputs opts)) 57 | then showUsage 58 | else runMain (erl_main opts) 59 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.18 2 | 3 | packages: 4 | - location: . 5 | --------------------------------------------------------------------------------