1. Paweł Wieczorek
  2. Opifex

Source

Opifex / src / Language / MiniML / MiniML_PrettyPrinter.ml

The branch 'port-stringpainter' does not exist.
(*
 * Opifex
 *
 * Copyrights(C) 2012 by Pawel Wieczorek <wieczyk at gmail>
 *)

open MiniML_AST
open Formatter
open Batteries

(*************************************************************************************************
 * Type representation
 ************************************************************************************************)

let rec collect_binders unhask xs ast =
    match unhask ast with
        | Some (x, inner) -> collect_binders unhask (x::xs) inner
        | None            -> (List.rev xs, ast)


let unhask_lambda_fun = function
    | EXPR_Lambda (LEXPR_Fun (_, argument, body)) ->
        Some (argument,body)
    | _ ->
        None

(*************************************************************************************************
 * Pretty printers
 ************************************************************************************************)

(*------------------------------------------------------------------------------------------------
 * Pretty printer for expression
 *)

let show_type_variable var =
    [ Formatter.psp_label (string_of_type_variable var)
    ]


let show_with_brackets fmt =
    [ Formatter.psp_syntax "("
    ; Formatter.psp_nested 0 fmt
    ; Formatter.psp_syntax ")"
    ]

let precedense_priority = function
    | TP_Ref _ -> 1
    | TP_Fun _ -> 2
    | _        -> 0


let rec show_type_expression _type = match _type with
    | TP_Int -> [ Formatter.psp_keyword "int" ]
    | TP_Bool -> [ Formatter.psp_keyword "bool" ]
    | TP_Unit ->  [ Formatter.psp_keyword "unit" ]
    | TP_Fun (tp_dom, tp_codom) ->
        show_with_brackets
        [ Formatter.psp_nested 0 (show_type_expression tp_dom)
        ; Formatter.psp_operator "->"
        ; Formatter.psp_nested 0 (show_type_expression tp_codom)
        ]

    | TP_Ref tp_ref ->
        [ Formatter.psp_nested 0 (show_type_expression tp_ref)
        ; Formatter.psp_keyword "ref"
        ]

    | TP_Variable tv ->
        [ Formatter.psp_nested 0 (show_type_variable tv)
        ]

(*------------------------------------------------------------------------------------------------
 * Pretty printer for expression
 *)

let rec show_expression = function
    | EXPR_Lambda lambda_expression ->
        show_lambda_expression lambda_expression

    | EXPR_Control control_expression ->
        show_control_expression control_expression

    | EXPR_Boolean boolean_expression ->
        show_boolean_expression boolean_expression

    | EXPR_Arithmetic arithmetic_expression ->
        show_arithmetic_expression arithmetic_expression

    | EXPR_Store store_expression ->
        show_store_expression store_expression


(*------------------------------------------------------------------------------------------------
 * Pretty printer for lambda_expression
 *)

and show_lambda_expression = function
    | LEXPR_Variable (_, variable) -> 
        [ psp_variable variable
        ]

    | LEXPR_App (_, first_expression, second_expression) ->
        let first_document  = show_expression first_expression in
        let second_document = show_expression second_expression in
        [ psp_nested 0 first_document
        ; psp_nested 0 second_document
        ]

    | LEXPR_Fun (label, argument, body) ->
        let (binded_variables, concrete_body) = collect_binders unhask_lambda_fun [] body in
        [ psp_keyword "fun" (* printing label, for fun currently *)
        ; psp_syntax "(*"
        ; psp_syntax (string_of_label label)
        ; psp_syntax "*)"
        ; psp_variable argument
        ; psp_nested 0 (List.map (fun s -> psp_variable s) binded_variables)
        ; psp_operator "->"
        ; psp_indent 0 (show_expression concrete_body)
        ]

    | LEXPR_Let (_, variable, binded_expression, expression) ->
        let (binded, concrete_body) = collect_binders unhask_lambda_fun [] binded_expression in
        [ psp_keyword "let"
        ; psp_variable variable
        ; psp_nested 0 (List.map (fun s -> psp_variable s) binded)
        ; psp_operator "="
        ; psp_nested 0 (show_expression concrete_body)
        ; psp_keyword "in"
        ; psp_break
        ; psp_nested 0 (show_expression expression)
        ]

    | LEXPR_Rec (_, definitions, expression) ->
        let handle_def (_, variable, argument_variable, binded_expression) aux =
            let (binded, concrete_body) = collect_binders unhask_lambda_fun [] binded_expression in
            [ psp_variable variable
            ; psp_variable argument_variable
            ; psp_nested 0 (List.map (fun s -> psp_variable s) binded)
            ; psp_operator "="
            ; psp_nested 0 (show_expression concrete_body)
            ] :: aux in

        let aux = List.fold_right handle_def definitions [] in

        let result = Util.concat_intersperse' [psp_keyword "and"] aux in

        [ psp_keyword "let"
        ; psp_keyword "rec"
        ; psp_nested 0 (result)
        ; psp_keyword "in"
        ; psp_break
        ; psp_nested 0 (show_expression expression)
        ] 

(*------------------------------------------------------------------------------------------------
 * Pretty printer for control_expression
 *)

