Merge pull request #6 from juusaw/js-of-ocaml

Compile target: Javascript

build.sh

@@ -1,3 +1,19 @@
 #!/bin/bash 
-corebuild -use-menhir src/cli.native
-mv cli.native troll
+case "$1" in
+  ""|"native")
+    echo "Compiling to native binary..."
+    corebuild -use-menhir src/cli.native
+    mv cli.native troll
+    ;;
+  "javascript")
+    echo "Compiling to Javascript..."
+    ocamlbuild -use-ocamlfind -pkgs 'base,js_of_ocaml,js_of_ocaml.ppx' -use-menhir src/javascript.byte
+    js_of_ocaml +base/runtime.js javascript.byte
+    mv javascript.js troll.js
+    ;;
+  *)
+    echo "Illegal argument to build script"
+    exit 1
+    ;;
+esac
+exit 0

src/cli.ml

@@ -10,12 +10,18 @@ struct
     +> flag "--times" (optional_with_default 1 int) ~doc:"int Number of rolls"
     +> flag "--seed" (optional int) ~doc:"int Seed value for dice"
 
+  let get_lex_stream filename =
+    let lb = Lexing.from_channel
+        (match filename with
+           Some (filename) -> (In_channel.create filename)
+         | None -> In_channel.stdin) in lb
+
   let command =
     Command.basic_spec
       ~summary:"Simulate dice rolling based on a domain-specific syntax"
       ~readme:(fun () -> "Command-line options")
       spec
-      (fun filename count seed () -> Main.main filename count seed)
+      (fun filename count seed () -> Main.main (get_lex_stream filename) count seed)
 
   let () =
     Command.run ~version:"0.0.1" command

src/javascript.ml

@@ -0,0 +1,10 @@
+open Main
+
+module Javascript =
+struct
+  let () =
+    Js.export_all
+      (object%js
+        method run src = Main.main (Lexing.from_string (Js.to_string src)) 1 (Some 1)
+      end)
+end

src/lexer.mll

@@ -1,8 +1,9 @@
 {
 
-open Core
+open Base
 open Lexing
 open Parser
+
 let currentLine = ref 1
 let lineStartPos = ref [0]
 
@@ -12,11 +13,10 @@ let rec getPos lexbuf = getLineCol (lexeme_start lexbuf)
 
 and getLineCol p l s = match p, l, s with
   pos, line, (p1::ps) ->
-      if pos>=p1 then (line, pos-p1)
+      if pos >= p1 then (line, pos - p1)
       else getLineCol pos (line - 1) ps
   | _, _, [] -> (0,0) (* should not happen *)
 
-
 exception LexicalError of string * (int * int) (* (message, (line, column)) *)
 
 let lexerError lexbuf s =
@@ -72,11 +72,11 @@ rule token = parse
                           token lexbuf } (* newlines *)
   | "\\" [^ '\n' '\012']*
                         { token lexbuf } (* comment *)
