diff --git a/src/passes/11-spilling/errors.ml b/src/passes/11-spilling/errors.ml index 93545afd3..eef709b4f 100644 --- a/src/passes/11-spilling/errors.ml +++ b/src/passes/11-spilling/errors.ml @@ -54,7 +54,7 @@ let rec error_ppformat : display_format:string display_format -> let s = Format.asprintf "%s\n corner case: %s\n%s" loc desc (corner_case_message ()) in Format.pp_print_string f s | `Spilling_no_type_variable tv -> - let s = Format.asprintf "type variables can't be transpiled : %a" Var.pp tv in + let s = Format.asprintf "unbound type variables can't be transpiled : %a" Var.pp tv in Format.pp_print_string f s | `Spilling_unsupported_pattern_matching loc -> let s = Format.asprintf "%a\n unsupported pattern-matching: tuple patterns aren't supported yet" Location.pp loc in diff --git a/src/stages/5-ast_typed/PP_json.ml b/src/stages/5-ast_typed/PP_json.ml new file mode 100644 index 000000000..745483ebc --- /dev/null +++ b/src/stages/5-ast_typed/PP_json.ml @@ -0,0 +1,88 @@ +open Types +open Fold +open Format + +type json = Yojson.Basic.t + +module M = struct + type no_state = NoState + + let to_json : (no_state, json) fold_config = { + generic = (fun NoState info -> + match info.node_instance.instance_kind with + | RecordInstance { fields } -> + let fields' = List.fold_left + (fun acc (fld : ('xi, json) Adt_info.ctor_or_field_instance) -> (fld.cf.name, fld.cf_continue NoState)::acc) + [] fields + in + `Assoc fields' + | VariantInstance { constructor ; _ } -> + `List [ `String constructor.cf.name ; constructor.cf_continue NoState ] + | PolyInstance { poly=_; arguments=_; poly_continue } -> + (poly_continue NoState) + ); + generic_empty_ctor = (fun NoState -> `Null ) ; + int = (fun _visitor NoState i -> `Int i ) ; + type_variable = (fun _visitor NoState tv -> `Assoc ["type-var", `String (asprintf "%a" Var.pp tv)] ) ; + bool = (fun _visitor NoState b -> `Bool b ) ; + z = (fun _visitor NoState i -> `String (asprintf "%a" Z.pp_print i) ) ; + string = (fun _visitor NoState str -> `String str ) ; + ligo_string = (fun _visitor NoState s -> `String (asprintf "%s" (match s with Standard s -> s | Verbatim s -> s)) ) ; + bytes = (fun _visitor NoState bytes -> `String (Bytes.to_string bytes)) ; + unit = (fun _visitor NoState () -> `String "unit" ) ; + packed_internal_operation = (fun _visitor NoState _op -> `String "Operation(...bytes)") ; + expression_variable = (fun _visitor NoState ev -> `Assoc ["exp-var", `String (asprintf "%a" Var.pp ev)] ) ; + constructor' = (fun _visitor NoState (Constructor c) -> `Assoc ["constructor", `String c] ) ; + location = (fun _visitor NoState loc -> `String (asprintf "%a" Location.pp loc) ) ; (*TODO*) + label = (fun _visitor NoState (Label lbl) -> `Assoc ["label" , `String lbl] ) ; + ast_core_type_expression = (fun _visitor NoState te -> `String (asprintf "%a" (Ast_core.PP.type_expression) te) ) ; (*TODO*) + constructor_map = (fun _visitor continue NoState cmap -> + let lst = List.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in + let lst' = List.fold_left + (fun acc (Constructor k, v) -> (k , continue NoState v)::acc) + [] lst + in + `Assoc lst' ); + label_map = (fun _visitor continue NoState lmap -> + let lst = List.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in + let lst' = List.fold_left + (fun acc (Label k, v) -> (k , continue NoState v)::acc) + [] lst + in + `Assoc lst' ); + list = (fun _visitor continue NoState lst -> + let aux elt = continue NoState elt in + `List (List.map aux lst) ); + location_wrap = (fun _visitor continue NoState lwrap -> + let ({ wrap_content; location } : _ Location.wrap) = lwrap in + `Assoc [("wrap_content", continue NoState wrap_content) ; ("location", `String (asprintf "%a" Location.pp location))] ); (*TODO*) + option = (fun _visitor continue NoState o -> + match o with + | None -> `List [ `String "None" ; `Null ] + | Some v -> `List [ `String "Some" ; continue NoState v ] ); + poly_unionfind = (fun _visitor continue NoState p -> + let lst = (UnionFind.Poly2.partitions p) in + let lst' = List.map (fun l -> continue NoState (UnionFind.Poly2.repr (List.hd l) p )) lst in + `Assoc ["UnionFind", `List lst'] ); + poly_set = (fun _visitor continue NoState set -> + let lst = (RedBlackTrees.PolySet.elements set) in + let lst' = List.map (fun el -> continue NoState el) lst in + `Assoc ["Set", `List lst'] ); + typeVariableMap = (fun _visitor continue NoState tvmap -> + let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in + let aux (k, v) = + `Assoc [ asprintf "%a" Var.pp k , continue NoState v ] in + let lst' = List.map aux lst in + `Assoc ["typeVariableMap", `List lst'] ); + } + + let print : ((no_state, json) fold_config -> no_state -> 'a -> json) -> 'a -> json = fun fold v -> + fold to_json NoState v +end + +include Fold.Folds(struct + type in_state = M.no_state ;; + type out_state = json ;; + type 'a t = 'a -> json ;; + let f = M.print ;; +end) diff --git a/src/stages/5-ast_typed/ast_typed.ml b/src/stages/5-ast_typed/ast_typed.ml index 09134e0fd..99f048844 100644 --- a/src/stages/5-ast_typed/ast_typed.ml +++ b/src/stages/5-ast_typed/ast_typed.ml @@ -4,6 +4,7 @@ module PP = PP module PP_generic = PP_generic module Compare_generic = Compare_generic module Formatter = Formatter +module PP_json = PP_json module Combinators = struct include Combinators end diff --git a/src/stages/5-ast_typed/formatter.ml b/src/stages/5-ast_typed/formatter.ml index 319342fff..f6c331722 100644 --- a/src/stages/5-ast_typed/formatter.ml +++ b/src/stages/5-ast_typed/formatter.ml @@ -4,9 +4,7 @@ let program_ppformat ~display_format f (typed,_) = match display_format with | Human_readable | Dev -> PP.program f typed -let program_jsonformat (typed,_) : json = - let core' = Format.asprintf "%a" PP.program typed in - `Assoc [("Typed(temp)" , `String core')] +let program_jsonformat (typed,_) : json = PP_json.program typed let program_format : 'a format = { pp = program_ppformat;