Source

ocaml-stringpainter / demo / Demo.ml

Full commit
open StringPainter.Prioritized


module ArithmeticExpressions = struct

    type binop = Add | Sub | Mul | Div | Mod
    type unop  = Neg

    type expr
        = Int of int
        | Binop of binop * expr * expr
        | Unop of unop * expr

    let psp_binop = function
        | Add -> psp_operator "+"
        | Sub -> psp_operator "-"
        | Mul -> psp_operator "*"
        | Div -> psp_operator "/"
        | Mod -> psp_operator "mod"

    let assoc_binop = function
        | _ -> LeftAssociative

    let prio_binop = function
        | Add -> 5
        | Sub -> 5
        | Mul -> 6
        | Div -> 6
        | Mod -> 6


    let psp_unop = function
        | Neg ->
            psp_operator "-"

    let rec psp_expr : expr -> painter = function
        | Int i ->
            psp_value_int i

        | Binop(op, e1, e2) -> 
            let assoc = assoc_binop op in
            let prio  = prio_binop op in
            psp_infix assoc prio (psp_binop op) (psp_expr e1) (psp_expr e2)
                

        | Unop (op, e1) -> psp_nested 0
            [ psp_unop op
            ; psp_expr e1
            ]


    let expr_a = Int 5
    let expr_b = Int 10
    let expr_c = Int 15

    let expr_aADDb   = Binop(Add, expr_a,   expr_b)
    let expr_bADDc   = Binop(Add, expr_b, expr_c)

    let expr_aSUBb   = Binop(Sub, expr_a,   expr_b)
    let expr_bSUBc   = Binop(Sub, expr_b, expr_c)

    let expr_aMULb   = Binop(Mul, expr_a,   expr_b)
    let expr_bMULc   = Binop(Mul, expr_b, expr_c)




    let exprs =
        let mk_pair a b = (a,b) in
        [ mk_pair
            "(5 + 10) + 15"
            (Binop(Add, expr_aADDb, expr_c))

        ; mk_pair
            "5 + (10 + 15)"
            (Binop(Add, expr_a, expr_bADDc))

        ; mk_pair
            "(5 - 10) - 15"
            (Binop(Sub, expr_aSUBb, expr_c))

        ; mk_pair
            "5 - (10 - 15)"
            (Binop(Sub, expr_a, expr_bSUBc))

        ; mk_pair
            "(5 - 10) + 15"
            (Binop(Add, expr_aSUBb, expr_c))

        ; mk_pair
            "5 + (10 - 15)"
            (Binop(Add, expr_a, expr_bSUBc))

        ; mk_pair
            "(5 + 10) - 15"
            (Binop(Sub, expr_aADDb, expr_c))

        ; mk_pair
            "5 - (10 + 15)"
            (Binop(Sub, expr_a, expr_bADDc))

        ; mk_pair
            "(5 * 10) + 15"
            (Binop(Add, expr_aMULb, expr_c))

        ; mk_pair
            "5 + (10 * 15)"
            (Binop(Add, expr_a, expr_bMULc))

        ; mk_pair
            "(5 + 10) * 15"
            (Binop(Mul, expr_aADDb, expr_c))

        ; mk_pair
            "5 * (10 + 15)"
            (Binop(Mul, expr_a, expr_bADDc))

       ]

    
    let test () = List.iter
        (fun (s,x) -> print_string ">> "; print_endline s; print_painter_nl (psp_expr x); print_newline ())
        exprs
end


module Lambda = struct
    
    type binop = ArithmeticExpressions.binop

    type expr
        = Var of string
        | App of expr * expr
        | Binop of binop
        | Let of string * expr * expr
        | Abs of string * expr

    let app_priority = psp_max_priority - 50

    let prio_expr = function
        | Var _ -> psp_max_priority
        | App _ -> app_priority
        | Abs _ -> app_priority - 1
        | Binop _ -> app_priority - 1
        | Let _ -> app_priority - 1


    let rec _psp_expr = function
        | Binop op ->
            ArithmeticExpressions.psp_binop op

        | Var txt ->
            psp_word txt

        | App (e1, e2) -> psp_infix
            LeftAssociative
            app_priority
            (psp_nested 0 [])
            (psp_expr e1) (psp_expr e2)

        | Abs (x,e) -> psp_nested 0
            [ psp_keyword "fun"
            ; psp_word x
            ; psp_operator "->"
            ; psp_expr e
            ]

        | Let (x, e1, e2) -> psp_nested 0
            [ psp_keyword "let"
            ; psp_word x
            ; psp_operator "="
            ; psp_expr e1
            ; psp_keyword "in"
            ; psp_expr e2
            ]

    and psp_expr tm = psp_reprioritize (prio_expr tm) (_psp_expr tm)


    let expr_f = Var "f"
    let expr_g = Var "g"
    let expr_h = Var "h"

    let expr_fg = App (expr_f, expr_g)
    let expr_gh = App (expr_g, expr_h)

    let expr_let_x_f_g = Let ("x", expr_f, expr_g)
    let expr_let_y_g_h = Let ("y", expr_g, expr_h)

    let expr_abs_x_x = Abs ("x", Var "x")
    let expr_abs_x_f = Abs ("x", expr_f)
    let expr_abs_x_g = Abs ("x", expr_g)

    let exprs =
        let mk_pair a b = (a,b) in
        [ mk_pair
            "(f g) h"
            (App (expr_fg, expr_h))

        ; mk_pair
            "f (g h)"
            (App (expr_f, expr_gh))

        ; mk_pair
            "let x = f in g"
            expr_let_x_f_g

        ; mk_pair
            "let x = f in let y = g in h"
            (Let ("x", expr_f, expr_let_y_g_h))

        ; mk_pair
            "fun x -> x"
            expr_abs_x_x

        ; mk_pair
            "fun x -> let y = g in h"
            (Abs ("x", expr_let_y_g_h))

        ; mk_pair
            "(fun x -> x) f"
            (App(expr_abs_x_x, expr_f))

        ; mk_pair
            "(let id = (fun x -> x) in id) f"
            (App(Let("id", expr_abs_x_x, Var "id"), expr_f))

        ; mk_pair
            "(fun x -> x) (fun x -> x)"
            (App(expr_abs_x_x, expr_abs_x_x))

        ; mk_pair
            "fun x -> (f g)"
            (Abs("x", App(expr_f, expr_g)))

        ; mk_pair
            "(fun x -> x) (let x = f in g)"
            (App(expr_abs_x_x, expr_let_x_f_g))

        ; mk_pair
            "(let x = f in g) (let x = f in g)"
            (App(expr_let_x_f_g, expr_let_x_f_g))

        ; mk_pair
            "h (let x = f in g)"
            (App(expr_h, expr_let_x_f_g))

        ; mk_pair
            "h (fun x -> x)"
            (App(expr_h, expr_abs_x_x))
        ]

    
    let test () = List.iter
        (fun (s,x) -> print_string ">> "; print_endline s; print_painter_nl (psp_expr x); print_newline ())
        exprs

end


let _ = print_endline "ArithmeticExpressions"; print_newline ()

let _ = ArithmeticExpressions.test ()

let _ = print_endline "Lambda"; print_newline ()

let _ = Lambda.test ()