Source

ocaml-stringpainter / src / Prioritized.ml

Full commit
(*********************************************************************************************************************
 * Copyrights (C) by
 *  Pawel Wieczorek <wieczyk gmail>
 *
 * http://bitbucket.org/wieczyk/ocaml-stringpainter
 ********************************************************************************************************************)

type priority = int

type painter = priority * Basic.painter


type associativity
    = LeftAssociative
    | RightAssociative
    | NoAssociative


module Embedding = struct

    let with_priority p sp = (p, sp)

    let embed_sp1 prio sp x1 =
        with_priority prio (sp x1)

    let unhask_sp0 f (_, sp) = f sp

    let embed_sp2 prio sp x1 x2 =
        with_priority prio (sp x1 x2)

    let embed_sp3 prio sp x1 x2 x3 =
        with_priority prio (sp x1 x2 x3)

end

open Embedding


let with_priority = Embedding.with_priority

let get_priority p = fst p

let get_painter  p = snd p

let psp_nested prio (xs : painter list) : painter = (prio, Basic.sp_nested (List.map get_painter xs))

let psp_group_with_priority prio (xs : painter list) : painter = (prio, Basic.sp_nested (List.map get_painter xs))

let psp_group = psp_group_with_priority 0

let psp_indent_group_with_priority prio xs = (prio, Basic.sp_indent (List.map get_painter xs))

let psp_indent_group = psp_indent_group_with_priority 0

let psp_indent prio xs = (prio, Basic.sp_indent (List.map get_painter xs))

let psp_indent_with_priority' prio x = psp_indent_group_with_priority prio [x]

let psp_indent' = psp_indent_with_priority' 0


let psp_reprioritize n (_, sp) = (n, sp)

let psp_max_priority = pred max_int / 2

let psp_min_priority = pred min_int / 2

let is_multiline    = unhask_sp0 Basic.is_multiline

let any_multiline   = List.exists is_multiline

(*--------------------------------------------------------------------------------------------------------------------
 * Basic combinators
 *)

let psp_break           = with_priority psp_max_priority Basic.sp_break
let psp_newline         = with_priority psp_max_priority Basic.sp_newline

let psp_word            = embed_sp1 psp_max_priority Basic.sp_word
let psp_keyword         = embed_sp1 psp_max_priority Basic.sp_keyword
let psp_value           = embed_sp1 psp_max_priority Basic.sp_value
let psp_value_keyword   = embed_sp1 psp_max_priority Basic.sp_value_keyword
let psp_operator        = embed_sp1 psp_max_priority Basic.sp_operator
let psp_syntax          = embed_sp1 psp_max_priority Basic.sp_syntax
let psp_label           = embed_sp1 psp_max_priority Basic.sp_label
let psp_special         = embed_sp1 psp_max_priority Basic.sp_special

let psp_value_int       = embed_sp1 psp_max_priority Basic.sp_value_int
let psp_value_bool      = embed_sp1 psp_max_priority Basic.sp_value_bool


(*--------------------------------------------------------------------------------------------------------------------
 * 
 *)

let psp_bracket psp_opening psp_closing n psp_elem = psp_nested n
    [ psp_opening
    ; psp_elem
    ; psp_closing
    ]

let psp_std_bracket    = psp_bracket (psp_syntax "(") (psp_syntax ")") psp_max_priority
let psp_square_bracket = psp_bracket (psp_syntax "[") (psp_syntax "]") psp_max_priority
let psp_no_bracket     = psp_reprioritize 0

let psp_decide_bracket brackets = function
    | true ->
        brackets

    | false ->
        psp_no_bracket

let psp_decide_std_bracket = psp_decide_bracket psp_std_bracket

(*--------------------------------------------------------------------------------------------------------------------
 * 
 *)

let psp_indent_when_multiline prio psp =
    if any_multiline psp
    then psp_indent prio psp
    else psp_nested prio psp

(*--------------------------------------------------------------------------------------------------------------------
 * correct_priority
 *)

let psp_correct_priority_after f_prio f x = 
    psp_reprioritize (f_prio x) (f x)


(*--------------------------------------------------------------------------------------------------------------------
 * 
 *)

let psp_associative_infix f_left f_right prio oper left right =
    let prio_left  = get_priority left in
    let prio_right = get_priority right in 
    psp_nested prio
        [ psp_decide_std_bracket (f_left prio_left prio) left
        ; oper
        ; psp_decide_std_bracket (f_right prio prio_right) right
        ]

let psp_left_associative_infix = psp_associative_infix
    (fun prio_left  prio -> prio_left  < prio)
    (fun prio prio_right -> prio_right < succ prio)

let psp_right_associative_infix = psp_associative_infix
    (fun prio_left  prio -> prio_left  < succ prio)
    (fun prio prio_right -> prio_right < prio)

let psp_no_associative_infix = psp_associative_infix
    (fun prio_left  prio -> prio_left  < succ prio)
    (fun prio prio_right -> prio_right < succ prio)


let psp_infix = function
    | LeftAssociative  -> psp_left_associative_infix 
    | RightAssociative -> psp_right_associative_infix 
    | NoAssociative    -> psp_no_associative_infix 

let psp_gen_infix f_assoc f_prio f_paint oper =
    psp_infix (f_assoc oper) (f_prio oper) (f_paint oper)

(*--------------------------------------------------------------------------------------------------------------------
 * Output
 *)

let print_painter_nl psp = Basic.print_painter_nl (get_painter psp)
let print_painter psp = Basic.print_painter (get_painter psp)
let render_painter psp = Basic.render_painter (get_painter psp)

let print_painters_nl psps = print_painter_nl (psp_nested 0 psps)
let print_painters psps    = print_painter (psp_nested 0 psps)
let render_painters psps   = render_painter (psp_nested 0 psps)