-  | ['0'-'9']+          { match int_of_string_opt (lexeme lexbuf) with
+  | ['0'-'9']+          { match Caml.int_of_string_opt (lexeme lexbuf) with
                                None   -> lexerError lexbuf "Bad integer"
                              | Some i -> Parser.NUM (i, getPos lexbuf)
                         }
-  | "0."['0'-'9']+ 	{ match float_of_string_opt (lexeme lexbuf) with
+  | "0."['0'-'9']+ 	{ match Caml.float_of_string_opt (lexeme lexbuf) with
                                None   -> lexerError lexbuf "Bad number"
                              | Some p -> Parser.FLOAT (p, getPos lexbuf)
                         }

src/main.ml

@@ -1,21 +1,21 @@
-open Core
+open Base
 open Lexing
 open Interpreter
 open Parser
 
 module Main =
 struct
 
-  let print s = Pervasives.print_string s
+  let print s = Caml.Pervasives.print_string s
 
   let times n f =  List.init n ~f:(fun _ -> f())
 
   let stringVal l =
     String.concat
       ~sep:" "
       (List.map
-         ~f:(fun n -> if n >= 0 then string_of_int n
-              else "-" ^ string_of_int (~-n))
+         ~f:(fun n -> if n >= 0 then Int.to_string n
+              else "-" ^ Int.to_string (~-n))
          l)
 
   let rec stringIVal = function
@@ -27,47 +27,43 @@ struct
 
   let printVal v = print (stringIVal v ^"\n")
 
-  let run filename n defs =
-    let lb = Lexing.from_channel
-        (match filename with
-           Some (filename) -> (In_channel.create filename)
-         | None -> In_channel.stdin) in
+  let run lb n defs =
     let dice =
       let (decls,exp) = Parser.dice Lexer.token lb in
       (decls, defs exp) in
     let roll = fun _ -> printVal (Interpreter.rollDice (Syntax.Syntax.optimize_tco dice)) in
     List.hd (times n roll)
 
-  let errorMess s = print s (* TODO: To stderr? *)
+  let print_error = print (* TODO: To stderr? *)
 
   let findDef str =
     match String.split_on_chars ~on:['='] str with
-      [name;valString] -> (match int_of_string_opt valString with
+      [name;valString] -> (match Caml.int_of_string_opt valString with
           None -> None
         | Some (value) -> Some (name,value))
     | _ -> None
 
-  let main filename count seed =
+  let main source count seed =
     let () = match seed with
         Some s -> Random.init s
       | None -> Random.self_init () in
     try
-      match run filename count (fun d -> d) with
+      match run source count (fun d -> d) with
         _ -> ()
-    with Parsing.YYexit _ -> errorMess "Parser-exit\n"
+    with Caml.Parsing.YYexit _ -> print_error "Parser-exit\n"
        | Parser.Error ->
          let (lin,col)
            = Lexer.getLineCol 0
              (!Lexer.currentLine)
              (!Lexer.lineStartPos) in
-         errorMess ("Parse-error at line "
-                    ^ string_of_int lin ^ ", column " ^ string_of_int col)
+         print_error ("Parse-error at line "
+                      ^ Int.to_string lin ^ ", column " ^ Int.to_string col)
        | Lexer.LexicalError (mess,(lin,col)) ->
-         errorMess ("Lexical error: " ^mess^ " at line "
-                    ^ string_of_int lin ^ ", column " ^ string_of_int col)
+         print_error ("Lexical error: " ^mess^ " at line "
+                      ^ Int.to_string lin ^ ", column " ^ Int.to_string col)
        | Interpreter.RunError (mess,(lin,col)) ->
-         errorMess ("Runtime error: " ^mess^ " at line "
-                    ^ string_of_int lin ^ ", column " ^ string_of_int col)
-       | Sys_error s -> errorMess ("Exception: " ^ s)
+         print_error ("Runtime error: " ^mess^ " at line "
+                      ^ Int.to_string lin ^ ", column " ^ Int.to_string col)
+       | Sys_error s -> print_error ("Exception: " ^ s)
 
 end

src/parser.mly

@@ -1,9 +1,15 @@
 %{
 
-open Core
+open Base
 
 module S = Syntax
 
+module Printf = Caml.Printf
+
+module Obj = Caml.Obj
+
+module Pervasives = Caml.Pervasives
+
 let p0 = (0,0)
 
 let fst x = let y, _ = x in y

src/syntax.ml

@@ -1,4 +1,4 @@
-open Core
+open Base
 
 module Syntax =
 struct
@@ -67,7 +67,7 @@ struct
 
   let rec string_of_exp exp =
     match exp with
-      NUM (i, _) -> string_of_int i
+      NUM (i, _) -> Int.to_string i
     | EMPTY -> "{}"
     | ID (x, _) -> x
     | CONC (e1, e2, _) -> "{" ^ string_of_exp e1 ^ ", " ^ string_of_exp e2 ^ "}"
@@ -124,7 +124,7 @@ struct
     | VCONCL (e1, e2, _) -> "(" ^ string_of_exp e1 ^ " |> " ^ string_of_exp e2 ^ ")"
     | VCONCR (e1, e2, _) -> "(" ^ string_of_exp e1 ^ " <| " ^ string_of_exp e2 ^ ")"
     | VCONCC (e1, e2, _) -> "(" ^ string_of_exp e1 ^ " <> " ^ string_of_exp e2 ^ ")"
-    | QUESTION (q, _) -> "?" ^ string_of_float q
+    | QUESTION (q, _) -> "?" ^ Float.to_string q
     | PAIR (e1, e2, _) -> "[" ^ string_of_exp e1 ^ " , " ^ string_of_exp e2 ^ "]"
     | FIRST (e1, _) -> "%1( " ^ string_of_exp e1 ^ ")"
     | SECOND (e1, _) -> "%2( " ^ string_of_exp e1 ^ ")"