shithub: martian9

ref: 1554de912987175430a808ad1d949f0567ca44bd
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
;;