c

.gitignore

@@ -0,0 +1,14 @@
+build.ninja
+.ninja_log
+.ninja_deps
+build/
+
+
+core
+*.cmx
+*.cml
+*.cmi
+*.cmo
+*.o
+*.d
+a.out

configure

@@ -0,0 +1,178 @@
+#!/bin/bash
+args="$@"  # backup for ninja regen
+
+OCAMLC=ocamlc
+OCAMLDEP=ocamldep
+OCAMLC_ARGS=
+OCAMLDEP_ARGS=-bytecode
+OBJEXT=cmo
+OCAMLLD=ocamlc
+OCAMLLD_ARGS=
+
+while [[ $# -gt 0 ]]; do
+  case $1 in
+    *=*)
+      eval "$1"
+      shift 1
+      ;;
+
+    --help|-help|-h|--h)
+      echo "Usage: ./configure [options] key=value ..."
+      echo ""
+      echo "Options:"
+      echo "  --help"
+      echo ""
+      echo "Varaibles:"
+      echo "  OBJEXT        = $OBJEXT"
+      echo "  OCAMLC        = $OCAMLC"
+      echo "  OCAMLDEP      = $OCAMLDEP"
+      echo "  OCAMLC_ARGS   = $OCAMLC_ARGS"
+      echo "  OCAMLDEP_ARGS = $OCAMLDEP_ARGS"
+      echo "  OCAMLLD       = $OCAMLLD"
+      echo "  OCAMLLD_ARGS  = $OCAMLLD_ARGS"
+      exit 0
+      ;;
+
+    *)
+      echo "Unexpected argument: $1"
+      exit 1
+      ;;
+  esac
+done
+
+mkdir -p build
+
+echo '# generated by ../configure
+OCAMLDEP=$1
+shift
+echo ninja_dyndep_version = 1
+$OCAMLDEP -one-line $@ | while read d; do
+  outs="$(echo "$d" | cut -d":" -f1)"
+  ins="$(echo "$d" | cut -d":" -f2)"
+  echo -ne "build build/$outs : dyndep |"
+  for f in $ins; do
+    echo -ne " build/$f"
+  done
+  echo
+done
+' > build/deps.sh
+
+echo "# generated by ../configure" > build/invokeld.sh
+echo "OCAMLDEP=\"$OCAMLDEP\"" >> build/invokeld.sh
+echo "OCAMLDEP_ARGS=\"$OCAMLDEP_ARGS\"" >> build/invokeld.sh
+echo "OCAMLLD=\"$OCAMLLD\"" >> build/invokeld.sh
+echo "OCAMLLD_ARGS=\"$OCAMLLD_ARGS\"" >> build/invokeld.sh
+echo "OBJEXT=\"$OBJEXT\"" >> build/invokeld.sh
+echo '
+set -e
+got=""
+get() {
+  set -e
+  got+=" $1"
+  deps="$($OCAMLDEP $OCAMLDEP_ARGS -one-line $1.ml | cut -d":" -f2)"
+  fixdeps=""
+  for dep in $deps; do
+    dep="$(basename $(basename $dep .cmi) .$OBJEXT)"
+    if ! [ $dep = $1 ]; then
+      fixdeps+=" $dep"
+    fi
+  done
+  for dep in $fixdeps; do
+    echo "$dep $1"
+  done
+  for dep in $fixdeps; do
+    if ! [[ " $got " =~ " $dep " ]]; then
+      get "$dep"
+    fi
+  done
+}
+
+files=""
+for dep in $(get "$(basename $1 .ml)" | tsort); do
+  files+=" build/$dep.$OBJEXT"
+done
+shift
+$OCAMLLD $files $OCAMLLD_ARGS $@
+' >> build/invokeld.sh
+
+
+if ! [ -f project ]; then
+  touch project
+  echo "# ocaml project description" >> project
+  echo "# (this is a bash script)" >> project
+  echo "#" >> project
+  echo "# functions:" >> project
+  echo "#   application [name]" >> project
+  echo "#     create module from \$name.ml, which will be linked with it's dependencies to an executable" >> project
+  echo "#" >> project
+  echo "#   module [name]" >> project
+  echo "#     create module from \$name.ml and \$name.mli" >> project
+  echo "#" >> project
+  echo "#   include [path]" >> project
+  echo "#     include other config path." >> project
+  echo "#     prefer this over regular 'source', because this also adds" >> project
+  echo "#     a dependency to the ninja build file" >> project
+  echo ""
+  echo "# put in project configuration here" >> project
+fi
+
+project_files=""
+module() {
+  true
+}
+application() {
+  true
+}
+include() {
+  project_files+=" $1"
+  source "$1"
+}
+include "project"
+
+rm -f build.ninja
+touch build.ninja
+
+echo "rule regen" >> build.ninja
+echo "  command = ./configure $args" >> build.ninja
+echo "  generator = 1" >> build.ninja
+echo "build build.ninja | build/deps.sh build/invokeld.sh : regen | configure $project_files" >> build.ninja
+echo "" >> build.ninja
+echo "rule ocamlc" >> build.ninja
+echo "  command = $OCAMLC $OCAMLC_ARGS -nocwd -I build -c \$in -o \$out" >> build.ninja
+echo "" >> build.ninja
+echo "rule ocamlld" >> build.ninja
+echo "  command = bash build/invokeld.sh \$in -o \$out" >> build.ninja
+echo "" >> build.ninja
+echo "rule ocamldep" >> build.ninja
+echo "  command = sh build/deps.sh $OCAMLDEP $OCAMLDEP_ARGS \$in > \$out" >> build.ninja
+
+module() {
+  echo "" >> build.ninja
+  echo "build build/$1.dd : ocamldep $1.ml $1.mli || build/deps.sh" >> build.ninja
+  echo "build build/$1.cmi : ocamlc $1.mli || build/$1.dd" >> build.ninja
+  echo "  dyndep = build/$1.dd" >> build.ninja
+  echo "build build/$1.$OBJEXT : ocamlc $1.ml | build/$1.cmi || build/$1.dd " >> build.ninja
+  echo "  dyndep = build/$1.dd" >> build.ninja
+}
+
+application() {
+  echo "" >> build.ninja
+  echo "build build/$1.dd : ocamldep $1.ml || build/deps.sh" >> build.ninja
+  echo "build build/$1.$OBJEXT | build/$1.cmi : ocamlc $1.ml || build/$1.dd" >> build.ninja
+  echo "  dyndep = build/$1.dd" >> build.ninja
+  echo "build build/$1 : ocamlld $1.ml | build/$1.$OBJEXT || build/invokeld.sh" >> build.ninja
+}
+
+include() {
+  project_files+=" $1"
+  source "$1"
+}
+
+for f in $project_files; do
+  source "$f"
+done
+
+
+echo Configuration Done!
+echo Run \"ninja\" to start build
+

example.lsp

