1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
open Lang

module Make (M : sig
  type type_expression

  val fprintf_type : Format.formatter -> type_expression -> unit
end) =
struct
  let fprintf_literal fmt = function
    | Unit ->
        Format.fprintf fmt "Unit"
    | Bool b ->
        Format.fprintf fmt "%s" (if b then "True" else "False")

  let fprintf_const fmt = function
    | Literal l ->
        Format.fprintf fmt "%a" fprintf_literal l
    | Var v ->
        Format.fprintf fmt "%s" v

  let fprintf_pattern fmt p = Format.fprintf fmt "%s" p

  let get_args_nosugar =
    let rec get_args_nosugar acc = function
      | Abstract (b, x, e) -> (
        match b with Raw -> get_args_nosugar (x :: acc) e | Generated -> acc )
      | _ ->
          acc
    in
    get_args_nosugar []

  let rec get_args_sugar acc = function
    | Abstract (b, x, e) as a -> (
      match b with Generated -> get_args_sugar (x :: acc) e | Raw -> (acc, a) )
    | e ->
        (acc, e)

  let fprintf_args fmt l =
    Format.fprintf fmt "%a"
      (Format.pp_print_list
         ~pp_sep:(fun _ () -> Format.fprintf fmt " ")
         fprintf_pattern)
      (List.rev l)

  let rec fprintf_bind fmt (f, e1, e2) =
    let args, e = get_args_sugar [] e1 in
    match args with
    | [] ->
        Format.fprintf fmt "let %a = %a in %a" fprintf_pattern f fprintf_expr e1
          fprintf_expr e2
    | args ->
        Format.fprintf fmt "let %a %a = %a in %a" fprintf_pattern f fprintf_args
          args fprintf_expr e fprintf_expr e2

  and fprintf_expr fmt = function
    | Const c ->
        fprintf_const fmt c
    | Bind (p, e1, e2) ->
        fprintf_bind fmt (p, e1, e2)
    | Abstract (_, p, e) ->
        Format.fprintf fmt "(fun %a -> %a)" fprintf_pattern p fprintf_expr e
    | Apply (e, e') -> (
      match e' with
      | Apply _ ->
          Format.fprintf fmt "%a (%a)" fprintf_expr e fprintf_expr e'
      | _ ->
          Format.fprintf fmt "%a %a" fprintf_expr e fprintf_expr e' )
    | If_then_else (cond, e1, e2) ->
        Format.fprintf fmt "if %a then %a else %a end" fprintf_expr cond
          fprintf_expr e1 fprintf_expr e2
    | Match (_orig, match_expr, cases) ->
        Format.fprintf fmt "match %a with@.%a end@." fprintf_expr match_expr
          (Format.pp_print_list
             ~pp_sep:(fun _ () -> Format.fprintf fmt "@.")
             fprintf_match_case)
          cases

  and fprintf_match_case fmt (con, expr) =
    Format.fprintf fmt "| %a -> %a" fprintf_literal con fprintf_expr expr

  let fprintf_primitive_type fmt =
    let open Types in
    function
    | Unit -> Format.fprintf fmt "unit" | Bool -> Format.fprintf fmt "bool"

  let fprintf_type = M.fprintf_type

  let fprintf_et fmt (e, t) =
    Format.fprintf fmt "%a : %a" fprintf_expr e fprintf_type t
end