Replace hardcoded universe levels with a proper level language and constraint solving

BidirTT/Level.lean

@@ -0,0 +1,52 @@
+namespace BidirTT
+
+inductive Level where
+  | zero : Level
+  | succ : Level → Level
+  | max  : Level → Level → Level
+  deriving Repr, Inhabited, BEq, DecidableEq
+
+def Level.ofNat : Nat → Level
+  | 0 => .zero
+  | n + 1 => .succ (Level.ofNat n)
+
+instance (n : Nat) : OfNat Level n where
+  ofNat := Level.ofNat n
+
+partial def Level.eval : Level → Nat
+  | .zero => 0
+  | .succ l => l.eval + 1
+  | .max l r => Nat.max l.eval r.eval
+
+def Level.normalise (l : Level) : Level :=
+  .ofNat l.eval
+
+def Level.succ' (l : Level) : Level :=
+  .normalise (.succ l)
+
+def Level.max' (l r : Level) : Level :=
+  .normalise (.max l r)
+
+def Level.pretty (l : Level) : String :=
+  s!"{l.eval}"
+
+abbrev LevelConstraint := Level × Level
+
+def solveLevelConstraints (constraints : List LevelConstraint) : Except String Unit := do
+  match constraints.find? fun (lhs, rhs) => lhs.eval > rhs.eval with
+  | some (lhs, rhs) =>
+      throw s!"unsatisfiable level constraint {lhs.pretty} <= {rhs.pretty}"
+  | none =>
+      pure ()
+
+def Level.leq (lhs rhs : Level) : Except String Bool := do
+  match solveLevelConstraints [(lhs, rhs)] with
+  | Except.ok _ => pure true
+  | Except.error _ => pure false
+
+def Level.eqv (lhs rhs : Level) : Except String Bool := do
+  match solveLevelConstraints [(lhs, rhs), (rhs, lhs)] with
+  | Except.ok _ => pure true
+  | Except.error _ => pure false
+
+end BidirTT