Genspio API : EDSL.Command

let parse
      (options: ('a, unit t) cli_options)
      (action: anon: string list t -> 'a) : unit t =
    let prefix = Common.Unique_name.variable "getopts" in
    let variable {switches; doc;} =
      sprintf "%s_%s" prefix (String.concat ~sep:"" switches|> Digest.string |> Digest.to_hex) in
    let inits = ref [] in
    let to_init s = inits := s :: !inits in
    let cases = ref [] in
    let to_case s = cases := s :: !cases in
    let help_intro = ref "" in
    let help = ref [] in
    let to_help s = help := s :: !help in
    let string_of_var var =
      getenv (string var) in
    let bool_of_var var =
      getenv (string var) |> Bool.of_string in
    let anonarg_var = prefix ^ "_anon" |> string in
    let anon =
      getenv anonarg_var |> string_list_of_string in
    let applied_action =

(** The loop function below is building 3 pieces of Genspio code at once:

variable initializations
individual case statements (including variable assignments) that are part of the "while true { switch { .... } }" loop that incrementally interprets each command line argument.
applied_action (of type unit t) is the the result of applying the action function to all the elements of options + the list of anonymous arguments. It is hence the (user-provided) code that uses the parsed arguments. The loop function builds the closure as the loop goes since options is a “difference list”, see also: Drup's blog post.

The 2 first items are agglomerated in the inits and cases references. *)


      let rec loop
        : type a b.
          a -> (a, b) cli_options -> b =
        fun f -> function
        | Opt_end doc ->
          help_intro := doc;
          f
        | Opt_cons (Opt_string x, more) ->
          let var = variable x in
          to_init (
            setenv (string var) x.default);
          to_case (
            case (List.fold ~init:(bool false) x.switches ~f:(fun p s ->
                p ||| (string s =$= getenv (string "1"))))
              [
                if_seq (getenv (string "2") =$= string "")
                  ~t:[
                    eprintf
                      (string "ERROR option '%s' requires an argument\\n")
                      [getenv (string "1")];
                    fail;
                  ]
                  ~e:[
                    setenv (string var) (getenv (string "2"));
                  ];
                exec ["shift"];
                exec ["shift"];
              ]
          );
          ksprintf to_help "* `%s <string>`: %s"
            (String.concat ~sep:"," x.switches) x.doc;
          loop (f (string_of_var var)) more
        | Opt_cons (Opt_flag x, more) ->
          let var = variable x in
          to_init (
            setenv (string var) (Bool.to_string x.default)
          );
          to_case (
            case (List.fold ~init:(bool false) x.switches ~f:(fun p s ->
                p ||| (string s =$= getenv (string "1"))))
              [
                setenv (string var) (Bool.to_string (bool true));
                exec ["shift"];
              ]
          );
          ksprintf to_help "* `%s`: %s"
            (String.concat ~sep:"," x.switches) x.doc;
          loop (f (bool_of_var var)) more
      in
      loop (action ~anon) options
    in
    let help_msg =
      sprintf "%s\n\nOptions:\n\n%s\n"
        !help_intro (String.concat ~sep:"\n" (List.rev !help))
    in
    let help_flag_var = ksprintf string "%s_help" prefix in
    let while_loop =
      let body =
        let append_anon_arg_to_list =
          setenv anonarg_var (
            list_append
              (string_list_of_string (getenv anonarg_var))
              (list [getenv (string "1")])
            |> string_list_to_string
          ) in
        let help_case =
          let help_switches = ["-h"; "-help"; "--help"] in
          case
            (List.fold ~init:(bool false) help_switches ~f:(fun p s ->
                 p ||| (string s =$= getenv (string "1")))) [
            setenv help_flag_var (Bool.to_string (bool true));
            string help_msg >>  exec ["cat"];
            exec ["break"];
          ]
        in
        let dash_dash_case =
          case (getenv (string "1") =$= string "--") [
            exec ["shift"];
            loop_while (getenv (string "#") <$> string "0") ~body:begin
              seq [
                append_anon_arg_to_list;
                exec ["shift"];
              ]
            end;
            exec ["break"];
          ] in
        let anon_case =
          case (getenv (string "#") <$> string "0") [
            append_anon_arg_to_list;
            exec ["shift"];
          ] in
        let default_case =
          default [
            exec ["break"];
          ] in
        let cases =
          help_case :: List.rev !cases @ [dash_dash_case; anon_case; default_case] in
        seq [
          switch cases;
        ] in
      loop_while (bool true) ~body
    in
    seq [
      setenv help_flag_var (Bool.to_string (bool false));
      setenv anonarg_var (string_list_to_string (list []));
      seq (List.rev !inits);
      while_loop;
      if_then_else (bool_of_var (sprintf "%s_help" prefix))
        (nop)
        applied_action;
    ]