@@ -1,22 +1,4 @@
-(:macro seq ())
-
-(:macro seq (hd)
-        (:t "- " hd))
-
-(:macro seq (hd .. tl)
-        (:seq hd) (:seq tl))
-
-(:macro @ ('k)
-        (:t 'k ":"))
-
-(:macro @ (k v)
-        (:t k ": " v))
-
-(:macro @ (k v .. other)
-        (k v)
-        other)
-
-
+(:cfg
   (name "Complex CI/CD Pipeline")
 
   (on
@@ -30,4 +12,4 @@
 
   (env
     (NODE_VERSION 20)
-  (PYTHON_VERSION "3.11"))
+    (PYTHON_VERSION "3.11")))

main.ml

@@ -0,0 +1,24 @@
+let read_all_stdin () =
+  let buf = Buffer.create 4096 in
+  try
+    while true do
+      let line = input_line stdin in
+      Buffer.add_string buf line;
+      Buffer.add_char buf '\n';
+    done;
+    Buffer.contents buf
+  with End_of_file ->
+    Buffer.contents buf
+
+
+let () =
+  let src = read_all_stdin () in
+  let v = Sexpr_macro.sparse src in
+  let v = Sexpr_macro.do_eval v in
+
+  Format.printf "; number of macro expansions: %d\n%!" !Sexpr_macro.num_expands;
+
+  Format.set_margin 40;
+  Format.printf "%a@.@?" Sexpr.pp_t v;
+
+  exit 0

pc.ml

@@ -0,0 +1,407 @@
+type severity = Style | Warning | Error
+
+type parse_error = {
+  severity: severity;
+  pos: int;
+  message: string;
+  expected: string list option;
+  found: string option;
+  other_case: parse_error option;
+}
+
+type src_info = {
+  source: string;
+  path: string;
+}
+
+type cursor = { source: string; pos: int }
+
+type parse_result = {
+  cursor: cursor;
+  errors: parse_error list
+}
+
+type 'a parsr = cursor -> 'a * parse_result
+
+type off2lres = {
+  line: int;    (** 0-indexed *)
+  col:  int;    (** 0-indexed *)
+  lstr: string;
+};;
+
+exception Parser_Cant_Recover of parse_result
+exception Parser_No_Progress of cursor
+
+let num_occ s f =
+  let num = ref 0 in
+  s |> Seq.iter begin fun x ->
+    if f x then
+      num := !num + 1
+  end;
+  !num
+;;
+
+let rec off2l (s:string) (p:int) =
+  let e = match String.index_from_opt s p '\n' with
+    Some(lb) -> lb
+  | None -> String.length s
+  in
+  match String.rindex_from_opt s p '\n' with
+    Some(lb) -> {
+      line = num_occ (Seq.take lb (String.to_seq s)) (fun x -> x = '\n');
+      col = p - lb;
+      lstr = String.sub s (lb + 1) (e - lb - 1) }
+  | None -> {
+      line = 0;
+      col = p;
+      lstr = String.sub s 0 e }
+;;
+
+let str_before s c =
+  match String.index_opt s c with
+    Some(x) -> String.sub s 0 (x - 1)
+  | None    -> s
+;;
+
+let limitw len s =
+  let s = str_before s '\n' in
+  if String.length s > len then
+    (String.sub s 0 (len - 3)) ^ "..."
+  else s
+;;
+
+let rec pp_err (s:src_info) out (e:parse_error) =
+  let open Format in
+  fprintf out "[%s] @[" begin match e.severity with
+    Style   -> "style"
+  | Warning -> "warn "
+  | Error   -> "error"
+  end;
+  fprintf out "%s@]\n" e.message;
+  let where = off2l s.source e.pos in
+  fprintf out "     in @[%s@]\n" s.path;
+  fprintf out "     at %i:%i\n\n" where.line where.col;
+  fprintf out "%3d: %s\n" where.line where.lstr;
+  fprintf out "     ";
+  for _ = 0 to where.col - 2 do
+    fprintf out " "
+  done;
+  fprintf out "^\n";
+  begin match e.expected with
+    Some([]) -> fprintf out "expected: nothing\nbut "
+  | Some(li) -> fprintf out "expected: @[%a@]\nbut "
+                  (Format.pp_print_list Format.pp_print_text) li
+  | None     -> fprintf out "unexpected\n"
+  end;
+  fprintf out "got '@[";
+  begin match e.found with
+  | Some(x) -> fprintf out "%s" @@ limitw 22 x
+  | None    -> fprintf out "something else"
+  end;
+  fprintf out "@]'\n";
+
+  begin match e.other_case with
+    Some(c) -> begin
+      fprintf out "\n  ^^^\n";
+      fprintf out "  \\\ === OR tried alternative parser === \\\\\\\n";
+      fprintf out "                                         \\/\n\n";
+      pp_err s out c
+    end
+  | None -> () end
+;;
+
+let pp_errli s out e =
+  let open Format in
+  let first = ref true in
+  e |> List.iter begin fun e ->
+    if not !first then begin
+      fprintf out "\n"
+    end;
+    first := false;
+    pp_err s out e
+  end
+;;
+
+let head c =
+  if String.length c.source > 0 then
+    Some(String.get c.source 0)
+  else
+    None;;
+
+let create src = { source = src; pos = 0 };;
+
+let expected c str =
+  {
+    severity = Error;
+    pos = c.pos;
+    message  = "";
+    expected = Some([str]);
+    found    = Some(c.source);
+    other_case = None;
+  };;
+
+let seek num c =
+  { source =
+      String.sub c.source num ((String.length c.source) - num);
+    pos = c.pos + num };;
+
+let merge a b =
+  { cursor = b.cursor;
+    errors = a.errors @ b.errors };;
+
+let ok c = { cursor = c; errors = [] }
+let put_err err res = { res with errors = res.errors @ [err] }
+let err c e = put_err e (ok c)
+;;
+
+let single_inline_white c =
+  match head c with
+    Some(' ')  |
+    Some('\b') |
+    Some('\t') ->
+      ((), ok (seek 1 c))
+  | _ -> raise (Parser_Cant_Recover (err c (expected c "inline whitespace")))
+;;
+
+let single_white c =
+  match head c with
+    Some(' ')  |
+    Some('\b') |
+    Some('\t') |
+    Some('\r') |
+    Some('\n') ->
+      ((), ok (seek 1 c))
+  | _ -> raise (Parser_Cant_Recover (err c (expected c "whitespace")))
+;;
+
+let any c =
+  match head c with
+    Some(x) -> (x, ok (seek 1 c))
+  | None    -> raise (Parser_Cant_Recover (err c (expected c "any")))
+;;
+
+let rec repeat p c =
+  try
+    let (v, res) = p c in
+    if res.cursor.pos = c.pos then
+      raise (Parser_No_Progress c)
+    else
+      let (v2, res2) = repeat p res.cursor in
+      (v :: v2, merge res res2)
+  with Parser_Cant_Recover _ ->
+    ([], ok c)
+;;
+
+let many p c =
+  let (av, ar) = p c in
+  let (bv, br) = repeat p (ar.cursor) in
+  (av :: bv, merge ar br)
+;;
+
+let rec until endp p c =
+  try
+    let (_, res) = endp c in
+    ([], res)
+  with Parser_Cant_Recover _ ->
+    let (v, res) = p c in
+    if res.cursor.pos = c.pos then
+      raise (Parser_No_Progress c)
+    else
+      let (v2, res2) = until endp p res.cursor in
+      (v :: v2, merge res res2)
+;;
+
+let map fn p c =
+  let (v, res) = p c in
+  ((fn v), res);;
+
+let set v p c =
+  let (_, res) = p c in
+  (v, res);;
+
+let opt p c =
+  try
+    map (fun x -> Some(x)) p c
+  with Parser_Cant_Recover _ ->
+    (None, ok c)
+;;
+
+let inv p c =
+  let fail = (try
+    let (_, r) = p c in
+    Some(r)
+  with Parser_Cant_Recover _ ->
+    None) in
+
+  let rec ouch r =
+    match r with
+      [] -> None
+    | head :: tail ->
+        let h = (match head.expected with
+          Some(x) -> Some( List.map (fun x -> "not " ^ x) x )
+        | None -> None
+        ) in
+        let t = ouch tail in
+        match h, t with
+          Some(x), Some(y) -> Some(x @ y)
+        | Some(x), None    -> Some(x)
+        | None,    Some(y) -> Some(y)
+        | None,    None    -> None
+  in
+
+  match fail with
+    Some(r) -> raise (Parser_Cant_Recover (err c {
+      severity = Error;
+      pos = c.pos;
+      message = "inverted parser matched";
+      expected = ouch r.errors;
+      found = Some(c.source);
+      other_case = None
+    }))
+  | None -> ((), ok c)
+;;
+
+let also a b c =
+  let (av, ar) = a c in
+  let (_, br) = b c in
+  (av, merge br ar);;
+
+exception Recursive_Parser_Used_Before_Created
+let recursive (prod:'a->'c-> 'v * 'r) (c:cursor) =
+  let future = ref None in
+  let par = prod (fun c -> match !future with
+    None    -> raise Recursive_Parser_Used_Before_Created
+  | Some(p) -> p c) in
+  future := Some(par);
+  par c
+;;
+
+let just str c =
+  if String.starts_with ~prefix:str c.source then
+    (str, ok (seek (String.length str) c))
+  else
+    raise (Parser_Cant_Recover (err c (expected c str)))
+;;
+
+let ex_end c =
+  if (String.length c.source) > 0 then
+    raise (Parser_Cant_Recover (err c (expected c "end of file")))
+  else
+    ((), ok c)
+;;
+
+let chain a b c =
+  let ar = a c in
+  let br = b (snd ar).cursor in
+  ((fst ar, fst br), merge (snd ar) (snd br))
+;;
+
+let ignore_then a b c =
+  let ar = a c in
+  let br = b (snd ar).cursor in
+  ((fst br), merge (snd ar) (snd br))
+;;
+
+let then_ignore a b c =
+  let ar = a c in
+  let br = b (snd ar).cursor in
+  ((fst ar), merge (snd ar) (snd br))
+;;
+
+let nd_of3 a b c =
+  then_ignore (ignore_then a b) c;;
+
+let outer_of3 a b c =
+  chain (then_ignore a b) c;;
+
+let ignore p c =
+  let (_, r) = p c in
+  ((), r);;
+
+let either a b c =
+  try a c
+  with Parser_Cant_Recover ar ->
+    try b c
+    with Parser_Cant_Recover br ->
+      raise (Parser_Cant_Recover {
+        cursor = ar.cursor;
+        errors = [{ (List.hd ar.errors) with
+                   other_case = Some(List.hd br.errors) }]
+      })
+;;
+
+let match_hd label fn c =
+  match head c with
+    Some(x) when fn x ->
+      (x, ok (seek 1 c))
+  | _ -> raise (Parser_Cant_Recover (err c (expected c label)))
+;;
+
+let hd_oneof label li =
+  match_hd label (fun x ->
+    Seq.exists (fun t->t=x) li);;
+
+let digitch =
+  (hd_oneof "digit"
+    (String.to_seq "0123456789"));;
+
+let digit =
+  map (fun x -> Char.code x - Char.code '0')
+  digitch;;
+
+let lower =
+  hd_oneof "lowercase letter"
+    (String.to_seq "abcdefghijklmnopqrstuvwxyz");;
+
+let upper =
+  hd_oneof "uppercase letter"
+    (String.to_seq "ABCDEFGHIJKLMNOPQRSTUVWXYZ");;
+
+let alpha = either lower upper;;
+let alnum = either alpha digitch;;
+
+let sign c =
+  match head c with
+    Some '+' -> ( 1, ok (seek 1 c))
+  | Some '-' -> (-1, ok (seek 1 c))
+  | _        -> ( 1, ok (seek 1 c))
+;;
+
+let p_uint =
+  map (fun digits ->
+    List.fold_right (fun x acc -> acc*10 + x) (List.rev digits) 0
+  ) (many digit)
+;;
+
+let p_int =
+  chain sign p_uint
+  |> map (fun (sign,d) -> sign * d)
+;;
+
+let p_uflt =
+  let fract =
+    map (fun digits ->
+      List.fold_right 
+        (fun x (acc,d) -> (acc +. (Float.of_int x) /. d), d *. 10.0 )
+        (List.rev digits)
+        (0.0,10.0)
+    ) (many digit)
+  in outer_of3 p_int (just ".") fract
+  |> map (fun (a,(b,_)) -> (Float.of_int a) +. b)
+;;
+
+let p_flt =
+  chain sign p_uflt
+  |> map (fun (sign,d) -> Float.of_int sign *. d)
+;;
+
+let doparse f (src:src_info) parsr =
+  let (v,r) = try
+    let (v,r) = parsr (create src.source) in
+    (Some(v), r)
+  with Parser_Cant_Recover r ->
+    (None, r)
+  in
+  pp_errli src f r.errors;
+  v
+;;

pc.mli

@@ -0,0 +1,85 @@
+type severity = Style | Warning | Error
+
+type parse_error = {
+  severity: severity;
+  pos: int;
+  message: string;
+  expected: string list option;
+  found: string option;
+  other_case: parse_error option;
+}
+
+type src_info = {
+  source: string;
+  path: string;
+}
+
+type cursor = { source: string; pos: int }
+
+type parse_result = {
+  cursor: cursor;
+  errors: parse_error list
+}
+
+val pp_err   : src_info -> Format.formatter -> parse_error -> unit
+val pp_errli : src_info -> Format.formatter -> parse_error list -> unit
+
+val create : string -> cursor
+
+exception Parser_Cant_Recover of parse_result
+exception Parser_No_Progress of cursor
+
+type 'a parsr = cursor -> 'a * parse_result
+
+val single_inline_white : unit parsr
+val single_white        : unit parsr
+val any     : char parsr
+val just    : string -> string parsr
+val ex_end  : unit parsr
+val digitch : char parsr
+val digit   : int  parsr
+val lower   : char parsr
+val upper   : char parsr
+val alpha   : char parsr
+val alnum   : char parsr
+val sign    : int  parsr   (** '+'->1, '-'->-1, _->1 *)
+val p_uint  : int  parsr
+val p_int   : int  parsr
+val p_uflt  : float parsr
+val p_flt   : float parsr
+
+
+val repeat : 'a parsr -> 'a list parsr (** at lest 0 times *)
+val many   : 'a parsr -> 'a list parsr (** at least 1 times *)
+
+
+(** repeat 'x parsr, as long as 'e parsr fails *)
+val until : 'e parsr -> 'x parsr -> 'x list parsr
+
+val opt : 'x parsr -> 'x option parsr
+
+val map : ('i -> 'o) -> 'i parsr -> 'o parsr
+val set : 'o -> 'i parsr -> 'o parsr
+
+
+(** if the given parser succeeds, this parser will fail, val the other way around *)
+val inv : 'x parsr -> unit parsr
+
+(** requires that both parsers parse successfully at the same loc,
+    but only uses first parser for progressing val returning result.
+    combines warnings / errors from both parsers *)
+val also : 'a parsr -> 'b parsr -> 'a parsr
+
+exception Recursive_Parser_Used_Before_Created
+val recursive : ('v parsr -> 'v parsr) -> 'v parsr
+
+val chain       : 'a parsr -> 'b parsr -> ('a * 'b) parsr
+val ignore_then : 'a parsr -> 'b parsr -> 'b parsr
+val then_ignore : 'a parsr -> 'b parsr -> 'a parsr
+val nd_of3      : 'a parsr -> 'b parsr -> 'c parsr -> 'b parsr
+val outer_of3   : 'a parsr -> 'b parsr -> 'c parsr -> ('a * 'c) parsr
+val ignore      : 'a parsr -> unit parsr
+val either      : 'a parsr -> 'a parsr -> 'a parsr
+
+
+val doparse : Format.formatter -> src_info -> 'a parsr -> 'a option

project

@@ -0,0 +1,5 @@
+application main
+module pc
+module sexpr
+module sexpr_macro
+module testing

sexpr.ml

@@ -1,434 +1,5 @@
-module Testing = struct
-  type result = Pass | Fail | Skip
-
-  let testing = ref false
-  let test_only = ref []
-  let test_results = ref []
-
-  let rec should_skip test =
-    match List.assoc_opt test !test_results with
-      Some Fail
-    | Some Skip -> true
-    | _         -> false
-
-  let test name ?(depends = []) run =
-    let test_only = !test_only in
-    if (test_only = [] && !testing) || List.exists (String.equal name) test_only then begin
-      Printf.printf "Test '%s':  " name;
-      let res = if List.exists should_skip depends then begin
-        Printf.printf "Skip\n%!";
-        Skip
-      end else begin
-        try
-          run ();
-          Printf.printf "Pass\n%!";
-          Pass
-        with e ->
-          Printf.printf "FAIL\n";
-          if test_only <> [] then begin
-            let msg = Printexc.to_string e
-            and stack = Printexc.get_backtrace () in
-              Printf.printf "exception thrown: %s%s\n\n%!" msg stack
-          end;
-          Fail
-      end; in
-      test_results := (name, res) :: !test_results
-    end
-
-  let () =
-    let rec proc args =
-      begin match args with
-        []                  -> ()
-      | "--run-tests" :: tl ->
-          testing := true;
-          proc tl
-      | "--run-test" :: test :: tl ->
-          testing := false;
-          test_only := test :: !test_only;
-          proc tl
-      | hd :: tl ->
-          proc tl
-      end
-    in proc @@ Array.to_list Sys.argv
-end
 let test = Testing.test
 
-
-module PC = struct
-  type severity = Style | Warning | Error
-
-  type parse_error = {
-    severity: severity;
-    pos: int;
-    message: string;
-    expected: string list option;
-    found: string option;
-    other_case: parse_error option;
-  }
-
-  type src_info = {
-    source: string;
-    path: string;
-  }
-
-  type off2lres = {
-    line: int;    (* 0-indexed *)
-    col:  int;    (* 0-indexed *)
-    lstr: string;
-  }
-
-  let num_occ s f =
-    let num = ref 0 in
-    s |> Seq.iter begin fun x ->
-      if f x then
-        num := !num + 1
-    end;
-    !num
-
-  let rec off2l (s:string) (p:int) =
-    let e = match String.index_from_opt s p '\n' with
-      Some(lb) -> lb
-    | None -> String.length s
-    in
-    match String.rindex_from_opt s p '\n' with
-      Some(lb) -> {
-        line = num_occ (Seq.take lb (String.to_seq s)) (fun x -> x = '\n');
-        col = p - lb;
-        lstr = String.sub s (lb + 1) (e - lb - 1) }
-    | None -> {
-        line = 0;
-        col = p;
-        lstr = String.sub s 0 e }
-
-  let str_before s c =
-    match String.index_opt s c with
-      Some(x) -> String.sub s 0 (x - 1)
-    | None    -> s
-
-  let limitw len s =
-    let s = str_before s '\n' in
-    if String.length s > len then
-      (String.sub s 0 (len - 3)) ^ "..."
-    else s
-
-  let rec pp_err s out e =
-    let open Format in
-    fprintf out "[%s] @[" begin match e.severity with
-      Style   -> "style"
-    | Warning -> "warn "
-    | Error   -> "error"
-    end;
-    fprintf out "%s@]\n" e.message;
-    let where = off2l s.source e.pos in
-    fprintf out "     in @[%s@]\n" s.path;
-    fprintf out "     at %i:%i\n\n" where.line where.col;
-    fprintf out "%3d: %s\n" where.line where.lstr;
-    fprintf out "     ";
-    for _ = 0 to where.col - 2 do
-      fprintf out " "
-    done;
-    fprintf out "^\n";
-    begin match e.expected with
-      Some([]) -> fprintf out "expected: nothing\nbut "
-    | Some(li) -> fprintf out "expected: @[%a@]\nbut "
-                    (Format.pp_print_list Format.pp_print_text) li
-    | None     -> fprintf out "unexpected\n"
-    end;
-    fprintf out "got '@[";
-    begin match e.found with
-    | Some(x) -> fprintf out "%s" @@ limitw 22 x
-    | None    -> fprintf out "something else"
-    end;
-    fprintf out "@]'\n";
-
-    begin match e.other_case with
-      Some(c) -> begin
-        fprintf out "\n  ^^^\n";
-        fprintf out "  \\\ === OR tried alternative parser === \\\\\\\n";
-        fprintf out "                                         \\/\n\n";
-        pp_err s out c
-      end
-    | None -> () end
-
-  let pp_errli s out e =
-    let open Format in
-    let first = ref true in
-    e |> List.iter begin fun e ->
-      if not !first then begin
-        fprintf out "\n"
-      end;
-      first := false;
-      pp_err s out e
-    end
-
-  type cursor = { source: string; pos: int }
-  let head c =
-    if String.length c.source > 0 then
-      Some(String.get c.source 0)
-    else
-      None
-
-  let create src = { source = src; pos = 0 }
-
-  let expected c str =
-    {
-      severity = Error;
-      pos = c.pos;
-      message  = "";
-      expected = Some([str]);
-      found    = Some(c.source);
-      other_case = None;
-    }
-
-  let seek num c =
-    { source =
-        String.sub c.source num ((String.length c.source) - num);
-      pos = c.pos + num }
-
-  type parse_result = {
-    cursor: cursor;
-    errors: parse_error list
-  }
-
-  let merge a b =
-    { cursor = b.cursor;
-      errors = a.errors @ b.errors }
-
-  let ok c = { cursor = c; errors = [] }
-  let put_err err res = { res with errors = res.errors @ [err] }
-  let err c e = put_err e (ok c)
-
-  exception Parser_Cant_Recover of parse_result
-  exception Parser_No_Progress of cursor
-
-  let single_inline_white c =
-    match head c with
-      Some(' ')  |
-      Some('\b') |
-      Some('\t') ->
-        ((), ok (seek 1 c))
-    | _ -> raise (Parser_Cant_Recover (err c (expected c "inline whitespace")))
-
-  let single_white c =
-    match head c with
-      Some(' ')  |
-      Some('\b') |
-      Some('\t') |
-      Some('\r') |
-      Some('\n') ->
-        ((), ok (seek 1 c))
-    | _ -> raise (Parser_Cant_Recover (err c (expected c "whitespace")))
-
-  let any c =
-    match head c with
-      Some(x) -> (x, ok (seek 1 c))
-    | None    -> raise (Parser_Cant_Recover (err c (expected c "any")))
-
-  (* at lest 0 times *)
-  let rec repeat p c =
-    try
-      let (v, res) = p c in
-      if res.cursor.pos = c.pos then
-        raise (Parser_No_Progress c)
-      else
-        let (v2, res2) = repeat p res.cursor in
-        (v :: v2, merge res res2)
-    with Parser_Cant_Recover _ ->
-      ([], ok c)
-
-  (* at least 1 times *)
-  let many p c =
-    let (av, ar) = p c in
-    let (bv, br) = repeat p (ar.cursor) in
-    (av :: bv, merge ar br)
-
-  let rec until endp p c =
-    try
-      let (_, res) = endp c in
-      ([], res)
-    with Parser_Cant_Recover _ ->
-      let (v, res) = p c in
-      if res.cursor.pos = c.pos then
-        raise (Parser_No_Progress c)
-      else
-        let (v2, res2) = until endp p res.cursor in
-        (v :: v2, merge res res2)
-
-  let map fn p c =
-    let (v, res) = p c in
-    ((fn v), res)
-
-  let set v p c =
-    let (_, res) = p c in
-    (v, res)
-
-  let opt p c =
-    try
-      map (fun x -> Some(x)) p c
-    with Parser_Cant_Recover _ ->
-      (None, ok c)
-
-  (* if the given parser succeeds, this parser will fail, and the other way around *)
-  let inv p c =
-    let fail = (try
-      let (_, r) = p c in
-      Some(r)
-    with Parser_Cant_Recover _ ->
-      None) in
-
-    let rec ouch r =
-      match r with
-        [] -> None
-      | head :: tail ->
-          let h = (match head.expected with
-            Some(x) -> Some( List.map (fun x -> "not " ^ x) x )
-          | None -> None
-          ) in
-          let t = ouch tail in
-          match h, t with
-            Some(x), Some(y) -> Some(x @ y)
-          | Some(x), None    -> Some(x)
-          | None,    Some(y) -> Some(y)
-          | None,    None    -> None
-    in
-
-    match fail with
-      Some(r) -> raise (Parser_Cant_Recover (err c {
-        severity = Error;
-        pos = c.pos;
-        message = "inverted parser matched";
-        expected = ouch r.errors;
-        found = Some(c.source);
-        other_case = None
-      }))
-    | None -> ((), ok c)
-
-  (* requires that both parsers parse successfully at the same loc,
-   * but only uses first parser for progressing and returning result.
-   * combines warnings / errors from both parsers *)
-  let also a b c =
-    let (av, ar) = a c in
-    let (_, br) = b c in
-    (av, merge br ar)
-
-  exception Recursive_Parser_Used_Before_Created
-
-  let recursive (prod:'a->'c-> 'v * 'r) (c:cursor) =
-    let future = ref None in
-    let par = prod (fun c -> match !future with
-      None    -> raise Recursive_Parser_Used_Before_Created
-    | Some(p) -> p c) in
-    future := Some(par);
-    par c
-
-  let just str c =
-    if String.starts_with ~prefix:str c.source then
-      (str, ok (seek (String.length str) c))
-    else
-      raise (Parser_Cant_Recover (err c (expected c str)))
-
-  let ex_end c =
-    if (String.length c.source) > 0 then
-      raise (Parser_Cant_Recover (err c (expected c "end of file")))
-    else
-      ((), ok c)
-
-  let chain a b c =
-    let ar = a c in
-    let br = b (snd ar).cursor in
-    ((fst ar, fst br), merge (snd ar) (snd br))
-
-  let ignore_then a b c =
-    let ar = a c in
-    let br = b (snd ar).cursor in
-    ((fst br), merge (snd ar) (snd br))
-
-  let then_ignore a b c =
-    let ar = a c in
-    let br = b (snd ar).cursor in
-    ((fst ar), merge (snd ar) (snd br))
-
-  (* only take value of 2nd parser of resulting 3 chained parsers *)
-  let nd_of3 a b c =
-    then_ignore (ignore_then a b) c
-
-  (* only take values of outer two parsers of resulting 3 chained parsers *)
-  let outer_of3 a b c =
-    chain (then_ignore a b) c
-
-  let ignore p c =
-    let (_, r) = p c in
-    ((), r)
-
-  let either a b c =
-    try a c
-    with Parser_Cant_Recover ar ->
-      try b c
-      with Parser_Cant_Recover br ->
-        raise (Parser_Cant_Recover {
-          cursor = ar.cursor;
-          errors = [{ (List.hd ar.errors) with
-                     other_case = Some(List.hd br.errors) }]
-        })
-
-  let match_hd label fn c =
-    match head c with
-      Some(x) when fn x ->
-        (x, ok (seek 1 c))
-    | _ -> raise (Parser_Cant_Recover (err c (expected c label)))
-
-  let hd_oneof label li =
-    match_hd label (fun x ->
-      Seq.exists (fun t->t=x) li)
-
-  let digitch =
-    (hd_oneof "digit"
-      (String.to_seq "0123456789"))
-
-  let digit =
-    map (fun x -> Char.code x - Char.code '0')
-      digitch
-
-  let lower =
-    hd_oneof "lowercase letter"
-      (String.to_seq "abcdefghijklmnopqrstuvwxyz")
-
-  let upper =
-    hd_oneof "uppercase letter"
-      (String.to_seq "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
-
-  let alpha = either lower upper
-  let alnum = either alpha digitch
-
-  let p_int =
-    map (fun digits ->
-      List.fold_right (fun x acc -> acc*10 + x) (List.rev digits) 0
-    ) (many digit)
-
-  let p_flt =
-    let fract =
-      map (fun digits ->
-        List.fold_right 
-          (fun x (acc,d) -> (acc +. (Float.of_int x) /. d), d *. 10.0 )
-          (List.rev digits)
-          (0.0,10.0)
-      ) (many digit)
-    in outer_of3 p_int (just ".") fract
-    |> map (fun (a,(b,_)) -> (Float.of_int a) +. b)
-
-  let doparse f (src:src_info) parsr =
-    let (v,r) = try
-      let (v,r) = parsr (create src.source) in
-      (Some(v), r)
-    with Parser_Cant_Recover r ->
-      (None, r)
-    in
-    pp_errli src f r.errors;
-    v
-end
-
-
-module SExpr = struct
 type t =
   Nil
 | Int  of int
@@ -440,13 +11,13 @@ module SExpr = struct
 let li1 s =
   Cons(s, Nil)
 
-  exception Not_Sexpr_List
+exception Not_SExpr_List
 
 let rec append tl hd =
   match hd with
     Nil          -> tl
   | Cons(x, rem) -> Cons(x, append tl rem)
-    | _            -> raise Not_Sexpr_List
+  | _            -> raise Not_SExpr_List
 
 let () = test "SExpr.append" @@ begin fun () ->
   let a = Cons(Int 1, Cons(Int 2, Cons(Int 3, Nil)))
@@ -471,7 +42,7 @@ module SExpr = struct
   match li with
     Nil          -> Nil
   | Cons(x, rem) -> append (flat_map fn rem) (fn x)
-    | _            -> raise Not_Sexpr_List
+  | _            -> raise Not_SExpr_List
 
 let () = test "SExpr.flat_map.0" @@ begin fun () ->
   let a = Cons(Int 1, Cons(Int 2, Cons(Int 3, Nil)))
@@ -491,6 +62,20 @@ module SExpr = struct
   assert (flat_map (fun x -> Cons(x, Cons((match x with Int(n) -> Int(n + 1) | x -> x) , Nil))) a = p)
 end
 
+let rec aggr_flat_map fn acc li =
+  match li with
+    Nil          -> Nil, acc
+  | Cons(x, rem) ->
+      let x, acc = fn acc x in
+      let vv, acc = aggr_flat_map fn acc rem in
+      append vv x, acc
+  | _  -> raise Not_SExpr_List
+
+let () = test "SExpr.aggr_flat_map.0" @@ begin fun () ->
+  let a = Cons(Int 1, Cons(Int 2, Nil))
+  and p = Cons(Int 1, Cons(Int 2, Cons(Int 2, Cons(Int 4, Nil)))) in
+  assert (fst (aggr_flat_map (fun aggr x -> Cons(x, Cons((match x with Int(n) -> Int(n + aggr) | x -> x) , Nil)) , aggr + 1) 1 a) = p)
+end
 
 (* a "list" here is: 
  *   ( e1 . ( e2 . ( e3 . NIL ) ) )
@@ -563,8 +148,8 @@ module SExpr = struct
       | _   -> fprintf out "@ ");
       pp_closed out b
 
-  let parse_inline () : PC.cursor -> t * PC.parse_result =
-    let open PC in
+let parse_inline () : Pc.cursor -> t * Pc.parse_result =
+  let open Pc in
   let comment = chain (just ";") (repeat (also any (inv (just "\n")))) in
   let pad = either (ignore single_white) (ignore comment) in
   let pad = repeat pad in
@@ -587,7 +172,7 @@ module SExpr = struct
          (just ")")
     in
     let x_list = (nd_of3
-        (just "(")
+      (padded (just "("))
       (repeat expr
       |> map (fun li ->
         List.fold_right (fun x acc -> Cons(x,acc)) li Nil))
@@ -637,155 +222,14 @@ module SExpr = struct
   )
 
 let parse_inline_end () =
-    let open PC in
+  let open Pc in
   then_ignore (parse_inline ()) ex_end
 
 let parse_top () =
-    let open PC in
+  let open Pc in
   parse_inline ()
     |> until ex_end
     |> map (fun li ->
         List.fold_right (fun x acc -> Cons(x,acc)) li Nil)
-end
 
-
-module SExprMacroExp = struct
-  exception Misformated_Macro of SExpr.t
-  exception Macro_Doesnt_App
-  exception Macro_App_TODO of ((string * SExpr.t) list) * SExpr.t
-  exception FIXME of SExpr.t
-
-  let assoc_all k li =
-    li
-    |> List.find_all (fun (x, _) -> x = k)
-    |> List.map (fun (_, v) -> v)
-
-  let () = test "SExprMacroExp.assoc_all" @@ begin fun () ->
-    let li = [
-      "asye","v4";
-      "key","v1";
-      "notkey","v2";
-      "key","v3"
-    ] in
-    assert (assoc_all "key" li = ["v1";"v3"])
-  end
-
-  let rec eval (ctx: (string * (SExpr.t * SExpr.t)) list ref) s =
-    let open SExpr in
-    let sli = match s with
-      Cons(l,r) ->
-        (* Cons(1, Cons(2, Nil)) 
-           l: Cons(1, Nil)
-           r: Cons(Cons(2, Nil), Nil)
-           append r l: Cons(1, Cons(Cons(2, Nil), Nil))
-           *)
-        let l = eval ctx l in
-        let r = eval ctx r in
-        begin match append r l with
-          Cons(l, Cons(r, Nil)) -> li1 @@ Cons(l,r)
-        | Nil -> Nil
-        | x   -> raise (FIXME x)
-        end
-    | s -> li1 s
-    in
-    flat_map (check_expands_while ctx) sli
-  (* expr -> list(new exprs) * bool:changed *)
-  and check_expands ctx s =
-    let open SExpr in
-    (* Format.printf "checking: %a\n%!" pp_t s; *)
-    match s with
-      Cons(Id(":macro"), r) -> begin
-        let a = match r with
-          Cons(Id(l), Cons(a,b)) -> l, (a,b)
-        | _ -> raise @@ Misformated_Macro s
-        in
-        (* Format.printf "define: %s%a -> %a\n%!" (fst a) pp_t (fst (snd a)) pp_t (snd (snd a)); *)
-        ctx := a :: !ctx;
-        Nil, false
-      end
-    | Cons(Id(i), r) -> begin
-        let i = if String.starts_with ~prefix:":" i then
-          String.sub i 1 ((String.length i) - 1)
-        else "@" in
-        (* Format.printf "consider expand %s %a\n%!" i pp_t r; *)
-        let rec test opt =
-          begin match opt with
-            [] -> li1 s, false
-          | hd :: tl ->
-              try
-                expand_macro r hd, true
-              with Macro_Doesnt_App ->
-                test tl
-          end
-        in
-        test (assoc_all i !ctx)
-      end
-    | s -> li1 s, false
-  and check_expands_while ctx s =
-    let v, c = check_expands ctx s in
-    if c then
-      check_expands_while ctx v
-    else
-      v
-  and match_macro_arg args margs =
-    let open SExpr in
-    match args, margs with
-      Nil,        Nil                               -> []
-    | Cons(_),    Cons(Id(".."), Cons(Id(rem),Nil)) -> [rem, args]
-    | Cons(v,rl), Cons(Id(k), rr)                   -> [k,v] @ match_macro_arg rl rr
-    | _                                             -> raise Macro_Doesnt_App
-  and expand_macro args macro =
-    let (margs, mbody) = macro in
-    let defs = match_macro_arg args margs in
-    raise @@ Macro_App_TODO (defs, mbody);
-    args
-  let do_eval s =
-    eval (ref []) s
-
-  let () = test "SExprMacroExp.do_eval.unchanged_num" @@ begin fun () ->
-    let open SExpr in
-    let a = Int 1 in
-    assert (do_eval a = li1 a)
-  end
-
-  let () = test "SExprMacroExp.do_eval.unchanged_list" ~depends:["SExprMacroExp.do_eval.unchanged_num"] @@ begin fun () ->
-    let open SExpr in
-    let a = Cons(Int 1, Cons(Int 2, Nil)) in
-    assert (do_eval a = li1 a)
-  end
-
-  let () = test "SExprMacroExp.do_eval.unchanged_nested_list" ~depends:["SExprMacroExp.do_eval.unchanged_list"] @@ begin fun () ->
-    let open SExpr in
-    let a = Cons(Int 1, Cons( Cons(Int 10, Cons(Int 20, Nil)), Cons(Int 3, Nil))) in
-    assert (do_eval a = li1 a)
-  end
-end
-
-
-let read_all_stdin () =
-  let buf = Buffer.create 4096 in
-  try
-    while true do
-      let line = input_line stdin in
-      Buffer.add_string buf line;
-      Buffer.add_char buf '\n';
-    done;
-    Buffer.contents buf
-  with End_of_file ->
-    Buffer.contents buf
-
-
-let () =
-  let parsr = SExpr.parse_top () in
-  let src = read_all_stdin () in
-  let v = PC.doparse
-    Format.err_formatter
-    { source = src; path = "top" }
-    parsr in
-  let v = Option.get v in
-  let v = SExpr.flat_map SExprMacroExp.do_eval v in
-
-  Format.set_margin 40;
-  Format.printf "%a@.@?" SExpr.pp_t v;
-
-  exit 0
+let parser_tests = []

sexpr.mli

@@ -0,0 +1,25 @@
+type t =
+  Nil
+| Int  of int
+| Flt  of float
+| Cons of t * t
+| Id   of string
+| Str  of string
+
+val li1 : t -> t
+
+exception Not_SExpr_List
+
+val is_list  : t -> bool
+val append   : t -> t -> t
+val rem_nil  : t -> t
+val flat_map : (t->t) -> t -> t
+val aggr_flat_map : ('a -> t -> t * 'a) -> 'a -> t -> t * 'a
+
+val pp_t : Format.formatter -> t -> unit
+
+val parse_inline     : unit -> t Pc.parsr
+val parse_inline_end : unit -> t Pc.parsr
+val parse_top        : unit -> t Pc.parsr
+
+val parser_tests : string list

sexpr_macro.ml

@@ -0,0 +1,252 @@
+let test = Testing.test
+
+exception Misformated_Macro of Sexpr.t
+exception Macro_Doesnt_App
+exception Not_Valid_Macro_Arg_Syntax
+exception FIXME of Sexpr.t
+
+let num_expands = ref 0;;
+
+let assoc_all k li =
+  li
+  |> List.find_all (fun (x, _) -> x = k)
+  |> List.map (fun (_, v) -> v)
+
+let () = test "SexprMacroExp.assoc_all" @@ begin fun () ->
+  let li = [
+    "asye","v4";
+    "key","v1";
+    "notkey","v2";
+    "key","v3"
+  ] in
+  assert (assoc_all "key" li = ["v1";"v3"])
+end
+
+let rec eval (ctx: (string * (Sexpr.t * Sexpr.t)) list) s =
+  let open Sexpr in
+  let aggr_eval ctx s = begin
+    let s, (ch,ctx) = aggr_flat_map (fun aggr s ->
+      let ch1, ctx = aggr in
+      let s, ch2, ctx = eval ctx s in
+      s, ((ch1 || ch2), ctx)
+    ) (false, ctx) s in
+    s, ch, ctx
+  end in
+  let s, ch1, ctx = match s with
+    Cons(Id ":macro", Cons(name, Cons(margs, rr))) ->
+      let rr, ch, ctx = aggr_eval ctx rr in
+      Cons(Id ":macro", Cons(name, Cons(margs, rr))), ch, ctx
+  | s when is_list s -> begin
+      aggr_eval ctx s
+    end
+  | _ ->
+      s, false, ctx
+  in
+  let s, ch2, ctx = check_expands ctx s in
+  s, (ch1 || ch2), ctx
+(* expr -> list(new exprs) * bool:changed * ctx *)
+and check_expands ctx s =
+  let open Sexpr in
+  match s with
+    Cons(Id ":macro", r) -> begin
+      let a = match r with
+        Cons(Id(l), Cons(a,b)) -> l, (a,b)
+      | _ -> raise @@ Misformated_Macro s
+      in
+      let ctx = (a :: ctx)
+        |> List.sort (fun a b -> macro_req_score (fst (snd b)) - macro_req_score (fst (snd a)))
+      in
+      Nil, false, ctx
+    end
+  | Cons(Id ":atm-to-str", Cons(Id x, Nil))
+  | Cons(Id ":atm-to-str", Cons(Str x, Nil)) ->
+      li1 (Str x), true, ctx
+  | Cons(Id ":atm-to-str", Cons(Int x, Nil)) ->
+      li1 (Str (Int.to_string x)), true, ctx
+  | Cons(Id ":atm-to-str", Cons(Flt x, Nil)) ->
+      li1 (Str (Float.to_string x)), true, ctx
+  | Cons(Id ":str-cat", Cons(Str l, Cons(Str r, Nil))) ->
+      li1 (Str (l ^ r)), true, ctx
+  | Cons(Id ":unpack", Cons(x, Nil)) when is_list x ->
+      x, true, ctx
+  | Cons(Id ":c-eq", Cons(l, Cons(r, Nil))) when l = r ->
+      Nil, true, ctx
+  | Cons(Id ":c-li0-eq", Cons( Cons(l, _) , Cons( r , Nil))) when l = r ->
+      Nil, true, ctx
+  | Cons(Id ":c-int", Cons(Int _, Nil)) ->
+      Nil, true, ctx
+  | Cons(Id ":c-float", Cons(Flt _, Nil)) ->
+      Nil, true, ctx
+  | Cons(Id ":c-num", Cons(Int _, Nil))
+  | Cons(Id ":c-num", Cons(Flt _, Nil)) ->
+      Nil, true, ctx
+  | Cons(Id ":c-str", Cons(Str _, Nil)) ->
+      Nil, true, ctx
+  | Cons(Id ":c-id", Cons(Id _, Nil)) ->
+      Nil, true, ctx
+  | Cons(Id ":c-colon-id", Cons(Id x, Nil)) when String.contains x ':' ->
+      Nil, true, ctx
+  | Cons(Id ":c-list", Cons(x, Nil)) when is_list x ->
+      Nil, true, ctx
+  | Cons(Id ":c-atm", Cons(Int _, Nil))
+  | Cons(Id ":c-atm", Cons(Flt _, Nil))
+  | Cons(Id ":c-atm", Cons(Str _, Nil))
+  | Cons(Id ":c-atm", Cons(Id _, Nil)) ->
+      Nil, true, ctx
+  | Cons(Id i, r) when String.starts_with ~prefix:":" i ->
+      let i = String.sub i 1 ((String.length i) - 1) in
+      check_expands_macro i ctx r s
+  | Cons(_) ->
+      check_expands_macro "@" ctx s s
+  | s -> li1 s, false, ctx
+and check_expands_macro i ctx r s =
+  let open Sexpr in
+  let rec test opt ctx =
+    begin match opt with
+      [] -> li1 s, false, ctx
+    | hd :: tl ->
+        try
+          let o = expand_macro r hd ctx, true, ctx in
+          (* Format.printf "expanded: %s, with: %a\n%!" i Sexpr.pp_t r; *)
+          o
+        with Macro_Doesnt_App ->
+          test tl ctx
+    end
+  in
+  test (assoc_all i ctx) ctx
+and match_macro_arg args margs ctx =
+  let open Sexpr in
+  match args, margs with
+    Nil,        Nil                                  -> []
+  | Cons(_),    Cons(Id(".."), Cons(Id(rem),Nil))    -> [rem, args]
+  | Cons(v,rl), Cons(Id(k), rr)                      -> [k,li1 v] @ match_macro_arg rl rr ctx
+  | Cons(v,rl), Cons(Cons(Id k, Cons(cst, Nil)), rr) ->
+      let cst_exp = expand_macro_eval cst ["_", li1 v] in
+      let cst_exp, _ = eval_while ctx cst_exp in
+      if cst_exp <> Nil then
+        raise Macro_Doesnt_App;
+      [k, li1 v] @ match_macro_arg rl rr ctx
+  | _                                                -> raise Macro_Doesnt_App
+and macro_req_score args =
+  let open Sexpr in
+  match args with
+    Nil                               -> 0
+  | Cons(Id(".."), Cons(Id(rem),Nil)) -> 1
+  | Cons(Id _, rr)                    -> 100 + macro_req_score rr
+  | Cons(Cons(Id _, Cons(_,Nil)), rr) -> 110 + macro_req_score rr
+  | _                                 -> raise Not_Valid_Macro_Arg_Syntax
+and expand_macro_eval expr defs =
+  let open Sexpr in
+  let perfm expr =
+    begin match expr with
+      Id(i) when String.starts_with ~prefix:"'" i ->
+        li1 @@ Id(String.sub i 1 (String.length i - 1))
+    | Id(i) -> begin match List.assoc_opt i defs with
+        Some x -> x
+      | None   -> li1 expr
+      end
+    | x when is_list x -> li1 (expand_macro_eval x defs)
+    | x -> li1 x
+    end
+  in
+  if is_list expr then
+    flat_map perfm expr
+  else
+    perfm expr
+and expand_macro args macro ctx =
+  let margs, mbody = macro in
+  let defs = match_macro_arg args margs ctx in
+  num_expands := !num_expands + 1;
+  expand_macro_eval mbody defs
+and eval_while ctx s = begin
+  let s, ch, ctx = eval ctx s in
+  if ch then
+    Sexpr.aggr_flat_map eval_while ctx s
+  else
+    s, ctx
+end
+and eval_root_while ctx s = begin
+  let s, ch, ctx = eval ctx s in
+  if ch then begin
+    (* Format.printf "%a\n%!" Sexpr.pp_t s; *)
+    Sexpr.aggr_flat_map eval_root_while ctx s
+  end else
+    s, ctx
+end
+
+let do_eval s =
+  eval_root_while [] s |> fst
+
+let sparse src =
+  Pc.doparse
+    Format.err_formatter
+    { source = src; path = "top" }
+    (Sexpr.parse_top ())
+  |> Option.get
+
+let () = test "SexprMacroExp.do_eval.unchanged_num" @@ begin fun () ->
+  let open Sexpr in
+  let a = Int 1 in
+  assert (do_eval a = li1 a)
+end
+
+let () = test "SexprMacroExp.do_eval.unchanged_list" ~depends:["SexprMacroExp.do_eval.unchanged_num"] @@ begin fun () ->
+  let open Sexpr in
+  let a = Cons(Int 1, Cons(Int 2, Nil)) in
+  assert (do_eval a = li1 a)
+end
+
+let () = test "SexprMacroExp.do_eval.unchanged_nested_list" ~depends:["SexprMacroExp.do_eval.unchanged_list"] @@ begin fun () ->
+  let open Sexpr in
+  let a = Cons(Int 1, Cons( Cons(Int 10, Cons(Int 20, Nil)), Cons(Int 3, Nil))) in
+  assert (do_eval a = li1 a)
+end
+
+let () = test "SexprMacroExp.do_eval.macro_no_body" ~depends:Sexpr.parser_tests @@ begin fun () ->
+  let open Sexpr in
+  let a = "(:macro one()) (:one)"
+  and p = "()" in
+  assert (do_eval (sparse a) = sparse p)
+end
+
+let () = test "SexprMacroExp.do_eval.macro_body" ~depends:Sexpr.parser_tests @@ begin fun () ->
+  let open Sexpr in
+  let a = "(:macro a() 1 2) (:a)"
+  and p = "(1 2)" in
+  assert (do_eval (sparse a) = sparse p)
+end
+
+let () = test "SexprMacroExp.do_eval.macro_arg" ~depends:Sexpr.parser_tests @@ begin fun () ->
+  let open Sexpr in
+  let a = "(:macro a(arg) 1 arg) (:a 2)"
+  and p = "(1 2)" in
+  assert (do_eval (sparse a) = sparse p)
+end
+
+let () = test "SexprMacroExp.do_eval.macro_args" ~depends:Sexpr.parser_tests @@ begin fun () ->
+  let open Sexpr in
+  let a = "(:macro a(arg arg2) arg2 1 arg) (:a 2 0)"
+  and p = "(0 1 2)" in
+  assert (do_eval (sparse a) = sparse p)
+end
+
+let () = test "SexprMacroExp.do_eval.macro_varargs" ~depends:Sexpr.parser_tests @@ begin fun () ->
+  let open Sexpr in
+  let a = "(:macro a(arg .. rem) arg 1 rem) (:a 0 2 3)"
+  and p = "(0 1 2 3)" in
+  assert (do_eval (sparse a) = sparse p)
+end
+
+let () = test "SexprMacroExp.do_eval.macro_varargs_notmatch_none" ~depends:Sexpr.parser_tests @@ begin fun () ->
+  let open Sexpr in
+  let a = "(:macro a(arg .. rem) arg 1 rem) (:a 0)"
+  and p = "((:a 0))" in
+  assert (do_eval (sparse a) = sparse p)
+end
+
+let () = test "SexprMacroExp.do_eval.macro_body_paren" ~depends:Sexpr.parser_tests @@ begin fun () ->
+  let open Sexpr in
+  let a = "(:macro a() (1)) (:a)"
+  and p = "((1))" in
+  assert (do_eval (sparse a) = sparse p)
+end

sexpr_macro.mli

@@ -0,0 +1,7 @@
+exception Misformated_Macro of Sexpr.t
+exception Not_Valid_Macro_Arg_Syntax
+
+val num_expands : int ref
+
+val sparse  : string -> Sexpr.t
+val do_eval : Sexpr.t -> Sexpr.t

testing.ml

@@ -0,0 +1,51 @@
+type result = Pass | Fail | Skip;;
+
+let testing = ref false;;
+let test_only = ref [];;
+let test_results = ref [];;
+
+let rec should_skip test =
+  match List.assoc_opt test !test_results with
+    Some Fail
+  | Some Skip -> true
+  | _         -> false;;
+
+let test name ?(depends = []) run =
+  let test_only = !test_only in
+  if (test_only = [] && !testing) || List.exists (String.equal name) test_only then begin
+    Printf.printf "Test '%s':  " name;
+    let res = if List.exists should_skip depends then begin
+      Printf.printf "Skip\n%!";
+      Skip
+    end else begin
+      try
+        run ();
+        Printf.printf "Pass\n%!";
+        Pass
+      with e ->
+        Printf.printf "FAIL\n%!";
+        if test_only <> [] then begin
+          let msg = Printexc.to_string e
+          and stack = Printexc.get_backtrace () in
+            Printf.printf "exception thrown: %s%s\n\n%!" msg stack
+        end;
+        Fail
+    end; in
+    test_results := (name, res) :: !test_results
+  end;;
+
+let () =
+  let rec proc args =
+    begin match args with
+      []                  -> ()
+    | "--run-tests" :: tl ->
+        testing := true;
+        proc tl
+    | "--run-test" :: test :: tl ->
+        testing := false;
+        test_only := test :: !test_only;
+        proc tl
+    | hd :: tl ->
+        proc tl
+    end
+  in proc @@ Array.to_list Sys.argv;;

testing.mli

@@ -0,0 +1,4 @@
+val test :  string
+         -> ?depends:(string list)
+         -> (unit -> unit)
+         -> unit;;

yaml.0.lsp

@@ -0,0 +1,71 @@
+(:macro seq ())
+
+(:macro c-not ( c )
+        )
+; works because this has a higher constraints score:
+(:macro c-not ( (c (:c-eq () _)) )
+        ())
+
+(:macro seq-exp (hd)
+        (':ot (':str-cat "- " (':t2ot-elt hd))))
+(:macro seq-exp (hd .. tl)
+        (':seq-exp hd) (':seq-exp tl))
+
+(:macro seq (hd)
+        (':seq-exp hd))
+(:macro seq (hd .. tl)
+        (':seq-exp hd tl))
+
+(:macro c-paren-eval (x)
+        (':c-atm x)
+        (':c-not (':c-colon-id x)))
+
+(:macro @ ( (k(:c-paren-eval _)) )
+        (':t (':str-cat (':t2ot-elt k) ":")))
+
+(:macro @ ( (k(:c-paren-eval _)) v )
+        (':t (':dict-key (':atm-to-str k)) v))
+
+(:macro @ ( (k(:c-paren-eval _)) (v(:c-paren-eval _)) )
+        (':t (':str-cat (':str-cat (':atm-to-str k) ": ") (':atm-to-str v) )))
+
+(:macro @ ( (k(:c-paren-eval _)) v .. other)
+        (':t (':dict-key (':atm-to-str k)) v other))
+
+(:macro t2ot-elt ( hd )
+        (':atm-to-str hd))
+
+(:macro t2ot-elt ( hd .. tl )
+        (':tree
+         (':t2ot-elt hd)
+         (':t2ot-elt tl)))
+
+(:macro t ()
+        (':ot))
+(:macro t ( .. tl )
+        (':ot
+          (':t2ot-elt tl)))
+
+(:macro ot ( x )
+        (':yot (':indent x)))
+
+(:macro indent-each ())
+(:macro indent-each ( hd )
+        (':indent hd))
+(:macro indent-each ( hd .. tl )
+        (':indent-each hd)
+        (':indent-each tl))
+
+(:macro rm-first (x .. tl)
+        tl)
+
+;(:macro indent ( (x(:c-str _)) )
+;        (':str-cat "  " x))
+(:macro indent ( (x(:c-li0-eq _ :tree)) )
+        (':tree (':indent-each (':rm-first (':unpack x)))))
+(:macro indent ( (x(:c-li0-eq _ :atm-to-str)) )
+        (':atm-to-str (':indent-each (':rm-first (':unpack x)))))
+(:macro indent ( (x(:c-li0-eq _ :yot)) )
+        (':yot (':indent-each (':rm-first (':unpack x)))))
+(:macro indent ( (x(:c-li0-eq _ :dict-key)) )
+        (':dict-key (':indent-each (':rm-first (':unpack x)))))

yaml.1.lsp

@@ -0,0 +1,43 @@
+(:macro rm-first (x .. tl)
+        tl)
+
+(:macro rm-indent ( (x(:c-li0-eq _ :tree)) )
+        (':tree
+         (':rm-indent-each
+          (':rm-first
+           (':unpack x)))))
+(:macro rm-indent ( (x(:c-li0-eq _ :yot)) )
+        (':yot
+         (':rm-indent
+          (':rm-first
+           (':unpack x)))))
+(:macro rm-indent ( (x(:c-li0-eq _ :atm-to-str)) )
+        (':atm-to-str
+         (':rm-indent
+          (':rm-first
+           (':unpack x)))))
+(:macro rm-indent ( (x(:c-li0-eq _ :dict-key)) )
+        (':dict-key
+         (':rm-indent
+          (':rm-first
+           (':unpack x)))))
+
+(:macro rm-indent ( (x(:c-li0-eq _ :indent)) )
+        (':rm-first
+         (':unpack x)))
+
+(:macro rm-indent-each ( x )
+        (':rm-indent x))
+(:macro rm-indent-each ( x .. tl )
+        (':rm-indent x)
+        (':rm-indent-each tl))
+
+(:macro cfg ()
+        (':ocfg))
+(:macro cfg ( x )
+        (':ocfg
+         (':rm-indent x)))
+(:macro cfg ( hd .. tl )
+        (':ocfg
+         (':rm-indent hd)
+         (':rm-indent-each tl)))

yaml.2.lsp

@@ -0,0 +1,31 @@
+(:macro dict-key ( x )
+        (':str-cat x ":"))
+
+(:macro yot ( x )
+        x)
+
+(:macro tree ( a b )
+        (':reduce-cat a "\n" b))
+
+(:macro c-paren-eval (x)
+        (':c-not (':c-colon-id x)))
+
+(:macro @ ( (x(:c-paren-eval _)) .. tl )
+        (':reduce-cat x tl ))
+
+(:macro reduce-cat ( x )
+        x)
+
+(:macro reduce-cat ( x .. tl )
+        (':str-cat x
+         (':reduce-cat tl)))
+
+(:macro ocfg ( )
+        "")
+(:macro ocfg ( x )
+        x)
+(:macro ocfg ( x .. tl )
+        (':tree x (':ocfg tl)))
+
+(:macro indent ( x )
+        (':str-cat "  " x))