summaryrefslogtreecommitdiff
path: root/utils.ml
blob: 3e055791f8195ccf8d5d0fcae2d5d43cc6a5b97e (plain)
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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
(****************************************
   utils.ml - helpers divers et variés
 ****************************************)

open Ast
open Lexing
open Typing

(* Formatage de base des constantes, motifs et opérateurs *)

let format_const = function
    | Cint i -> Printf.sprintf "Cint %d" i
    | Cstring s -> Printf.sprintf "Cstring \"%s\"" s
    | Cbool true -> "Cbool true"
    | Cbool false -> "Cbool false"
    | Cunit -> "Cunit ()"
    | Cemptylist -> "Cemptylist []"

let format_unop = function
    | ONot -> "ONot"
    | ONeg -> "ONeg"

let format_binop = function
    | OAdd -> "OAdd"
    | OSub -> "OSub"
    | OMul -> "OMul"
    | ODiv -> "ODiv"
    | OAnd -> "OAnd"
    | OOr -> "OOr"
    | OEq -> "OEq"
    | ONeq -> "ONeq"
    | OLt -> "OLt"
    | OLe -> "OLe"
    | OGt -> "OGt"
    | OGe -> "OGe"

let rec format_motif m =
    match m.m with
        | Munderscore -> "Munderscore _"
        | Mident id -> Printf.sprintf "Mident %s" id
        | Mtuple (m::motifs) ->
            List.fold_left motif_tuple_folder (format_motif m) motifs
        | Mtuple [] -> "" (* Avoids an useless warning *)
and motif_tuple_folder base motif =
    Printf.sprintf "%s, %s" base (format_motif motif)
and motif_list_folder base motif =
    Printf.sprintf "%s ; %s" base (format_motif motif)

