1. Paweł Wieczorek
  2. Opifex

Source

Opifex / src / Lib / Command.ml

(*
 * Opifex
 *
 * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
 *)

(*************************************************************************************************
 * Command signature
 ************************************************************************************************)


type command = 
    { command_name       : string
    ; command_title      : string
    ; command_synopsis   : string list
    ; command_handler    : string list -> int
    }

type command_tree
    = LeafCommand of command
    | NodeCommand of (string * string * command_tree list) list


module type Command = sig

    val description : command

end

module type Language_representation = sig
    type ast

    type result

    type value

    type typecheck_result

    val name : string
end

module type Language_driver = sig

    module Representation : Language_representation

    open Representation

    val parse : Lexing.lexbuf -> ast

    val pretty_print : ast -> unit

    val eval : value Store.t -> ast -> result

    val show_value : value -> Formatter.painter list

    val print_result : result -> unit

    val typecheck : ast -> typecheck_result

    val print_typecheck_result : typecheck_result -> unit
end

(*************************************************************************************************
 * Make_parser_command functors
 *
 * Make command from simple parser driver
 ************************************************************************************************)


module Make_parser_command (LD : Language_driver) = struct

    let parse path =
            let file   = open_in path in
            let lexbuf = Lexing.from_channel file in
            let ast    = LD.parse lexbuf in
            ast

    let parse_file path =
        try
            Util.print_words_ln [ "-"; "parsing"; path ];
            let ast    = parse path in
            Util.print_words_ln [ "-"; "result:" ];
            LD.pretty_print ast
        with
            | Parsing.Parse_error ->
                Util.print_words_ln ["PARSING FAILED"]

    let handler arguments =
        List.iter parse_file arguments;
        0

    let title = Util.concat_words ["Run the parser and print an abstract syntax tree" ]

    let description =
        { command_name       = "parse" 
        ; command_title      = title
        ; command_synopsis   = []
        ; command_handler    = handler
        }
end

(*************************************************************************************************
 * Make_type_command functors
 ************************************************************************************************)


module Make_type_command (LD : Language_driver) = struct

    module MParser = Make_parser_command(LD) 

    let typecheck path =
        try
            Util.print_words_ln [ "-"; "parsing"; path ];
            let ast    = MParser.parse path in
            Util.print_words_ln [ "-"; "result:" ];
            LD.pretty_print ast;
            Util.print_words_ln [ "-"; "typechecking" ];
            let result = LD.typecheck ast in
            print_newline ();
            Util.print_words_ln [ "-"; "result:" ];
            LD.print_typecheck_result result;
            ()
        with
            | Parsing.Parse_error ->
                Util.print_words_ln [ "PARSING FAILED" ];
                ()

    let handler xs = 
            List.iter typecheck xs;
            0


    let title = Util.concat_words ["Run the typechecker" ]

    let description =
        { command_name       = "type"
        ; command_title      = title
        ; command_synopsis   = []
        ; command_handler    = handler
        }
end

(*************************************************************************************************
 * Make_eval_command functors
 *
 * Make command from simple imperative evaluator driver
 ************************************************************************************************)


module Make_eval_command (LD : Language_driver) = struct

    module MParser = Make_parser_command(LD)

    let eval path =
        try
            Util.print_words_ln [ "-"; "parsing"; path ];
            let ast    = MParser.parse path in
            Util.print_words_ln [ "-"; "result:" ];
            LD.pretty_print ast;
            let store  = Store.create () in
            Util.print_words_ln [ "-"; "evaluating" ];
            let result = LD.eval store ast in
            let doc    = Store.PrettyPrinter.show_store LD.show_value store in
            let output = Formatter.render_painter (Formatter.psp_nested 0 doc) in
            print_newline ();
            Util.print_words_ln [ "-"; "result:" ];
            LD.print_result result;
            Util.print_words_ln [ "-"; "memory:" ];
            print_endline output;
            0
        with
            | Parsing.Parse_error ->
                Util.print_words_ln [ "PARSING FAILED" ];
                -1

    let handler = function
        | (path::nil) ->
            eval path

        | _ ->
            raise Exit

        
        

    let title = Util.concat_words ["Run the imperative evaluator" ]

    let description =
        { command_name       = "eval"
        ; command_title      = title
        ; command_synopsis   = []
        ; command_handler    = handler
        }
