balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

using yojson to print typed AST program

Browse Source
This commit is contained in:
Lesenechal Remi 2020-06-22 19:10:31 +02:00 committed by Suzanne Dupéron
parent db051e7d3b
commit b4bf0ae159
2 changed files with 57 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

144
src/stages/5-ast_typed/PP_json.ml
View File

@ -1,125 +1,93 @@
open Types open Types
open Fold open Fold
open Format open Format
open PP_helpers
type json = Yojson.Basic.t
module M = struct module M = struct
type no_state = NoState type no_state = NoState
let needs_parens = {
generic = (fun NoState info ->
match info.node_instance.instance_kind with
| RecordInstance _ -> false
| VariantInstance _ -> true
| PolyInstance { poly =_; arguments=_; poly_continue } ->
(poly_continue NoState)
);
generic_empty_ctor = (fun _ -> false) ;
type_variable = (fun _ _ _ -> true) ;
bool = (fun _ _ _ -> false) ;
int = (fun _ _ _ -> false) ;
z = (fun _ _ _ -> false) ;
string = (fun _ _ _ -> false) ;
ligo_string = (fun _ _ _ -> false) ;
bytes = (fun _ _ _ -> false) ;
unit = (fun _ _ _ -> false) ;
packed_internal_operation = (fun _ _ _ -> false) ;
expression_variable = (fun _ _ _ -> false) ;
constructor' = (fun _ _ _ -> false) ;
location = (fun _ _ _ -> false) ;
label = (fun _ _ _ -> false) ;
ast_core_type_expression = (fun _ _ _ -> true) ;
constructor_map = (fun _ _ _ _ -> false) ;
label_map = (fun _ _ _ _ -> false) ;
list = (fun _ _ _ _ -> false) ;
location_wrap = (fun _ _ _ _ -> false) ;
option = (fun _visitor _continue _state o ->
match o with None -> false | Some _ -> true) ;
poly_unionfind = (fun _ _ _ _ -> false) ;
poly_set = (fun _ _ _ _ -> false) ;
typeVariableMap = (fun _ _ _ _ -> false) ;
}
let str ppf s = let to_json : (no_state, json) fold_config = {
fprintf ppf "\"%s\"" (Str.global_replace (Str.regexp_string "\"") "\\\"" s)
let strpp pp ppf x =
fprintf ppf "\"%s\"" (asprintf "%a" pp x)
let op ppf : (no_state, unit) fold_config = {
generic = (fun NoState info -> generic = (fun NoState info ->
match info.node_instance.instance_kind with match info.node_instance.instance_kind with
| RecordInstance { fields } -> | RecordInstance { fields } ->
let aux ppf (fld : ('xi , 'xo) Adt_info.ctor_or_field_instance) = let fields' = List.fold_left
fprintf ppf "%a: %a" str fld.cf.name (fun _ppf -> fld.cf_continue) NoState in (fun acc (fld : ('xi, json) Adt_info.ctor_or_field_instance) -> (fld.cf.name, fld.cf_continue NoState)::acc)
fprintf ppf "{ %a }" (list_sep aux (fun ppf () -> fprintf ppf " ;@ ")) fields [] fields
in
`Assoc fields'
| VariantInstance { constructor ; _ } -> | VariantInstance { constructor ; _ } ->
if constructor.cf_new_fold needs_parens NoState `List [ `String constructor.cf.name ; constructor.cf_continue NoState ]
then fprintf ppf "[ %a , %a ]" str constructor.cf.name (fun _ppf -> constructor.cf_continue) NoState
else let spc = if String.equal constructor.cf.type_ "" then "" else " , " in
fprintf ppf "%a%s%a" str constructor.cf.name spc (fun _ppf -> constructor.cf_continue) NoState
| PolyInstance { poly=_; arguments=_; poly_continue } -> | PolyInstance { poly=_; arguments=_; poly_continue } ->
(poly_continue NoState) (poly_continue NoState)
); );
generic_empty_ctor = (fun NoState -> ()) ; generic_empty_ctor = (fun NoState -> `Null ) ;
int = (fun _visitor NoState i -> fprintf ppf "%i" i ); int = (fun _visitor NoState i -> `Int i ) ;
type_variable = (fun _visitor NoState type_variable -> fprintf ppf "Var %a" (strpp Var.pp) type_variable) ; type_variable = (fun _visitor NoState tv -> `Assoc ["type-var", `String (asprintf "%a" Var.pp tv)] ) ;
bool = (fun _visitor NoState b -> fprintf ppf "%s" (if b then "true" else "false")) ; bool = (fun _visitor NoState b -> `Bool b ) ;
z = (fun _visitor NoState i -> fprintf ppf "%a" Z.pp_print i) ; z = (fun _visitor NoState i -> `String (asprintf "%a" Z.pp_print i) ) ;
string = (fun _visitor NoState str -> fprintf ppf "\"%s\"" str) ; string = (fun _visitor NoState str -> `String str ) ;
ligo_string = (fun _visitor NoState s -> fprintf ppf "%a" str (match s with Standard s -> s | Verbatim s -> s)) ; ligo_string = (fun _visitor NoState s -> `String (asprintf "%s" (match s with Standard s -> s | Verbatim s -> s)) ) ;
bytes = (fun _visitor NoState _bytes -> fprintf ppf "\"bytes...\"") ; bytes = (fun _visitor NoState bytes -> `String (Bytes.to_string bytes)) ;
unit = (fun _visitor NoState () -> fprintf ppf "\"unit\"") ; unit = (fun _visitor NoState () -> `String "unit" ) ;
packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "\"Operation(...bytes)\"") ; packed_internal_operation = (fun _visitor NoState _op -> `String "Operation(...bytes)") ;
expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" (strpp Var.pp) ev) ; expression_variable = (fun _visitor NoState ev -> `Assoc ["exp-var", `String (asprintf "%a" Var.pp ev)] ) ;
constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "[ \"Constructor\" %a]" str c) ; constructor' = (fun _visitor NoState (Constructor c) -> `Assoc ["constructor", `String c] ) ;
location = (fun _visitor NoState loc -> fprintf ppf "%a" (strpp Location.pp) loc) ; location = (fun _visitor NoState loc -> `String (asprintf "%a" Location.pp loc) ) ; (*TODO*)
label = (fun _visitor NoState (Label lbl) -> fprintf ppf "[ \"Label\" , %a ]" str lbl) ; label = (fun _visitor NoState (Label lbl) -> `Assoc ["label" , `String lbl] ) ;
ast_core_type_expression = (fun _visitor NoState te -> fprintf ppf "%a" (strpp Ast_core.PP.type_expression) te) ; 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 -> 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.sort (fun (Constructor a, _) (Constructor b, _) -> String.compare a b) (CMap.bindings cmap) in
let aux ppf (Constructor k, v) = let lst' = List.fold_left
fprintf ppf "%a: %a" str k (fun _ppf -> continue NoState) v in (fun acc (Constructor k, v) -> (k , continue NoState v)::acc)
fprintf ppf "{ %a }" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); [] lst
in
`Assoc lst' );
label_map = (fun _visitor continue NoState lmap -> 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.sort (fun (Label a, _) (Label b, _) -> String.compare a b) (LMap.bindings lmap) in
let aux ppf (Label k, v) = let lst' = List.fold_left
fprintf ppf "%a: %a" str k (fun _ppf -> continue NoState) v in (fun acc (Label k, v) -> (k , continue NoState v)::acc)
fprintf ppf "{ %a }" (list_sep aux (fun ppf () -> fprintf ppf " ; ")) lst); [] lst
in
`Assoc lst' );
list = (fun _visitor continue NoState lst -> list = (fun _visitor continue NoState lst ->
let aux ppf elt = let aux elt = continue NoState elt in
fprintf ppf "%a" (fun _ppf -> continue NoState) elt in `List (List.map aux lst) );
fprintf ppf "[ \"List\" %a ]" (list_sep aux (fun ppf () -> fprintf ppf " , ")) lst);
location_wrap = (fun _visitor continue NoState lwrap -> location_wrap = (fun _visitor continue NoState lwrap ->
let ({ wrap_content; location } : _ Location.wrap) = lwrap in let ({ wrap_content; location } : _ Location.wrap) = lwrap in
fprintf ppf "{ \"wrap_content\": %a ; \"location\" = %a }" (fun _ppf -> continue NoState) wrap_content (strpp Location.pp) location); `Assoc [("wrap_content", continue NoState wrap_content) ; ("location", `String (asprintf "%a" Location.pp location))] ); (*TODO*)
option = (fun _visitor continue NoState o -> option = (fun _visitor continue NoState o ->
match o with match o with
| None -> fprintf ppf "\"None\"" | None -> `Null
| Some v -> fprintf ppf "[\"Some\" , %a]" (fun _ppf -> continue NoState) v) ; | Some v -> continue NoState v );
poly_unionfind = (fun _visitor continue NoState p -> poly_unionfind = (fun _visitor continue NoState p ->
let lst = (UnionFind.Poly2.partitions p) in let lst = (UnionFind.Poly2.partitions p) in
let aux1 l = fprintf ppf "[ %a ]" let lst' = List.map (fun l -> continue NoState (UnionFind.Poly2.repr (List.hd l) p )) lst in
(* (fun _ppf -> continue NoState) (UnionFind.Poly2.repr (List.hd l) p) *) `Assoc ["UnionFind", `List lst'] );
(list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " , ")) l in
let aux2 = list_sep (fun _ppf -> aux1) (fun ppf () -> fprintf ppf " , ") in
fprintf ppf "[ \"UnionFind\" %a ]" aux2 lst);
poly_set = (fun _visitor continue NoState set -> poly_set = (fun _visitor continue NoState set ->
let lst = (RedBlackTrees.PolySet.elements set) in let lst = (RedBlackTrees.PolySet.elements set) in
fprintf ppf "[ \"Set\" %a ]" (list_sep (fun _ppf -> continue NoState) (fun ppf () -> fprintf ppf " , ")) lst); let lst' = List.map (fun el -> continue NoState el) lst in
`Assoc ["Set", `List lst'] );
typeVariableMap = (fun _visitor continue NoState tvmap -> typeVariableMap = (fun _visitor continue NoState tvmap ->
let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in let lst = List.sort (fun (a, _) (b, _) -> Var.compare a b) (RedBlackTrees.PolyMap.bindings tvmap) in
let aux ppf (k, v) = let aux (k, v) =
fprintf ppf "[ %a , %a ]" Var.pp k (fun _ppf -> continue NoState) v in `Assoc [ ("key", `String (asprintf "%a" Var.pp k)) ; ("value", continue NoState v) ] in
fprintf ppf "[ \"typeVariableMap\" %a ]" (list_sep aux (fun ppf () -> fprintf ppf " , ")) lst); let lst' = List.map aux lst in
`Assoc ["typeVariableMap", `List lst'] );
} }
let print : ((no_state, unit) fold_config -> no_state -> 'a -> unit) -> formatter -> 'a -> unit = fun fold ppf v -> let print : ((no_state, json) fold_config -> no_state -> 'a -> json) -> 'a -> json = fun fold v ->
fold (op ppf) NoState v fold to_json NoState v
end end
include Fold.Folds(struct include Fold.Folds(struct
type in_state = M.no_state ;; type in_state = M.no_state ;;
type out_state = unit ;; type out_state = json ;;
type 'a t = formatter -> 'a -> unit ;; type 'a t = 'a -> json ;;
let f = M.print ;; let f = M.print ;;
end) end)
(* type in_state
type out_state
type 'a t
val f : ((in_state , out_state) fold_config -> in_state -> 'a -> out_state) -> 'a t *)

4
src/stages/5-ast_typed/formatter.ml
View File

@ -4,9 +4,7 @@ let program_ppformat ~display_format f (typed,_) =
match display_format with match display_format with
| Human_readable | Dev -> PP.program f typed | Human_readable | Dev -> PP.program f typed
let program_jsonformat (typed,_) : json = let program_jsonformat (typed,_) : json = PP_json.program typed
let core' = Format.asprintf "%a" PP.program typed in
`Assoc [("Typed(temp)" , `String core')]
let program_format : 'a format = { let program_format : 'a format = {
pp = program_ppformat; pp = program_ppformat;