(* Helper pour l'indentation, crée une string de `level` espaces de long *)
let make_indent level =
    Printf.sprintf "%s" (String.make level ' ')

let format_string_option = function
    | None -> "None"
    | Some x -> Printf.sprintf "Some %s" x

let typeof e =
    match e.t with
        | None -> ""
        | Some t ->
            let ts, tvar_names = canon_string t Imap.empty
            in
                Printf.sprintf "{%s}" ts

let rec format_expr level expr =
    let expr_t = typeof expr
    in
        match expr.e with
                | Econst c -> Printf.sprintf "Econst%s %s" expr_t
                                                           (format_const c)
                | Eident id -> Printf.sprintf "Eident%s %s" (typeof expr) id
                | Etuple (e1::l) ->
                    Printf.sprintf "Etuple%s (%s,\n%s)"
                        expr_t
                        (format_expr (level + 8) e1)
                        (format_expr_list "," (level + 8) l)
                | Etuple l -> ""
                | Eunop (o, e) ->
                    let so = (format_unop o)
                    in
                        Printf.sprintf "Eunop%s (%s, %s)" expr_t so
                               (format_expr (level + 9 + String.length so) e)
                | Ebinop (e1, o, e2) ->
                    let s1 = format_expr (level + 8) e1 and so = format_binop o
                    and s2 = format_expr_i (level + 8) e2
                    in
                        Printf.sprintf "Ebinop%s (%s,\n%s%s,\n%s)" expr_t s1
                            (make_indent (level + 8)) so s2
                | Eletin (m, value, body) ->
                    Printf.sprintf "Eletin%s (%s,\n%s,\n%s)" expr_t
                        (format_motif m)
                        (format_expr_i (level + 8) value)
                        (format_expr_i (level + 8) body)
                | Efunc f ->
                    format_func level expr_t f
                | Eif (cond, then_expr, else_expr) ->
                    Printf.sprintf "Eif%s (%s,\n%s,\n%s)" expr_t
                        (format_expr (level + 5) cond)
                        (format_expr_i (level + 5) then_expr)
                        (format_expr_i (level + 5) else_expr)
                | Elistcons (hd_expr, tl_expr) ->
                    Printf.sprintf "Elistcons%s (%s,\n%s)" expr_t
                        (format_expr (level + 11) hd_expr)
                        (format_expr_i (level + 11) tl_expr)
                | Ecall (func_expr, arg) ->
                    Printf.sprintf "Ecall%s (%s,\n%s%s" expr_t
                        (format_expr (level + 7) func_expr)
                        (make_indent (level + 7))
                        (format_expr (level + 7) arg)
                | Ematch (matched_expr, empty_expr, m1, m2, m_expr) ->
                    Printf.sprintf "Ematch%s (%s,\n%s,\n%s((%s)::(%s)),\n%s)"
                        expr_t
                        (format_expr (level + 8) matched_expr)
                        (format_expr_i (level + 8) empty_expr)
                        (make_indent (level + 8))
                        (format_motif m1)
                        (format_motif m2)
                        (format_expr_i (level + 8) m_expr)
                | Eclos _ -> failwith "format_expr : Unreachable matching"
and format_expr_i level expr =
    Printf.sprintf "%s%s" (make_indent level) (format_expr level expr)
and format_expr_list sep level = function
    | [] -> ""
    | [e] -> Printf.sprintf "%s" (format_expr_i level e)
    | e::l ->
        Printf.sprintf "%s%s\n%s" (format_expr_i level e) sep
            (format_expr_list sep level l)
and format_func level expr_t f =
    let get_recursive = function
        | true -> "recursive"
        | false -> "not recursive"
    in
        Printf.sprintf "Efunc%s {name = %s, %s, arg = %s,\n%s}" expr_t
            (format_string_option f.name) (get_recursive f.recursive)
            (format_motif f.arg)
            (format_expr_i (level + 7) f.body)

let display_ast ast =
    Printf.printf "%s\n" (format_expr 0 ast)

(* Helpers au moment du parsing *)

(* Création d'un record expr/motif non localisé *)
let raw_expr expr =
    { e = expr ; loc = None ; t = None }
let raw_motif m =
    { m = m ; motif_loc = None ; motif_t = None }

(* Création d'un record loc avec les positions fournies par menhir *)
let make_loc startpos endpos =
    let make_pos p =
        { l = p.pos_lnum ;
          c = p.pos_cnum - p.pos_bol ;
          raw_c = p.pos_cnum }
    in
        { spos = make_pos startpos ;
          epos = make_pos endpos }

let make_start_end_loc sloc eloc =
    match sloc, eloc with
        | None, _ -> None
        | _, None -> None
        | (Some sloc), (Some eloc) ->
            Some { spos = sloc.spos ; epos = eloc.epos }

(* Création d'un record expr/motif localisé *)
let locd_expr e loc =
    { e = e ; loc = Some loc ; t = None }
let locd_motif m loc =
    { m = m ; motif_loc = Some loc ; motif_t = None }

(* Création d'un record func en séparatant le premier argument des autres,
   puis en appliquant un fold right afin d'utiliser la curyfication
   (f a b c est gérée comme f = function a -> function b -> function c) *)
let make_func id recur fbody = function
    | [] -> failwith "make_func : Unreachable matching"
    | arg::args ->
        let body = List.fold_right (fun arg base ->
                                        raw_expr (Efunc {
                                                            name = None ;
                                                            recursive = false ;
                                                            arg = arg ;
                                                            body = base
                                                        }))
                                   args
                                   fbody
        in
            Efunc { name = Some id ;
                    recursive = recur <> None ;
                    arg = arg ;
                    body = body }

(* Détermination récursive des identificateurs d'une expression *)
let rec identifiers expr =
    match expr.e with
        | Econst _ -> Sset.empty
        | Eident id -> Sset.singleton id
        | Etuple l -> List.fold_left (fun base e ->
                                        Sset.union base (identifiers e))
                                     Sset.empty l
        | Ebinop (e1, _, e2)
        | Elistcons (e1, e2)
        | Ecall (e1, e2)
        | Eletin (_, e1, e2) ->
            Sset.union (identifiers e1) (identifiers e2)
        | Eunop (_, e) -> identifiers e
        | Eif (e1, e2, e3)
        | Ematch (e1, e2, _, _, e3) ->
            Sset.union (Sset.union (identifiers e1) (identifiers e2))
                       (identifiers e3)
        | Efunc f -> identifiers f.body
        | Eclos _ -> failwith "identifiers : Unreachable matching"