lib/ast.ml

  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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168

[@@@ocaml.text "/*"]

(** Copyright 2021-2024, Kakadu and contributors *)

(** SPDX-License-Identifier: LGPL-3.0-or-later *)

[@@@ocaml.text "/*"]

type name =
  | Wildcard
  | Real of string

type unary_operation =
  | Neg
  | Not
[@@deriving show { with_path = false }]

type binary_operation =
  | Add
  | Sub
  | Mul
  | Div
  | Mod
  | And
  | Or
  | Equal
  | NotEqual
  | Less
  | LessEqual
  | Greater
  | GreaterEqual
[@@deriving show { with_path = false }]

type let_mnemonic =
  | Let
  | LetRec
[@@deriving show { with_path = false }]

type t =
  | Unit
  | Int of int
  | Bool of bool
  | Var of name
  | Tuple of t * t * t list
  | UnaryOp of unary_operation * t
  | BinaryOp of binary_operation * t * t
  | IfThenElse of t * t * t
  | LetExpr of let_mnemonic * name * t * t
  | Abstraction of name * t
  | Application of t * t
  | Exception of string * t
  | TryWith of t * string * t
  | Raise of t

let show_name = function
  | Wildcard -> "_"
  | Real name -> name
;;

let rec show_ast_verbose = function
  | Unit -> "unit"
  | Int value -> string_of_int value
  | Bool value -> string_of_bool value
  | Var name -> show_name name
  | Tuple (first, second, rest) ->
    Format.sprintf
      "Tuple(%s)"
      (String.concat ", " (List.map show_ast_verbose (first :: second :: rest)))
  | UnaryOp (op, expr) ->
    Format.sprintf "%s(%s)" (show_unary_operation op) (show_ast_verbose expr)
  | BinaryOp (op, left, right) ->
    Format.sprintf
      "%s(%s, %s)"
      (show_binary_operation op)
      (show_ast_verbose left)
      (show_ast_verbose right)
  | IfThenElse (cond, then_expr, else_expr) ->
    Format.sprintf
      "IfThenElse(%s, %s, %s)"
      (show_ast_verbose cond)
      (show_ast_verbose then_expr)
      (show_ast_verbose else_expr)
  | LetExpr (rf, name, lhs, rhs) ->
    Format.sprintf
      "%s(%s, %s, %s)"
      (show_let_mnemonic rf)
      (show_name name)
      (show_ast_verbose lhs)
      (show_ast_verbose rhs)
  | Abstraction (name, expr) ->
    Format.sprintf "Abs(%s, %s)" (show_name name) (show_ast_verbose expr)
  | Application (lhs, rhs) ->
    Format.sprintf "App(%s, %s)" (show_ast_verbose lhs) (show_ast_verbose rhs)
  | Exception (name, expr) ->
    Format.sprintf "Exception(%s, %s)" name (show_ast_verbose expr)
  | TryWith (lhs, name, rhs) ->
    Format.sprintf
      "TryWith(%s, %s, %s)"
      (show_ast_verbose lhs)
      name
      (show_ast_verbose rhs)
  | Raise name -> Format.sprintf "Raise(%s)" (show_ast_verbose name)
;;

let show_pretty_unary_operation = function
  | Neg -> "-"
  | Not -> "!"
;;

let show_pretty_binary_operation = function
  | Add -> "+"
  | Sub -> "-"
  | Mul -> "*"
  | Div -> "/"
  | Mod -> "mod"
  | And -> "&&"
  | Or -> "||"
  | Equal -> "="
  | NotEqual -> "<>"
  | Less -> "<"
  | LessEqual -> "<="
  | Greater -> ">"
  | GreaterEqual -> ">="
;;

let show_pretty_rec_flag = function
  | Let -> "let"
  | LetRec -> "let rec"
;;

let rec show_ast = function
  | Unit -> "()"
  | Int value -> string_of_int value
  | Bool value -> string_of_bool value
  | Var name -> show_name name
  | Tuple (first, second, rest) ->
    Format.sprintf
      "(%s)"
      (String.concat ", " (List.map show_ast (first :: second :: rest)))
  | UnaryOp (op, expr) ->
    Format.sprintf "%s(%s)" (show_pretty_unary_operation op) (show_ast expr)
  | BinaryOp (op, left, right) ->
    Format.sprintf
      "(%s %s %s)"
      (show_ast left)
      (show_pretty_binary_operation op)
      (show_ast right)
  | IfThenElse (cond, then_expr, else_expr) ->
    Format.sprintf
      "if (%s) then (%s) else (%s)"
      (show_ast cond)
      (show_ast then_expr)
      (show_ast else_expr)
  | LetExpr (rf, name, lhs, rhs) ->
    Format.sprintf
      "%s %s = (%s) in (%s)"
      (show_pretty_rec_flag rf)
      (show_name name)
      (show_ast lhs)
      (show_ast rhs)
  | Abstraction (var, expr) ->
    Format.sprintf "fun %s -> %s" (show_name var) (show_ast expr)
  | Application (lhs, rhs) -> Format.sprintf "((%s) (%s))" (show_ast lhs) (show_ast rhs)
  | Exception (name, expr) -> Format.sprintf "let exception %s in %s" name (show_ast expr)
  | TryWith (lhs, name, rhs) ->
    Format.sprintf "try (%s) with %s -> (%s)" (show_ast lhs) name (show_ast rhs)
  | Raise name -> Format.sprintf "raise %s" (show_ast name)
;;