Commits

Paweł Wieczorek  committed 6877375

added prioritized infix

  • Participants
  • Parent commits 4233b0e

Comments (0)

Files changed (2)

File demo/Demo.ml

-open StringPainter.Basic
+open StringPainter.Prioritized
 
 
 module ArithmeticExpressions = struct
         | Binop of binop * expr * expr
         | Unop of unop * expr
 
-    let sp_binop = function
-        | Add ->
-            sp_operator "+"
+    let psp_binop = function
+        | Add -> psp_operator "+"
+        | Sub -> psp_operator "-"
+        | Mul -> psp_operator "*"
+        | Div -> psp_operator "/"
+        | Mod -> psp_operator "mod"
 
-        | Sub ->
-            sp_operator "-"
+    let assoc_binop = function
+        | _ -> LeftAssociative
 
-        | Mul ->
-            sp_operator "*"
+    let prio_binop = function
+        | Add -> 5
+        | Sub -> 5
+        | Mul -> 6
+        | Div -> 6
+        | Mod -> 6
 
-        | Div ->
-            sp_operator "/"
 
-        | Mod ->
-            sp_operator "mod"
+    let psp_unop = function
+        | Neg ->
+            psp_operator "-"
 
-    let sp_unop = function
-        | Neg ->
-            sp_operator "-"
+    let rec psp_expr : expr -> painter = function
+        | Int i ->
+            psp_value_int i
 
-    let rec sp_expr = function
-        | Int i ->
-            sp_value_int i
-
-        | Binop(op, e1, e2) -> sp_nested
-            [ sp_expr e1
-            ; sp_binop op
-            ; sp_expr e2
-            ]
+        | Binop(op, e1, e2) -> 
+            let assoc = assoc_binop op in
+            let prio  = prio_binop op in
+            psp_infix prio assoc (psp_binop op) (psp_expr e1) (psp_expr e2)
                 
 
-        | Unop (op, e1) -> sp_nested
-            [ sp_unop op
-            ; sp_expr e1
+        | Unop (op, e1) -> psp_nested 0
+            [ psp_unop op
+            ; psp_expr e1
             ]
 
 
 
 ;;
 
-print_painter_nl (sp_expr expr_12_3 );;
-print_painter_nl (sp_expr expr_1_23 )
+
+print_painter_nl (psp_expr expr_12_3 );;
+print_painter_nl (psp_expr expr_1_23 )
+

File src/Prioritized.ml

  ********************************************************************************************************************)
 
 type painter = int * Engine.painter
+
+type associativity
+    = LeftAssociative
+    | RightAssociative
+    | NoAssociative
+
+
+module Embedding = struct
+
+    let with_priority p sp = (p, sp)
+
+    let embed_sp1 prio (sp : 'a -> Engine.painter) x1 : painter =
+        with_priority prio (sp x1)
+
+    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 get_priority p = fst p
+
+let get_painter  p = snd p
+
+let psp_nested prio (xs : painter list) : painter = (prio, Engine.sp_nested (List.map get_painter xs))
+
+let psp_indent prio xs = (prio, Engine.sp_indent (List.map get_painter xs))
+
+let psp_reprioritize n (_, sp) = (n, sp)
+
+(*--------------------------------------------------------------------------------------------------------------------
+ * Basic combinators
+ *)
+
+let psp_word            = embed_sp1 0 Engine.sp_word
+let psp_keyword         = embed_sp1 0 Engine.sp_keyword
+let psp_value           = embed_sp1 0 Engine.sp_value
+let psp_value_keyword   = embed_sp1 0 Engine.sp_value_keyword
+let psp_operator        = embed_sp1 0 Engine.sp_operator
+let psp_syntax          = embed_sp1 0 Engine.sp_syntax
+
+let psp_value_int       = embed_sp1 0 Basic.sp_value_int
+
+
+(*--------------------------------------------------------------------------------------------------------------------
+ * 
+ *)
+
+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 ")") 0
+let psp_square_bracket = psp_bracket (psp_syntax "[") (psp_syntax "]") 0
+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_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 < prio_left)
+    (fun prio prio_right -> prio < succ prio_right)
+
+let psp_right_associative_infix = psp_associative_infix
+    (fun prio_left  prio -> prio < succ prio_left)
+    (fun prio_right prio -> prio < prio_right)
+
+
+
+let psp_infix prio assoc oper =
+    match assoc with
+        | LeftAssociative  -> psp_left_associative_infix prio oper
+        | RightAssociative -> psp_right_associative_infix prio oper
+        | NoAssociative    -> psp_left_associative_infix prio oper 
+
+(*--------------------------------------------------------------------------------------------------------------------
+ * Output
+ *)
+
+let print_painter_nl psp = Engine.print_painter_nl (get_painter psp)
+
+