tmp
This commit is contained in:
Galfour
parent
7df3f68f77
commit
9ebd206494
@ -28,25 +28,16 @@ let rec type_ ppf : type_value -> _ = function
|
||||
| T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_ k type_ v
|
||||
| T_list(t) -> fprintf ppf "list(%a)" type_ t
|
||||
| T_option(o) -> fprintf ppf "option(%a)" type_ o
|
||||
| T_shallow_closure(_, a, b) -> fprintf ppf "[big_closure](%a) -> (%a)" type_ a type_ b
|
||||
| T_deep_closure(c, arg, ret) ->
|
||||
fprintf ppf "[%a](%a)->(%a)"
|
||||
environment_small c
|
||||
environment c
|
||||
type_ arg type_ ret
|
||||
|
||||
and environment_element ppf ((s, tv) : environment_element) =
|
||||
Format.fprintf ppf "%s : %a" s type_ tv
|
||||
|
||||
and environment_small' ppf e' = let open Append_tree in
|
||||
let lst = to_list' e' in
|
||||
fprintf ppf "S[%a]" (list_sep_d environment_element) lst
|
||||
|
||||
and environment_small ppf e = let open Append_tree in
|
||||
let lst = to_list e in
|
||||
fprintf ppf "S[%a]" (list_sep_d environment_element) lst
|
||||
|
||||
let environment ppf (x:environment) =
|
||||
fprintf ppf "Env[%a]" (list_sep_d environment_small) x
|
||||
and environment ppf (x:environment) =
|
||||
fprintf ppf "Env[%a]" (list_sep_d environment_element) x
|
||||
|
||||
let rec value ppf : value -> unit = function
|
||||
| D_bool b -> fprintf ppf "%b" b
|
||||
@ -96,7 +87,6 @@ and function_ ppf ({binder ; input ; output ; body ; result ; capture_type}:anon
|
||||
fprintf ppf "fun[%s] (%s:%a) : %a %a return %a"
|
||||
(match capture_type with
|
||||
| No_capture -> "quote"
|
||||
| Shallow_capture _ -> "shallow"
|
||||
| Deep_capture _ -> "deep")
|
||||
binder
|
||||
type_ input
|
||||
@ -109,8 +99,7 @@ and assignment ppf ((n, e):assignment) = fprintf ppf "%s = %a;" n expression e
|
||||
and declaration ppf ((n, e):assignment) = fprintf ppf "let %s = %a;" n expression e
|
||||
|
||||
and statement ppf ((s, _) : statement) = match s with
|
||||
| S_environment_extend -> fprintf ppf "extend"
|
||||
| S_environment_restrict -> fprintf ppf "restrict"
|
||||
| S_environment_load _ -> fprintf ppf "load env"
|
||||
| S_environment_add (name, tv) -> fprintf ppf "add %s %a" name type_ tv
|
||||
| S_declaration ass -> declaration ppf ass
|
||||
| S_assignment ass -> assignment ppf ass
|
||||
|
||||
@ -118,7 +118,6 @@ let t_int : type_value = T_base Base_int
|
||||
let t_nat : type_value = T_base Base_nat
|
||||
|
||||
let t_function x y : type_value = T_function ( x , y )
|
||||
let t_shallow_closure x y z : type_value = T_shallow_closure ( x , y , z )
|
||||
let t_deep_closure x y z : type_value = T_deep_closure ( x , y , z )
|
||||
let t_pair x y : type_value = T_pair ( x , y )
|
||||
let t_union x y : type_value = T_or ( x , y )
|
||||
|
||||
@ -8,8 +8,7 @@ let basic_int_quote_env : environment =
|
||||
|
||||
let statement s' env : statement =
|
||||
match s' with
|
||||
| S_environment_extend -> s', environment_wrap env (Environment.extend env)
|
||||
| S_environment_restrict -> s', environment_wrap env (Environment.restrict env)
|
||||
| S_environment_load env' -> s', environment_wrap env env'
|
||||
| S_environment_add (name, tv) -> s' , environment_wrap env (Environment.add (name , tv) env)
|
||||
| S_cond _ -> s' , id_environment_wrap env
|
||||
| S_do _ -> s' , id_environment_wrap env
|
||||
|
||||
@ -1,118 +1,20 @@
|
||||
open Trace
|
||||
(* open Trace *)
|
||||
open Types
|
||||
|
||||
type element = environment_element
|
||||
module type ENVIRONMENT = sig
|
||||
type element = environment_element
|
||||
type t = environment
|
||||
|
||||
module Small = struct
|
||||
open Append_tree
|
||||
|
||||
type t' = environment_small'
|
||||
type t = environment_small
|
||||
|
||||
let not_in_env' ?source s t' =
|
||||
let title () = match source with
|
||||
| None -> "Not in environment"
|
||||
| Some source -> Format.asprintf "Not in environment' (%s)" source in
|
||||
let content () =
|
||||
Format.asprintf "Variable : %s, Environment' : %a"
|
||||
s PP.environment_small' t' in
|
||||
error title content
|
||||
|
||||
let not_in_env ?source s t =
|
||||
let title () = match source with
|
||||
| None -> "Not in environment"
|
||||
| Some source -> Format.asprintf "Not in environment (%s)" source in
|
||||
let content () =
|
||||
Format.asprintf "Variable : %s, Environment : %a"
|
||||
s PP.environment_small t in
|
||||
error title content
|
||||
|
||||
let has' s = exists' (fun ((x, _):element) -> x = s)
|
||||
let has s = function
|
||||
| Empty -> false
|
||||
| Full x -> has' s x
|
||||
|
||||
let empty : t = empty
|
||||
|
||||
let get_opt = assoc_opt
|
||||
|
||||
let append s (e:t) = if has (fst s) e then e else append s e
|
||||
|
||||
let of_list lst =
|
||||
let rec aux = function
|
||||
| [] -> Empty
|
||||
| hd :: tl -> append hd (aux tl)
|
||||
in
|
||||
aux @@ List.rev lst
|
||||
|
||||
|
||||
let rec to_list' (e:t') =
|
||||
match e with
|
||||
| Leaf x -> [x]
|
||||
| Node {a;b} -> (to_list' a) @ (to_list' b)
|
||||
|
||||
let to_list (e:t) =
|
||||
match e with
|
||||
| Empty -> []
|
||||
| Full x -> to_list' x
|
||||
|
||||
type bound = string list
|
||||
|
||||
let rec get_path' = fun s env' ->
|
||||
match env' with
|
||||
| Leaf (n, v) when n = s -> ok ([], v)
|
||||
| Leaf _ -> fail @@ not_in_env' ~source:"get_path'" s env'
|
||||
| Node {a;b} ->
|
||||
match%bind bind_lr @@ Tezos_utils.Tuple.map2 (get_path' s) (a,b) with
|
||||
| `Left (lst, v) -> ok ((`Left :: lst), v)
|
||||
| `Right (lst, v) -> ok ((`Right :: lst), v)
|
||||
|
||||
let get_path = fun s env ->
|
||||
match env with
|
||||
| Empty -> fail @@ not_in_env ~source:"get_path" s env
|
||||
| Full x -> get_path' s x
|
||||
val empty : t
|
||||
val add : element -> t -> t
|
||||
end
|
||||
|
||||
type t = environment
|
||||
module Environment : ENVIRONMENT = struct
|
||||
type element = environment_element
|
||||
type t = environment
|
||||
|
||||
let empty : t = [Small.empty]
|
||||
let extend t : t = Small.empty :: t
|
||||
let restrict t : t = List.tl t
|
||||
let of_small small : t = [small]
|
||||
let empty = []
|
||||
let add = List.cons
|
||||
end
|
||||
|
||||
let rec get_opt : t -> string -> type_value option = fun t k ->
|
||||
match t with
|
||||
| [] -> None
|
||||
| hd :: tl -> (
|
||||
match Small.get_opt hd k with
|
||||
| None -> get_opt tl k
|
||||
| Some v -> Some v
|
||||
)
|
||||
|
||||
let rec has x : t -> bool = function
|
||||
| [] -> raise (Failure "Schema.Big.has")
|
||||
| [hd] -> Small.has x hd
|
||||
| hd :: tl -> Small.has x hd || has x tl
|
||||
let add x : t -> t = function
|
||||
| [] -> raise (Failure "Schema.Big.add")
|
||||
| hd :: tl -> Small.append x hd :: tl
|
||||
|
||||
type path = [`Left | `Right] list
|
||||
let pp_path : _ -> path -> unit =
|
||||
let open Format in
|
||||
let aux ppf lr = match lr with
|
||||
| `Left -> fprintf ppf "L"
|
||||
| `Right -> fprintf ppf "R"
|
||||
in
|
||||
PP_helpers.(list_sep aux (const " "))
|
||||
|
||||
let rec get_path : string -> environment -> ([`Left | `Right] list * type_value) result = fun s t ->
|
||||
match t with
|
||||
| [] -> simple_fail "Get path : empty big schema"
|
||||
| [ x ] -> Small.get_path s x
|
||||
| Empty :: tl -> get_path s tl
|
||||
| hd :: tl -> (
|
||||
match%bind bind_lr_lazy (Small.get_path s hd, (fun () -> get_path s tl)) with
|
||||
| `Left (lst, v) -> ok (`Left :: lst, v)
|
||||
| `Right (lst, v) -> ok (`Right :: lst, v)
|
||||
)
|
||||
include Environment
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
module Append_tree = Tree.Append
|
||||
|
||||
type type_name = string
|
||||
|
||||
type type_base =
|
||||
@ -13,21 +11,15 @@ type type_value =
|
||||
| T_pair of (type_value * type_value)
|
||||
| T_or of type_value * type_value
|
||||
| T_function of type_value * type_value
|
||||
| T_deep_closure of environment_small * type_value * type_value
|
||||
| T_shallow_closure of environment * type_value * type_value
|
||||
| T_deep_closure of environment * type_value * type_value
|
||||
| T_base of type_base
|
||||
| T_map of (type_value * type_value)
|
||||
| T_list of type_value
|
||||
| T_option of type_value
|
||||
|
||||
|
||||
and environment_element = string * type_value
|
||||
|
||||
and environment_small' = environment_element Append_tree.t'
|
||||
|
||||
and environment_small = environment_element Append_tree.t
|
||||
|
||||
and environment = environment_small list
|
||||
and environment = environment_element list
|
||||
|
||||
type environment_wrap = {
|
||||
pre_environment : environment ;
|
||||
@ -79,8 +71,7 @@ and expression = {
|
||||
and assignment = var_name * expression
|
||||
|
||||
and statement' =
|
||||
| S_environment_extend
|
||||
| S_environment_restrict
|
||||
| S_environment_load of environment
|
||||
| S_environment_add of (var_name * type_value)
|
||||
| S_declaration of assignment (* First assignment *)
|
||||
| S_assignment of assignment
|
||||
@ -112,8 +103,7 @@ and anon_function_expression = anon_function_content
|
||||
|
||||
and capture =
|
||||
| No_capture (* For functions that don't capture their environments. Quotes. *)
|
||||
| Shallow_capture of environment (* Duplicates the whole environment. A single DUP. Heavier GETs and SETs at use. *)
|
||||
| Deep_capture of environment_small (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *)
|
||||
| Deep_capture of environment (* Retrieves only the values it needs. Multiple SETs on init. Lighter GETs and SETs at use. *)
|
||||
|
||||
and block' = statement list
|
||||
|
||||
|
||||
@ -358,7 +358,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express
|
||||
let%bind n = translate_annotated_expression env match_none in
|
||||
let%bind (tv' , s') =
|
||||
let%bind tv' = translate_type tv in
|
||||
let env' = Environment.(add (name , tv') @@ extend env) in
|
||||
let env' = Environment.(add (name , tv') @@ env) in
|
||||
let%bind s' = translate_annotated_expression env' s in
|
||||
ok (tv' , s') in
|
||||
return @@ E_if_none (expr' , n , ((name , tv') , s'))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user