ocaml/core.ml

   1 module T = Types.Types
   2 let ns = Env.make None
   3
   4 let num_fun t f = Types.fn
   5   (function
   6     | [(T.Int a); (T.Int b)] -> t (f a b)
   7     | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin"))
   8
   9 let mk_int x = T.Int x
  10 let mk_bool x = T.Bool x
  11
  12 let seq = function
  13   | T.List   { T.value = xs } -> xs
  14   | T.Vector { T.value = xs } -> xs
  15   | T.Map    { T.value = xs } ->
  16      Types.MalMap.fold (fun k v list -> k :: v :: list) xs []
  17   | _ -> []
  18
  19 let rec assoc = function
  20   | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs)
  21   | [T.Nil; k; v] -> Types.map (Types.MalMap.add k v Types.MalMap.empty)
  22   | [T.Map { T.value = m; T.meta = meta }; k; v]
  23     -> T.Map { T.value = (Types.MalMap.add k v m);
  24                T.meta = meta }
  25   | _ -> T.Nil
  26
  27 let rec dissoc = function
  28   | c :: x :: (_ :: _ as xs) -> dissoc ((dissoc [c; x]) :: xs)
  29   | [T.Map { T.value = m; T.meta = meta }; k]
  30     -> T.Map { T.value = (Types.MalMap.remove k m);
  31                T.meta = meta }
  32   | _ -> T.Nil
  33
  34 let rec conj = function
  35   | c :: x :: (_ :: _ as xs) -> conj ((conj [c; x]) :: xs)
  36   | [T.Map { T.value = c; T.meta = meta }; T.Vector { T.value = [k; v] }]
  37     -> T.Map { T.value = (Types.MalMap.add k v c);
  38                T.meta = meta }
  39   | [T.List { T.value = c; T.meta = meta }; x ]
  40     -> T.List { T.value = x :: c;
  41                 T.meta = meta }
  42   | [T.Vector { T.value = c; T.meta = meta }; x ]
  43     -> T.Vector { T.value = c @ [x];
  44                   T.meta = meta }
  45   | _ -> T.Nil
  46
  47 let init env = begin
  48   Env.set env (Types.symbol "throw")
  49           (Types.fn (function [ast] -> raise (Types.MalExn ast) | _ -> T.Nil));
  50
  51   Env.set env (Types.symbol "+")  (num_fun mk_int  ( +  ));
  52   Env.set env (Types.symbol "-")  (num_fun mk_int  ( -  ));
  53   Env.set env (Types.symbol "*")  (num_fun mk_int  ( *  ));
  54   Env.set env (Types.symbol "/")  (num_fun mk_int  ( /  ));
  55   Env.set env (Types.symbol "<")  (num_fun mk_bool ( <  ));
  56   Env.set env (Types.symbol "<=") (num_fun mk_bool ( <= ));
  57   Env.set env (Types.symbol ">")  (num_fun mk_bool ( >  ));
  58   Env.set env (Types.symbol ">=") (num_fun mk_bool ( >= ));
  59
  60   Env.set env (Types.symbol "list") (Types.fn (function xs -> Types.list xs));
  61   Env.set env (Types.symbol "list?")
  62     (Types.fn (function [T.List _] -> T.Bool true | _ -> T.Bool false));
  63   Env.set env (Types.symbol "vector") (Types.fn (function xs -> Types.vector xs));
  64   Env.set env (Types.symbol "vector?")
  65     (Types.fn (function [T.Vector _] -> T.Bool true | _ -> T.Bool false));
  66   Env.set env (Types.symbol "empty?")
  67     (Types.fn (function
  68                 | [T.List   {T.value = []}] -> T.Bool true
  69                 | [T.Vector {T.value = []}] -> T.Bool true
  70                 | _ -> T.Bool false));
  71   Env.set env (Types.symbol "count")
  72     (Types.fn (function
  73                 | [T.List   {T.value = xs}]
  74                 | [T.Vector {T.value = xs}] -> T.Int (List.length xs)
  75                 | _ -> T.Int 0));
  76   Env.set env (Types.symbol "=")
  77     (Types.fn (function
  78                 | [a; b] -> T.Bool (Types.mal_equal a b)
  79                 | _ -> T.Bool false));
  80
  81   Env.set env (Types.symbol "pr-str")
  82     (Types.fn (function xs ->
  83       T.String (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs))));
  84   Env.set env (Types.symbol "str")
  85     (Types.fn (function xs ->
  86       T.String (String.concat "" (List.map (fun s -> Printer.pr_str s false) xs))));
  87   Env.set env (Types.symbol "prn")
  88     (Types.fn (function xs ->
  89       print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs));
  90       T.Nil));
  91   Env.set env (Types.symbol "println")
  92     (Types.fn (function xs ->
  93       print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s false) xs));
  94       T.Nil));
  95
  96   Env.set env (Types.symbol "compare")
  97     (Types.fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil));
  98   Env.set env (Types.symbol "with-meta")
  99     (Types.fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil));
 100   Env.set env (Types.symbol "meta")
 101     (Types.fn (function [x] -> Printer.meta x | _ -> T.Nil));
 102
 103   Env.set env (Types.symbol "read-string")
 104     (Types.fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil));
 105   Env.set env (Types.symbol "slurp")
 106     (Types.fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil));
 107
 108   Env.set env (Types.symbol "cons")
 109     (Types.fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil));
 110   Env.set env (Types.symbol "concat")
 111     (Types.fn (let rec concat =
 112                  function
 113                  | x :: y :: more -> concat ((Types.list ((seq x) @ (seq y))) :: more)
 114                  | [x] -> x
 115                  | [] -> Types.list []
 116                in concat));
 117
 118   Env.set env (Types.symbol "nth")
 119     (Types.fn (function [xs; T.Int i] -> List.nth (seq xs) i | _ -> T.Nil));
 120   Env.set env (Types.symbol "first")
 121     (Types.fn (function
 122                 | [xs] -> (match seq xs with x :: _ -> x | _ -> T.Nil)
 123                 | _ -> T.Nil));
 124   Env.set env (Types.symbol "rest")
 125     (Types.fn (function
 126                 | [xs] -> Types.list (match seq xs with _ :: xs -> xs | _ -> [])
 127                 | _ -> T.Nil));
 128
 129   Env.set env (Types.symbol "symbol")
 130     (Types.fn (function [T.String x] -> Types.symbol x | _ -> T.Nil));
 131   Env.set env (Types.symbol "symbol?")
 132     (Types.fn (function [T.Symbol _] -> T.Bool true | _ -> T.Bool false));
 133   Env.set env (Types.symbol "keyword")
 134     (Types.fn (function [T.String x] -> T.Keyword x | _ -> T.Nil));
 135   Env.set env (Types.symbol "keyword?")
 136     (Types.fn (function [T.Keyword _] -> T.Bool true | _ -> T.Bool false));
 137   Env.set env (Types.symbol "nil?")
 138     (Types.fn (function [T.Nil] -> T.Bool true | _ -> T.Bool false));
 139   Env.set env (Types.symbol "true?")
 140     (Types.fn (function [T.Bool true] -> T.Bool true | _ -> T.Bool false));
 141   Env.set env (Types.symbol "false?")
 142     (Types.fn (function [T.Bool false] -> T.Bool true | _ -> T.Bool false));
 143   Env.set env (Types.symbol "sequential?")
 144     (Types.fn (function [T.List _] | [T.Vector _] -> T.Bool true | _ -> T.Bool false));
 145   Env.set env (Types.symbol "apply")
 146     (Types.fn (function
 147                 | (T.Fn { T.value = f } :: apply_args) ->
 148                    (match List.rev apply_args with
 149                     | last_arg :: rev_args ->
 150                        f ((List.rev rev_args) @ (seq last_arg))
 151                     | [] -> f [])
 152                 | _ -> raise (Invalid_argument "First arg to apply must be a fn")));
 153   Env.set env (Types.symbol "map")
 154     (Types.fn (function
 155                 | [T.Fn { T.value = f }; xs] ->
 156                    Types.list (List.map (fun x -> f [x]) (seq xs))
 157                 | _ -> T.Nil));
 158   Env.set env (Types.symbol "readline")
 159     (Types.fn (function
 160                 | [T.String x] -> print_string x; T.String (read_line ())
 161                 | _ -> T.String (read_line ())));
 162
 163   Env.set env (Types.symbol "map?")
 164     (Types.fn (function [T.Map _] -> T.Bool true | _ -> T.Bool false));
 165   Env.set env (Types.symbol "hash-map")
 166     (Types.fn (function xs -> Types.list_into_map Types.MalMap.empty xs));
 167   Env.set env (Types.symbol "assoc") (Types.fn assoc);
 168   Env.set env (Types.symbol "dissoc") (Types.fn dissoc);
 169   Env.set env (Types.symbol "get")
 170     (Types.fn (function
 171                 | [T.Map { T.value = m }; k]
 172                   -> (try Types.MalMap.find k m with _ -> T.Nil)
 173                 | _ -> T.Nil));
 174   Env.set env (Types.symbol "keys")
 175     (Types.fn (function
 176                 | [T.Map { T.value = m }]
 177                   -> Types.list (Types.MalMap.fold (fun k _ c -> k :: c) m [])
 178                 | _ -> T.Nil));
 179   Env.set env (Types.symbol "vals")
 180     (Types.fn (function
 181                 | [T.Map { T.value = m }]
 182                   -> Types.list (Types.MalMap.fold (fun _ v c -> v :: c) m [])
 183                 | _ -> T.Nil));
 184   Env.set env (Types.symbol "contains?")
 185     (Types.fn (function
 186                 | [T.Map { T.value = m }; k] -> T.Bool (Types.MalMap.mem k m)
 187                 | _ -> T.Bool false));
 188   Env.set env (Types.symbol "conj") (Types.fn conj);
 189
 190   Env.set env (Types.symbol "atom?")
 191           (Types.fn (function [T.Atom _] -> T.Bool true | _ -> T.Bool false));
 192   Env.set env (Types.symbol "atom")
 193           (Types.fn (function [x] -> T.Atom (ref x) | _ -> T.Nil));
 194   Env.set env (Types.symbol "deref")
 195           (Types.fn (function [T.Atom x] -> !x | _ -> T.Nil));
 196   Env.set env (Types.symbol "reset!")
 197           (Types.fn (function [T.Atom x; v] -> x := v; v | _ -> T.Nil));
 198   Env.set env (Types.symbol "swap!")
 199           (Types.fn (function T.Atom x :: T.Fn { T.value = f } :: args
 200                               -> let v = f (!x :: args) in x := v; v | _ -> T.Nil));
 201
 202   Env.set env (Types.symbol "time-ms")
 203           (Types.fn (function _ -> T.Int (truncate (1000.0 *. Unix.gettimeofday ()))));
 204 end