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
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
module Make (M : sig
  module Types : sig
    type type_expression
  end

  module Pp : sig
    val fprintf_expr : Format.formatter -> Lang.expr -> unit

    val fprintf_type : Format.formatter -> Types.type_expression -> unit
  end
end) =
struct
  exception Apply_anon_const

  exception Const_rebind of Lang.var_id

  exception Duplication of Lang.expr

  exception Inline_lack of Lang.var_id

  exception Internal_error of string

  exception Known_value of Lang.expr

  exception Recursive_type of M.Types.type_expression

  exception Scope_too_large of Lang.var_id

  exception Sugar_lack_args of Lang.var_id * Lang.var_id list

  exception Unbound_variable of Lang.var_id

  exception Unused_variable of Lang.var_id

  exception Useless_if of Lang.expr

  exception Useless_if_cond of Lang.expr

  exception Useless_if_expr of Lang.expr

  exception Wrong_application of Lang.expr * M.Types.type_expression

  exception
    Wrong_type of Lang.expr * M.Types.type_expression * M.Types.type_expression

  let args_to_string = List.fold_left (fun acc el -> el ^ " " ^ acc) ""

  let args_anon_to_string =
    List.fold_left (fun acc el -> "fun " ^ el ^ " -> " ^ acc) "..."

  let fprintf fmt = function
    | Apply_anon_const ->
        Format.fprintf fmt
          "you're applying an anonymous function, it's useless, inline the arg \
           and remove that function"
    | Const_rebind x ->
        Format.fprintf fmt "variable %s is useless, please inline it" x
    | Duplication e ->
        Format.fprintf fmt
          "expression `%a` is duplicated in your program, please factor it"
          M.Pp.fprintf_expr e
    | Inline_lack x ->
        Format.fprintf fmt "variable %s is used only once, please inline it" x
    | Internal_error s ->
        Format.fprintf fmt "%s" s
    | Known_value e ->
        Format.fprintf fmt "known value for expr `%a`" M.Pp.fprintf_expr e
    | Complice.Cli.Empty_filename ->
        Format.fprintf fmt "file name shouldn't be empty"
    | Complice.Lexer.Error s
    | Complice.Parse.Error s
    | Complice.Cli.File_is_dir s
    | Complice.Cli.Invalid_filename s
    | Complice.Cli.Missing_file s
    | Complice.Cli.Usage s ->
        Format.fprintf fmt "%s" s
    | Recursive_type t ->
        Format.fprintf fmt
          "type %a is recursive, stop doing this please... ( \
           https://youtu.be/mqA2evDu4Mw )"
          M.Pp.fprintf_type t
    | Scope_too_large x ->
        Format.fprintf fmt "the scope of the variable %s can be reduced" x
    | Sugar_lack_args (f, x) ->
        Format.fprintf fmt
          "please use more sugar: you should write `let %s %s= ... in ...` \
           instead of `let %s = %s in ...`"
          f (args_to_string x) f (args_anon_to_string x)
    | Unbound_variable id ->
        Format.fprintf fmt "unbound variable %s" id
    | Unused_variable id ->
        Format.fprintf fmt "unused variable %s" id
    | Useless_if expr ->
        Format.fprintf fmt "useless if, it is equivalent to the condition: `%a`"
          M.Pp.fprintf_expr expr
    | Useless_if_cond cond ->
        Format.fprintf fmt "useless if, the condition is constant: `%a`"
          M.Pp.fprintf_expr cond
    | Useless_if_expr expr ->
        Format.fprintf fmt "useless if, the two branches are the same: `%a`"
          M.Pp.fprintf_expr expr
    | Wrong_application (e, t) ->
        Format.fprintf fmt
          "expression `%a` has type %a, it is not a function, it can't be \
           applied"
          M.Pp.fprintf_expr e M.Pp.fprintf_type t
    | Wrong_type (e, t, t') ->
        Format.fprintf fmt
          "expression `%a` has type %a but an expression of type %a was \
           expected"
          M.Pp.fprintf_expr e M.Pp.fprintf_type t M.Pp.fprintf_type t'
    | e ->
        raise e
end