Skip to content
This repository
Newer
Older
100644 144 lines (129 sloc) 5.931 kb
fccc6851 »
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18
19 module List = Base.List
20 module Q = QmlAst
21
22
23 type env = {
24 bindings : Q.expr IdentMap.t;
25 warn_x_field : unit (* just in case, if we want to add a field to this env *)
26 }
27
28 let depth_max = 10
29
30 let empty_env () = {
31 bindings = IdentMap.empty ;
32 warn_x_field = ()
33 }
34 let update_gamma gamma id ty =
35 let tsc = QmlTypes.Scheme.generalize gamma ty in
36 QmlTypes.Env.Ident.add id tsc gamma
37
38 let add_to_bindings env (id,e) = { env with bindings = IdentMap.add id e env.bindings }
39
40 let insert_bindings ~typed (gamma,annotmap) bindings e =
41 List.fold_right
42 (fun (id,e) (gamma,annotmap,expr) ->
43 if typed then
44 let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
45 let gamma = update_gamma gamma id ty in
46 let annotmap,expr = QmlAstCons.TypedExpr.letin annotmap [(id,e)] expr in
47 gamma, annotmap, expr
48 else
49 let expr = QmlAstCons.UntypedExpr.letin [(id,e)] expr in
50 gamma, annotmap, expr
51 )
52 bindings
53 (gamma, annotmap, e)
54
55 let traverse_expr ~typed (gamma,annotmap) e =
56 let rec aux tra depth (gamma, annotmap, env) e =
57 let depth = succ depth in
58 match e with
59 | Q.Record _ ->
60 let ((gamma, annotmap, env), e) as nothing_to_do = tra depth (gamma, annotmap, env) e in
61 let (gamma, annotmap, env),e =
62 (match e with
63 | Q.Record (label, l) ->
64 if depth < depth_max then
65 nothing_to_do
66 else (* store bindings and make the replacements *)
67 let fresh () = Ident.next "r" in
68 let l = List.map (fun (f,e) -> f,fresh (),e) l in
69 let env = List.fold_left (fun env (_, id, e) -> add_to_bindings env (id,e)) env l in
70 let (gamma, annotmap), l =
71 List.fold_left_map
72 (fun (gamma, annotmap) (f, v, e) ->
73 let gamma, annotmap, new_expr =
74 if typed then
75 let ty = QmlAnnotMap.find_ty (Q.QAnnot.expr e) annotmap in
76 let gamma = update_gamma gamma v ty in
77 let annotmap,expr = QmlAstCons.TypedExpr.ident annotmap v ty in
78 gamma, annotmap, expr
79 else
80 let expr = QmlAstCons.UntypedExpr.ident v in
81 gamma, annotmap, expr
82 in (gamma, annotmap),(f, new_expr)
83 )
84 (gamma, annotmap)
85 l
86 in
87 (gamma, annotmap,env), Q.Record (label, l)
88
89 | Q.ExtendRecord (label, f, expr, r) ->
90 let (_gamma, _annotmap, env_), r = aux tra depth (gamma, annotmap, env) r in
91 let (gamma, annotmap, env), expr = aux tra depth (gamma, annotmap, env) expr in
92 let b = env_.bindings in
93 let env = { env with bindings =
94 IdentMap.fold (fun id e m -> IdentMap.add id e m) b env.bindings } in
95 let e = Q.ExtendRecord (label, f, expr, r) in
96 (gamma, annotmap, env), e
97 | _ -> tra 0 (gamma, annotmap, env) e)
98 in
99 (gamma, annotmap, env), e
100 | Q.ExtendRecord _ ->
101 tra depth (gamma, annotmap, env) e
102 | _ -> tra 0 (gamma, annotmap, env) e
103 in
104 let env = empty_env () in
105 let rec aux2 (gamma, annotmap) e =
106 match e with
107 | Q.Record _
108 | Q.ExtendRecord _ ->
109 let (gamma, annotmap, env),new_e = QmlAstWalk.Expr.traverse_foldmap_context_down aux 0 (gamma, annotmap, env) e in
110 let bindings = IdentMap.rev_ordered_list env.bindings in
111 let (gamma, annotmap, expr) = insert_bindings ~typed (gamma, annotmap) bindings new_e in
112 (gamma, annotmap), expr
113 | Q.Lambda (label, l, e) ->
114 let (gamma, annotmap), new_e = aux2 (gamma, annotmap) e in
115 let expr = Q.Lambda (label, l,new_e) in
116 (gamma, annotmap), expr
117 | Q.LetIn (_, l, e) ->
118 let l,e = QmlAstUtils.LetIn.uncons l e in
119 let (gamma, annotmap), new_e = aux2 (gamma, annotmap) e in
120 let expr = QmlAstUtils.LetIn.cons l new_e in
121 (gamma, annotmap), expr
122 | Q.LetRecIn (_, l, e) ->
123 let l,e = QmlAstUtils.LetRecIn.uncons l e in
124 let (gamma, annotmap), new_e = aux2 (gamma, annotmap) e in
125 let expr = QmlAstUtils.LetRecIn.cons l new_e in
126 (gamma, annotmap), expr
127 | Q.Match (_, e, p) ->
128 let if_,pats,exprs = QmlAstUtils.Match.uncons e p in
129 let (gamma, annotmap), new_e = aux2 (gamma, annotmap) if_ in
130 let (gamma, annotmap), new_exprs = List.fold_left_map aux2 (gamma, annotmap) exprs in
131 let expr = QmlAstUtils.Match.cons new_e pats new_exprs in
132 (gamma, annotmap), expr
133 | _ ->
134 let (gamma, annotmap, env), new_e = QmlAstWalk.Expr.traverse_foldmap_context_down aux 0 (gamma, annotmap, env) e in
135 let bindings = IdentMap.rev_ordered_list env.bindings in
136 let (gamma, annotmap,expr) = insert_bindings ~typed (gamma, annotmap) bindings new_e in
137 (gamma, annotmap), expr
138 in
139 aux2 (gamma, annotmap) e
140
141 let process_code ~typed gamma annotmap code =
142 let (gamma, annotmap), code = QmlAstWalk.CodeExpr.fold_map (traverse_expr ~typed) (gamma, annotmap) code in
143 (gamma,annotmap), code
Something went wrong with that request. Please try again.