Initial zoo with bidirectional impl

.envrc

@@ -0,0 +1 @@
+use flake

.gitignore

@@ -0,0 +1,4 @@
+/_build
+/.direnv
+/.vscode
+/node_modules

LICENSE.txt

@@ -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?

README.md

@@ -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)

bidirectional/bidirectional.ml

@@ -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")

bidirectional/dune

@@ -0,0 +1,3 @@
+(executable
+ (name bidirectional)
+ (public_name bidirectional))

dune-project

@@ -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)))

flake.lock

@@ -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
+}

flake.nix

@@ -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
+              ;
+          };
+        };
+      };
+    };
+}