camlp5o pr_scheme.cmo pr_schemep.cmo s.ml > s.scm

s.ml

type t =
  | Leaf of int * string
  | Concat of int * t * t

let length = function
  | Leaf (i, _) -> i
  | Concat (i, _, _) -> i

let leaf s =
  Leaf (String.length s, s)

let empty = leaf ""

let (^) t1 t2 =
  Concat (length t1 + length t2, t1, t2)

let (@+) s t =
  leaf s ^ t

let (+@) t s =
  t ^ leaf s

let to_string t =
  let buf = Buffer.create @@ length t in
  let rec loop = function
    | Leaf (_, s) -> Buffer.add_string buf s
    | Concat (_, t1, t2) ->
      loop t1;
      loop t2
  in
  loop t;
  Buffer.contents buf

(* tail-recursive *)
let to_string' t =
  let buf = Buffer.create @@ length t in
  let rec loop rest = function
    | Leaf (_, s) ->
      Buffer.add_string buf s;
      begin match rest with
      | r::rs ->
        loop rs r
      | [] ->
        Buffer.contents buf
      end
    | Concat (_, t1, t2) ->
      loop (t2::rest) t1
  in loop [] t

let () =
  ("1" @+ empty) +@ "2" |> to_string' |> print_endline;
  "1" @+ (empty +@ "2") |> to_string' |> print_endline;
  "1" @+ (empty +@ "2" +@ "3") |> to_string' |> print_endline;
  ("1" @+ empty +@ "2") +@ "3" |> to_string' |> print_endline;
  empty +@ "1" +@ "2" +@ "3" +@ "4" |> to_string' |> print_endline;
  let x = leaf "xy" in
  let x = "{" @+ "(" @+ x +@ ")" +@ "}" in
  x |> to_string' |> print_endline;
  ()

let to_string'' t =
  let rec loop acc rest = function
    | Leaf (_, s) ->
      begin match rest with
      | [] -> s::acc
      | r::rs -> loop (s::acc) rs r
      end
    | Concat (_, t1, t2) ->
      loop acc (t1::rest) t2
  in
  loop [] [] t |> String.concat ""

let () =
  ("1" @+ empty) +@ "2" |> to_string'' |> print_endline;
  "1" @+ (empty +@ "2") |> to_string'' |> print_endline;
  "1" @+ (empty +@ "2" +@ "3") |> to_string'' |> print_endline;
  ("1" @+ empty +@ "2") +@ "3" |> to_string'' |> print_endline;
  empty +@ "1" +@ "2" +@ "3" +@ "4" |> to_string'' |> print_endline;
  let x = leaf "xy" in
  let x = "{" @+ "(" @+ x +@ ")" +@ "}" in
  x |> to_string'' |> print_endline;
  ()

s.scm

(type t
 (sum
  (Leaf int string)
  (Concat int t t)))

(define length
 (lambda_match
  ((Leaf i _) i)
  ((Concat i _ _) i)))

(define (leaf s) (Leaf (String.length s) s))

(define empty (leaf ""))

(define (^ t1 t2) (Concat (+ (length t1) (length t2)) t1 t2))

(define (@+ s t) (^ (leaf s) t))

(define (+@ t s) (^ t (leaf s)))

(define (to_string t)
 (let ((buf (@@ Buffer.create (length t))))
  (letrec
   ((loop
     (lambda_match
      ((Leaf _ s) (Buffer.add_string buf s))
      ((Concat _ t1 t2) (begin (loop t1) (loop t2))))))
   (begin (loop t) (Buffer.contents buf)))))

(* tail-recursive *)
(define (to_string' t)
 (let ((buf (@@ Buffer.create (length t))))
  (letrec
   (((loop rest)
     (lambda_match
      ((Leaf _ s)
       (begin
        (Buffer.add_string buf s)
        (match rest ([r . rs] (loop rs r)) ([] (Buffer.contents buf)))))
      ((Concat _ t1 t2) (loop [t2 . rest] t1)))))
   (loop [] t))))

(define ()
 (begin
  (|> (|> (+@ (@+ "1" empty) "2") to_string') print_endline)
  (|> (|> (@+ "1" (+@ empty "2")) to_string') print_endline)
  (|> (|> (@+ "1" (+@ (+@ empty "2") "3")) to_string') print_endline)
  (|> (|> (+@ (@+ "1" (+@ empty "2")) "3") to_string') print_endline)
  (|> (|> (+@ (+@ (+@ (+@ empty "1") "2") "3") "4") to_string') print_endline)
  (let* ((x (leaf "xy")) (x (@+ "{" (@+ "(" (+@ (+@ x ")") "}")))))
   (begin (|> (|> x to_string') print_endline) ()))))

(define (to_string'' t)
 (letrec
  (((loop acc rest)
    (lambda_match
     ((Leaf _ s) (match rest ([] [s . acc]) ([r . rs] (loop [s . acc] rs r))))
     ((Concat _ t1 t2) (loop acc [t1 . rest] t2)))))
  (|> (loop [] [] t) (String.concat ""))))

(define ()
 (begin
  (|> (|> (+@ (@+ "1" empty) "2") to_string'') print_endline)
  (|> (|> (@+ "1" (+@ empty "2")) to_string'') print_endline)
  (|> (|> (@+ "1" (+@ (+@ empty "2") "3")) to_string'') print_endline)
  (|> (|> (+@ (@+ "1" (+@ empty "2")) "3") to_string'') print_endline)
  (|> (|> (+@ (+@ (+@ (+@ empty "1") "2") "3") "4") to_string'')
   print_endline)
  (let* ((x (leaf "xy")) (x (@+ "{" (@+ "(" (+@ (+@ x ")") "}")))))
   (begin (|> (|> x to_string'') print_endline) ()))))