and show_control_expression = function
    | CEXPR_If (_, condition, then_expression, else_expression) ->
        [ psp_keyword "if"
        ; psp_nested 0 (show_expression condition)
        ; psp_indent 0
            [ psp_keyword "then"
            ; psp_indent 0 (show_expression then_expression)
            ]
        ; psp_indent 0
            [ psp_keyword "else"
            ; psp_indent 0 (show_expression else_expression)
            ]
        ]

    | CEXPR_Try (_, expression, exception_identifier, catch_expression) ->
        [ psp_keyword "try"
        ; psp_indent 0
            [ psp_nested 0 (show_expression expression)
            ]
        ; psp_keyword "catch"
        ; psp_label (string_of_identifier exception_identifier)
        ; psp_indent 0
            [ psp_nested 0 (show_expression catch_expression)
            ]
        ]

    | CEXPR_Unit _ ->
        [ psp_value "()"
        ]

    | CEXPR_Throw (_, identifier) ->
        [ psp_keyword "throw"
        ; psp_label (string_of_identifier identifier)
        ]

    | CEXPR_Compose (_, first_expression, second_expression) ->
        [ psp_nested 0 (show_expression first_expression)
        ; psp_syntax ";"
        ; psp_break
        ; psp_nested 0 (show_expression second_expression)
        ]
 
(*------------------------------------------------------------------------------------------------
 * Pretty printer for boolean_expression
 *)

and show_boolean_expression = function
    | BEXPR_Constant (_, constant) ->
        [ psp_value_bool constant
        ]

    | BEXPR_BinaryOperator (_, operator, first_expression, second_expression) ->
        let first_document  = show_expression first_expression in
        let second_document = show_expression second_expression in
        [ psp_nested 0 first_document
        ; psp_boolean_binary_operator operator
        ; psp_nested 0 second_document
        ]

    | BEXPR_UnaryOperator (_, operator, expression) ->
        let document  = show_expression expression in
        [ psp_boolean_unary_operator operator
        ; psp_nested 0 document
        ]

    | BEXPR_ArithmeticBinaryOperator (_, operator, first_expression, second_expression) ->
        let first_document  = show_expression first_expression in
        let second_document = show_expression second_expression in
        [ psp_nested 0 first_document
        ; psp_boolean_arithmetic_binary_operator operator
        ; psp_nested 0 second_document
        ]

(*------------------------------------------------------------------------------------------------
 * Pretty printer for arithmetic_expression
 *)

and show_arithmetic_expression = function
    | AEXPR_Constant (_, constant) ->
        [ psp_value_int constant
        ]

    | AEXPR_BinaryOperator (_, arithmetic_op, first_expression, second_expression) ->
        let first_document  = show_expression first_expression in
        let second_document = show_expression second_expression in
        [ psp_nested 0 first_document
        ; psp_arithmetic_binary_operator arithmetic_op
        ; psp_nested 0 second_document
        ]

    | AEXPR_UnaryOperator (_, arithmetic_op, expression) ->
        let document  = show_expression expression in
        [ psp_arithmetic_unary_operator arithmetic_op
        ; psp_nested 0 document
        ]

and show_store_expression = function
    | SEXPR_Deref (_, expression) ->
        [ psp_operator "!"
        ; psp_nested 0 (show_expression expression)
        ]

    | SEXPR_Assign (_, loc_expression, val_expression) ->
        [ psp_nested 0 (show_expression loc_expression)
        ; psp_operator ":="
        ; psp_nested 0 (show_expression val_expression)
        ]

    | SEXPR_Ref (_, expression) ->
        [ psp_keyword "ref"
        ; psp_nested 0 (show_expression expression)
        ]

(*------------------------------------------------------------------------------------------------
 * Pretty printer for declaration
 *)

let show_declaration = function
    | DECL_Rec (_, declarations)  ->
        let handle_def (_, name, argument_name, expression) aux = 
            let (binded, concrete_body) = collect_binders unhask_lambda_fun [] expression  in
            [ psp_variable name
            ; psp_variable argument_name
            ; psp_nested 0 (List.map (fun s -> psp_variable s) binded)
            ; psp_operator "="
            ; psp_indent 0 (show_expression concrete_body)
            ; psp_break
            ; psp_newline
            ] :: aux in 
        let result = Util.concat_intersperse' [psp_keyword "and"]  (List.fold_right handle_def declarations []) in
        [ psp_keyword "let"
        ; psp_keyword "rec"
        ; psp_nested 0 (result)
        ; psp_break
        ] 

    | DECL_Let (_, name, expression) ->
        let (binded, concrete_body) = collect_binders unhask_lambda_fun [] expression  in
        [ psp_keyword "let"
        ; psp_variable name
        ; psp_nested 0 (List.map (fun s -> psp_variable s) binded)
        ; psp_operator "="
        ; psp_indent 0 (show_expression concrete_body)
        ; psp_break
        ; psp_newline
        ]

(*------------------------------------------------------------------------------------------------
 * Pretty printer for program
 *)

let show_program = function
    | PROGRAM (declarations, main_expr) ->
       [ psp_nested 0 (Util.concat_map show_declaration declarations)
       ; psp_break
       ; psp_syntax ";;"
       ; psp_break
       ; psp_nested 0 (show_expression main_expr)
       ]

(*************************************************************************************************
 * Type representation
 ************************************************************************************************)

let print_program = Formatter.render_painter -| psp_nested 0 -| show_program

let print_expression = Formatter.render_painter -| psp_nested 0 -| show_expression