Skip to content
Newer
Older
100644 694 lines (591 sloc) 22.1 KB
fccc685 Initial open-source release
MLstate authored
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 (* SEE THE DOCUMENTATION IN MLI FILE *)
19
20 (* dependencies *)
21 module List = Base.List
22 module String = Base.String
23
24 (* TODO: define open Base.InfixOperators *)
25 let (@*) = InfixOperator.(@*)
26
27 (* refactoring in progress *)
28
29 (* typevars *)
30 module TypeVar = QmlTypeVars.TypeVar
31 module TypeVarPrint = QmlTypeVars.TypeVarPrint
32 module TypeVarSet = QmlTypeVars.TypeVarSet
33 module TypeVarMap = QmlTypeVars.TypeVarMap
34
35 let (~@) i = QmlTypeVars.get_canonical_typevar i
36
37 let debug fmt =
38 OManager.printf ("@{<cyan>[BslTypes]@}@ @[<2>"^^fmt^^"@]@.")
39
40 (* exported in this module for simplicity, do not hack libbsl please *)
41 let private_typevar_name_table = Hashtbl.create 10
42 let private_typevar_counter = ref 0
43 let (~$) name =
44 let index =
45 try
46 Hashtbl.find private_typevar_name_table name
47 with
48 | Not_found ->
49 let index = !private_typevar_counter in
50 incr(private_typevar_counter);
51 Hashtbl.add private_typevar_name_table name index;
52 index
53 in
54 ~@ index
55
56 (* Guideline : whenever you match an AST, define an alias rather than doing 'open' *)
57 module Q = QmlAst
58
59 type pos = FilePos.pos
60 type typevar = TypeVarSet.elt
61 type t =
62 | Const of pos * Q.const_ty
63 | TypeVar of pos * typevar
64 | Void of pos
65 | Bool of pos
66 | Option of pos * t
67 | OpaValue of pos * t
68 | Fun of pos * t list * t
69 | External of pos * string * t list
70
71 let pos = LangAst.pos
72 let reset_pos = LangAst.reset_pos
73 let merge_pos = LangAst.merge_pos
74
75 type 't pprinter = 't Base.Format.pprinter
76 let pp_list = Base.Format.pp_list
77 let pp_parameters = LangPrint.pp_parameters
78
79 let ty_void = Opacapi.Types.void
80 let ty_bool = Opacapi.Types.bool
81 let ty_option = Opacapi.Types.option
82 let ty_opavalue = "opa"
83 let ty_external = "external"
84
85 let pp_scope ~scope fmt =
86 let typevar fmt = TypeVarPrint.pp scope fmt in
87 let rec aux parfun fmt = function
88 | Const (_, k) ->
89 Q.Const.pp_ty fmt k
90
91 | TypeVar (_, v) ->
92 typevar fmt v
93
94 | Void _ ->
95 Format.pp_print_string fmt ty_void
96
97 | Bool _ ->
98 Format.pp_print_string fmt ty_bool
99
100 | Option (_, t) ->
101 Format.fprintf fmt "%s(%a)" ty_option (aux false) t
102
103 | OpaValue (_, t) ->
104 Format.fprintf fmt "%s[%a]" ty_opavalue (aux false) t
105
106 | ( Fun (_, u, v) ) as t ->
107 if parfun then Format.fprintf fmt "(%a)" (aux false) t else
108 let paren_out = true in
109 Format.fprintf fmt "%a -> %a" (pp_list ", " (aux true)) u (aux paren_out) v
110
111 | External (_, n, vs) ->
112 Format.fprintf fmt "%s[%a]" ty_external (pp_parameters (aux true) n) vs
113
114 in aux false fmt
115
116 let pp fmt =
117 let scope = TypeVarPrint.new_scope () in
118 pp_scope ~scope fmt
119
120 (* Error without context *)
121 let (!!) pos fmt =
122 FilePos.citation OManager.oformatter.contents pos ;
123 OManager.error fmt
124
125
126 type this_t = t (* ocaml does not like type 'a t = t in Subs *)
127
128 module Subs : TraverseInterface.S2
129 with type 'a t = this_t constraint 'a = _ * _ * _ =
130 struct
131 type 'a t = this_t constraint 'a = _ * _ * _
132
133 let foldmap tra acc t =
134 match t with
135 | Const _
136 | TypeVar _
137 | Void _
138 | Bool _ -> acc, t
139 | Option (pos, t') ->
140 let acc, ft' = tra acc t' in
141 acc,
142 if t' == ft' then t else
143 Option (pos, ft')
144
145 | OpaValue (pos, t') ->
146 let acc, ft' = tra acc t' in
147 acc,
148 if t' == ft' then t else
149 OpaValue (pos, ft')
150
151 | Fun (pos, u, v) ->
152 let acc, fu = List.fold_left_map_stable tra acc u in
153 let acc, fv = tra acc v in
154 acc,
155 if u == fu && v = fv then t else
156 Fun (pos, fu, fv)
157
158 | External (pos, name, params) ->
159 let acc, fparams = List.fold_left_map_stable tra acc params in
160 acc,
161 if params == fparams then t else
162 External (pos, name, fparams)
163
164 (* TODO: optimized versions *)
165 let iter x = Traverse.Unoptimized.iter foldmap x
166 let map x = Traverse.Unoptimized.map foldmap x
167 let fold x = Traverse.Unoptimized.fold foldmap x
168 end
169
170 module Walk = Traverse.Make2 ( Subs )
171
172 type freevars = TypeVarSet.t
173
174 let fold_freevars =
175 Walk.fold
176 (fun acc -> function
177 | TypeVar (_, v) -> TypeVarSet.add v acc
178 | _ -> acc)
179
180 let freevars = fold_freevars TypeVarSet.empty
181
182 let nopos = FilePos.nopos "BslTypes"
183 let quantify_sort set =
184 let var v = TypeVar (nopos, v) in
185 List.map var (TypeVarSet.elements set)
186
187 (* reset type variable from 0 *)
188 (* dont factorize ty because of the Hashtbl *)
189 let normalize t =
190 let c = ref 0 in
191 let box = Hashtbl.create 10 in
192 let map i =
193 try
194 Hashtbl.find box i
195 with
196 | Not_found ->
197 let v = ~@ !c in
198 incr(c) ;
199 (* TODO: hook there for Valentine's patch *)
200 Hashtbl.add box i v ;
201 v
202 in
203 Walk.map_down
204 (function
205 | ( TypeVar (pos, v) ) as t ->
206 let fv = map v in
207 if v == fv then t else TypeVar (pos, fv)
208 | t -> t) t
209
210 (* for coherence of label normalize *)
211 let normalize_alias = normalize
212
213 let rec opavalue = function
214 | OpaValue (_, t) -> opavalue t
215 | Fun (pos, arg, ret) ->
216 let arg = List.map opavalue arg in
217 let ret = opavalue ret in
218 Fun (pos, arg, ret)
219 | External _ as t -> t
220 | t ->
221 OpaValue (pos t, t)
222
223 let purge_opavalue = Walk.map_up (
224 function
225 | OpaValue (_, t) -> t
226 | t -> t
227 )
228
229 (* {6 Substitution} *)
230
231 type 'a substitution = 'a TypeVarMap.t
232
233 let empty_substitution = TypeVarMap.empty
234
235 let substitute subst =
236 Walk.map_up (* <!> beware, map_down loops if 'a is rewriten in a term containing 'a *)
237 (function
238 | ( TypeVar (_, v) ) as t -> (
239 match TypeVarMap.find_opt v subst with
240 | Some t -> t
241 | None -> t
242 )
243 | t -> t)
244
245 (* {6 comparaison} *)
246
247 (* TODO inline normalization with 2 hashtbl, not this naive approach *)
248 let compare ?(normalize=false) a b =
249 let rec compare a b =
250 match a, b with
251 | Const (_, c), Const (_, c') -> Pervasives.compare c c'
252 | Const _, _ -> -1
253 | _, Const _ -> 1
254 | TypeVar (_, v), TypeVar (_, v') -> TypeVarSet.compare_elt v v'
255 | TypeVar _, _ -> -1
256 | _, TypeVar _ -> 1
257 | Void _, Void _ -> 0
258 | Void _, _ -> -1
259 | _, Void _ -> 1
260 | Bool _, Bool _ -> 0
261 | Bool _, _ -> -1
262 | _, Bool _ -> 1
263 | Option (_, u), Option (_, v) -> compare u v
264 | Option _, _ -> -1
265 | _, Option _ -> 1
266 | OpaValue (_, t), OpaValue (_, t') -> compare t t'
267 | OpaValue _, _ -> -1
268 | _, OpaValue _ -> 1
269 | Fun (_, u, v), Fun (_, u', v') ->
270 let r = List.make_compare compare u u' in
271 if r <> 0 then r
272 else compare v v'
273 | Fun _ , _ -> -1
274 | _, Fun _ -> 1
275 | External (_, n, tl), External (_, m, ttl) ->
276 let r = String.compare n m in
277 if r <> 0 then r
278 else List.make_compare compare tl ttl
279 in
280 if normalize
281 then compare (normalize_alias a) (normalize_alias b) (* cf TODO *)
282 else compare a b
283
284 (* {6 Checking} *)
285
286 let pp_citation fmt t =
287 let pos = pos t in
288 if not (FilePos.is_empty pos) then FilePos.citation fmt pos else ()
289
290 let pp_context fmt t =
291 let pos = pos t in
292 if not (FilePos.is_empty pos) then FilePos.citation fmt pos else pp fmt t
293
294 let pp_multi_context fmt ts =
295 let mpos = List.fold_left (fun acc t -> FilePos.merge_pos acc (pos t)) nopos ts in
296 (if not (FilePos.is_empty mpos) then FilePos.citation fmt mpos);
297 List.iter (
298 fun t ->
299 if FilePos.is_empty (pos t) then Format.fprintf fmt "type %a@\n" pp t
300 )
301 ts
302
303
304 let is_second_order t =
305 let contains_arrow = Walk.exists (
306 function
307 | Fun _ -> true
308 | _ -> false
309 )
310 in
311 match t with
312 | Fun (_, args, returned) ->
313 List.exists contains_arrow (returned::args)
314 | _ -> false
315
316
317 let fail_check global_expected global_found expected found () =
318 let fmt = OManager.oformatter.contents in
319 (* FilePos.citation OManager.oformatter.contents (pos t) ; *)
320 OManager.printf "During External Primitives Type Checking@\n" ;
321 pp_citation fmt global_expected;
322 pp_citation fmt global_found;
323 OManager.printf "The context expects the type : %a@\n" pp global_expected ;
324 OManager.printf "where the type found at runtime is : %a@\n" pp global_found ;
325 if (global_expected != expected) && ( global_found != found) then
326 OManager.printf "Type %a is not included in type %a@\n" pp found pp expected
327 else ();
328 OManager.error "@\n"
329
330 let check_parametric_type fail aux subst n n' vs vs' =
331 if String.compare n n' <> 0 then fail () else
332 try
333 List.fold_left2 aux subst vs vs'
334 with
335 | Invalid_argument _ -> fail ()
336
337 let check_inclusion ?(static_strict_check=true) subst ~expected ~found =
338 let fail = fail_check expected found in
339 let rec aux subst expected found =
340 let () =
341 #<If:BSL_PROJECTION>
342 debug "check_inclusion(aux) %b %a %a@." static_strict_check pp expected pp found
343 #<End>
344 in
345 let fail = fail expected found in
346 match (expected, found) with
347 | TypeVar (_, v), t -> (
348 match TypeVarMap.find_opt v subst with
349 | None ->
350 (* From there, any v should be a t *)
351 TypeVarMap.add v t subst
352 | Some t' ->
353 aux subst t' t
354 )
355
356 | t, TypeVar (_, v) -> (
357 if static_strict_check then
358 fail ()
359 else
360 (*
361 Used principally in opatop, when we apply e.g. a function of type :
362 ['a -> foo('a)] on a string, the result in a foo(string), but we
363 should not tag the type as foo(string), because a conversion would
364 be done on the string.
365 *)
366 match TypeVarMap.find_opt v subst with
367 | None ->
368 (* From there, any v should be a t *)
369 TypeVarMap.add v t subst
370 | Some t' ->
371 aux subst t' t
372 )
373
374 | Const (_, c), Const (_, c') ->
375 if Pervasives.compare c c' <> 0 then fail () else subst
376 | Const _, _
377 | _, Const _ -> fail ()
378
379 | Void _, Void _ -> subst
380 | Void _, _
381 | _, Void _ -> fail ()
382
383 | Bool _, Bool _ -> subst
384 | Bool _ , _
385 | _, Bool _ -> fail ()
386
387 | Option (_, t), Option (_, t') -> aux subst t t'
388 | Option _, _
389 | _, Option _ -> fail ()
390
391 | OpaValue (_, t), OpaValue (_, t') -> aux subst t t'
392 | OpaValue _, _
393 | _, OpaValue _ -> fail ()
394
395 | Fun (_, u, v), Fun (_, u', v') ->
396 let subst =
397 try
398 List.fold_left2 aux subst u u'
399 with
400 | Invalid_argument "List.fold_left2" -> fail ()
401 in
402 aux subst v' v (* beware of inversion *)
403
404 | Fun _, _
405 | _, Fun _ -> fail ()
406
407 | External (_, n, vs), External (_, n', vs') ->
408 check_parametric_type fail aux subst n n' vs vs'
409
410 in aux subst expected found
411
412 let check ?static_strict_check ~expected ~found =
413 let _ = check_inclusion ?static_strict_check empty_substitution ~expected ~found in ()
414
415 let fail_specialize vars t fmt =
416 let citation t =
417 let pos = pos t in
418 if not (FilePos.is_empty pos) then FilePos.citation OManager.oformatter.contents pos in
419 (* FilePos.citation OManager.oformatter.contents (pos t) ; *)
420 OManager.printf "During External Primitives Type Specialization@\n" ;
421 citation t;
422 OManager.printf "The type is : %a@\n" pp t;
423 OManager.printf "@[<2>The parameters are :@\n%a@]@\n" (pp_list "@\n" pp) vars;
424 OManager.error fmt
425
426 let specialize vars t =
427 match t with
428 | External (_, _, v) ->
429 let subst = empty_substitution in
430 let subst =
431 let fold2 subst expected found = check_inclusion subst ~expected ~found in
432 try
433 List.fold_left2 fold2 subst v vars
434 with
435 | Invalid_argument "List.fold_left2" -> fail_specialize vars t "Invalid arity@\n"
436 in
437 substitute subst t
438
439 | _ ->
440 fail_specialize vars t "BslTypes.specialize : this type is not parametric,@ it cannot be specialized@\n"
441
442 (* {6 Binding with QmlAst.ty} *)
443
444 let of_const c = Const (nopos, Q.Const.type_of c)
445
446 (* TODO: add pos in QmlAst *)
447 let fail_ty ty sub_ty fmt =
448 (* FilePos.citation OManager.oformatter.contents (pos t) ; *)
449 OManager.printf "Context type is : %a@\n" QmlPrint.pp#ty ty ;
450 (if ty != sub_ty then
451 OManager.printf "in the part : %a@\n" QmlPrint.pp#ty sub_ty ;
452 );
453 OManager.error fmt
454
455
456 (* TODO: detect opavalue cases *)
457 let of_ty ~gamma ty =
458 let fail_ty x = fail_ty ty x in
459 let rec aux ?(name=None) varmap ty =
460 let fail_ty x = fail_ty ty x in
461 let pos = (* get pos from ty *) nopos in
462 match ty with
463 | Q.TypeConst const -> varmap, Const (pos, const)
464
465 | Q.TypeVar var -> (
466 (* build a TypeVar , with coherence for a full call to of_ty *)
467 match TypeVarMap.find_opt var varmap with
468 | None ->
469 let alpha = TypeVar (pos, TypeVar.refresh var) in
470 TypeVarMap.add var alpha varmap, alpha
471 | Some alpha -> varmap, alpha
472 )
473
474 | Q.TypeArrow (la, b) ->
475 let varmap, auxla = List.fold_left_map aux varmap la in
476 let varmap, auxb = aux varmap b in
477 varmap, Fun (pos, auxla, auxb)
478
479 | (Q.TypeName (ty_list, typeident)) -> (
480 match
481 (* A priori, this is part is used by the back-end so it needs to
482 access the internal of types even if they are not visible from the
483 package. Typechecking will have to have ensured that types were
484 used in a consistent way. *)
485 QmlTypes.Env.TypeIdent.findi_opt
486 ~visibility_applies: false typeident gamma with
487 | Some (typeident, typ) ->
488 let ident = Q.TypeIdent.to_string typeident in
489 if Q.TypeIdent.is_abstract typeident
490 then
491 (* warning : an abstract type can point to another type which can be different;
492 extern types point to themselves, so we have to avoid looping *)
493 if Q.TypeIdent.is_extern typeident
494 then
495 let varmap, maped_ty = List.fold_left_map aux varmap ty_list in
496 let maped = External (pos, ident, maped_ty) in
497 varmap, maped
498 else (
499 (* abstract, but we found its definition: apparently we do as if it was concrete *)
500 List.iter (ignore @* aux varmap) ty_list; (* side-effect *)
501 aux varmap (QmlTypes.Scheme.specialize ~typeident:typeident ~ty:ty_list typ)
502 )
503 else (
504 (* Standard extended types in LibBSL : bool, option *)
505 match ident with
506 | "bool" -> varmap, Bool pos
507 | "unit" | "void" -> varmap, Void pos
508 | "option" -> (
509 match ty_list with
510 | [what] ->
511 let varmap, auxwhat = aux varmap what in
512 varmap, Option (pos, auxwhat)
513 | _ ->
514 (** Here we can raise a public typing exception because the type option is
515 used with a wrong number of parameters *)
516 fail_ty
517 "The external constructor \"option\" expects 1 arg@ but is here called with %d arguments(s)@\n"
518 (List.length ty_list)
519 )
520 | other -> (
521 (* warning : an typename do point on a other type that is instancied *)
522 (* side-effect so that we can use the quantify_sort function *)
523 List.iter (ignore @* aux varmap) ty_list;
524 let ty = (QmlTypes.Scheme.specialize ~typeident:typeident ~ty:ty_list typ) in
525 aux ~name:(Some other) varmap ty
526 )
527 )
528
529 | None ->
530 (* This can appears in some funny cases with #typer off, playing with qmltop *)
531 (* in this case, we build an extern type *)
532 let ident = Q.TypeIdent.to_string typeident in
533 let varmap, maped_ty = List.fold_left_map aux varmap ty_list in
534 let maped = External (pos, ident, maped_ty) in
535 varmap, maped
536 )
537
538 | Q.TypeRecord (Q.TyRow ([], None))
539 | Q.TypeSum (Q.TyCol ([[]], _)) ->
540 (* We close the column variable by passing it the the external primitive *)
541 varmap, Void pos
542
543 | Q.TypeRecord t ->
544 let name =
545 match name with
546 | Some n -> n
547 | None ->
548 fail_ty "Opa anonymous records cannot escape the opa wold.@ You should name this type for interacting with an external primitive.@\n"
549 in
550 let fold_map varmap (field, ty) =
551 let varmap, auxty = aux varmap ty in varmap, (field, auxty) in
552 let varmap, maped_fields =
553 List.fold_left_map fold_map varmap (QmlAstWalk.Row.elements t) in
554 let parameters =
555 let freevars =
556 List.fold_left
557 (fun acc (_, t) -> fold_freevars acc t) TypeVarSet.empty maped_fields
558 in
559 (* there we are sure that the order is correct because of
560 the side-effect done with TypeName *)
561 quantify_sort freevars
562 in
563 let std = External (pos, name, parameters) in
564 varmap, std
565
566 | other ->
567 let pos = nopos (* TODO: add pos in QmlAst *) in
568 OManager.warning ~wclass:WarningClass.bsl_type_checking
569 "%aThe type@ %a@ will be given as an external alpha to the external library@\n"
570 pp_citation pos QmlPrint.pp#ty other ;
571 (* This is dangerous,
572 but the type checking combine with the bypass typer assure
573 that we cannot do bad things *)
574 (* However, this is buggy. We should return the same var from 2 equal ty *)
575 (* TODO: version 1 : try just with a Hashtbl on other directly, is maybe enough *)
576 (* TODO: version 2 : hazardous use of Type comparaison (mamamia) *)
577 varmap, TypeVar (pos, TypeVar.next ())
578 in
579 let _, sttyp = aux ~name:None TypeVarMap.empty ty in
580 sttyp
581
582 (* TODO: add position in QmlAst *)
583 let to_ty ?(typeident=Q.TypeIdent.of_string) t = (* don't factorize t because of the typevarmap *)
584 let map =
585 let box = ref TypeVarMap.empty in
586 (fun v ->
587 match TypeVarMap.find_opt v !box with
588 | Some qv -> qv
589 | None ->
590 let qv = Q.TypeVar (TypeVar.refresh v) in
591 box := TypeVarMap.add v qv !box;
592 qv
593 )
594 in
595 let rec aux = function
596 | Const (_, const) -> Q.TypeConst const
597 | TypeVar (_, v) -> map v
598 | Void _ -> Q.TypeRecord (Q.TyRow ([], None))
599 | Bool _ -> Q.TypeName ([], Q.TypeIdent.of_string Opacapi.Types.bool)
600 | Option (_, t) -> Q.TypeName ([aux t], Q.TypeIdent.of_string Opacapi.Types.option)
601 | OpaValue(_, t) -> aux t
602 | Fun (_, u, v) ->
603 let u = List.map aux u in
604 let v = aux v in
605 Q.TypeArrow (u, v)
606
607 | External (_, name, tlist) ->
608 Q.TypeName (List.map aux tlist, typeident ~check:false name)
609
610 in aux t
611
612 (* {6 Bslregister Code Generation} *)
613
614 (* TODO: use a brightness or something for highlithing citations *)
615 let fmt m =
616 "%aType variables for parametric extern types should be generic only.@\nThe instance : %a@ in the type : %a@\nis not allowed in the interface of this bypass@\n"^^m
617
618 let notify context allowed runtime instance parent =
619 if allowed then
620 OManager.warning ~wclass:WarningClass.bsl_backend_restriction
621 (fmt
622 "However, a compatibility of runtime(s) is specified for this bypass@\nthis primitive will be available only with the following back-ends :@\n@\t%s@\n"
623 )
624 pp_citation context pp instance pp parent runtime
625 else
626 OManager.error
627 (fmt
628 "However, if you want this primitive to be used with a specific runtime back-end algebra,@\nplease add a runtime restriction specification :@\nexample : ##register [backend:qmlflat, ...]"
629 )
630 pp_citation context pp instance pp parent
631
632 let check_runtime_restriction bsltags t =
633 let context = t in
634 let runtime, allowed =
635 if BslTags.never_projected bsltags
636 then "anyruntime ([no-projection] is set)", true
637 else
638 match Option.default_map [] StringSet.elements bsltags.BslTags.backend_restriction with
639 | [] -> "", false
640 | backend -> (String.concat ", " backend, true)
641 in
642 (* detect instanciate types variables *)
643 let iter parent = function
644 | OpaValue _
645 | External _
646 | TypeVar _ -> ()
647 | instance ->
648 notify context allowed runtime instance parent
649
650 in
651 Walk.traverse_iter
652 (fun tra t -> match t with
653 | OpaValue _ -> () (* ignored case *)
654 (* checked cases *)
655 | External (_, _, params) -> List.iter (iter t) params; tra t
656 | t -> tra t) t
657
658 (* {6 Bslregister Code Generation} *)
659
660 (* TODO:
661 export a function in FilePos to get position after BslDynloading.
662 *)
663 (* <!> keep in synch with BslPluginInterface, meta_plugin__02 *)
664 let meta_pos = FilePos.nopos "BslTypes.meta_pos"
665 let var_mp = "mp"
666
667 let rec pp_meta_scope scope fmt t =
668 let pp_meta f = pp_meta_scope scope f in
669 match t with
670 | Const (_, c) -> Format.fprintf fmt "B.Const (%s, Q.%s)" var_mp (Q.Const.meta c)
671 | TypeVar (_, v) -> Format.fprintf fmt "B.TypeVar (%s, ~$ %S)" var_mp (TypeVarPrint.get scope v)
672 | Void _ -> Format.fprintf fmt "B.Void %s" var_mp
673 | Bool _ -> Format.fprintf fmt "B.Bool %s" var_mp
674 | Option (_, t) -> Format.fprintf fmt "B.Option (%s, (%a))" var_mp pp_meta t
675 | OpaValue (_, t) -> Format.fprintf fmt "B.OpaValue (%s, (%a))" var_mp pp_meta t
676
677 | Fun (_, u, v) ->
678 Format.fprintf fmt "B.Fun (%s, [%a], (%a))" var_mp (pp_list "@ ;@ " pp_meta) u pp_meta v
679
680 | External (_, n, vs) ->
681 Format.fprintf fmt "B.External (%s, %S, [%a])" var_mp n (pp_list "@ ;@ " pp_meta) vs
682
683 and pp_meta_fields_scope scope fmt fds =
684 let fd fmt (f, t) = Format.fprintf fmt "(%S, %a)" f (pp_meta_scope scope) t in
685 Format.fprintf fmt "[ %a ]" (pp_list "@ ;@ " fd) fds
686
687 let pp_meta fmt t =
688 let scope = TypeVarPrint.new_scope () in
689 pp_meta_scope scope fmt t
690
691 let pp_meta_fields fmt fds =
692 let scope = TypeVarPrint.new_scope () in
693 pp_meta_fields_scope scope fmt fds
Something went wrong with that request. Please try again.