From b8f72603f4e3d984552fb2fb5cef1f859a10bd25 Mon Sep 17 00:00:00 2001 From: Neale Pickett Date: Sun, 8 Nov 2009 17:28:07 -0700 Subject: [PATCH] Looks like I was trying to add scheme callbacks. --- Makefile | 4 ++++ arf.ml | 8 ++++++++ bindings.ml | 40 ++++++++++++++++++++++++++++++++++++++++ bot.ml | 22 ++++++++++++++++++---- bot_ocs.ml | 44 ++++++++++++++++++++++++++++++++++++++++++++ callback.ml | 24 ++++++++++++++++++++++++ 6 files changed, 138 insertions(+), 4 deletions(-) create mode 100644 arf.ml create mode 100644 bindings.ml create mode 100644 bot_ocs.ml create mode 100644 callback.ml diff --git a/Makefile b/Makefile index e01ff5c..ef4bfab 100644 --- a/Makefile +++ b/Makefile @@ -13,6 +13,10 @@ bot: irc.cmo dispatch.cmo command.cmo iobuf.cmo cdb.cmo bot.cmo bot: $(OCS_DIR)/src/ocs.cma $(OCAMLC) -o $@ $(OCAMLLIBS) $^ +callback: callback.cmo +callback: $(OCS_DIR)/src/ocs.cma + $(OCAMLC) -o $@ $(OCAMLLIBS) $^ + $(OCS_DIR)/src/ocs.cma $(OCS_DIR)/src/ocs.cmxa: $(OCS_DIR) cd $(OCS_DIR)/src && make diff --git a/arf.ml b/arf.ml new file mode 100644 index 0000000..61faeb2 --- /dev/null +++ b/arf.ml @@ -0,0 +1,8 @@ +type goob = Goob of (int ref) * int + +let _ = + let a = Goob (ref 1, 2) in + if (match a with + | Goob ({contents = 1}, _) -> true + | _ -> false) then + print_endline "hi asl" diff --git a/bindings.ml b/bindings.ml new file mode 100644 index 0000000..f291913 --- /dev/null +++ b/bindings.ml @@ -0,0 +1,40 @@ +type callback = Iobuf.t -> Command.t -> unit +type t = (string * Str.regexp * callback) list + +let create () = [] + +let remove b id = + let keep = function + | (id', _, _) -> + id' <> id + in + List.filter keep b + +let add b id regex cb = + (id, regex, cb) :: (remove b id) + +let lookup b text = + let rec groups str i acc = + try + groups str (i + 1) ((Str.matched_group i str) :: acc) + with + | Not_found -> + groups str (i + 1) ("" :: acc) + | Invalid_argument _ -> + List.rev acc + in + let rec loop b acc = + match b with + | [] -> + List.rev acc + | (id, regex, cb) :: tl -> + try + ignore (Str.search_forward regex text 0); + loop tl ((id, cb, groups text 0 []) :: acc) + with Not_found -> + loop tl acc + in + loop b [] + + + diff --git a/bot.ml b/bot.ml index 081d14d..8b37d49 100644 --- a/bot.ml +++ b/bot.ml @@ -5,7 +5,7 @@ let choice l = let n = Random.int (List.length l) in List.nth l n -let get_one key = +let choose_one key = let matches = Cdb.get_matches info_db key in match Stream.npeek 120 matches with | [] -> raise Not_found @@ -16,10 +16,24 @@ let write iobuf command args text = print_endline ("--> " ^ (Command.as_string cmd)); Iobuf.write iobuf cmd +let make_sandbox_env () = + let e = Ocs_env.top_env () in + Ocs_compile.bind_lang e; + Ocs_macro.bind_macro e; + Ocs_num.init e; + Ocs_numstr.init e; + Ocs_prim.init e; + Ocs_vector.init e; + Ocs_list.init e; + Ocs_char.init e; + Ocs_string.init e; + Ocs_contin.init e; + e + let scheme_eval str = try let thread = Ocs_top.make_thread () in - let env = Ocs_top.make_env () in + let env = make_sandbox_env () in let inport = Ocs_port.open_input_string str in let outport = Ocs_port.open_output_string () in let lexer = Ocs_lex.make_lexer inport "interactive" in @@ -35,7 +49,7 @@ let scheme_eval str = let handle_privmsg iobuf sender target text = try - let factoid = get_one text in + let factoid = choose_one text in let response = match factoid.[0] with | ':' -> @@ -43,7 +57,7 @@ let handle_privmsg iobuf sender target text = | '\\' -> Str.string_after factoid 1 | _ -> - Printf.sprintf "Gosh, %s, I think %s is %s" sender text factoid + Printf.sprintf "I've heard that %s is %s" text factoid in write iobuf "PRIVMSG" [target] (Some response) with Not_found -> diff --git a/bot_ocs.ml b/bot_ocs.ml new file mode 100644 index 0000000..0af42db --- /dev/null +++ b/bot_ocs.ml @@ -0,0 +1,44 @@ +open Ocs_types + +module Iobuf = + Ocs_wrap.Make (struct + type t = Iobuf.t + end) + +let rec string_list_of_spair v acc = + match v with + | Snull -> + acc + | Spair { car = Sstring s; cdr = cdr } -> + string_list_of_spair cdr (acc @ s) + | _ -> + raise Ocs_error.Error "Not a string list" + +let write_vals iobuf vals = + let cmd = + match vals with + | [| Swrapped iobuf; Sstring command; Spair args; Sstring text |] -> + Command.create None command (string_list_of_spair args) (Some text) + | [| Swrapped iobuf; Sstring command; Spair args |] -> + Command.create None command (string_list_of_spair args) None + | _ -> + raise Ocs_error.Error "Invalid arguments" + in + Iobuf.write iobuf cmd + +let iobuf_write_proc iobuf = + let primf = Pfn (write_vals iobuf) in + let sprim = { prim_fun = primf; prim_name = "iobuf-write" } in + Sproc (sprim, [| [| |] |]) + +let ocs_bind b regexp cb = + match (regexp, cb) with + | (Sstring regexp_s, Sproc (p, d)) -> + let regexp = Str.regexp regexp_s in + b := Bindings.add (regexp_s, regexp, p) + | _ -> + raise Ocs_error.Error "invalid arguments" + +let init b e = + set_pf3 e (ocs_bind b) "bind" + diff --git a/callback.ml b/callback.ml new file mode 100644 index 0000000..44dcdac --- /dev/null +++ b/callback.ml @@ -0,0 +1,24 @@ +open Ocs_types + +let prefix_print prefix = + function + | [| Sstring txt |] -> + print_endline (prefix ^ txt); + Sunspec + | _ -> + raise (Ocs_error.Error "Invalid arguments") + +let prefix_print_proc prefix = + let primf = Pfn (prefix_print prefix) in + let sprim = { prim_fun = primf; prim_name = "iobuf-write" } in + Sprim sprim + +let code = + Capply1 ((Cval (prefix_print_proc "pfx: ")), + (Cval (Sstring "hello world"))) + +let _ = + let thread = Ocs_top.make_thread () in + let outport = Ocs_port.open_output_string () in + Ocs_eval.eval thread (Ocs_print.print outport false) code; + Ocs_port.get_output_string outport