end


(*************************************************************************************************
 * HELP - Builtin command 
 ************************************************************************************************)

module Help_command = struct


    let help_message_for_tree program_name hashtbl =
        let special_compare a b =
            match (fst a = "help", fst b = "help") with
                | (true, false) -> 1
                | (false, true) -> -1
                | (true, true)  -> 0
                | _ -> compare (fst a) (fst b)
            in

        let add_command _ sb result = (sb.command_name, sb.command_title) :: result in
        let elements                = Hashtbl.fold add_command hashtbl [] in
        let sorted_elements         = List.sort special_compare elements in

        let print_element (name, title) result = 
            Printf.sprintf "  %-15s %s" name title :: result
            in

        let output = List.fold_right print_element sorted_elements [] in
        let prefix =
            [ Predefined.copyright_header
            ; Predefined.build_header
            ; Util.concat_words [ "Usage:"; program_name; "<command>"; "[arguments...]" ]
            ; "" 
            ; "List of available commands:"
            ] in
        prefix @ output

    let general_handler program_name hashtbl =
        Util.print_lines (help_message_for_tree program_name hashtbl);
        0

    let handler program_name hashtbl = function
        | [] ->
            general_handler program_name hashtbl

        | [a] ->
            general_handler program_name hashtbl

        | _ ->
            Util.print_words_ln ["Zero or one argument please"];
            1

    let description program_name hashtbl = 
        { command_name       = "help"
        ; command_title      = "Print this message or dedicated help for given command"
        ; command_synopsis   = ["Help"]
        ; command_handler    = handler program_name hashtbl
        }

end

(*************************************************************************************************
 * First-class modules in action!
 ************************************************************************************************)

let create_language_command_tree driver =
    let module LD     = (val driver : Language_driver) in
    let module Parser = Make_parser_command(LD) in
    let module Eval   = Make_eval_command(LD) in
    let module Type   = Make_type_command(LD) in
    let subtrees = 
        [ LeafCommand Parser.description
        ; LeafCommand Eval.description
        ; LeafCommand Type.description
        ] in
    let command_name  = String.lowercase (LD.Representation.name) in
    let command_descr = LD.Representation.name ^ "-related commands" in
    NodeCommand [(command_name, command_descr, subtrees)]

let create_language_command_trees driver_list =
    let command_name  = "lang" in
    let command_descr = "Commands related to implemented languages" in
    let command_tree  = List.map create_language_command_tree driver_list in
    NodeCommand [(command_name, command_descr, command_tree)]

(*************************************************************************************************
 * CommandTree executor
 ************************************************************************************************)

module CommandTree_executor = struct


let execute_command compiled_commands selected_command command_arguments = 
    try
        let sb = Hashtbl.find compiled_commands selected_command in
        sb.command_handler command_arguments
    with
        | Not_found ->
            Util.print_words_ln [ "Unknown command"; selected_command ];
            -1

let rec execute_command_trees program_name command_tree program_arguments =
    let compiled_commands = compile_command_trees program_name command_tree in
    match program_arguments with
        | [] -> 
            execute_command compiled_commands "help" []

        | (selected_command :: command_arguments) ->
            execute_command compiled_commands selected_command command_arguments

and compile_command_trees program_name command_trees =
    let hash_table = Hashtbl.create 13 in
    List.iter (compile_command_tree program_name hash_table) command_trees;
    let help_command = Help_command.description program_name hash_table in
    Hashtbl.replace hash_table help_command.command_name help_command;
    hash_table

and compile_command_tree program_name hash_table = function
    | LeafCommand command ->
        Hashtbl.replace hash_table command.command_name command

    | NodeCommand subtrees ->
        List.iter (handle_subtree program_name hash_table) subtrees

and handle_subtree program_name hash_table (subtree_name, subtree_description, command_subtree) =
        let compiled_subtree = compile_command_trees program_name command_subtree in
        let prog_name        =  program_name ^ " " ^ subtree_name in
        let node_handler     = execute_command_trees prog_name command_subtree in
        let synopsis         = Help_command.help_message_for_tree prog_name compiled_subtree in
        let subtree_command  =
            { command_name      = subtree_name
            ; command_title     = subtree_description
            ; command_synopsis  = synopsis
            ; command_handler   = node_handler
            } in
        Hashtbl.replace hash_table subtree_name subtree_command

end