Commits

Paweł Wieczorek committed fce82b4 Draft

usable

Comments (0)

Files changed (7)

-OCAMLBUILD= ocamlbuild -use-ocamlfind
-OCAMLFIND = ocamlfind
-
-SOURCE_DIRS=\
-	-Is src\
+OCAMLBUILD= ocamlbuild -use-ocamlfind -no-hygiene
 
 DEMO_DIRS=\
 	-Is demo\
     type flag = ()
 
     let name = "about"
+    
+    let title = "about the program"
 
-    let description = "About program"
+    let description = "Prints description about program"
 
     let options = 
         []
 
     let name = "action"
 
-    let description = "Action program"
+    let title = "action program"
+
+    let description = "Executes some action"
 
     let options =
         let output x = Output x in
-        [ WithArgument    (output, "FILE", 'o', "output", "Output file")
-        ; WithoutArgument (Verbose, 'v', "verbose", "Verbose mode")
+        [ WithArgument    (output, "FILE", Some 'o', Some "output",         "output file")
+        ; WithoutArgument (Verbose,        None,     Some "verbose",        "verbose mode")
         ]
 
     let f = function
 
 let rec menu =
     [ Leaf (module AboutCommand : Command)
-    ; Node ("select", select_menu)
+    ; Node ("select", "Select an action to execute", select_menu)
     ]
 and select_menu =
     [ Leaf (module ActionCommand : Command)
     ]
 
+let header = String.concat "\n"
+    [ "Copyrights(C)2013 by Pawel Wieczorek"
+    ; ""
+    ; "Demo application"
+    ]
+
 ;;
 
 execute_command_tree_v menu Sys.argv
 all: ${DEMO}
 
 ${DEMO}: Demo.ml
-	${OCAMLC} -I ../_build/src -o ${DEMO} CommandTree.cma Demo.ml
+	${OCAMLC} -g -I ../_build/src -o ${DEMO} CommandTree.cma Demo.ml
 
 clean:
 	rm -f ${DEMO} Demo.cmo Demo.cmi 
+(*
+ * CommandTree
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+
+(*********************************************************************************************************************
+ * Types
+ ********************************************************************************************************************)
+
 open Type
 
 exception Unknown_command of string
 
 type tree
     = XLeaf of (module Command)
-    | XNode of string list * (string, tree) Hashtbl.t 
+    | XNode of string * (string, tree) Hashtbl.t 
 
-let rec fill_hashtable path hash_table = function
+(*********************************************************************************************************************
+ * Hash table fillers
+ ********************************************************************************************************************)
+
+let rec fill_hashtable hash_table = function
     | Leaf command_module ->
         let module Command  = (val command_module : Command) in
         Hashtbl.replace hash_table Command.name (XLeaf command_module)
 
-    | Node (name, commands) ->
-        let sub_hash_table = build_hashtable_for_node path commands in
-        Hashtbl.replace hash_table name (XNode (name :: path, sub_hash_table))
+    | Node (name, title, commands) ->
+        let sub_hash_table = build_hashtable_for_node commands in
+        Hashtbl.replace hash_table name (XNode (title, sub_hash_table))
         
 
-and build_hashtable_for_node path xs = 
+and build_hashtable_for_node xs = 
     let hash_table = Hashtbl.create 13 in
-    List.iter (fill_hashtable path hash_table) xs;
+    List.iter (fill_hashtable hash_table) xs;
     hash_table
 
-
-let execute_command command_module passed_arguments =
-    let module Command  = (val command_module : Command) in
-    let (flags, arguments) = GetOpt.getopt Command.options passed_arguments in
-    Command.action flags arguments
-
-
 let prepare command_trees =
     let hash_table = Hashtbl.create 13 in
-    List.iter (fill_hashtable [] hash_table) command_trees;
+    List.iter (fill_hashtable hash_table) command_trees;
     hash_table
 
+(*********************************************************************************************************************
+ * Printers
+ ********************************************************************************************************************)
 
-let rec execute hash_table = function
+let print_path = function
     | [] ->
-        print_endline "usage";
-        1
+        ""
+
+    | x::xs ->
+        List.fold_left (fun str elem -> elem ^ " " ^ str) x xs
+
+let list_of_available_commands hash_table =
+    let prepare_hashtbl_entry name entry aux = 
+        match entry with
+            | XLeaf command_module ->
+                let module Command  = (val command_module : Command) in
+                (name, Command.title) :: aux
+            | XNode (title, _) ->
+                (name, title) :: aux
+        in
+    let cmp (name1, _) (name2, _) = compare name1 name2 in
+    let entries = List.sort cmp (Hashtbl.fold prepare_hashtbl_entry hash_table []) in
+    let print_entry (name, title) = Printf.sprintf " %-15s %s" name title in
+    String.concat "\n" (List.map print_entry entries)
+
+let usage_of_node path hash_table = String.concat "\n"
+    [ "usage: " ^ print_path path
+    ; ""
+    ; "available commands:"
+    ; list_of_available_commands hash_table
+    ]
+
+let usage_of_leaf path command_module = 
+    let module Command  = (val command_module : Command) in
+    String.concat "\n"
+    [ "usage: " ^ print_path path
+    ; ""
+    ; Command.description
+    ; ""
+    ; GetOpt.usage_message Command.options
+    ]
+
+let print_usage_of_node path hash_table =
+    print_endline (usage_of_node path hash_table)
+
+let print_usage_of_leaf path command_module =
+    print_endline (usage_of_leaf path command_module)
+
+(*********************************************************************************************************************
+ * Entries
+ ********************************************************************************************************************)
+
+let execute_command path command_module passed_arguments =
+    let module Command  = (val command_module : Command) in
+    try
+        let (flags, arguments) = GetOpt.getopt Command.options passed_arguments in
+        Command.action flags arguments
+    with Invalid_usage str ->
+        print_usage_of_leaf path command_module;
+        -1
+
+let rec execute path hash_table = function
+    | [] ->
+        print_usage_of_node path hash_table;
+        0
 
     | command_name :: passed_arguments ->
         try
             match Hashtbl.find hash_table command_name with
             | XLeaf command_module ->
-                execute_command command_module passed_arguments
+                execute_command (command_name :: path) command_module passed_arguments
 
-            | XNode (_, sub_hash_table) ->
-                execute sub_hash_table passed_arguments
+            | XNode (title, sub_hash_table) ->
+                execute (command_name :: path) sub_hash_table passed_arguments
 
         with 
             | Not_found ->
-                raise (Unknown_command command_name)
+                print_usage_of_node path hash_table;
+                -1
+                
 
-let execute_command_tree commands =
-    execute (prepare commands)
+(*********************************************************************************************************************
+ * Entries
+ ********************************************************************************************************************)
 
+let execute_command_tree commands passed_arguments =
+    let hash_table = prepare commands in
+    match passed_arguments with
+    | executable_name :: passed_arguments ->
+        execute [executable_name] hash_table passed_arguments
+
+    | [] ->
+        print_usage_of_node [] hash_table;
+        0
 
 let execute_command_tree_v commands passed_arguments_v =
-    match Array.to_list passed_arguments_v with
-    | _ :: passed_arguments ->
-        execute (prepare commands) passed_arguments
+    let passed_arguments = Array.to_list passed_arguments_v in
+    execute_command_tree commands passed_arguments
 
-    | [] ->
-        print_endline "e";
-        0
-
+(*
+ * CommandTree
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
+
+
 exception Unknown_command of string
 
 val execute_command_tree_v : Type.command_tree list -> string array -> int
  * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
  *)
 
-exception Invalid_usage
 
 (*********************************************************************************************************************
  * Types
  ********************************************************************************************************************)
 
-type 'flag option_specification
-    = WithArgument of (string -> 'flag) * string * char * string * string
-    | WithoutArgument of 'flag * char * string * string
-
-type 'flag options_specification = 'flag option_specification list
+open Type
 
 (*********************************************************************************************************************
  * Private
 let create_mapping get_key options =
     let mapping = Hashtbl.create 13 in
     let update_mapping opt =
-        Hashtbl.replace mapping (get_key opt) opt
+        match get_key opt with
+            | Some key -> Hashtbl.replace mapping key opt
+            | None -> () 
         in
     List.iter update_mapping options;
     mapping
 
 let get_short_name = function
-    | WithArgument (_, _, short, _, _) -> "-" ^ String.make 1 short
-    | WithoutArgument (_, short, _, _) -> "-" ^ String.make 1 short
+    | WithArgument (_, _, Some short, _, _) -> Some ("-" ^ String.make 1 short)
+    | WithoutArgument (_, Some short, _, _) -> Some ("-" ^ String.make 1 short)
+    | _ -> None
 
 
 let get_long_name = function
-    | WithArgument (_, _, _, long, _) -> "--" ^ long
-    | WithoutArgument (_, _, long, _) -> "--" ^ long
+    | WithArgument (_, _, _, Some long, _) -> Some ("--" ^ long)
+    | WithoutArgument (_, _, Some long, _) -> Some ("--" ^ long)
+    | _ -> None
 
 
 let create_mappings options =
     | x::xs when is_option x ->
         begin match check_argument_in_mappings mappings x with
             | None ->
-                raise Invalid_usage
+                raise (Invalid_usage ("unknown option: " ^ x))
 
             | Some (WithoutArgument (flag, _, _, _)) ->
                 compute_flags mappings (flag::result) xs
 
             | Some (WithArgument (flag_func, _, _, name, _)) ->
-                obtain_argument_for_option mappings result flag_func name xs
+                obtain_argument_for_option mappings result flag_func name x xs
         end
 
     | xs ->
         (List.rev result, xs)
 
-and obtain_argument_for_option mappings result flag_func name = function
+and obtain_argument_for_option mappings result flag_func name passed_argument = function
     | [] ->
-        raise Invalid_usage
+        raise (Invalid_usage ("argument required for: " ^ passed_argument))
 
     | x::xs ->
         compute_flags mappings (flag_func x :: result) xs
        (String.length argument == 2 && argument.[0] = '-')
     || (String.length argument > 2  && argument.[0] = '-' && argument.[1] = '-')
 
-let describe_option = function
-    | _ ->
-        "option"
 
-let usage_message program_name options = 
-    let header = 
-        [ "usage: " ^ program_name ^ " OPTIONS ..."
-        ; ""
-        ; "Options:"
-        ] in
+let print_option_flag short long argname =
+    let sep = match short, long with
+        | Some _, Some _ -> ", "
+        | _ -> ""
+        in
 
-    let option_info = List.map describe_option options in
+    let str_short = match short with
+        | Some c -> "-" ^ String.make 1 c
+        | None   -> ""
+        in
 
-    String.concat "\n" (header @ option_info)
+    let str_long = match long with
+        | Some s -> "--" ^ s 
+        | None -> ""
+        in
+
+    let str_argname = if String.length argname <> 0
+        then " " ^ argname
+        else ""
+        in
+
+    str_short ^ sep ^ str_long ^ str_argname
+
+let print_option = function
+    | WithArgument (_, argname, short, long, title) ->
+        (print_option_flag short long argname, title)
+
+    | WithoutArgument (_, short, long, title) ->
+        (print_option_flag short long "", title)
+
+let usage_message options = 
+    let cmp (a,_) (b,_) = compare a b in
+    let entries = List.sort cmp (List.map print_option options) in
+    let f (name, title) = Printf.sprintf " %-20s %s" name title in
+    let output  = String.concat "\n" (List.map f entries) in
+    String.concat "\n"
+    [ "options:"
+    ; output
+    ]
 
 
 let getopt options arguments = 
     let mappings = create_mappings options in
     compute_flags mappings [] arguments
 
-(*********************************************************************************************************************
- * Group
- ********************************************************************************************************************)
 
-let embed_options embed = function 
-    | WithArgument (flag_func, argname, short, long, descr) ->
-       WithArgument ( (fun x -> embed (flag_func x)) , argname, short, long, descr)  
-   
-    | WithoutArgument (flag, short, long, descr) ->
-        WithoutArgument (embed flag, short, long, descr)
-
-(*********************************************************************************************************************
- * Example
- ********************************************************************************************************************)
-
-type flag
-    = OutputFile of string
-    | Verbose
-    | Help
-
-let options =
-    let outputFile x = OutputFile x in
-    [ WithoutArgument (Verbose, 'v', "verbose", "Set verbose") 
-    ; WithoutArgument (Help, 'h', "help", "Prints help")
-    ; WithArgument (outputFile, "FILE", 'o', "output", "Sets output file name")
-    ]
+(*
+ * CommandTree
+ *
+ * Copyrights(C) 2012,2013 by Pawel Wieczorek <wieczyk at gmail>
+ *)
 
 
+(*********************************************************************************************************************
+ * Types
+ ********************************************************************************************************************)
+
+exception Invalid_usage of string
+
+type 'flag option_specification
+    = WithArgument of (string -> 'flag) * string * char option * string option * string
+    | WithoutArgument of 'flag * char option * string option * string
+
+type 'flag options_specification = 'flag option_specification list
+
 module type Command = sig
 
     type flag
 
-    val options : flag GetOpt.options_specification
+    val options : flag options_specification
 
     val name : string
 
+    val title : string
+
     val description : string
 
     val action : flag list -> string list -> int
 end
 
 
+
 type command_tree
     = Leaf of (module Command)
-    | Node of string * command_tree list
+    | Node of string * string * command_tree list