From 821ab1eaf130bb74857b6deee48b9efa4d41e29c Mon Sep 17 00:00:00 2001
From: jutty <j@jutty.dev>
Date: Tue, 13 May 2025 02:30:25 -0300
Subject: [PATCH] OCaml: Implement Writer monad

---
 ocaml/bin/main.ml             |  2 ++
 ocaml/lib/types/structures.ml | 65 +++++++++++++++++++++++++++++++++++
 2 files changed, 67 insertions(+)
 create mode 100644 ocaml/lib/types/structures.ml

diff --git a/ocaml/bin/main.ml b/ocaml/bin/main.ml
index 9bf5a0b..817140c 100644
--- a/ocaml/bin/main.ml
+++ b/ocaml/bin/main.ml
@@ -1,5 +1,6 @@
 module ConfigFetcher = Tori.Parsers.Config.Fetcher
 
+
 let () =
 
     match Array.to_list Sys.argv with
@@ -12,3 +13,4 @@ let () =
         in
         exit future.meta.status
     | [] -> assert false
+
diff --git a/ocaml/lib/types/structures.ml b/ocaml/lib/types/structures.ml
new file mode 100644
index 0000000..1d6f08a
--- /dev/null
+++ b/ocaml/lib/types/structures.ml
@@ -0,0 +1,65 @@
+open Utilities.Aliases
+type schema = Schema.schema
+
+module type Monad = sig
+    type 'f t
+    val lift : 'f -> ('f * string)
+    val (>>=) : 'f t -> ('f -> 'b t) -> 'b t
+    val ( let* ) : 'f t -> ('f -> 'b t) -> 'b t
+end
+
+module type Writer = sig
+    include Monad
+    val write : string -> unit t
+    val read : 'f t -> string
+    val withdraw : 'f t -> 'f
+end
+
+module Writer : Writer with type 'f t = 'f * string = struct
+
+    type 'f t = 'f * string
+
+    let lift f = (f, "")
+
+    let append_newline s =
+        if s == "" then s else s ^"\n"
+
+    let (>>=) pair f =
+        let (past, pre_str) = pair in
+        let (future, post_str) = f past in
+        (future, append_newline pre_str ^ post_str)
+
+    let ( let* ) = ( >>= )
+
+    let write (s : string) = ((), s)
+    let read (_, s) = s
+    let withdraw (m, s) = print s; m (* should this I/O live here? *)
+
+end
+
+let demo : unit =
+    let open Writer in
+
+    let add (i: int) (m: schema): schema =
+        { m with meta = { m.meta with status = m.meta.status + i }}
+    in
+
+    let log_add (i: int) (m: schema): schema t =
+        let current = str_int m.meta.status in
+        let partial = str_int $ m.meta.status + i in
+        let addend = str_int i in
+        add i m, "adding: " ^ current ^ " + " ^ addend ^ " = " ^ partial
+    in
+
+    let (m: schema) = withdraw (
+        lift Schema.origin >>=
+        log_add 1 >>=
+        log_add 2 >>=
+        (* how can this be simplified? *)
+        fun carry -> write "just write" >>= fun () ->
+        log_add 1 carry >>=
+        log_add 5
+    ) in
+
+    print_endline $ "total: " ^ str_int m.meta.status
+