open PPrint open Closures_types let id x = x let utf = utf8string let doc_var var = utf (Var.to_string var) let doc_binding print (x, v) = group (infix 2 0 colon (doc_var x) (print v)) let emptyset = utf "∅" let vdash = utf "⊢" let add_annot doc annot = doc ^^ if annot then utf "¹" else utf "⁰" let doc_context doc_elem gamma = if gamma = [] then emptyset else group (separate_map comma (doc_binding doc_elem) (* contexts are stored last-variable-first *) (List.rev gamma)) let doc_annot_map gamma = if gamma = [] then emptyset else group (separate_map comma (fun (x, annot) -> add_annot (doc_var x) annot) (List.rev gamma)) let rec doc_ty = function | Atom (Const atom) -> utf atom | Product (sigma1, sigma2) -> group (parens (infix 2 1 star (doc_ty sigma1) (doc_ty sigma2))) | Closure (gamma_pphi, x, sigma_phi, tau) -> (prefix 2 0 (brackets (doc_context doc_ann_ty gamma_pphi)) (infix 2 1 (utf "→") (parens (doc_binding doc_ann_ty (x, sigma_phi))) (doc_ty tau))) and doc_ann_ty (sigma, annot) = group (add_annot (doc_ty sigma) annot) let doc_lambda binder t = group (utf "λ" ^^ binder ^//^ t) let rec doc_exp = function | Var x -> doc_var x | Pair (e1, e2) -> group (parens (prefix 0 1 (doc_exp e1 ^^ comma) (doc_exp e2))) | Proj (left_or_right, e) -> group ((if left_or_right then utf "π₁" else utf "π₂") ^^ parens (doc_exp e)) | Lam (x, sigma, e) -> doc_lambda (parens (doc_binding doc_ty (x, sigma))) (doc_exp e) | App(t, u) -> parens (doc_exp t) ^//^ (doc_exp u) | Let(x, e1, e2) -> soft_surround 2 1 (separate space [utf "let"; doc_var x; utf "="]) (doc_exp e1) (utf "in") ^//^ (doc_exp e2) let doc_judgment_scope_context gamma = (doc_context doc_ty gamma) ^^ space ^^ vdash let doc_judgment_scope (gamma, sigma) = infix 2 1 vdash (doc_context doc_ty gamma) (doc_ty sigma) let doc_judgment_ty (gamma, pphi, e, sigma) = let gamma_pphi = Closures_check.(map2_context with_annot gamma pphi) in infix 2 1 vdash (doc_context doc_ann_ty gamma_pphi) (prefix 0 1 (doc_exp e) (colon ^^ space ^^ doc_ty sigma)) let doc_judgment_subst y sdoc lhs rhs = infix 2 1 (group (utf "~" ^^ doc_var y ^^ backslash ^^ sdoc ^^ utf "~>")) lhs rhs let doc_judgment_subst_context (gamma, rho, y, delta, ppsi, delta') = doc_judgment_subst y (doc_annot_map ppsi) (doc_context doc_ty (delta @ [y,rho] @ gamma)) (doc_context doc_ty (delta' @ gamma)) let doc_judgment_subst_ty (gamma, rho, y, delta, sigma, ppsi, delta', tau) = doc_judgment_subst y (doc_annot_map ppsi) (doc_judgment_scope (delta @ [y,rho] @ gamma, sigma)) (doc_judgment_scope (delta' @ gamma, tau)) let rec doc_value = function | VError -> utf "VError" | VAtom (_atom, value_atom) -> utf value_atom | VPair (v1, v2) -> group (parens (prefix 2 1 (doc_value v1 ^^ comma) (doc_value v2))) | VClosure (free_vars, captured_vars, x, t) -> let doc_captured (x, v) = group (parens (infix 2 0 (utf "↦") (doc_var x) (doc_value v))) in group (parens (separate (comma ^^ break 1) [ (if free_vars = [] then emptyset else brackets (flow comma (* context is stored last-variable-first *) (List.rev_map doc_var free_vars))); (if captured_vars = [] then emptyset else parens (flow comma (* no rev: captured-vars are added in the right order *) (List.map doc_captured captured_vars))); (doc_lambda (parens (doc_var x)) (doc_exp t)); ])) (* ((x_i), (x_j ↦ v_j), λx.t) *) let doc_judgment_subst_value (w, y, v, w') = doc_judgment_subst y (doc_value v) (doc_value w) (doc_value w') let doc_judgment_red (vv, e, v) = infix 2 1 vdash (doc_context doc_value vv) (prefix 0 1 (doc_exp e) (utf "=>" ^^ space ^^ doc_value v)) let text s = flow (break 1) (words s) let header s doc = text s ^//^ doc let print doc = ToChannel.pretty 1. !(Closures_config.line_length) stdout doc (** Generic support for printing derivations of inference judgments *) type 'kind derivation = { kind: 'kind; label: string; judgment: document; hypotheses: 'kind derivation list; } type show = | Full | Only_judgment | Judgment_and_comment of document | Hidden let doc_derivation show der = let rec doc_derivation {kind; label; judgment; hypotheses} = let show_status = show kind in show_status, match show_status with | Hidden -> empty | Only_judgment -> judgment | Judgment_and_comment comment -> judgment ^//^ comment | Full -> (* we rely on the fact that List.map applies its user-passed function in list order, to guarantee that "show" will be called on subderivations in topmost order; this can be useful if "show" has side-effects (eg. memoization) *) let leaves = BatList.filter_map (fun der -> match doc_derivation der with | Hidden, _ -> None | _, doc -> Some doc) hypotheses in group (judgment ^/^ utf label ^^ colon) ^^ if leaves = [] then empty else nest 2 (hardline ^^ separate hardline leaves) in snd (doc_derivation der) (** specific derivation printers *) open Closures_check let error_msg = function | Context_size_mismatch -> "context size mismatch" | Context_mismatch -> "context mismatch" | Ty_Proj_expected_a_tuple -> "Proj: expected a tuple" | Ty_App_expected_a_function -> "App: expected a function" | Red_Proj_expected_a_tuple -> "Proj: expected a tuple" | Red_App_expected_a_function -> "App: expected a function" | Ty_App_argument_mismatch -> "App: argument type mismatch" | Subst_function_argument_scope_escape -> "a function argument escapes through a substitution" | Subst_on_error -> "substituting on error" | Subst_nontop_variable -> "variable not at the top" | Red_missing_variable -> "variable not found" let error_label err = Printf.sprintf "ERROR(%s)" (error_msg err) let rec der_scope_context der = let kind = `Scope_context der in let judgment = doc_judgment_scope_context (judgment_scope_context der) in let rule label hypotheses = { kind; judgment; label; hypotheses } in match der with | Scope_context_nil -> rule "Scope-Context-Nil" [] | Scope_context (gamma_der_sigma, _gamma, _sigma, _x) -> rule "Scope-Context" [ der_scope gamma_der_sigma; ] and der_scope der = let kind = `Scope der in let judgment = doc_judgment_scope (judgment_scope der) in let rule label hypotheses = { kind; judgment; label; hypotheses } in match der with | Scope_error (err, _gamma, _sigma) -> rule (error_label err) [] | Scope_atom (gamma_der, _gamma, _atom) -> rule "Scope-Atom" [ der_scope_context gamma_der; ] | Scope_product (_gamma, _tau1, der_tau1, _tau2, der_tau2) -> rule "Scope-Product" [ der_scope der_tau1; der_scope der_tau2; ] | Scope_closure (_gamma0_pphi, _gamma1, gamma0_gamma1_der, _sigma_phi, der_sigma, _x, _tau, der_tau) -> rule "Scope-Closure" [ der_scope_context gamma0_gamma1_der; der_scope der_sigma; der_scope der_tau; ] let full_memo table input = if Hashtbl.mem table input then Judgment_and_comment (utf "(already shown)") else (Hashtbl.add table input (); Full) let doc_der_scope_context, doc_der_scope = let show () = let tbl_context = Hashtbl.create 10 in let tbl = Hashtbl.create 10 in function | `Scope_context der -> full_memo tbl_context der | `Scope der -> full_memo tbl der in (fun der -> doc_derivation (show ()) (der_scope_context der)), (fun der -> doc_derivation (show ()) (der_scope der)) let rec der_ty der = let kind = `Ty der in let judgment = doc_judgment_ty (judgment_ty der) in let rule label hypotheses = { kind; judgment; label; hypotheses } in match der with | Ty_error (err, _gamma, _e) -> rule (error_label err) [] | Ty_var (der, _gamma, _sigma, _x, _delta) -> rule "Ty-Var" [ der_scope_context der; ] | Ty_product (der1, _j1, der2, _j2) -> rule "Ty-Product" [ der_ty der1; der_ty der2; ] | Ty_proj (_lor, der, _gamma_phi, _e, _tau1, _tau2) -> rule "Ty-Proj" [ der_ty der; ] | Ty_lam (der, _gamma_phi, _sigma_phi, x, t, tau) -> rule "Ty-Lam" [ der_ty der; ] | Ty_let (_j, _pphibody, _phi, _x, _tau, _e2, _tau', derdef, derbody, dersubst) -> rule "Ty-Let" [ der_ty derdef; der_ty derbody; der_subst_ty dersubst; ] | Ty_app (derfun, _gamma0, _gamma1, _pphifun, _t, _pphiclos, _sigma, _phi, x, _tau, derarg, _pphiarg, _u, dersubst, _tau') -> rule "Ty-App" [ der_ty derfun; der_ty derarg; der_subst_ty dersubst; ] and der_subst_ty der = let kind = `Subst_ty der in let judgment = doc_judgment_subst_ty (judgment_subst_ty der) in let rule label hypotheses = { kind; judgment; label; hypotheses } in match der with | Subst_error (err, _, _, _, _, _, _, _) -> rule (error_label err) [] | Subst_atom (der, _j, _) -> rule "Subst-Atom" [ der_subst_context der; ] | Subst_product (der1, _j1, der2, _sigma2, _tau2) -> rule "Subst-Product" [ der_subst_ty der1; der_subst_ty der2; ] | Subst_closure_notin (dercontext, _, _, _, _, _, _, _, _, _, _, _) -> rule "Subst-Closure-Notin" [ der_subst_context dercontext; ] | Subst_closure (dercontext, _gamma_pphi, _rho_chi, _y, _delta_pphi', _gamma1, _ppsi, _delta', _gamma1', der1, _sigma1_phi, _x, der2, _sigma2, _tau2) -> rule "Susbt-Closure" [ der_subst_context dercontext; der_subst_ty der1; der_subst_ty der2; ] and der_subst_context der = let kind = `Subst_context der in let judgment = doc_judgment_subst_context (judgment_subst_context der) in let rule label hypotheses = { kind; judgment; label; hypotheses } in match der with | Subst_context_nil (_gamma, _rho, _y, _ppsi) -> rule "Subst-Context-Nil" [] | Subst_context (der, _, _, _, _, _, _, _, _, _) -> rule "Subst-Context" [ der_subst_ty der; ] let doc_der_ty = let show () = let tbl_ty = Hashtbl.create 10 in function | `Scope_context _ | `Scope _ -> Hidden | `Subst_ty _ | `Subst_context _ -> Only_judgment | `Ty der -> full_memo tbl_ty der in fun der -> doc_derivation (show ()) (der_ty der) let rec der_red der = let kind = `Red der in let judgment = doc_judgment_red (judgment_red der) in let rule label hypotheses = { kind; judgment; label; hypotheses } in match der with | Red_error (err, vv, e) -> rule (error_label err) [] | Red_var _ -> rule "Red-Var" [] | Red_lam _ -> rule "Red-Lam" [] | Red_pair (_vv, der1, _e1, _v1, der2, _e2, _v2) -> rule "Red-Pair" [ der_red der1; der_red der2; ] | Red_proj (_lor, _vv, der, _e, _v1, _v2) -> rule "Red-Proj" [ der_red der; ] | Red_let (_vv, der1, _e1, _v1, der2, _x, _e2, _v2, dersubst, _v'2) -> rule "Red-Let" [ der_red der1; der_red der2; der_subst_value dersubst; ] | Red_app (_vv, derclos, _t, _free_vars, _captured_vars, y, _t', derarg, _u, varg, w, derarg_subst, dercont_subst, w') -> rule "Red-App" [ der_red derclos; der_red derarg; der_subst_value_chain w y varg derarg_subst dercont_subst w'; ] and der_subst_value der = let kind = `Subst_value der in let judgment = doc_judgment_subst_value (judgment_subst_value der) in let rule label hypotheses = { kind; judgment; label; hypotheses } in match der with | Subst_value_error (err, _, _, _) -> rule (error_label err) [] | Subst_value_atom _ -> rule "Subst-Value-Atom" [] | Subst_value_product (_, _, der1, _, _, der2, _, _) -> rule "Subst-Value-Product" [ der_subst_value der1; der_subst_value der2; ] | Subst_value_closure _ -> rule "Subst-Value-Closure" [] | Subst_value_closure_notin _ -> rule "Subst-Value-Closure_notin" [] and der_subst_value_chain w y varg derarg_subst dercont_subst w' = { kind = `Subst_value_chain; label = "Der-Subst-Value-Chain"; hypotheses = List.map der_subst_value (derarg_subst :: List.map snd dercont_subst); judgment = ( let vv2 = List.map (fun (y, der) -> let (_w, y_, v, _w') = judgment_subst_value der in assert (y = y_); (y, v)) dercont_subst in infix 2 1 (group (utf "~" ^^ doc_var y ^^ backslash ^^ doc_value w ^^ utf "~" ^^ parens (doc_context doc_value vv2) ^^ utf "~>")) (doc_value w) (doc_value w') ); } let doc_der_red = let show () = function | `Subst_value _ | `Subst_value_chain -> Only_judgment | `Red der -> Full in fun der -> doc_derivation (show ()) (der_red der)