open Batteries open Closures_types let annot (_sigma, phi) = phi let no_annot (sigma, _phi) = sigma let with_annot sigma phi = (sigma, phi) let map_context f context = List.map (fun (x,v) -> (x, f v)) context let map2_context f c1 c2 = List.map2 (fun (x,v1) (y,v2) -> assert (x = y); (x, f v1 v2)) c1 c2 let domain context = List.map fst context let pre test = test (); () let post test x = test x; x let valid_call f = let valid = ref true in ignore (f valid); !valid type error = | Context_size_mismatch | Context_mismatch | Ty_Proj_expected_a_tuple | Ty_App_expected_a_function | Red_Proj_expected_a_tuple | Red_App_expected_a_function | Ty_App_argument_mismatch | Subst_function_argument_scope_escape | Subst_on_error | Subst_nontop_variable | Red_missing_variable exception Error of error type judgment_scope_context = ty context and judgment_scope = ty context * ty type der_scope_context = | Scope_context_nil (* ∅ ⊢ *) | Scope_context of der_scope * ty context * ty * var (* Γ ⊢ σ ——————— Γ,x:σ ⊢ *) and der_scope = | Scope_error of error * ty context * ty | Scope_atom of der_scope_context * ty context * atom (* Γ ⊢ ————— Γ ⊢ α *) | Scope_product of ty context * ty * der_scope * ty * der_scope (* Γ ⊢ τ₁ Γ ⊢ τ₂ ——————————————— Γ ⊢ τ₁ * τ₂ *) | Scope_closure of ann_ty context * ty context * der_scope_context * ann_ty (* σ^φ *) * der_scope * var * ty (* τ *) * der_scope (* Γ₀,Γ₁ ⊢ Γ₀ ⊢ σ Γ₀,x:σ ⊢ τ —————————————————————————————— Γ₀,Γ₁ ⊢ [Γ₀^Φ](x:σ^φ) -> τ *) let judgment_scope_context = function | Scope_context_nil -> [] | Scope_context (_gamma_der_sigma, gamma, sigma, x) -> (x, sigma) :: gamma let judgment_scope = function | Scope_error (_err, gamma, sigma) -> (gamma, sigma) | Scope_atom (_gamma_der, gamma, atom) -> (gamma, Atom atom) | Scope_product (gamma, tau1, _gamma_der_tau1, tau2, _gamma_der_tau2) -> (gamma, Product (tau1, tau2)) | Scope_closure (gamma0_pphi, gamma1, _gamma01_der, sigma_phi, _gamma0_der_sigma, x, tau, _gamma0_x_sigma_der_tau) -> let gamma0 = map_context no_annot gamma0_pphi in (gamma1 @ gamma0, Closure (gamma0_pphi, x, sigma_phi, tau)) type ('a, 'b) result = Ok of 'a | Fail of 'b let remove_context_prefix ~gamma01 ~gamma0 = let len0 = List.length gamma0 in let len01 = List.length gamma01 in try let len1 = len01 - len0 in if len1 < 0 then raise (Error Context_size_mismatch); let gamma1 = List.take len1 gamma01 in let gamma0' = List.drop len1 gamma01 in if gamma0 <> gamma0' then raise (Error Context_mismatch); Ok gamma1 with Error err -> Fail err let rec check_scope_context valid gamma = post (fun der -> assert (judgment_scope_context der = gamma)) begin match gamma with | [] -> Scope_context_nil | (x,sigma) :: gamma -> let gamma_der_sigma = check_scope valid gamma sigma in Scope_context (gamma_der_sigma, gamma, sigma, x) end and check_scope valid gamma ty = post (fun der -> assert (judgment_scope der = (gamma, ty))) begin match ty with | Atom atom -> let gamma_der = check_scope_context valid gamma in Scope_atom (gamma_der, gamma, atom) | Product (tau1, tau2) -> let gamma_der_tau1 = check_scope valid gamma tau1 in let gamma_der_tau2 = check_scope valid gamma tau2 in Scope_product (gamma, tau1, gamma_der_tau1, tau2, gamma_der_tau2) | Closure (gamma0_pphi, x, sigma_phi, tau) as ty -> let gamma01 = gamma in let gamma0 = map_context no_annot gamma0_pphi in match remove_context_prefix ~gamma01 ~gamma0 with | Fail err -> valid := false; Scope_error (err, gamma, ty) | Ok gamma1 -> let gamma01_der = check_scope_context valid gamma01 in let sigma = no_annot sigma_phi in let gamma0_der_sigma = check_scope valid gamma0 sigma in let gamma0_x_sigma_der_tau = check_scope valid ((x,sigma)::gamma0) tau in Scope_closure (gamma0_pphi, gamma1, gamma01_der, sigma_phi, gamma0_der_sigma, x, tau, gamma0_x_sigma_der_tau) end let venv = Var.empty_env let venv, paper_example = (* y:σ¹, z:τ⁰ ⊢ (y, λ(x:ρ).z) : σ * [y:σ⁰, z:τ¹](x:ρ⁰) → τ *) let venv = Var.empty_env in let x, venv = Var.fresh "x" venv in let y, venv = Var.fresh "y" venv in let z, venv = Var.fresh "z" venv in let sigma = Atom (Const "σ") in let rho = Atom (Const "ρ") in let tau = Atom (Const "τ") in let gamma_pphi = List.rev [(y,(sigma, true)); (z,(tau,false))] in let e = Pair (Var y, Lam (x, rho, Var z)) in let ty = Product (sigma, Closure (List.rev [(y,(sigma,false)); (z,(tau,true))], x, (rho, false), tau)) in venv, (gamma_pphi, e, ty) let test = let valid = ref true in let (gamma_pphi, e, ty) = paper_example in let der_scope = check_scope valid (map_context no_annot gamma_pphi) ty in assert !valid; der_scope (** Expressions *) type judgment_ty = ty context * annot context * exp * ty (* Γ^Φ ⊢ e : σ *) and judgment_subst_context = ty context * ty * var * ty context * annot context * ty context (* Γ,y:ρ,Δ ~(y\Ψ)~> Γ,Δ' *) and judgment_subst_ty = ty context * ty * var * ty context * ty * annot context * ty context * ty (* Γ,y:ρ,Δ ⊢ σ ~(y\Ψ)~> Γ,Δ' ⊢ τ *) type der_ty = | Ty_error of error * ty context * exp | Ty_var of der_scope_context * ty context * ty * var * ty context (* Γ,x:σ,Δ ⊢ ———————————————— Γ⁰,x:σ¹,Δ⁰ ⊢ x:σ *) | Ty_product of der_ty * judgment_ty * der_ty * judgment_ty (* Γ^Φ₁ ⊢ e₁ : τ₁ Γ^Φ₂ ⊢ e₂ : τ₂ ——————————————————————————————— Γ^(Φ₁ + Φ₂) ⊢ (e₁, e₂) : τ₁ * τ₂ *) | Ty_proj of bool * der_ty * ann_ty context * exp * ty * ty (* Γ^Φ ⊢ e : τ₁ * τ₂ ————————————————— Γ^Φ ⊢ π₁₂(e) : τ₁₂ *) | Ty_lam of der_ty * ann_ty context * ann_ty * var * exp * ty (* Γ^Φ,x:σ^φ ⊢ t : τ ————————————————————————————— Γ⁰ ⊢ λx.t : [Γ^Φ](x:σ^φ) -> τ *) | Ty_let of judgment_ty (* Φbody,φ,x,τ,e₂,τ' *) * annot context * annot * var * ty * exp * ty * der_ty * der_ty * der_subst_ty (* Γ^Φdef ⊢ e₁ : σ Γ^Φbody,x:σ^φ ⊢ e₂ : τ Γ,x:σ ⊢ τ ~(x\Φdef)~> Γ ⊢ τ' —————————————————————————————————————————— Γ^(Φbody+φ.Φdef) ̣⊢ let x = e₁ in e₂ : τ' *) | Ty_app of der_ty (*Γ₀,Γ₁,Φfun,t*) * ty context * ty context * annot context * exp (*Φclos,σ,φ,x,τ*) * annot context * ty * annot * var * ty (*Φarg,u*) * der_ty * annot context * exp (*τ'*) * der_subst_ty * ty (* (Γ₀,Γ₁)^Φfun ⊢ t : [Γ₀^Φclos](x:σ^φ) → τ (Γ₀,Γ₁)^Φarg ⊢ u : σ Γ₀,Γ₁,x:σ ⊢ τ ~(x\Φarg)~> Γ₀,Γ₁ ⊢ τ' ———————————————————————————————————————— (Γ₀,Γ₁)^Φfun+Φclos+φ.Φarg ⊢ t u : τ' *) and der_subst_ty = | Subst_error of error * ty context * ty * var * ty context * ty * annot context * ty context (* Γ,ρ,y,Δ,σ,Ψ,~Δ'*) | Subst_atom of der_subst_context * judgment_subst_context * atom (* Γ,y:ρ,Δ ~(y\Ψ)~> Γ,Δ' —————————————————————————————— Γ,y:ρ,Δ ⊢ α ~(y\Ψ)~> Γ,Δ' ⊢ α *) | Subst_product of der_subst_ty * judgment_subst_ty * der_subst_ty * (* σ₂, τ₂ *) ty * ty (* Γ,y:ρ,Δ ⊢ σ₁ ~(y\Ψ)~> Γ,Δ' ⊢ τ₁ Γ,y:ρ,Δ ⊢ σ₂ ~(y\Ψ)~> Γ,Δ' ⊢ τ₂ —————————————————————————————————————— Γ,y:ρ,Δ ⊢ σ₁*σ₂ ~(y\Ψ)~> Γ,Δ' ⊢ τ₁*τ₂ *) | Subst_closure_notin of der_subst_context * ty context * ty context * ty * var * ty context * annot context * ty context (* Φ,x:σ₁^φ,σ₂ *) * annot context * ann_ty * var * ty (* Γ₀,Γ₁,y:ρ,Δ ~(y\Ψ)~> Γ₀,Γ₁,Δ' ————————————————————————————————————————————————————————————————————— Γ₀,Γ₁,y:ρ,Δ ⊢ [Γ₀^Φ](x:σ₁^φ)→σ₂ ~(y\Ψ)~> Γ₀,Γ₁,Δ' ⊢ [Γ₀^Φ](x:σ₁^φ)→σ₂ *) | Subst_closure of der_subst_context (* Γ^Φ,ρ^χ,y *) * ann_ty context * ann_ty * var (* Δ^Φ',Γ₁ *) * ann_ty context * ty context (* Ψ,Δ',Γ'₁ *) * annot context * ty context * ty context (* σ₁^φ,x *) * der_subst_ty * ann_ty * var (* σ₂,τ₂ *) * der_subst_ty * ty * ty (* Γ,y:ρ,Δ,Γ₁ ~(y\Ψ)~> Γ,Δ',Γ'₁ Γ,y:ρ,Δ ⊢ σ₁ ~(y\Ψ)~> Γ,Δ' ⊢ σ₁ Γ,y:ρ,Δ,x:σ₁ ⊢ σ₂ ~(y\Ψ)~> Γ,Δ',x:σ₁ ⊢ τ₂ ——————————————————————————————————————————————————————————————————————————— Γ,y:ρ,Δ,Γ₁ ⊢ [Γ^Φ,y:ρ^χ,Δ^Φ'](x:σ₁^φ)→σ₂ ~(y\Ψ)~> Γ,Δ',Γ'₁ ⊢ [Γ^Φ+χ.Ψ,Δ'^Φ'](x:σ₁^φ)→τ₂ *) and der_subst_context = | Subst_context_nil of ty context * ty * var * annot context (* Γ,y:ρ,∅ ~(y\Ψ)~> Γ *) | Subst_context of der_subst_ty * ty context * ty * var * ty context (* σ,x *) * ty * var * annot context * ty context * ty (* Γ,y:ρ,Δ ⊢ σ ~(y\Ψ)~> Γ,Δ' ⊢ τ ————————————————————————————— Γ,y:ρ,Δ,x:σ ~(y\Ψ)~> Γ,Δ,x:τ *) let split_context x context = match List.span (fun (y,_) -> y <> x) context with | _, [] -> raise Not_found | delta, (x',sigma)::gamma -> assert (x = x'); delta, sigma, gamma let all_zero context = map_context (const false) context let error_ty = Atom (Const "error") let remove_context_prefix_exn ~gamma01 ~gamma0 = match remove_context_prefix ~gamma01 ~gamma0 with | Fail err -> raise (Error err) | Ok gamma1 -> gamma1 (* Φ₁ + Φ₂ *) let sum pphi1 pphi2 = map2_context (||) pphi1 pphi2 (* φ.Φ *) let prod phi pphi = map_context ((&&) phi) pphi let judgment_ty = function | Ty_error (_err, gamma, e) -> (gamma, all_zero gamma, e, error_ty) | Ty_var (_der, gamma, sigma, x, delta) -> let pphi = all_zero delta @ [x,true] @ all_zero gamma in (delta @ [x,sigma] @ gamma, pphi, Var x, sigma) | Ty_product (_der1, (gamma1, pphi1, e1, tau1), _der2, (gamma2, pphi2, e2, tau2)) -> assert (gamma1 = gamma2); let gamma = gamma1 in let pphi = sum pphi1 pphi2 in (gamma, pphi, Pair (e1, e2), Product (tau1, tau2)) | Ty_proj(left_or_right, _derprod, gamma_pphi, e, tau1, tau2) -> let gamma = map_context no_annot gamma_pphi in let pphi = map_context annot gamma_pphi in (gamma, pphi, Proj(left_or_right, e), (if left_or_right then tau1 else tau2)) | Ty_lam (_derbody, gamma_pphi, sigma_phi, x, e, tau) -> let gamma = map_context no_annot gamma_pphi in (gamma, all_zero gamma, Lam (x, no_annot sigma_phi, e), Closure (gamma_pphi, x, sigma_phi, tau)) | Ty_let ((gamma, pphidef, e1, sigma), pphibody, phi, x, tau, e2, tau', _derdef, _derbody, _dersubst) -> let pphi = sum pphibody (prod phi pphidef) in (gamma, pphi, Let (x, e1, e2), tau') | Ty_app (_derfun, gamma0, gamma1, pphifun, t, pphiclos, sigma, phi, x, tau, _derarg, pphiarg, u, _dersubst, tau') -> (* extend Φclos to the domain (Γ₀,Γ₁) *) assert (domain pphiclos = domain gamma0); let extended_pphiclos = all_zero gamma1 @ pphiclos in let pphi = sum (sum pphifun extended_pphiclos) (prod phi pphiarg) in (gamma1 @ gamma0, pphi, App (t, u), tau') let judgment_subst_ty = function | Subst_error (_err, gamma, rho, y, delta, sigma, ppsi, delta') -> gamma, rho, y, delta, sigma, ppsi, delta', error_ty | Subst_atom (der, (gamma, rho, y, delta, ppsi, delta'), atom) -> gamma, rho, y, delta, Atom atom, ppsi, delta', Atom atom | Subst_product (der1, (gamma, rho, y, delta, sigma1, ppsi, delta', tau1), der2, sigma2, tau2) -> (gamma, rho, y, delta, Product (sigma1, sigma2), ppsi, delta', Product (tau1, tau2)) | Subst_closure_notin(der, gamma0, gamma1, rho, y, delta, ppsi, delta', pphi, sigma1_phi, x, sigma2) -> let gamma0_pphi = map2_context with_annot gamma0 pphi in (gamma1 @ gamma0, rho, y, delta, Closure(gamma0_pphi, x, sigma1_phi, sigma2), ppsi, delta', Closure(gamma0_pphi, x, sigma1_phi, sigma2)) | Subst_closure (dercontext, gamma_pphi, rho_chi, y, delta_pphi', gamma1, ppsi, delta', gamma1', dersigma1, sigma1_phi, x, derbody, sigma2, tau2) -> let gamma = map_context no_annot gamma_pphi in let pphi = map_context annot gamma_pphi in let delta = map_context no_annot delta_pphi' in let pphi' = map_context annot delta_pphi' in let rho, chi = no_annot rho_chi, annot rho_chi in (gamma, rho, y, gamma1 @ delta, Closure (delta_pphi' @ [y, rho_chi] @ gamma_pphi, x, sigma1_phi, sigma2), ppsi, gamma1' @ delta', Closure (map2_context with_annot delta' pphi' @ map2_context with_annot gamma (sum pphi (prod chi ppsi)), x, sigma1_phi, tau2)) let judgment_subst_context = function | Subst_context_nil (gamma, rho, y, ppsi) -> (gamma, rho, y, [], ppsi, []) | Subst_context (_der, gamma, rho, y, delta, sigma, x, ppsi, delta', tau) -> (gamma, rho, y, (x,sigma)::delta, ppsi, (x,tau)::delta') let output_of_ty der = let (_gamma, pphi, _e, sigma) = judgment_ty der in pphi, sigma let output_of_subst_ty der = let (_gamma, _rho, _y, delta, sigma, ppsi, delta', tau') = judgment_subst_ty der in delta', tau' let output_of_subst_context der = let (_gamma, _rho, _y, _delta, _ppsi, delta') = judgment_subst_context der in delta' (* Given Γ and e, infer Φ and σ such that Γ^Φ ⊢ e : σ *) let rec infer_ty valid context exp = post (fun der -> let (context_, pphi, exp_, sigma) = judgment_ty der in assert (context = context_); assert (exp = exp_); assert (domain pphi = domain context); assert (valid_call (fun v -> check_scope v context sigma)); ) begin try match exp with | Var x -> (* note that contexts are in reverse order, most recent binding first *) let delta, sigma, gamma = split_context x context in Ty_var (check_scope_context valid context, gamma, sigma, x, delta) | Pair (e1, e2) -> let der1 = infer_ty valid context e1 in let judgment1 = judgment_ty der1 in let der2 = infer_ty valid context e2 in let judgment2 = judgment_ty der2 in Ty_product (der1, judgment1, der2, judgment2) | Proj (left_or_right, e) -> let derprod = infer_ty valid context e in let pphi, sigma = output_of_ty derprod in begin match sigma with | Atom _ | Closure _ -> raise (Error Ty_Proj_expected_a_tuple) | Product (tau1, tau2) -> let gamma_pphi = map2_context with_annot context pphi in Ty_proj(left_or_right, derprod, gamma_pphi, e, tau1, tau2) end | Lam (x, sigma, e) -> let gamma = context in let (pphi, phi, tau, derbody) = infer_ty_in_extended_context valid gamma x sigma e in let gamma_pphi = map2_context with_annot gamma pphi in Ty_lam (derbody, gamma_pphi, (sigma, phi), x, e, tau) | Let (x, e1, e2) -> let gamma = context in let derdef = infer_ty valid gamma e1 in let pphidef, sigma = output_of_ty derdef in let (pphibody, phi, tau, derbody) = infer_ty_in_extended_context valid gamma x sigma e2 in let (tau', dersubst) = compute_subst_ty_last_var valid gamma x sigma pphidef tau in Ty_let ((gamma, pphidef, e1, sigma), pphibody, phi, x, tau, e2, tau', derdef, derbody, dersubst) | App (t, u) -> let gamma01 = context in let derfun = infer_ty valid gamma01 t in let pphifun, tyfun = output_of_ty derfun in let derarg = infer_ty valid gamma01 u in let pphiarg, sigma = output_of_ty derarg in begin match tyfun with | Atom _ | Product _ -> raise (Error Ty_App_expected_a_function) | Closure (gamma0_pphiclos, x, (sigma', phi), tau) -> if sigma <> sigma' then raise (Error Ty_App_argument_mismatch); let gamma0 = map_context no_annot gamma0_pphiclos in let pphiclos = map_context annot gamma0_pphiclos in let tau', dersubst = compute_subst_ty_last_var valid gamma01 x sigma pphiarg tau in let gamma1 = remove_context_prefix_exn ~gamma01 ~gamma0 in Ty_app (derfun, gamma0, gamma1, pphifun, t, pphiclos, sigma, phi, x, tau, derarg, pphiarg, u, dersubst, tau') end with Error err -> valid := false; Ty_error (err, context, exp) end and infer_ty_in_extended_context valid gamma x sigma e = let der = infer_ty valid ((x,sigma)::gamma) e in let context, annot, e', tau = judgment_ty der in assert (context = (x,sigma)::gamma); assert (e' = e); match annot with | [] -> assert false (* the annotation has the same length as the input context which is non-empty here *) | (x',phi)::pphi -> assert (x = x'); assert (domain gamma = domain pphi); (pphi, phi, tau, der) and compute_subst_ty_last_var valid gamma y rho ppsi sigma = let der = compute_subst_ty valid gamma y rho ppsi [] sigma in let delta', sigma' = output_of_subst_ty der in assert (delta' = []); (sigma', der) and compute_subst_ty valid gamma y rho ppsi delta sigma = pre (fun () -> assert (domain gamma = domain ppsi); assert (valid_call (fun v -> check_scope v (delta @ [y,rho] @ gamma) sigma)); ); post (fun der -> let (gamma_, rho_, y_, delta_, sigma_, ppsi_, delta', tau') = judgment_subst_ty der in assert (gamma = gamma_); assert (rho = rho_); assert (y = y_); assert (delta = delta_); assert (sigma = sigma_); assert (ppsi = ppsi_); assert (domain delta = domain delta'); assert (valid_call (fun v -> check_scope v (delta' @ gamma) tau')); ) begin match sigma with | Atom atom -> let der = compute_subst_context valid gamma y rho ppsi delta in let delta' = output_of_subst_context der in let judgment = (gamma, rho, y, delta, ppsi, delta') in Subst_atom (der, judgment, atom) | Product (sigma1, sigma2) -> let der1 = compute_subst_ty valid gamma y rho ppsi delta sigma1 in let delta'1, tau1 = output_of_subst_ty der1 in let der2 = compute_subst_ty valid gamma y rho ppsi delta sigma2 in let delta'2, tau2 = output_of_subst_ty der2 in assert (delta'1 = delta'2); Subst_product (der1, (gamma, rho, y, delta, sigma1, ppsi, delta'1, tau1), der2, sigma2, tau2) | Closure (ann_context, x, sigma1_phi, sigma2) -> if not (List.mem_assoc y ann_context) then begin let der = compute_subst_context valid gamma y rho ppsi delta in let delta' = output_of_subst_context der in let gamma'_pphi = ann_context in let gamma01 = gamma in let gamma0 = map_context no_annot gamma'_pphi in match remove_context_prefix ~gamma01 ~gamma0 with | Fail err -> valid := false; Subst_error (err, gamma, rho, y, delta, sigma, ppsi, delta') | Ok gamma1 -> let pphi = map_context annot gamma'_pphi in Subst_closure_notin(der, gamma0, gamma1, rho, y, delta, ppsi, delta', pphi, sigma1_phi, x, sigma2) end else begin let delta_gamma1 = delta in let dercontext = compute_subst_context valid gamma y rho ppsi delta_gamma1 in let delta'_gamma1' = output_of_subst_context dercontext in let delta_pphi', rho_chi, gamma_pphi = split_context y ann_context in let gamma = map_context no_annot gamma_pphi in let rho, chi = rho_chi in let delta = map_context no_annot delta_pphi' in try let gamma1 = remove_context_prefix_exn ~gamma01:delta_gamma1 ~gamma0:delta in let sigma1 = no_annot sigma1_phi in let dersigma1 = compute_subst_ty valid gamma y rho ppsi delta sigma1 in let delta', sigma1' = output_of_subst_ty dersigma1 in if sigma1' <> sigma1 then raise (Error Subst_function_argument_scope_escape); let gamma1' = remove_context_prefix_exn ~gamma01:delta'_gamma1' ~gamma0:delta' in let derbody = compute_subst_ty valid gamma y rho ppsi ((x,sigma1)::delta) sigma2 in match output_of_subst_ty derbody with | ([], _tau2) -> assert false (* the annotation has the same length as the input context which is non-empty here *) | ((x',sigma1'')::delta'', tau2) -> assert (x = x'); assert (sigma1'' = sigma1'); assert (delta'' = delta'); Subst_closure (dercontext, gamma_pphi, rho_chi, y, delta_pphi', gamma1, ppsi, delta', gamma1', dersigma1, sigma1_phi, x, derbody, sigma2, tau2) with Error err -> valid := false; Subst_error (err, gamma, rho, y, delta, sigma, ppsi, delta'_gamma1') end end and compute_subst_context valid gamma y rho ppsi delta = pre (fun () -> assert (domain gamma = domain ppsi); ); post (fun der -> let (gamma_, rho_, y_, delta_, ppsi_, delta') = judgment_subst_context der in assert (gamma = gamma_); assert (rho = rho_); assert (y = y_); assert (delta = delta_); assert (ppsi = ppsi_); assert (domain delta = domain delta'); ) begin match delta with | [] -> Subst_context_nil (gamma, rho, y, ppsi) | ((x,sigma) :: delta) -> let der = compute_subst_ty valid gamma y rho ppsi delta sigma in let delta', tau = output_of_subst_ty der in Subst_context (der, gamma, rho, y, delta, sigma, x, ppsi, delta', tau) end let () = let (gamma_pphi, e, ty) = paper_example in let gamma = map_context no_annot gamma_pphi in let pphi = map_context annot gamma_pphi in let valid = ref true in let der = infer_ty valid gamma e in assert !valid; assert ((pphi, ty) = output_of_ty der); ignore der type judgment_ty_value = ty context * value * ty type judgment_subst_value = value * var * value * value type der_ty_value = | Value_error of ty context * value | Value_atomic of der_scope_context * value_atom (* Γ ⊢ —————————— Γ ⊢ vα : α *) | Value_product of ty context * der_ty_value * value * ty * der_ty_value * value * ty (* Γ ⊢ v₁ : τ₁ Γ ⊢ v₂ : τ₂ ————————————————————————— Γ ⊢ (v₁,v₂) : τ₁ * τ₂ *) | Value_closure of (*der,Γ^Φ,Γ₁*) der_scope_context * ann_ty context * ty context (*(xi:τi^ψi),(deri,vi,τi)*)* ann_ty context * (der_ty * value * ty) context (*der,σ^φ,x,t,τ*) * der_ty * ann_ty * var * exp * ty (*deri,Φ',τ'*) * der_subst_ty context * ann_ty context * ty (* Γ,Γ₁ ⊢ ∀i∈I, Γ,(xj:τj){j Γ^Φ',x:σ^φ ⊢ τ' ——————————————————————————————————————————————————————————— Γ,Γ₁ ⊢ (dom Γ, (xi ↦ vi){i∈I}, λx.t) : [Γ^Φ'](x:σ^φ) → τ' *) type der_subst_value = | Subst_value_error of (* v,y,w *) error * value * var * value | Subst_value_atom of value * var * atom * value_atom (* vα ~(y\v)~> vα *) | Subst_value_product of value * var * der_subst_value * value * value * der_subst_value * value * value (* w₁ ~(y\v)~> w'₁ w₂ ~(y\v)~> w'₂ ————————————————————————————————— (w₁,w₂) ~(y\v)~> (w'₁,w'₂) *) | Subst_value_closure_notin of value * var * var list * value context * var * exp (* y ∉ [xj]{j∈J} —————————————————————————————————————————————————————————————— ([xj]{j∈J}, (xi↦wi){i∈I}, λx.t) ~(y\v)~> ([xj], (xi↦wi), λx.t) *) | Subst_value_closure of value * var * var list * value context * var * exp (* ([x0,̣...,xN,y], (xi↦wi), λx.t) ~(y\v)~> ([x0,...,xN], (y↦v)(xi↦wi), λx.t) *) let judgment_subst_value = function | Subst_value_error (error, v, y, w) -> (w, y, w, VError) | Subst_value_atom (v, y, atom, value_atom) -> let w = VAtom (atom, value_atom) in (w, y, v, w) | Subst_value_product (v, y, der1, w1, w'1, der2, w2, w'2) -> (VPair (w1, w2), y, v, VPair (w'1, w'2)) | Subst_value_closure (v, y, free_vars, captured_vars, x, t) -> (VClosure (free_vars, captured_vars, x, t), y, v, VClosure (free_vars, (y,v)::captured_vars, x, t)) | Subst_value_closure_notin (v, y, free_vars, captured_vars, x, t) -> let w = VClosure (free_vars, captured_vars, x, t) in (w, y, v, w) let output_subst_value der = let (_v, _y, _w, v') = judgment_subst_value der in v' let rec compute_subst_value valid w y v = try match w with | VError -> raise (Error Subst_on_error) | VAtom (atom, value_atom) -> Subst_value_atom (v, y, atom, value_atom) | VPair (w1, w2) -> let der1 = compute_subst_value valid w1 y v in let w'1 = output_subst_value der1 in let der2 = compute_subst_value valid w2 y v in let w'2 = output_subst_value der2 in Subst_value_product (v, y, der1, w1, w'1, der2, w2, w'2) | VClosure (free_vars, captured_vars, x, t) -> match free_vars with | y'::free_vars when y' = y -> Subst_value_closure (v, y, free_vars, captured_vars, x, t) | _ -> if List.mem y free_vars then raise (Error Subst_nontop_variable); Subst_value_closure_notin (v, y, free_vars, captured_vars, x, t) with Error err -> valid := false; Subst_value_error (err, v, y, w) type judgment_red = value context * exp * value type der_red = | Red_error of error * value context * exp | Red_var of value context * var (* V ⊢ x => V(x) *) | Red_lam of value context * var * ty * exp (* V ⊢ λ(x:σ)t => (dom V, ∅, λx.t) *) | Red_pair of value context * der_red * exp * value * der_red * exp * value (* V ⊢ e₁ => v₁ V ⊢ e₂ => v₂ ——————————————————————————— V ⊢ (e₁,e₂) => (v₁,v₂) *) | Red_proj of bool * value context * der_red * exp * value * value (* V ⊢ e => (v₁,v₂) ———————————————— V ⊢ πi(e) => vi *) | Red_let of value context * der_red * exp * value * der_red * var * exp * value * der_subst_value * value (* V ⊢ e₁ => v₁ V,(x↦v₁) ⊢ e₂ => v₂ v₂ ~(x\v₁)~> v'₂ ——————————————————————————————————————————————————— V ⊢ let x = e₁ in e₂ => v'₂ *) | Red_app of value context * der_red * exp * var list * value context * var * exp * der_red * exp * value * value * der_subst_value * der_subst_value context * value (* V,V₁ ⊢ t => (dom V, V₂, λy.t') V,V₁ ⊢ u => varg V,V₁,V₂,(y↦varg) ⊢ t' => w w ~(y/varg)~(V₂)~> w' ——————————————————————————————————————————————————— V,V₁ ⊢ t u => w' *) let judgment_red = function | Red_error (error, vv, e) -> (vv, e, VError) | Red_var (vv, x) -> (vv, Var x, List.assoc x vv) | Red_lam (vv, x, sigma, t) -> (vv, Lam (x, sigma, t), VClosure (domain vv, [], x, t)) | Red_pair (vv, _der1, e1, v1, _der2, e2, v2) -> (vv, Pair (e1, e2), VPair (v1, v2)) | Red_proj (left_or_right, vv, _der, e, v1, v2) -> (vv, e, (if left_or_right then v1 else v2)) | Red_let (vv, der1, e1, v1, der2, x, e2, v2, dersubst, v'2) -> (vv, Let (x, e1, e2), v'2) | Red_app (vv, derclos, t, free_vars, captured_vars, y, t', derarg, u, varg, w, derarg_subst, dercont_subst, w') -> (vv, App (t, u), w') let output_red der = let (_vv, _e, v) = judgment_red der in v let rec compute_red valid vv exp = try match exp with | Var x -> if not (List.mem_assoc x vv) then raise (Error Red_missing_variable); Red_var (vv, x) | Lam (x, sigma, t) -> Red_lam (vv, x, sigma, t) | Pair (e1, e2) -> let der1 = compute_red valid vv e1 in let v1 = output_red der1 in let der2 = compute_red valid vv e2 in let v2 = output_red der2 in Red_pair (vv, der1, e1, v1, der2, e2, v2) | Proj (left_or_right, e) -> let der = compute_red valid vv e in begin match output_red der with | VError _ | VAtom _ | VClosure _ -> raise (Error Red_Proj_expected_a_tuple) | VPair (v1, v2) -> Red_proj (left_or_right, vv, der, e, v1, v2) end | Let (x, e1, e2) -> let der1 = compute_red valid vv e1 in let v1 = output_red der1 in let der2 = compute_red valid ((x,v1)::vv) e2 in let v2 = output_red der2 in let dersubst = compute_subst_value valid v2 x v1 in let v'2 = output_subst_value dersubst in Red_let (vv, der1, e1, v1, der2, x, e2, v2, dersubst, v'2) | App (t, u) -> let derclos = compute_red valid vv t in let derarg = compute_red valid vv u in let varg = output_red derarg in begin match output_red derclos with | VError _ | VAtom _ | VPair _ -> raise (Error Red_App_expected_a_function) | VClosure (free_vars, captured_vars, y, t') -> let app_context = (y,varg) :: captured_vars in let derbody = compute_red valid (app_context @ vv) t' in let w = output_red derbody in let derarg_subst = compute_subst_value valid w y varg in let w0 = output_subst_value derarg_subst in let (w', dercont_subst) = let do_subst (xi, vi) (wi, acc) = let der = compute_subst_value valid wi xi vi in let wip1 = output_subst_value der in (wip1, (xi,der)::acc) in List.fold_right do_subst captured_vars (w0, []) in Red_app (vv, derclos, t, free_vars, captured_vars, y, t', derarg, u, varg, w, derarg_subst, dercont_subst, w') end with Error err -> valid := false; Red_error (err, vv, exp) let compute_paper_example = (* y:σ¹, z:τ⁰ ⊢ (y, λ(x:ρ).z) : σ * [y:σ⁰, z:τ¹](x:ρ⁰) → τ *) let (gamma_pphi, e, ty) = paper_example in match gamma_pphi with | [(z, (Atom az, _)); (y, (Atom ay, _))] -> let vv = [(z, VAtom(az, "vz")); (y, VAtom(ay, "vy"))] in let valid = ref true in let result = compute_red valid vv e in assert !valid; result | _ -> assert false let free_vars exp = let module VSet = Set.Make(Var) in let rec fv = function | Var v -> VSet.singleton v | Pair (e1, e2) -> VSet.union (fv e1) (fv e2) | Proj (b, e) -> fv e | Lam (x, _sigma, e) -> VSet.remove x (fv e) | App (t, u) -> VSet.union (fv t) (fv u) | Let (x, e1, e2) -> VSet.union (fv e1) (VSet.remove x (fv e2)) in VSet.elements (fv exp) let default_env exp = (* we want the (reversed) context in alphabetic order *) let domain = List.rev (free_vars exp) in let open Printf in let atom v = Const (sprintf "ty_%a" (fun () -> Var.to_string) v) in let ty v = Atom (atom v) in let value v = VAtom (atom v, sprintf "val_%a" (fun () -> Var.to_string) v) in let gamma = List.map (fun v -> (v, ty v)) domain in let vv = List.map (fun v -> (v, value v)) domain in gamma, vv let global_venv = ref Var.empty_env