c

.gitignore

@@ -1,7 +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
+

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.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;;