shithub: martian9

ref: dffe9bae1142fff062f6dc1a0867d8a9247f5bcf
dir: /macro.ml/

module T = Types.Types

let gen_sym root =
  let gen () =
    match Random.int (26 + 26 + 10) with
    | n when n < 26 -> int_of_char 'a' + n
    | n when n < 26 + 26 -> int_of_char 'A' + n - 26
    | n -> int_of_char '0' + n - 26 - 26
  in
  let gen _ = String.make 1 (char_of_int (gen ())) in
  root ^ String.concat "" (Array.to_list (Array.init 5 gen))
;;

let rec is_matching_pattern sym pattern args matched =
  match pattern, args with
  (* literals and ellipses not handled, yet *)
  | ph :: pt, ah :: at ->
    print_endline "    LIST <-> LIST";
    if ph = "_" || (ph = Printer.print sym true && sym = ah)
    then is_matching_pattern sym pt at matched && true
    else (
      print_endline (" ------> " ^ ph ^ " vs " ^ Printer.print ah true);
      is_matching_pattern sym pt at matched)
  | ph :: pt, [] ->
    print_endline "    LIST <-> []";
    if ph = "_" || ph = Printer.print sym true
    then is_matching_pattern sym pt [] matched && true
    else ph = "..."
  | [], ah :: at ->
    print_endline "    [] <-> LIST";
    false
  | _, _ -> matched
;;

let rec ellipsis pattern template args =
    print_endline
    ("pattern length: "
    ^ string_of_int (List.length pattern)
    ^ "  arg length: "
    ^ string_of_int (List.length args));
    let has_ellipsis = (try ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0); true
                        with Not_found -> false) in
  let ellipsis_substitutions = ref [] in
  let missing = List.length args - List.length pattern + (if has_ellipsis then 1 else 0) in
  print_endline (" NEED TO ADD " ^ string_of_int missing ^ " PLACEHOLDERS");
  if missing > 0
  then (
    for i = 1 to missing do
      ellipsis_substitutions := !ellipsis_substitutions @ [ gen_sym "x" ]
    done);
  let pattern_str =
    Str.global_replace
      (Str.regexp "\\.\\.\\.")
      (String.concat " " !ellipsis_substitutions)
      (Printer.stringify pattern true)
  in
  let template_str =
    Str.global_replace
      (Str.regexp "\\.\\.\\.")
      (String.concat " " !ellipsis_substitutions)
      (Printer.print template true)
  in
  let args_str = Printer.stringify args true in
  print_endline ("ellipsis: template: " ^ template_str ^ "  args: " ^ args_str);
  "(" ^ pattern_str ^ ") " ^ template_str ^ ")"
;;

let lambdaize pattern template args =
  match pattern, args with
  | ph :: pt, ah :: at :: rest ->
    print_endline "lambdaize: list list";
    Reader.read
      ("((lambda " ^ ellipsis pt template args ^ Printer.stringify args false ^ ")")
  | ph :: pt, ah :: at ->
    print_endline "lambdaize: list short";
    Reader.read
      ("((lambda ("
      ^ Printer.stringify pt true
      ^ ")"
      ^ Printer.print template true
      ^ ")"
      ^ Printer.stringify args true
      ^ ")")
  | ph :: pt, [] ->
    print_endline "lambdaize: list empty";
    Reader.read
      ("((lambda ("
      ^ Printer.stringify pt false
      ^ ") "
      ^ Printer.print template true
      ^ "))")
  | _ ->
    print_endline "lambdaize: empty";
    Reader.read ("((lambda () " ^ Printer.print template true ^ "))")
;;

let rec expand ast env args sym meta =
  print_endline ("\n\nTHIS IS A MACRO: " ^ Printer.print sym true);
  print_endline ("   META: " ^ Printer.print meta true);
  print_endline ("   ARGS: " ^ Printer.dump args);
  print_endline ("  AST:   " ^ Printer.print ast true);
  match meta with
  | T.Map { T.value = m } ->
    (try
       let literals = Types.M9map.find Types.macro_literals m in
       let transformers = Types.M9map.find Types.macro_transformers m in
       print_endline
         ("  -- EVAL_MACRO: literals: "
         ^ Printer.print literals true
         ^ "     transformers: "
         ^ Printer.print transformers true);
       print_endline ("    args: " ^ Printer.dump args);
       let rec match_transform transforms =
         match transforms with
         | hd :: tl ->
           print_endline ("      transform: " ^ Printer.print hd true);
           (match hd with
           | T.List
               { T.value = [ T.List { T.value = pattern }; T.List { T.value = template } ]
               } ->
             print_endline "   MULTI";
             print_endline ("     - template: " ^ Printer.dump template);
             print_endline
               ("      matched?: "
               ^ (if is_matching_pattern
                       sym
                       (List.map (fun x -> Printer.print x true) pattern)
                       (Core.seq ast)
                       true
                 then "yes"
                 else "no")
               ^ " ::> "
               ^ Printer.dump pattern);
             if is_matching_pattern
                  sym
                  (List.map (fun x -> Printer.print x true) pattern)
                  (Core.seq ast)
                  true
             then lambdaize pattern (Types.list template) args
             else match_transform tl
           | T.List { T.value = [ T.List { T.value = pattern }; atom ] } ->
             print_endline "   SINGLE";
             print_endline
               ("      matched?: "
               ^ (if is_matching_pattern
                       sym
                       (List.map (fun x -> Printer.print x true) pattern)
                       (Core.seq ast)
                       true
                 then "yes"
                 else "no")
               ^ " ::> "
               ^ Printer.dump pattern);
             if is_matching_pattern
                  sym
                  (List.map (fun x -> Printer.print x true) pattern)
                  (Core.seq ast)
                  true
             then lambdaize pattern atom args
             else match_transform tl
           | _ -> T.Nil)
           (* errors? *)
         | [] -> T.Nil
       in
       match_transform (Core.seq transformers)
     with
    | Not_found -> T.Nil)
  | _ -> T.Nil
;;