Initial zoo with bidirectional impl
commit
47c9ad1666
|
|
@ -0,0 +1,4 @@
|
||||||
|
/_build
|
||||||
|
/.direnv
|
||||||
|
/.vscode
|
||||||
|
/node_modules
|
||||||
|
|
@ -0,0 +1,44 @@
|
||||||
|
STEAL THIS LICENSE
|
||||||
|
|
||||||
|
Copyright 2022 mat ess. All rights reserved.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
This is not a valid license file, this is simply a note to thieves.
|
||||||
|
|
||||||
|
You can probably get away with stealing this work.
|
||||||
|
|
||||||
|
1. I am unlikely to find out. Who the utter fuck has time to spend all day
|
||||||
|
scanning the net to find copyright infractions. Hell, you might not even
|
||||||
|
publish it on the net in the first place. That just sounds boring as fuck.
|
||||||
|
I have better things to do like touching some fucking grass or hugging cute
|
||||||
|
people.
|
||||||
|
|
||||||
|
2. Thanks to Late Stage Capitalism™, I am unlikely to have the means for a
|
||||||
|
lengthy and drawn out court battle, you could easily win that through
|
||||||
|
attrition. I mean as I write this note I’m effectively homeless and bed
|
||||||
|
surfing. Literally the last thing I care about right now is someone using
|
||||||
|
my shit.
|
||||||
|
|
||||||
|
3. You and I both know that since I wrote this, I probably do not give a
|
||||||
|
flying shit if you create derivatives from my work or not.
|
||||||
|
|
||||||
|
However, you also can’t trust that any of those things are true.
|
||||||
|
|
||||||
|
I could be lying to you.
|
||||||
|
|
||||||
|
We both know it’s probably morally good for you to build off my work, and
|
||||||
|
redistribute it as far as it can go, humans have been doing this since
|
||||||
|
before we figured out fire. Plagiarism is a lie we tell ourselves to try to
|
||||||
|
constrain and suppress entropy. We like to pretend someone in 200 years
|
||||||
|
will give a shit about something we wrote while hyperfocusing and probably
|
||||||
|
high as shit.
|
||||||
|
|
||||||
|
But maybe if you’re a fucking nazi or a piggy or a xenophobic snitch, I
|
||||||
|
actually do care and will prosecute you to the fullest extent of the law.
|
||||||
|
Maybe I change my mind one day. Or something else.
|
||||||
|
|
||||||
|
If you’re reading this file, you probably want to use my shit anyway,
|
||||||
|
right? You wanna build it, you wanna package it, you wanna build off it.
|
||||||
|
|
||||||
|
So will you obey the law? Or will you do what is morally correct?
|
||||||
|
|
@ -0,0 +1,5 @@
|
||||||
|
# lang zoo
|
||||||
|
|
||||||
|
- bidirectional
|
||||||
|
- implementation of ["Complete and Easy Bidirectional Typechecking
|
||||||
|
for Higher-Rank Polymorphism"](https://www.cl.cam.ac.uk/~nk480/bidir.pdf)
|
||||||
|
|
@ -0,0 +1,185 @@
|
||||||
|
module StringSet = Set.Make (String)
|
||||||
|
|
||||||
|
type name = string
|
||||||
|
|
||||||
|
type type' =
|
||||||
|
(* 1 *)
|
||||||
|
| Unit
|
||||||
|
(* x *)
|
||||||
|
| Variable of name
|
||||||
|
(* ^x *)
|
||||||
|
| Existential of name
|
||||||
|
(* forall a. A *)
|
||||||
|
| ForAll of name * type'
|
||||||
|
(* A -> B *)
|
||||||
|
| Function of type' * type'
|
||||||
|
|
||||||
|
let rec free_variables = function
|
||||||
|
| Unit -> StringSet.empty
|
||||||
|
| Variable x | Existential x -> StringSet.singleton x
|
||||||
|
| ForAll (alpha, a) -> StringSet.remove alpha (free_variables a)
|
||||||
|
| Function (a, b) -> StringSet.inter (free_variables a) (free_variables b)
|
||||||
|
|
||||||
|
let occurs_check name type' = free_variables type' |> StringSet.mem name |> not
|
||||||
|
|
||||||
|
let rec is_monotype = function
|
||||||
|
| Unit | Variable _ | Existential _ -> true
|
||||||
|
| ForAll _ -> false
|
||||||
|
| Function (a, b) -> is_monotype a && is_monotype b
|
||||||
|
|
||||||
|
let rec replace name with_type in_type =
|
||||||
|
match in_type with
|
||||||
|
| (Variable n | Existential n) when n = name -> with_type
|
||||||
|
| Variable _ | Existential _ | Unit -> in_type
|
||||||
|
| ForAll (alpha, _) when name = alpha -> in_type
|
||||||
|
| ForAll (alpha, a) -> ForAll (alpha, replace name with_type a)
|
||||||
|
| Function (a, b) ->
|
||||||
|
Function (replace name with_type a, replace name with_type b)
|
||||||
|
|
||||||
|
type term =
|
||||||
|
(* () *)
|
||||||
|
| Unit
|
||||||
|
(* x *)
|
||||||
|
| Variable of name
|
||||||
|
(* \x. e *)
|
||||||
|
| Lambda of name * term
|
||||||
|
(* f x *)
|
||||||
|
| Application of term * term
|
||||||
|
(* x : T *)
|
||||||
|
| Annotation of term * type'
|
||||||
|
|
||||||
|
type judgment =
|
||||||
|
(* universally quantified *)
|
||||||
|
| ForAll of name
|
||||||
|
| Assume of name * type'
|
||||||
|
(* existentially quantified *)
|
||||||
|
| Exists of name
|
||||||
|
| Solved of name * type'
|
||||||
|
(* marker *)
|
||||||
|
| Marker of name
|
||||||
|
|
||||||
|
type context = judgment list
|
||||||
|
|
||||||
|
let existentials =
|
||||||
|
List.fold_left
|
||||||
|
(fun vars j ->
|
||||||
|
match j with
|
||||||
|
| Exists n | Solved (n, _) ->
|
||||||
|
StringSet.singleton n |> StringSet.union vars
|
||||||
|
| _ -> vars)
|
||||||
|
StringSet.empty
|
||||||
|
|
||||||
|
let in_existentials name gamma = existentials gamma |> StringSet.mem name
|
||||||
|
|
||||||
|
exception TypeError of string
|
||||||
|
|
||||||
|
let lookup_name context name =
|
||||||
|
let find_name = function
|
||||||
|
| (ForAll n | Assume (n, _) | Exists n | Solved (n, _)) when n = name ->
|
||||||
|
true
|
||||||
|
| _ -> false
|
||||||
|
in
|
||||||
|
List.find find_name context
|
||||||
|
|
||||||
|
let rec drop_marker marker context =
|
||||||
|
match context with
|
||||||
|
| [] -> raise (TypeError "tried to drop missing marker")
|
||||||
|
| top :: rest when top = marker -> rest
|
||||||
|
| _ :: rest -> drop_marker marker rest
|
||||||
|
|
||||||
|
let solve name solution context =
|
||||||
|
let solve' = function
|
||||||
|
| Exists n when n = name -> Solved (n, solution)
|
||||||
|
| j -> j
|
||||||
|
in
|
||||||
|
List.map solve' context
|
||||||
|
|
||||||
|
let rec substitute gamma (a : type') =
|
||||||
|
match a with
|
||||||
|
| Unit | Variable _ -> a
|
||||||
|
| Existential alpha -> (
|
||||||
|
match lookup_name gamma alpha with
|
||||||
|
| Exists _ -> a
|
||||||
|
| Solved (_, tau) -> substitute gamma tau
|
||||||
|
| _ -> raise (TypeError "unbound existential"))
|
||||||
|
| Function (a, b) -> Function (substitute gamma a, substitute gamma b)
|
||||||
|
| ForAll (alpha, a) -> ForAll (alpha, substitute gamma a)
|
||||||
|
|
||||||
|
let mk_fresh_generator prefix =
|
||||||
|
let counter = ref 0 in
|
||||||
|
fun base ->
|
||||||
|
let output = prefix ^ base ^ string_of_int !counter in
|
||||||
|
counter := !counter + 1;
|
||||||
|
output
|
||||||
|
|
||||||
|
let fresh_variable = mk_fresh_generator "$"
|
||||||
|
let fresh_type_variable = mk_fresh_generator "'"
|
||||||
|
|
||||||
|
let rec instantiate_left alpha a gamma =
|
||||||
|
match a with
|
||||||
|
| _ when is_monotype a -> solve alpha a gamma
|
||||||
|
| Existential beta -> solve beta (Existential alpha) gamma
|
||||||
|
| Function (a1, a2) ->
|
||||||
|
let alpha_1 = fresh_type_variable alpha in
|
||||||
|
let alpha_2 = fresh_type_variable alpha in
|
||||||
|
let theta =
|
||||||
|
instantiate_right a1 alpha_1
|
||||||
|
(Solved (alpha, Function (Variable alpha_1, Variable alpha_2))
|
||||||
|
:: Exists alpha_1 :: Exists alpha_2 :: gamma)
|
||||||
|
in
|
||||||
|
instantiate_left alpha_2 (substitute theta a2) theta
|
||||||
|
| ForAll (beta, b) ->
|
||||||
|
let beta' = fresh_type_variable beta in
|
||||||
|
instantiate_left alpha b (ForAll beta' :: gamma)
|
||||||
|
|> drop_marker (ForAll beta')
|
||||||
|
| _ -> raise (TypeError "bad left instantiation")
|
||||||
|
|
||||||
|
and instantiate_right a alpha gamma =
|
||||||
|
match a with
|
||||||
|
| _ when is_monotype a -> solve alpha a gamma
|
||||||
|
| Existential beta -> solve beta (Existential alpha) gamma
|
||||||
|
| Function (a1, a2) ->
|
||||||
|
let alpha_1 = fresh_type_variable alpha in
|
||||||
|
let alpha_2 = fresh_type_variable alpha in
|
||||||
|
let theta =
|
||||||
|
instantiate_left alpha_1 a1
|
||||||
|
(Solved (alpha, Function (Variable alpha_1, Variable alpha_2))
|
||||||
|
:: Exists alpha_1 :: Exists alpha_2 :: gamma)
|
||||||
|
in
|
||||||
|
instantiate_right (substitute theta a2) alpha_2 theta
|
||||||
|
| ForAll (beta, b) ->
|
||||||
|
let beta' = fresh_type_variable beta in
|
||||||
|
instantiate_right b alpha (ForAll beta' :: gamma)
|
||||||
|
|> drop_marker (ForAll beta')
|
||||||
|
| _ -> raise (TypeError "bad right instantiation")
|
||||||
|
|
||||||
|
let rec subtype (a : type') (b : type') gamma =
|
||||||
|
match (a, b) with
|
||||||
|
| Variable a, Variable b when a = b -> gamma
|
||||||
|
| Unit, Unit -> gamma
|
||||||
|
| Existential a, Existential b when a = b && in_existentials a gamma -> gamma
|
||||||
|
| Function (a1, a2), Function (b1, b2) ->
|
||||||
|
let theta = subtype b1 a1 gamma in
|
||||||
|
subtype (substitute theta a2) (substitute theta b2) theta
|
||||||
|
| ForAll (alpha, a), _ ->
|
||||||
|
let alpha' = fresh_type_variable alpha in
|
||||||
|
let gamma = Exists alpha' :: Marker alpha' :: gamma in
|
||||||
|
let a' = replace alpha (Existential alpha') a in
|
||||||
|
subtype a' b gamma |> drop_marker (Marker alpha')
|
||||||
|
| _, ForAll (beta, b) ->
|
||||||
|
let beta' = fresh_type_variable beta in
|
||||||
|
let b' = replace beta (Variable beta') b in
|
||||||
|
subtype a b' (ForAll beta' :: gamma) |> drop_marker (ForAll beta')
|
||||||
|
| Existential alpha, _ when occurs_check alpha b ->
|
||||||
|
instantiate_left alpha b gamma
|
||||||
|
| _, Existential beta when occurs_check beta a ->
|
||||||
|
instantiate_right a beta gamma
|
||||||
|
| _ -> raise (TypeError "invalid subtype relation")
|
||||||
|
|
||||||
|
let rec check (e : term) (a : type') gamma =
|
||||||
|
match (e, a) with _ -> raise (TypeError "bad check")
|
||||||
|
|
||||||
|
and synth (e : term) gamma = match e with _ -> raise (TypeError "bad synth")
|
||||||
|
|
||||||
|
and apply (a : type') (e : term) gamma =
|
||||||
|
match (a, e) with _ -> raise (TypeError "bad apply")
|
||||||
|
|
@ -0,0 +1,3 @@
|
||||||
|
(executable
|
||||||
|
(name bidirectional)
|
||||||
|
(public_name bidirectional))
|
||||||
|
|
@ -0,0 +1,19 @@
|
||||||
|
(lang dune 3.6)
|
||||||
|
|
||||||
|
(name lang_zoo)
|
||||||
|
|
||||||
|
(source
|
||||||
|
(uri https://git.mat.services/mat/lang-zoo))
|
||||||
|
|
||||||
|
(authors "mat ess")
|
||||||
|
|
||||||
|
(maintainers "mat ess")
|
||||||
|
|
||||||
|
(license LICENSE.txt)
|
||||||
|
|
||||||
|
(package
|
||||||
|
(name lang_zoo)
|
||||||
|
(description "programming language experiments")
|
||||||
|
(depends ocaml dune)
|
||||||
|
(tags
|
||||||
|
(plt programming language experiment)))
|
||||||
|
|
@ -0,0 +1,101 @@
|
||||||
|
{
|
||||||
|
"nodes": {
|
||||||
|
"flake-parts": {
|
||||||
|
"inputs": {
|
||||||
|
"nixpkgs-lib": "nixpkgs-lib"
|
||||||
|
},
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1672616755,
|
||||||
|
"narHash": "sha256-dvwU2ORLpiP6ZMXL3CJ/qrqmtLBLF6VAc+Fois7Qfew=",
|
||||||
|
"owner": "hercules-ci",
|
||||||
|
"repo": "flake-parts",
|
||||||
|
"rev": "87673d7c13a799d95ce25ff5dc7b9e15f01af2ea",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "hercules-ci",
|
||||||
|
"repo": "flake-parts",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"flake-utils": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1667395993,
|
||||||
|
"narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "numtide",
|
||||||
|
"repo": "flake-utils",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"nixpkgs": {
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1672791794,
|
||||||
|
"narHash": "sha256-mqGPpGmwap0Wfsf3o2b6qHJW1w2kk/I6cGCGIU+3t6o=",
|
||||||
|
"owner": "NixOS",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"rev": "9813adc7f7c0edd738c6bdd8431439688bb0cb3d",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "NixOS",
|
||||||
|
"ref": "master",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"nixpkgs-lib": {
|
||||||
|
"locked": {
|
||||||
|
"dir": "lib",
|
||||||
|
"lastModified": 1672350804,
|
||||||
|
"narHash": "sha256-jo6zkiCabUBn3ObuKXHGqqORUMH27gYDIFFfLq5P4wg=",
|
||||||
|
"owner": "NixOS",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"rev": "677ed08a50931e38382dbef01cba08a8f7eac8f6",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"dir": "lib",
|
||||||
|
"owner": "NixOS",
|
||||||
|
"ref": "nixos-unstable",
|
||||||
|
"repo": "nixpkgs",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"ocaml": {
|
||||||
|
"inputs": {
|
||||||
|
"flake-utils": "flake-utils",
|
||||||
|
"nixpkgs": [
|
||||||
|
"nixpkgs"
|
||||||
|
]
|
||||||
|
},
|
||||||
|
"locked": {
|
||||||
|
"lastModified": 1672791669,
|
||||||
|
"narHash": "sha256-tlH9qTn6MedVq71GtExiRrGnWAFhkQNq2I6YvG87iaQ=",
|
||||||
|
"owner": "nix-ocaml",
|
||||||
|
"repo": "nix-overlays",
|
||||||
|
"rev": "34b689e9189e63bc6e093e6fccc690519e985a94",
|
||||||
|
"type": "github"
|
||||||
|
},
|
||||||
|
"original": {
|
||||||
|
"owner": "nix-ocaml",
|
||||||
|
"repo": "nix-overlays",
|
||||||
|
"type": "github"
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": {
|
||||||
|
"inputs": {
|
||||||
|
"flake-parts": "flake-parts",
|
||||||
|
"nixpkgs": "nixpkgs",
|
||||||
|
"ocaml": "ocaml"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
},
|
||||||
|
"root": "root",
|
||||||
|
"version": 7
|
||||||
|
}
|
||||||
|
|
@ -0,0 +1,53 @@
|
||||||
|
{
|
||||||
|
description = "language zoo";
|
||||||
|
|
||||||
|
inputs = {
|
||||||
|
nixpkgs.url = "github:NixOS/nixpkgs/master";
|
||||||
|
ocaml.url = "github:nix-ocaml/nix-overlays";
|
||||||
|
ocaml.inputs.nixpkgs.follows = "nixpkgs";
|
||||||
|
flake-parts.url = "github:hercules-ci/flake-parts";
|
||||||
|
};
|
||||||
|
|
||||||
|
outputs = inputs@{ self, flake-parts, nixpkgs, ocaml }:
|
||||||
|
let
|
||||||
|
ocamlModule = {
|
||||||
|
config.perSystem = { system, ... }: {
|
||||||
|
config._module.args.pkgs = import nixpkgs {
|
||||||
|
inherit system;
|
||||||
|
overlays = [
|
||||||
|
ocaml.overlays.${system}
|
||||||
|
(_: prev: {
|
||||||
|
ocaml = prev.ocaml-ng.ocamlPackages_latest.ocaml;
|
||||||
|
ocamlPackages = prev.ocaml-ng.ocamlPackages_latest;
|
||||||
|
})
|
||||||
|
];
|
||||||
|
};
|
||||||
|
};
|
||||||
|
};
|
||||||
|
in
|
||||||
|
flake-parts.lib.mkFlake { inherit inputs; } {
|
||||||
|
imports = [ ocamlModule ];
|
||||||
|
systems = [ "x86_64-linux" "aarch64-darwin" ];
|
||||||
|
perSystem = { config, self', inputs', pkgs, system, ... }: {
|
||||||
|
devShells.default = pkgs.mkShell {
|
||||||
|
nativeBuildInputs = builtins.attrValues {
|
||||||
|
inherit (pkgs.ocamlPackages)
|
||||||
|
dune
|
||||||
|
ocaml
|
||||||
|
;
|
||||||
|
};
|
||||||
|
buildInputs = builtins.attrValues {
|
||||||
|
inherit (pkgs.ocamlPackages)
|
||||||
|
dune
|
||||||
|
merlin
|
||||||
|
ocaml
|
||||||
|
ocaml-lsp
|
||||||
|
ocamlformat
|
||||||
|
ocamlformat-rpc-lib
|
||||||
|
utop
|
||||||
|
;
|
||||||
|
};
|
||||||
|
};
|
||||||
|
};
|
||||||
|
};
|
||||||
|
}
|
||||||
Loading…
Reference in New Issue