├── docs ├── dune ├── index.mld └── quickstart.mld ├── dune-project ├── CONTRIBUTORS.markdown ├── example ├── dune ├── Syntax.ml ├── ConcreteSyntax.ml ├── README.markdown ├── NbE.mli ├── Bidir.mli ├── ULvl.ml ├── Bidir.ml ├── Domain.ml └── NbE.ml ├── src ├── dune ├── Mugen.ml ├── Theory.mli ├── Mugen.mli ├── Builder.mli ├── StructuredType.ml ├── Syntax.ml ├── Builder.ml ├── Theory.ml ├── TheorySigs.ml ├── BuilderSigs.ml ├── Syntax.mli ├── ShiftWithJoin.ml ├── ShiftWithJoin.mli ├── Shift.mli └── Shift.ml ├── .github ├── dependabot.yaml └── workflows │ └── ocaml.yml ├── mugen.opam ├── CONTRIBUTING.markdown ├── .gitignore ├── README.markdown └── LICENSE /docs/dune: -------------------------------------------------------------------------------- 1 | (documentation 2 | (package mugen)) 3 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (formatting disabled) 3 | -------------------------------------------------------------------------------- /CONTRIBUTORS.markdown: -------------------------------------------------------------------------------- 1 | # CONTRIBUTORS 2 | 3 | - Favonia 4 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name Bidir) 3 | (libraries bwd mugen)) 4 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name Mugen) 3 | (public_name mugen)) 4 | -------------------------------------------------------------------------------- /example/Syntax.ml: -------------------------------------------------------------------------------- 1 | type ulvl = (ULvl.shift, t) Mugen.Syntax.endo 2 | 3 | and t = 4 | | Var of int 5 | | Univ of t 6 | | TpULvl 7 | | ULvl of ulvl 8 | -------------------------------------------------------------------------------- /.github/dependabot.yaml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "daily" 7 | -------------------------------------------------------------------------------- /example/ConcreteSyntax.ml: -------------------------------------------------------------------------------- 1 | (** The concrete syntax of a minimal language with only variables and universes. *) 2 | type t = 3 | | Var of int 4 | | Univ of t 5 | | TpULvl 6 | | Shift of t * int 7 | -------------------------------------------------------------------------------- /example/README.markdown: -------------------------------------------------------------------------------- 1 | # Example Use of ♾ mugen 2 | 3 | This directory contains an NbE-based bidirectional type checker for a minimal language with only variables, universes, and universe levels. 4 | -------------------------------------------------------------------------------- /src/Mugen.ml: -------------------------------------------------------------------------------- 1 | module Shift = Shift 2 | module ShiftWithJoin = ShiftWithJoin 3 | module Syntax = Syntax 4 | module Builder = Builder 5 | module Theory = Theory 6 | module StructuredType = StructuredType 7 | -------------------------------------------------------------------------------- /example/NbE.mli: -------------------------------------------------------------------------------- 1 | (** NbE-based conversion checker for bidirectional type checking. *) 2 | 3 | val eval : Domain.env -> Syntax.t -> Domain.t 4 | val quote : int -> Domain.t -> Syntax.t 5 | val equate : int -> Domain.t -> Domain.t -> unit 6 | val subtype : int -> Domain.t -> Domain.t -> unit 7 | -------------------------------------------------------------------------------- /src/Theory.mli: -------------------------------------------------------------------------------- 1 | (** Parameters of the theory. *) 2 | module type Param = TheorySigs.Param 3 | 4 | (** The signature of the theory. *) 5 | module type S = TheorySigs.S 6 | 7 | (** The implementation of the theory. *) 8 | module Make (P : Param) : S with type shift := P.Shift.t and type var := P.var 9 | -------------------------------------------------------------------------------- /docs/index.mld: -------------------------------------------------------------------------------- 1 | {0 mugen: Universe Levels} 2 | 3 | {1 Links} 4 | 5 | {ul 6 | {- {{!page:quickstart} 🔰 Quickstart tutorial}} 7 | {- {{!module:Mugen} 📔 API reference}}} 8 | 9 | {1 What is "mugen"?} 10 | 11 | "mugen" is the transliteration of "無限" in Japanese, possibly a learned borrowing of "無限" from Chinese. It literally means "without limits", and is widely used in anime for the obvious reason. It is fitting in the context of universe polymorphism. 12 | -------------------------------------------------------------------------------- /example/Bidir.mli: -------------------------------------------------------------------------------- 1 | type cell = {tm : Domain.t; tp : Domain.t} 2 | (** Cells in a typed context *) 3 | 4 | type ctx = cell Bwd.bwd 5 | (** Contexts for type checking *) 6 | 7 | val check : ctx -> ConcreteSyntax.t -> Domain.t -> Syntax.t 8 | (** [check ctx tm tp] checks the term [tm] against the type [tp] and returns the elaborated syntax. *) 9 | 10 | val infer : ctx -> ConcreteSyntax.t -> Syntax.t * Domain.t 11 | (** [infer ctx tm] takes a term [tm] and returns its elaborated syntax and inferred type. *) 12 | -------------------------------------------------------------------------------- /.github/workflows/ocaml.yml: -------------------------------------------------------------------------------- 1 | name: Build, test, and doc update 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | jobs: 8 | run: 9 | strategy: 10 | matrix: 11 | include: 12 | - ocaml-compiler: "4.14" 13 | - ocaml-compiler: "5.0" 14 | - ocaml-compiler: "5.2" 15 | with-doc: true 16 | runs-on: ubuntu-latest 17 | steps: 18 | - uses: actions/checkout@v4 19 | - uses: RedPRL/actions-ocaml@v2 20 | with: 21 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 22 | with-doc: ${{ matrix.with-doc }} 23 | publish-doc-if-built: ${{ github.ref == 'refs/heads/main' }} 24 | -------------------------------------------------------------------------------- /src/Mugen.mli: -------------------------------------------------------------------------------- 1 | (** {1 Gallery of Displacement Algebras} *) 2 | 3 | (** Stock displacement algebras *) 4 | module Shift : module type of Shift 5 | 6 | (** Stock displacement algebras with joins *) 7 | module ShiftWithJoin : module type of ShiftWithJoin 8 | 9 | (** {1 Syntax of Level Expressions} *) 10 | 11 | (** Definitions of level expressions *) 12 | module Syntax : module type of Syntax 13 | 14 | (** Smart constructors for level expressions *) 15 | module Builder : module type of Builder 16 | 17 | (** {1 Comparators of Level Expressions} *) 18 | 19 | (** Semantic comparators for free level expressions *) 20 | module Theory : module type of Theory 21 | 22 | (**/**) 23 | 24 | (** Structured types used in this library *) 25 | module StructuredType : module type of StructuredType 26 | -------------------------------------------------------------------------------- /example/ULvl.ml: -------------------------------------------------------------------------------- 1 | (** A convenience module for freely generated universe level expressions. *) 2 | 3 | module Param = 4 | struct 5 | (** Your chosen displacement algebra *) 6 | module Shift = Mugen.Shift.Int 7 | 8 | (** The representation of variables in free level expressions *) 9 | type var = int 10 | 11 | (** The equality checker for variables *) 12 | let equal_var : var -> var -> bool = Int.equal 13 | end 14 | include Param 15 | 16 | (** An alias of the type of displacements *) 17 | type shift = Shift.t 18 | 19 | (** An alias of the type of free level expressions *) 20 | type t = (shift, int) Mugen.Syntax.free 21 | 22 | (** Smart constructors for free level expressions *) 23 | include Mugen.Builder.Free.Make (Param) 24 | 25 | (** Comparators for free level expressions *) 26 | include Mugen.Theory.Make (Param) 27 | -------------------------------------------------------------------------------- /src/Builder.mli: -------------------------------------------------------------------------------- 1 | (** Semantic operations for {!type:Syntax.endo}. *) 2 | module Endo : 3 | sig 4 | 5 | (** Parameters of smart constructors. *) 6 | module type Param = BuilderSigs.Endo.Param 7 | 8 | (** The signature of smart constructors. *) 9 | module type S = BuilderSigs.Endo.S 10 | 11 | (** The implementation of smart constructors. *) 12 | module Make (P : Param) : S with type shift := P.Shift.t and type level := P.level 13 | end 14 | 15 | (** Semantic operations for {!type:Syntax.free}. *) 16 | module Free : 17 | sig 18 | 19 | (** Parameters of smart constructors. *) 20 | module type Param = BuilderSigs.Free.Param 21 | 22 | (** The signature of smart constructors. *) 23 | module type S = BuilderSigs.Free.S 24 | 25 | (** The implementation of smart constructors. *) 26 | module Make (P : Param) : S with type shift := P.Shift.t and type var := P.var 27 | end 28 | -------------------------------------------------------------------------------- /mugen.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "mugen" 3 | synopsis: "Universe levels and universe polymorphism" 4 | description: """ 5 | This package implements the generalization of Conor McBride’s crude but effective stratification. The theory behind the design is discussed in the POPL 2023 paper “An Order-Theoretic Analysis of Universe Polymorphism.” 6 | """ 7 | maintainer: "favonia " 8 | authors: "The RedPRL Development Team" 9 | license: "Apache-2.0 WITH LLVM-exception" 10 | homepage: "https://github.com/RedPRL/mugen" 11 | bug-reports: "https://github.com/RedPRL/mugen/issues" 12 | dev-repo: "git+https://github.com/RedPRL/mugen.git" 13 | depends: [ 14 | "dune" {>= "2.0"} 15 | "ocaml" {>= "4.13"} 16 | "bwd" {>= "2.1" & with-test} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "build" "-p" name "-j" jobs] 21 | ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} 22 | ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} 23 | ] 24 | -------------------------------------------------------------------------------- /src/StructuredType.ml: -------------------------------------------------------------------------------- 1 | module type EqualityType = 2 | sig 3 | (** The type. *) 4 | type t 5 | 6 | (** [equal x y] checks whether [x] and [y] are equivalent. *) 7 | val equal : t -> t -> bool 8 | 9 | (** Ugly printer. *) 10 | val dump : Format.formatter -> t -> unit 11 | end 12 | 13 | module type PartiallyOrderedType = 14 | sig 15 | (** @closed *) 16 | include EqualityType 17 | 18 | (** [lt x y] checks if [x] is strictly less than [y]. Note that trichotomy fails for general partial orders. *) 19 | val lt : t -> t -> bool 20 | 21 | (** [leq x y] checks if [x] is less than or equal to [y]. Note that trichotomy fails for general partial orders. *) 22 | val leq : t -> t -> bool 23 | end 24 | 25 | module type PartiallyOrderedTypeWithRightAction = 26 | sig 27 | (** @closed *) 28 | include PartiallyOrderedType 29 | 30 | (** the underlying type of an algebra *) 31 | type act 32 | 33 | (** the right action *) 34 | val act : t -> act -> t 35 | end 36 | -------------------------------------------------------------------------------- /example/Bidir.ml: -------------------------------------------------------------------------------- 1 | open Bwd 2 | 3 | module CS = ConcreteSyntax 4 | 5 | type cell = {tm : Domain.t; tp : Domain.t} 6 | type ctx = cell bwd 7 | 8 | let to_env ctx = Bwd.map (fun {tm; _} -> tm) ctx 9 | let to_size ctx = Bwd.length ctx 10 | 11 | let shift s = ULvl.Shift.of_int s 12 | 13 | (** Type checking. *) 14 | let rec check ctx (tm : CS.t) (tp : Domain.t) = 15 | match tm, tp with 16 | | CS.Univ l1, Univ l2 -> 17 | let l1 = check ctx l1 TpULvl in 18 | assert (ULvl.lt (Domain.to_ulvl (NbE.eval (to_env ctx) l1)) (Domain.to_ulvl l2)); 19 | Univ l1 20 | | CS.TpULvl, Univ (ULvl Top) -> TpULvl 21 | | CS.Shift (l, s), TpULvl -> 22 | let l = check ctx l TpULvl in 23 | ULvl (Shifted (l, shift s)) 24 | | _ -> 25 | let tm, tp' = infer ctx tm in 26 | NbE.subtype (to_size ctx) tp' tp; 27 | tm 28 | 29 | (** Type inference. *) 30 | and infer ctx = 31 | function 32 | | CS.Var i -> 33 | let {tm; tp} = Bwd.nth ctx i in 34 | NbE.quote (to_size ctx) tm, tp 35 | | _ -> failwith "not inferable" 36 | -------------------------------------------------------------------------------- /src/Syntax.ml: -------------------------------------------------------------------------------- 1 | type ('s, 'a) endo = 2 | | Shifted of 'a * 's 3 | | Top 4 | 5 | type ('s, 'v) free = 6 | | Level of ('s, ('s, 'v) free) endo 7 | | Var of 'v 8 | 9 | module Endo = 10 | struct 11 | type ('s, 'a) t = ('s, 'a) endo = 12 | | Shifted of 'a * 's 13 | | Top 14 | 15 | let shifted l s = Shifted (l, s) 16 | let top = Top 17 | 18 | let dump dump_s dump_a fmt = 19 | function 20 | | Shifted (base, shift) -> 21 | Format.fprintf fmt "@[<2>Shifted@ @[@[<1>(%a@],@, @[%a@])@]@]" dump_a base dump_s shift 22 | | Top -> 23 | Format.pp_print_string fmt "Top" 24 | end 25 | 26 | module Free = 27 | struct 28 | type ('s, 'v) t = ('s, 'v) free = 29 | | Level of ('s, ('s, 'v) free) endo 30 | | Var of 'v 31 | 32 | let shifted l s = Level (Shifted (l, s)) 33 | 34 | let top = Level Top 35 | 36 | let var v = Var v 37 | 38 | let rec dump dump_s dump_v fmt = 39 | function 40 | | Level ulevel -> Endo.dump dump_s (dump dump_s dump_v) fmt ulevel 41 | | Var v -> dump_v fmt v 42 | end 43 | -------------------------------------------------------------------------------- /CONTRIBUTING.markdown: -------------------------------------------------------------------------------- 1 | # Copyright Assignment 2 | 3 | Thank you for your contribution. Here is some important legal stuff. 4 | 5 | By submitting a pull request for this project, unless explicitly stated otherwise, you agree to assign your copyright of the contribution to **The RedPRL Development Team** when it is accepted (merged with or without minor changes). You assert that you have full power to assign the copyright, and that any copyright owned by or shared with a third party has been clearly marked with appropriate copyright notices. If you are employed, please check with your employer about the ownership of your contribution. 6 | 7 | This would allow us to, for example, change the license of the codebase to [Mozilla Public License (MPL) 2.0](https://www.mozilla.org/en-US/MPL/2.0/FAQ/) or transfer the ownership of the project to someone else *without your further consent*. We demand this assignment so that we do not have to ask *everyone* who has ever contributed for these activities. This requires trust, and if you feel uncomfortable about this assignment, please make an explicit note. 8 | -------------------------------------------------------------------------------- /src/Builder.ml: -------------------------------------------------------------------------------- 1 | module Endo = 2 | struct 3 | include BuilderSigs.Endo 4 | 5 | module Make (P : Param) : S with type shift := P.Shift.t and type level := P.level = 6 | struct 7 | include P 8 | open Syntax.Endo 9 | 10 | let top = level Top 11 | 12 | let shifted l s = 13 | match unlevel l with 14 | | Some Top -> invalid_arg "cannot shift the top level" 15 | | Some (Shifted (l, s')) -> 16 | let s = Shift.compose s' s in 17 | level @@ Shifted (l, s) 18 | | None -> 19 | level @@ Shifted (l, s) 20 | end 21 | end 22 | 23 | module Free = 24 | struct 25 | include BuilderSigs.Free 26 | 27 | module Make (P : Param) : S with type shift := P.Shift.t and type var := P.var = 28 | struct 29 | open Syntax.Free 30 | 31 | let var = var 32 | module P = struct 33 | include P 34 | type level = (Shift.t, var) Syntax.free 35 | let level t = Level t 36 | let unlevel t = match t with Level l -> Some l | _ -> None 37 | end 38 | 39 | include P 40 | include Endo.Make(P) 41 | end 42 | end 43 | -------------------------------------------------------------------------------- /example/Domain.ml: -------------------------------------------------------------------------------- 1 | open Bwd 2 | 3 | type env = t bwd 4 | 5 | (** Use [endo] to embed universe levels into your datatype. *) 6 | and ulvl = (ULvl.shift, t) Mugen.Syntax.endo 7 | 8 | (** The (NbE) domain. *) 9 | and t = 10 | | Var of int 11 | | Univ of t 12 | | TpULvl 13 | | ULvl of ulvl 14 | 15 | (** Conversion from the domain to free universe level expressions *) 16 | let rec to_ulvl : t -> ULvl.t = 17 | function 18 | | Var i -> Mugen.Syntax.Var i 19 | | ULvl endo -> endo_to_ulvl endo 20 | | _ -> invalid_arg "to_ulvl" 21 | 22 | and endo_to_ulvl : ulvl -> ULvl.t = 23 | let module M = Mugen.Syntax in 24 | function 25 | | M.Shifted (l, s) -> ULvl.shifted (to_ulvl l) s 26 | | M.Top -> ULvl.top 27 | 28 | (** Include smart constructors for universe levels *) 29 | include 30 | Mugen.Builder.Endo.Make 31 | (struct 32 | (** Your chosen displacement algebra *) 33 | module Shift = ULvl.Shift 34 | 35 | (** The type of embedded level expressions *) 36 | type level = t 37 | 38 | (** A function to embed a level expression *) 39 | let level (l : ulvl) : t = ULvl l 40 | 41 | (** A function to check whether an expression is an embedded level expression *) 42 | let unlevel : t -> ulvl option = function ULvl l -> Some l | _ -> None 43 | end) 44 | -------------------------------------------------------------------------------- /example/NbE.ml: -------------------------------------------------------------------------------- 1 | open Bwd 2 | 3 | let rec eval_ulvl env = 4 | let module M = Mugen.Syntax in 5 | function 6 | | M.Top -> Domain.top 7 | | M.Shifted (b, s) -> Domain.shifted (eval env b) s 8 | 9 | and eval env : Syntax.t -> Domain.t = 10 | function 11 | | Var i -> Bwd.nth env i 12 | | Univ l -> Univ (eval env l) 13 | | TpULvl -> TpULvl 14 | | ULvl l -> eval_ulvl env l 15 | 16 | let rec quote_ulvl ctx : _ Mugen.Syntax.endo -> _ Mugen.Syntax.endo = 17 | function 18 | | Top -> Top 19 | | Shifted (b, s) -> Shifted (quote ctx b, s) 20 | 21 | and quote ctx : Domain.t -> Syntax.t = 22 | function 23 | | Var i -> Var ((ctx-1) - i) 24 | | Univ l -> Univ (quote ctx l) 25 | | TpULvl -> TpULvl 26 | | ULvl l -> ULvl (quote_ulvl ctx l) 27 | 28 | let equate_ulvl l1 l2 = 29 | assert (ULvl.equal (Domain.endo_to_ulvl l1) (Domain.endo_to_ulvl l2)) 30 | 31 | let rec equate ctx (v1 : Domain.t) (v2 : Domain.t) = 32 | match v1, v2 with 33 | | Var i1, Var i2 -> 34 | assert (Int.equal i1 i2) 35 | | Univ l1, Univ l2 -> 36 | equate ctx l1 l2 37 | | TpULvl, TpULvl -> 38 | () 39 | | ULvl l1, ULvl l2 -> 40 | equate_ulvl l1 l2 41 | | _ -> 42 | failwith "equate" 43 | 44 | let subtype _ctx (v1 : Domain.t) (v2 : Domain.t) = 45 | match v1, v2 with 46 | | Var i1, Var i2 -> 47 | assert (Int.equal i1 i2) 48 | | Univ l1, Univ l2 -> 49 | assert (ULvl.leq (Domain.to_ulvl l1) (Domain.to_ulvl l2)) 50 | | TpULvl, TpULvl -> 51 | () 52 | | ULvl l1, ULvl l2 -> 53 | equate_ulvl l1 l2 54 | | _ -> 55 | failwith "subtype" 56 | -------------------------------------------------------------------------------- /src/Theory.ml: -------------------------------------------------------------------------------- 1 | include TheorySigs 2 | 3 | module Make (P : Param) : S with type shift := P.Shift.t and type var := P.var = 4 | struct 5 | open Syntax.Free 6 | 7 | include P 8 | include Builder.Free.Make(P) 9 | 10 | let normalize l = 11 | let rec go l acc = 12 | match l with 13 | | Level Top -> 14 | if acc = [] 15 | then Level Top 16 | else invalid_arg "cannot shift the top level" 17 | | Level (Shifted (l, s)) -> go l (s :: acc) 18 | | Var v -> Level (Shifted (Var v, List.fold_left Shift.compose Shift.id acc)) 19 | in 20 | go l [] 21 | 22 | let equal x y = 23 | match normalize x, normalize y with 24 | | Level Top, Level Top -> true 25 | | Level (Shifted (Var vx, sx)), Level (Shifted (Var vy, sy)) -> 26 | equal_var vx vy && Shift.equal sx sy 27 | | _ -> false 28 | 29 | let lt x y = 30 | match normalize x, normalize y with 31 | | Level (Shifted (Var _, _)), Level Top -> true 32 | | Level (Shifted (Var vx, sx)), Level (Shifted (Var vy, sy)) -> 33 | equal_var vx vy && Shift.lt sx sy 34 | | _ -> false 35 | 36 | let leq x y = 37 | match normalize x, normalize y with 38 | | _, Level Top -> true 39 | | Level (Shifted (Var vx, sx)), Level (Shifted (Var vy, sy)) -> 40 | equal_var vx vy && Shift.leq sx sy 41 | | _ -> false 42 | 43 | let gt x y = lt y x 44 | let geq x y = leq y x 45 | 46 | module Infix = 47 | struct 48 | let (=) = equal 49 | let (<) = lt 50 | let (<=) = leq 51 | let (>) = gt 52 | let (>=) = geq 53 | end 54 | end 55 | -------------------------------------------------------------------------------- /src/TheorySigs.ml: -------------------------------------------------------------------------------- 1 | (** Parameters of smart constructors. *) 2 | module type Param = 3 | sig 4 | (** The displacement algebra. *) 5 | module Shift : Shift.S 6 | 7 | (** The type of level variables. *) 8 | type var 9 | 10 | (** [equal_var x y] checks whether two level variables [x] and [y] are the same. *) 11 | val equal_var : var -> var -> bool 12 | end 13 | 14 | (** The signature of smart constructors. *) 15 | module type S = 16 | sig 17 | (** The displacement algebra. *) 18 | type shift 19 | 20 | (** The type of level variables. *) 21 | type var 22 | 23 | (** The type of freely generated levels. *) 24 | type level = (shift, var) Syntax.free 25 | 26 | (** [equal l1 l2] checks whether [l1] and [l2] are the same universe level. 27 | 28 | @raise Invalid_argument When [l1] or [l2] is shifted top. *) 29 | val equal : level -> level -> bool 30 | 31 | (** [lt l1 l2] checks whether [l1] is strictly less than [l2]. Note that trichotomy fails for general universe levels. 32 | 33 | @raise Invalid_argument When [l1] or [l2] is shifted top. *) 34 | val lt : level -> level -> bool 35 | 36 | (** [leq l1 l2] checks whether [l1] is less than or equal to [l2]. Note that trichotomy fails for general universe levels. 37 | 38 | @raise Invalid_argument When [l1] or [l2] is shifted top. *) 39 | val leq : level -> level -> bool 40 | 41 | (** [gt l1 l2] is [lt l2 l1]. *) 42 | val gt : level -> level -> bool 43 | 44 | (** [geq l1 l2] is [leq l2 l1]. *) 45 | val geq : level -> level -> bool 46 | 47 | (** Infix notation. *) 48 | module Infix : 49 | sig 50 | (** Alias of {!val:equal}. *) 51 | val (=) : level -> level -> bool 52 | 53 | (** Alias of {!val:lt}. *) 54 | val (<) : level -> level -> bool 55 | 56 | (** Alias of {!val:leq}. *) 57 | val (<=) : level -> level -> bool 58 | 59 | (** Alias of {!val:gt}. *) 60 | val (>) : level -> level -> bool 61 | 62 | (** Alias of {!val:geq}. *) 63 | val (>=) : level -> level -> bool 64 | end 65 | end 66 | -------------------------------------------------------------------------------- /src/BuilderSigs.ml: -------------------------------------------------------------------------------- 1 | (** Smart constructors for {!type:Syntax.endo}. *) 2 | module Endo = 3 | struct 4 | 5 | (** Parameters of smart constructors. *) 6 | module type Param = 7 | sig 8 | (** The displacement algebra. *) 9 | module Shift : Shift.S 10 | 11 | (** The type that embeds level expressions. *) 12 | type level 13 | 14 | (** The embedding of level expressions into {!type:level}. *) 15 | val level : (Shift.t, level) Syntax.endo -> level 16 | 17 | (** Extract the embedded level, if any. *) 18 | val unlevel : level -> (Shift.t, level) Syntax.endo option 19 | end 20 | 21 | (** The signature of smart constructors. *) 22 | module type S = 23 | sig 24 | (** The displacement algebra. *) 25 | type shift 26 | 27 | (** The type that embeds levels. *) 28 | type level 29 | 30 | (** [shifted s l] is the smarter version of {!val:Syntax.Endo.shifted} that collapses multiple displacements, 31 | representing the level [l] shifted by the displacement [s]. 32 | 33 | @raise Invalid_argument When it (directly or indirectly) attempts to shift the top level. *) 34 | val shifted : level -> shift -> level 35 | 36 | (** [top] is {!val:Syntax.Endo.top}, the additional top level for convenience. *) 37 | val top : level 38 | end 39 | end 40 | 41 | (** Smart constructors for {!type:Syntax.free}. *) 42 | module Free = 43 | struct 44 | 45 | (** Parameters of smart constructors. *) 46 | module type Param = 47 | sig 48 | (** The displacement algebra. *) 49 | module Shift : Shift.S 50 | 51 | (** The type of level variables. *) 52 | type var 53 | end 54 | 55 | (** The signature of smart constructors. *) 56 | module type S = 57 | sig 58 | (** The displacement algebra. *) 59 | type shift 60 | 61 | (** The type of level variables. *) 62 | type var 63 | 64 | (** The type of freely generated levels. *) 65 | type level = (shift, var) Syntax.free 66 | 67 | (** [var] is {!val:Syntax.Free.var}, representing the variable level [v]. *) 68 | val var : var -> level 69 | 70 | include Endo.S with type shift := shift and type level := level 71 | end 72 | end 73 | -------------------------------------------------------------------------------- /src/Syntax.mli: -------------------------------------------------------------------------------- 1 | (** A family of polynomial endofunctors [('s, -) endo] indexed by the type of displacements ['s]. *) 2 | type ('s, 'a) endo = 3 | | Shifted of 'a * 's 4 | | Top 5 | 6 | (** The free monad [('s, -) free] on the endofunctor [('s, -) endo] indexed by the type of displacements ['s]. *) 7 | type ('s, 'v) free = 8 | | Level of ('s, ('s, 'v) free) endo 9 | | Var of 'v 10 | 11 | (** Stupid constructors for {!type:endo}. *) 12 | module Endo : 13 | sig 14 | (** A family of polynomial endofunctors [('s, -) t] indexed by the type of displacements ['s]. *) 15 | type ('s, 'a) t = ('s, 'a) endo = 16 | | Shifted of 'a * 's 17 | | Top 18 | 19 | (** [shifted l s] is [Shifted (l, s)], representing the level [l] shifted by the displacement [s]. *) 20 | val shifted : 'a -> 's -> ('s, 'a) t 21 | 22 | (** [top] is [Top], the additional top level for convenience. *) 23 | val top : ('s, 'a) t 24 | 25 | (** [dump dump_s dump_a] is the ugly printer for levels, where [dump_s] is the printer for displacements and [dump_a] is the printer for inner sub-expressions. *) 26 | val dump : 27 | (Format.formatter -> 's -> unit) -> 28 | (Format.formatter -> 'a -> unit) -> 29 | Format.formatter -> ('s, 'a) t -> unit 30 | end 31 | 32 | (** Stupid constructors for {!type:free}. *) 33 | module Free : 34 | sig 35 | (** The free monad [('s, -) t] on the endofunctor [('s, -) endo] indexed by the type of displacements ['s]. *) 36 | type ('s, 'v) t = ('s, 'v) free = 37 | | Level of ('s, ('s, 'v) free) endo 38 | | Var of 'v 39 | 40 | (** [shifted l s] is [Level (Shifted (l, s))], representing the level [l] shifted by the displacement [s]. *) 41 | val shifted : ('s, 'v) t -> 's -> ('s, 'v) t 42 | 43 | (** [top] is [Top], the additional top level for convenience. *) 44 | val top : ('s, 'v) t 45 | 46 | (** [var v] is [Var v], representing the variable level [v]. *) 47 | val var : 'v -> ('s, 'v) t 48 | 49 | (** [dump dump_s dump_v] is the ugly printer for levels, where [dump_s] is the printer for displacements and [dump_v] is the printer for variables. *) 50 | val dump : 51 | (Format.formatter -> 's -> unit) -> 52 | (Format.formatter -> 'v -> unit) -> 53 | Format.formatter -> ('s, 'v) t -> unit 54 | end 55 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | 3 | # -*- mode: gitignore; -*- 4 | *.install 5 | *~ 6 | \#*\# 7 | /.emacs.desktop 8 | /.emacs.desktop.lock 9 | *.elc 10 | auto-save-list 11 | tramp 12 | .\#* 13 | 14 | # Org-mode 15 | .org-id-locations 16 | *_archive 17 | 18 | # flymake-mode 19 | *_flymake.* 20 | 21 | # eshell files 22 | /eshell/history 23 | /eshell/lastdir 24 | 25 | # elpa packages 26 | /elpa/ 27 | 28 | # reftex files 29 | *.rel 30 | 31 | # AUCTeX auto folder 32 | auto/ 33 | 34 | # cask packages 35 | .cask/ 36 | dist/ 37 | 38 | # Flycheck 39 | flycheck_*.el 40 | 41 | # server auth directory 42 | /server/ 43 | 44 | # projectiles files 45 | .projectile 46 | 47 | # directory configuration 48 | .dir-locals.el 49 | 50 | 51 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/Linux.gitignore 52 | 53 | *~ 54 | 55 | # temporary files which can be created if a process still has a handle open of a deleted file 56 | .fuse_hidden* 57 | 58 | # KDE directory preferences 59 | .directory 60 | 61 | # Linux trash folder which might appear on any partition or disk 62 | .Trash-* 63 | 64 | # .nfs files are created when an open file is removed but is still being accessed 65 | .nfs* 66 | 67 | 68 | ### https://raw.github.com/github/gitignore/fad779220742a6d54ccfc0c1a0e5b3d820253de6/Global/macOS.gitignore 69 | 70 | # General 71 | .DS_Store 72 | .AppleDouble 73 | .LSOverride 74 | 75 | # Icon must end with two \r 76 | Icon 77 | 78 | 79 | # Thumbnails 80 | ._* 81 | 82 | # Files that might appear in the root of a volume 83 | .DocumentRevisions-V100 84 | .fseventsd 85 | .Spotlight-V100 86 | .TemporaryItems 87 | .Trashes 88 | .VolumeIcon.icns 89 | .com.apple.timemachine.donotpresent 90 | 91 | # Directories potentially created on remote AFP share 92 | .AppleDB 93 | .AppleDesktop 94 | Network Trash Folder 95 | Temporary Items 96 | .apdisk 97 | 98 | 99 | ### https://raw.githubusercontent.com/github/gitignore/main/OCaml.gitignore 100 | 101 | *.annot 102 | *.cmo 103 | *.cma 104 | *.cmi 105 | *.a 106 | *.o 107 | *.cmx 108 | *.cmxs 109 | *.cmxa 110 | 111 | # ocamlbuild working directory 112 | _build/ 113 | 114 | # ocamlbuild targets 115 | *.byte 116 | *.native 117 | 118 | # oasis generated files 119 | setup.data 120 | setup.log 121 | 122 | # Merlin configuring file for Vim and Emacs 123 | .merlin 124 | 125 | # Dune generated files 126 | *.install 127 | 128 | # Local OPAM switch 129 | _opam/ 130 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # ♾️ mugen 無限: Universe Levels 2 | 3 | An implementation of [Conor McBride’s crude but effective stratification](https://personal.cis.strath.ac.uk/conor.mcbride/Crude.pdf). Our POPL 2023 paper [“An Order-Theoretic Analysis of Universe Polymorphism”](https://favonia.org/files/mugen.pdf) explained the theory behind our design. 4 | 5 | ## Stability 6 | 7 | ⚠ The API is experimental and unstable. We will break things! 8 | 9 | ## Components 10 | 11 | - [Mugen.Shift](https://redprl.org/mugen/mugen/Mugen/Shift): example displacement algebras 12 | - [Mugen.ShiftWithJoin](https://redprl.org/mugen/mugen/Mugen/ShiftWithJoin): example displacement algebras with joins 13 | - [Mugen.Syntax](https://redprl.org/mugen/mugen/Mugen/Syntax): syntax of universe levels 14 | - [Mugen.Semantics](https://redprl.org/mugen/mugen/Mugen/Semantics): smart builders and comparators 15 | 16 | ## Philosophy and Beliefs in this Experiment 17 | 18 | 1. The distinguished level variable for top-level definitions should be explicit in the core language for clean semantics. (It can remain implicit in the surface language.) 19 | 2. One-variable universe polymorphism with cumulativity is enough. Typical ambiguity (as in Coq) and multi-variable universe polymorphism (as in Agda) are overkill. 20 | 3. It is convenient to have the top level for type checking. However, end users should not be allowed to write the top level, and shifting the top level is forbidden. 21 | 22 | ## Displacement Algebras 23 | 24 | In Conor McBride’s notes, it was noted that any class of strictly monotone operators on levels closed under identity and composition will work. We codified such a class as a displacement algebra. The classic displacement operators may be recovered by using the following module with non-negative numbers: 25 | 26 | - [Mugen.Shift.Int](https://redprl.org/mugen/mugen/Mugen/Shift/Int). 27 | 28 | ## How to Use It 29 | 30 | ### Installation 31 | 32 | You need OCaml 4.13 or later. Here is the fastest way to install the library with OPAM 2.1: 33 | 34 | ```sh 35 | opam pin mugen git+https://github.com/RedPRL/mugen 36 | ``` 37 | 38 | ### Example Code 39 | 40 | ```ocaml 41 | module I = Mugen.Shift.Int 42 | module M = Mugen.Syntax 43 | 44 | (* The type of universe levels, using integers as displacements and strings as variable names. *) 45 | type ulevel = (I.t, string) M.free 46 | 47 | (* The level representing "x + 10" *) 48 | let l : ulevel = M.Free.(shifted (var "x") (I.of_int 10)) 49 | ``` 50 | 51 | ### Documentation 52 | 53 | [Here is the API documentation.](https://redprl.org/mugen/mugen/Mugen) 54 | -------------------------------------------------------------------------------- /src/ShiftWithJoin.ml: -------------------------------------------------------------------------------- 1 | module type Semilattice = 2 | sig 3 | include Shift.S 4 | val join : t -> t -> t 5 | end 6 | 7 | module type BoundedSemilattice = 8 | sig 9 | include Semilattice 10 | val bot : t 11 | end 12 | 13 | module Nat = 14 | struct 15 | include Shift.Nat 16 | let bot = of_int 0 17 | let join x y = of_int (Stdlib.Int.max (to_int x) (to_int y)) 18 | end 19 | 20 | module Int = 21 | struct 22 | include Shift.Int 23 | let join x y = of_int (Int.max (to_int x) (to_int y)) 24 | end 25 | 26 | module NonPositive = 27 | struct 28 | include Shift.NonPositive 29 | let join x y = of_int (Stdlib.Int.max (to_int x) (to_int y)) 30 | end 31 | 32 | module Product (X : Semilattice) (Y : Semilattice) = 33 | struct 34 | include Shift.Product (X) (Y) 35 | 36 | let join s1 s2 = pair (X.join (fst s1) (fst s2)) (Y.join (snd s1) (snd s2)) 37 | end 38 | 39 | module Lexicographic (X : BoundedSemilattice) (Y : BoundedSemilattice) = 40 | struct 41 | include Shift.Lexicographic (X) (Y) 42 | 43 | let bot = pair X.bot Y.bot 44 | 45 | let join s1 s2 = 46 | let x = X.join (fst s1) (fst s2) in 47 | let y1 = if X.equal (fst s1) x then snd s1 else Y.bot 48 | and y2 = if X.equal (fst s2) x then snd s2 else Y.bot 49 | in 50 | pair x (Y.join y1 y2) 51 | end 52 | 53 | module NearlyConstant (Base : BoundedSemilattice) : 54 | sig 55 | include BoundedSemilattice 56 | val of_based_list : Base.t * Base.t list -> t 57 | val to_based_list : t -> Base.t * Base.t list 58 | end 59 | = 60 | struct 61 | include Shift.NearlyConstant (Base) 62 | 63 | (* [of_list] in [join] will do the normalization *) 64 | let rec join_based_list_ (b1, l1) (b2, l2) = 65 | match l1, l2 with 66 | | [], [] -> [] 67 | | l1, [] -> List.map (fun x1 -> Base.join x1 b2) l1 68 | | [], l2 -> List.map (fun x2 -> Base.join b1 x2) l2 69 | | x1::l1, x2::l2 -> Base.join x1 x2 :: join_based_list_ (b1, l1) (b2, l2) 70 | 71 | let join bl1 bl2 = 72 | let b1, l1 = to_based_list bl1 73 | and b2, l2 = to_based_list bl2 74 | in 75 | of_based_list (Base.join b1 b2, join_based_list_ (b1, l1) (b2, l2)) 76 | 77 | let bot = of_based_list (Base.bot, []) 78 | end 79 | 80 | module FiniteSupport (Base : Semilattice) : 81 | sig 82 | include Semilattice 83 | val of_list : Base.t list -> t 84 | val to_list : t -> Base.t list 85 | end 86 | = 87 | struct 88 | include Shift.FiniteSupport (Base) 89 | 90 | (* [of_list] in [join] will do the normalization *) 91 | let rec join_list l1 l2 = 92 | match l1, l2 with 93 | | [], [] -> [] 94 | | l, [] -> List.map (fun x -> Base.join x Base.id) l 95 | | [], l -> List.map (fun x -> Base.join Base.id x) l 96 | | x::xs, y::ys -> Base.join x y :: join_list xs ys 97 | 98 | let join l1 l2 = of_list (join_list (to_list l1) (to_list l2)) 99 | end 100 | -------------------------------------------------------------------------------- /src/ShiftWithJoin.mli: -------------------------------------------------------------------------------- 1 | (** The signature of a displacement algebra with binary joins. (Note that this refers to joins of displacements, not joins of universe levels.) *) 2 | module type Semilattice = 3 | sig 4 | (** @closed *) 5 | include Shift.S 6 | 7 | (** [join x y] is the maximum of [x] and [y]. *) 8 | val join : t -> t -> t 9 | end 10 | 11 | (** A displacement algebra with joins and a bottom element. *) 12 | module type BoundedSemilattice = 13 | sig 14 | (** @closed *) 15 | include Semilattice 16 | 17 | (** [bot] is the minimum value. *) 18 | val bot : t 19 | end 20 | 21 | (** Natural numbers with addition. Caveats: it does not handle integer overflow. *) 22 | module Nat : 23 | sig 24 | (** @closed *) 25 | include BoundedSemilattice 26 | 27 | (** Conversion from [int] *) 28 | val of_int : int -> t 29 | 30 | (** Conversion to [int] *) 31 | val to_int : t -> int 32 | end 33 | 34 | (** Integers with addition. Caveats: it does not handle integer overflow. *) 35 | module Int : 36 | sig 37 | (** @closed *) 38 | include Semilattice 39 | 40 | (** Conversion from [int] *) 41 | val of_int : int -> t 42 | 43 | (** Conversion to [int] *) 44 | val to_int : t -> int 45 | end 46 | 47 | (** Non-positive integers with addition. Caveats: it does not handle integer overflow. *) 48 | module NonPositive : 49 | sig 50 | (** @closed *) 51 | include Semilattice 52 | 53 | (** Conversion from [int] *) 54 | val of_int : int -> t 55 | 56 | (** Conversion to [int] *) 57 | val to_int : t -> int 58 | end 59 | 60 | (** Binary products. *) 61 | module Product (X : Semilattice) (Y : Semilattice) : 62 | sig 63 | (** @closed *) 64 | include Semilattice 65 | 66 | (** Forming a pair *) 67 | val pair : X.t -> Y.t -> t 68 | 69 | (** First projection *) 70 | val fst : t -> X.t 71 | 72 | (** Second projection *) 73 | val snd : t -> Y.t 74 | 75 | (** [inl x] is equivalent to [pair x Y.id] *) 76 | val inl : X.t -> t 77 | 78 | (** [inr y] is equivalent to [pair X.id y] *) 79 | val inr : Y.t -> t 80 | end 81 | 82 | (** Binary products, but with the lexicographical order. *) 83 | module Lexicographic (X : BoundedSemilattice) (Y : BoundedSemilattice) : 84 | sig 85 | (** @closed *) 86 | include BoundedSemilattice 87 | 88 | (** Forming a pair *) 89 | val pair : X.t -> Y.t -> t 90 | 91 | (** First projection *) 92 | val fst : t -> X.t 93 | 94 | (** Second projection *) 95 | val snd : t -> Y.t 96 | 97 | (** [inl x] is equivalent to [pair x Y.id] *) 98 | val inl : X.t -> t 99 | 100 | (** [inr y] is equivalent to [pair X.id y] *) 101 | val inr : Y.t -> t 102 | end 103 | 104 | (** Infinite products with finite elements different from a fixed displacement. *) 105 | module NearlyConstant (Base : BoundedSemilattice) : 106 | sig 107 | include BoundedSemilattice 108 | 109 | (** Conversion from a based list *) 110 | val of_based_list : Base.t * Base.t list -> t 111 | 112 | (** Conversion to a based list *) 113 | val to_based_list : t -> Base.t * Base.t list 114 | end 115 | 116 | (** Infinite products with finite supports. A special case of {!module:NearlyConstant}. *) 117 | module FiniteSupport (Base : Semilattice) : 118 | sig 119 | (** @closed *) 120 | include Semilattice 121 | 122 | (** Conversion from a list *) 123 | val of_list : Base.t list -> t 124 | 125 | (** Conversion to a list *) 126 | val to_list : t -> Base.t list 127 | end 128 | -------------------------------------------------------------------------------- /src/Shift.mli: -------------------------------------------------------------------------------- 1 | open StructuredType 2 | 3 | (** The signature of a displacement algebra. *) 4 | module type S = 5 | sig 6 | (** To form a valid displacement algebra, {!val:compose} and {!val:id} should form a monoid, and {!val:lt} (the strict order) must be left-invariant respect to {!val:compose}. *) 7 | 8 | (** @open *) 9 | include PartiallyOrderedType 10 | 11 | (** [id] is the unit. *) 12 | val id : t 13 | 14 | (** [is_id s] checks whether [s] is the unit. It is equivalent to [equal id s], but potentially faster. *) 15 | val is_id : t -> bool 16 | 17 | (** [compose s1 s2] composes the operators [s1] and [s2]. Note that [Foo^s1^s2] in McBride's notation is understood as [compose (compose ... s2) s1] with the reversed order. *) 18 | val compose : t -> t -> t 19 | end 20 | 21 | (** Natural numbers with addition. Caveats: it does not handle integer overflow. *) 22 | module Nat : 23 | sig 24 | (** @closed *) 25 | include S 26 | 27 | (** Conversion from [int] *) 28 | val of_int : int -> t 29 | 30 | (** Conversion to [int] *) 31 | val to_int : t -> int 32 | end 33 | 34 | (** Integers with addition. Caveats: it does not handle integer overflow. *) 35 | module Int : 36 | sig 37 | (** @closed *) 38 | include S 39 | 40 | (** Conversion from [int] *) 41 | val of_int : int -> t 42 | 43 | (** Conversion to [int] *) 44 | val to_int : t -> int 45 | end 46 | 47 | (** Non-positive integers with addition. Caveats: it does not handle integer overflow. *) 48 | module NonPositive : 49 | sig 50 | (** @closed *) 51 | include S 52 | 53 | (** Conversion from [int] *) 54 | val of_int : int -> t 55 | 56 | (** Conversion to [int] *) 57 | val to_int : t -> int 58 | end 59 | 60 | (** Constant displacements. *) 61 | module Constant (Act : S) (Const : PartiallyOrderedTypeWithRightAction with type act := Act.t) : 62 | sig 63 | (** @closed *) 64 | include S 65 | 66 | (** [act s] represents actions. *) 67 | val act : Act.t -> t 68 | 69 | (** [const s] represents constants. *) 70 | val const : Const.t -> t 71 | 72 | (** [to_either] convert an element to a value of type [Either.t] *) 73 | val to_either : t -> (Act.t, Const.t) Either.t 74 | end 75 | 76 | (** Binary products. *) 77 | module Product (X : S) (Y : S) : 78 | sig 79 | (** @closed *) 80 | include S 81 | 82 | (** Forming a pair *) 83 | val pair : X.t -> Y.t -> t 84 | 85 | (** First projection *) 86 | val fst : t -> X.t 87 | 88 | (** Second projection *) 89 | val snd : t -> Y.t 90 | 91 | (** [inl x] is equivalent to [pair x Y.id] *) 92 | val inl : X.t -> t 93 | 94 | (** [inr y] is equivalent to [pair X.id y] *) 95 | val inr : Y.t -> t 96 | end 97 | 98 | (** Binary products, but with the lexicographical order. *) 99 | module Lexicographic (X : S) (Y : S) : 100 | sig 101 | (** @closed *) 102 | include S 103 | 104 | (** Forming a pair *) 105 | val pair : X.t -> Y.t -> t 106 | 107 | (** First projection *) 108 | val fst : t -> X.t 109 | 110 | (** Second projection *) 111 | val snd : t -> Y.t 112 | 113 | (** [inl x] is equivalent to [pair x Y.id] *) 114 | val inl : X.t -> t 115 | 116 | (** [inr y] is equivalent to [pair X.id y] *) 117 | val inr : Y.t -> t 118 | end 119 | 120 | (** Infinite products with finite elements different from a fixed displacement. *) 121 | module NearlyConstant (Base : S) : 122 | sig 123 | (** @closed *) 124 | include S 125 | 126 | (** Conversion from a based list; a based list [(b, l)] represents the following infinite product (as a function from natural numbers to [Base.t]) 127 | {v 128 | f 0 = List.nth l 0 129 | f 1 = List.nth l 1 130 | ... 131 | f (n-1) = List.nth l (n-1) 132 | f n = b 133 | f (n+1) = b 134 | ... 135 | v} 136 | *) 137 | val of_based_list : Base.t * Base.t list -> t 138 | 139 | (** Right inverse of {!val:of_based_list}. It is not a left inverse of {!val:of_based_list} because trailing values that are equal to the base will be stripped. *) 140 | val to_based_list : t -> Base.t * Base.t list 141 | end 142 | 143 | (** Infinite products with finite supports. A special case of {!module:NearlyConstant} where the base is [id]. *) 144 | module FiniteSupport (Base : S) : 145 | sig 146 | (** @closed *) 147 | include S 148 | 149 | (** Conversion from a list; a list [l] represents the following infinite product (as a function from natural numbers to [Base.t]) 150 | {v 151 | f 0 = List.nth l 0 152 | f 1 = List.nth l 1 153 | ... 154 | f (n-1) = List.nth l (n-1) 155 | f n = Base.id 156 | f (n+1) = Base.id 157 | ... 158 | v} 159 | *) 160 | val of_list : Base.t list -> t 161 | 162 | (** List representation of an infinite product. Right inverse of {!val:of_list}. It is not a left inverse of {!val:of_list} because trailing [Base.id] will be stripped. *) 163 | val to_list : t -> Base.t list 164 | end 165 | 166 | (** Prefix displacements. *) 167 | module Prefix (Base : EqualityType) : 168 | sig 169 | (** @closed *) 170 | include S 171 | 172 | (** Prepend a symbol to a displacement. *) 173 | val prepend : Base.t -> t -> t 174 | 175 | (** Conversion to a list *) 176 | val to_list : t -> Base.t list 177 | end 178 | 179 | (** Opposite displacements *) 180 | module Opposite (Base : S) : 181 | sig 182 | include S 183 | 184 | (** [of_base b] gives the same level [b] in the opposite algebra. *) 185 | val of_base : Base.t -> t 186 | 187 | (** [to_base b] gives the same level [b] in the original algebra. *) 188 | val to_base : t -> Base.t 189 | end 190 | -------------------------------------------------------------------------------- /docs/quickstart.mld: -------------------------------------------------------------------------------- 1 | {0 Quickstart Tutorial} 2 | 3 | This tutorial is for an implementer (you!) to integrate this library into your type theory implementation as quickly as possible. We will assume you are already familiar with OCaml and dependent type theory, and are using a typical OCaml package structure. 4 | 5 | {1 Introduction} 6 | 7 | Following {{: https://personal.cis.strath.ac.uk/conor.mcbride/Crude.pdf} Conor McBride’s crude but effective stratification} and {{: https://doi.org/10.1145/3571250} our algebraic reformulation}, a universe level in this library is represented as a pair of a variable together with some {e displacement}. For example, a universe level might be [x + 10], meaning the variable level [x] shifted (bumped) by 10 levels. The shifting of 10 levels is the displacement. For the same variable [x], the level [x + n] is larger than [x + m] if [n] is larger than [m], while levels [x + n] and [y + m] are in general incomparable for different variables [x] and [y]. Substituting [x + n1] for [y] in [y + n2] results in the level [x + (n1 + n2)]. 8 | 9 | While this scheme (with only a variable and some displacement) looks limited, we proved that it is in a sense {e universal} if you allow all mathematically possible displacements beyond natural numbers. We also call the minimum algebra of displacements that would make the scheme work a {e displacement algebra}. See our {{: https://doi.org/10.1145/3571250} POPL paper} for more details. 10 | 11 | This library implements several displacement algebras you could choose from, along with a uniform interface to construct and compare universe levels. 12 | 13 | {1 Choose Your Displacements} 14 | 15 | The first step is to choose your favorite {e displacements}. We will use {!module:Mugen.Shift.Int} (integers) as the starting point, and it is easy to switch to another displacement algebra later. Other displacements are under {!module:Mugen.Shift} and {!module:Mugen.ShiftWithJoin}. 16 | 17 | {1 Free Level Expressions} 18 | 19 | {e Free} level expressions are expressions freely generated by only variables and shifting operators. In contrast, we will have a different kind of level expressions embedded in your datatype holding terms or types. The free level expressions are the only ones that can be compared against each other; the embedded ones must be converted to free ones for comparison. More on this point later. 20 | 21 | Save the following content as the file [ULvl.ml] for free level expressions, assuming that you are using integers to represent variables. 22 | 23 | {[ 24 | module Param = 25 | struct 26 | (** Your chosen displacement algebra *) 27 | module Shift = Mugen.Shift.Int 28 | 29 | (** The representation of variables in free level expressions *) 30 | type var = int 31 | 32 | (** The equality checker for variables *) 33 | let equal_var : var -> var -> bool = Int.equal 34 | end 35 | include Param 36 | 37 | (** An alias of the type of displacements *) 38 | type shift = Shift.t 39 | 40 | (** An alias of the type of free level expressions *) 41 | type t = (shift, int) Mugen.Syntax.free 42 | 43 | (** Smart constructors for free level expressions *) 44 | include Mugen.Builder.Free.Make (Param) 45 | 46 | (** Comparators for free level expressions *) 47 | include Mugen.Theory.Make (Param) 48 | ]} 49 | 50 | Take a look at {!type:Mugen.Syntax.free} for the definition of free level expressions. 51 | 52 | {1 Extend Your Syntax} 53 | 54 | Now we have the free level expressions ready, you need to extend your datatype to embed levels and define the conversion functions to free ones. A typical datatype holding terms or types will have the following pattern: 55 | {[ 56 | type t = 57 | | Var of int (* maybe using De Bruijn indexes or levels *) 58 | (* ... more syntax follows ... *) 59 | ]} 60 | There are three steps to add level expressions to your datatype 61 | 62 | {2 Change the Datatype} 63 | 64 | The idea is to use {!Mugen.Syntax.endo}, instead of {!Mugen.Syntax.free}, so that displacements can syntactically apply to any term or type in your language (but most of them will be ill-formed terms or types). The first parameter of {!Mugen.Syntax.endo} is the type of displacements, and the second parameter is your datatype. It needs to be defined together with your datatype due to the mutual recursion; in the following example, we choose to add a new constructor, [ULvl], to embed level expressions: 65 | 66 | {[ 67 | (** Use [endo] to embed levels into your datatype. *) 68 | type ulvl = (ULvl.shift, t) Mugen.Syntax.endo 69 | 70 | (** The datatype of terms. *) 71 | and t = 72 | | Var of int 73 | (* ... more syntax follows ... *) 74 | | ULvl of ulvl 75 | ]} 76 | 77 | You can take a look at {!type:Mugen.Syntax.endo} for the definition of embedded level expressions. 78 | 79 | {2 Add Converters} 80 | 81 | 82 | {[ 83 | (** Conversion to free level expressions *) 84 | let rec to_ulvl : t -> ULvl.t = 85 | function 86 | | Var i -> Mugen.Syntax.Var i 87 | | ULvl endo -> endo_to_ulvl endo 88 | | _ -> invalid_arg "to_ulvl" 89 | 90 | and endo_to_ulvl : ulvl -> ULvl.t = 91 | let module M = Mugen.Syntax in 92 | function 93 | | M.Shifted (l, s) -> ULvl.shifted (to_ulvl l) s 94 | | M.Top -> ULvl.top 95 | ]} 96 | 97 | 98 | {2 Add Smart Constructors} 99 | 100 | {1 Comparing Levels} 101 | 102 | The most common tasks are to compare two embedded levels. The code is straightforward---the [ULvl] module you have created comes with comparators for free level expressions. It is sufficient to convert embedded level expressions to free ones and compare them accordingly. Copy and paste the following code snippet after the definition of your datatype: 103 | {[ 104 | (** Conversion to free level expressions *) 105 | let rec to_ulvl : t -> ULvl.t = 106 | function 107 | | Var i -> Mugen.Syntax.Var i 108 | | ULvl endo -> endo_to_ulvl endo 109 | | _ -> invalid_arg "to_ulvl" 110 | 111 | and endo_to_ulvl : ulvl -> ULvl.t = 112 | let module M = Mugen.Syntax in 113 | function 114 | | M.Shifted (l, s) -> ULvl.shifted (to_ulvl l) s 115 | | M.Top -> ULvl.top 116 | ]} 117 | Now, the comparators for embedded level expressions can be defined as followed: 118 | {[ 119 | let equal_ulvl l1 l2 = ULvl.equal (to_ulvl l1) (to_ulvl l2) 120 | let leq_ulvl l1 l2 = ULvl.leq (to_ulvl l1) (to_ulvl l2) 121 | let lt_ulvl l1 l2 = ULvl.lt (to_ulvl l1) (to_ulvl l2) 122 | ]} 123 | You might have noticed that there is a "top" level---we added the top level for convenience. 124 | 125 | {1 Building Levels} 126 | 127 | Another common task in a real system is to parse user inputs and construct corresponding (embedded) level expressions. The recommended approach is to use smart constructors that will consolidate displacements when building level expressions. To do so, these smart constructors need to know how to check whether an expression in your datatype is a level expression. Here is the snippet to copy and paste to summon smart constructors: 128 | {[ 129 | (** Include smart constructors for universe levels *) 130 | include 131 | Mugen.Builder.Endo.Make 132 | (struct 133 | (** Your chosen displacement algebra *) 134 | module Shift = ULvl.Shift 135 | 136 | (** The type of embedded level expressions *) 137 | type level = t 138 | 139 | (** A function to embed a level expression *) 140 | let level (l : ulvl) : t = ULvl l 141 | 142 | (** A function to check whether an expression is an embedded level expression *) 143 | let unlevel : t -> ulvl option = function ULvl l -> Some l | _ -> None 144 | end) 145 | ]} 146 | 147 | See 148 | Remember that you have included the smart constructors in previous steps. 149 | 150 | The essential one 151 | {[ 152 | let _ = shifted l s 153 | ]} 154 | to obtain the level [l] shifted by the displacement [s]. Constructing the displacement [s] depends on your chosen displacement algebra. If you were using integers, aliasing the stock {!module:Mugen.Shift.Int} as [ULvl.Shift]), then the shifting by 10 levels can be implemented as: 155 | {[ 156 | let _ = shifted l (ULvl.Shift.of_int 10) 157 | ]} 158 | 159 | For convenience, we also introduced the top level 160 | {[ 161 | let _ = top 162 | ]} 163 | that will be greater than any other level. (Note that you cannot shift the distinguished top level!) 164 | 165 | {1 Concluding Notes} 166 | 167 | That's it! Now you have rich universe levels. Here are a few remarks: 168 | 169 | {2 Ugly Printers for Debugging} 170 | 171 | It is recommended to write your own pretty printer. However, if you wish to dump the universe levels, check out {!val:Mugen.Syntax.Free.dump} for free level expressions and {!val:Mugen.Syntax.Endo.dump} for embedded ones. 172 | 173 | {2 Changing the Displacement Algebra} 174 | 175 | It is trivial to switch to another displacement algebra by aliasing [ULvl.Shift] to another module implementing the interface {!module-type:Mugen.Shift.S}. Changing the displacement algebra only affects how displacements are constructed and printed. 176 | -------------------------------------------------------------------------------- /src/Shift.ml: -------------------------------------------------------------------------------- 1 | open StructuredType 2 | 3 | module type S = 4 | sig 5 | include PartiallyOrderedType 6 | val id : t 7 | val is_id : t -> bool 8 | val compose : t -> t -> t 9 | end 10 | 11 | module Nat = 12 | struct 13 | type t = int 14 | let of_int x = if x < 0 then invalid_arg "Nat.of_int"; x 15 | let id = 0 16 | let to_int x = x 17 | let equal = Stdlib.Int.equal 18 | let is_id x = x = 0 19 | let lt : t -> t -> bool = (<) 20 | let leq : t -> t -> bool = (<=) 21 | let compose : t -> t -> t = (+) 22 | let dump = Format.pp_print_int 23 | end 24 | 25 | module Int : 26 | sig 27 | include S 28 | val of_int : int -> t 29 | val to_int : t -> int 30 | end 31 | = 32 | struct 33 | type t = int 34 | let of_int x : t = x 35 | let to_int x : int = x 36 | let id = 0 37 | let equal = Int.equal 38 | let is_id = function 0 -> true | _ -> false 39 | let lt : int -> int -> bool = (<) 40 | let leq : int -> int -> bool = (<=) 41 | let compose : int -> int -> int = (+) 42 | let dump = Format.pp_print_int 43 | end 44 | 45 | module NonPositive : 46 | sig 47 | include S 48 | val of_int : int -> t 49 | val to_int : t -> int 50 | end 51 | = 52 | struct 53 | type t = int 54 | let of_int x = if x > 0 then invalid_arg "NonPositive.of_int"; x 55 | let id = 0 56 | let to_int x = x 57 | let equal = Stdlib.Int.equal 58 | let is_id x = x = 0 59 | let lt : t -> t -> bool = (<) 60 | let leq : t -> t -> bool = (<=) 61 | let compose : t -> t -> t = (+) 62 | let dump = Format.pp_print_int 63 | end 64 | 65 | module Constant (Act : S) (Const : PartiallyOrderedTypeWithRightAction with type act := Act.t) : 66 | sig 67 | include S 68 | val act : Act.t -> t 69 | val const : Const.t -> t 70 | val to_either : t -> (Act.t, Const.t) Either.t 71 | end 72 | = 73 | struct 74 | type t = Act of Act.t | Const of Const.t 75 | let act x = Act x 76 | let const x = Const x 77 | let to_either = 78 | function 79 | | Act x -> Either.Left x 80 | | Const x -> Either.Right x 81 | let id = act Act.id 82 | let equal x y = 83 | match x, y with 84 | | Act x, Act y -> Act.equal x y 85 | | Const x, Const y -> Const.equal x y 86 | | _ -> false 87 | let is_id = function Act s -> Act.is_id s | _ -> false 88 | let lt x y = 89 | match x, y with 90 | | Act x, Act y -> Act.lt x y 91 | | Const x, Const y -> Const.lt x y 92 | | _ -> false 93 | let leq x y = 94 | match x, y with 95 | | Act x, Act y -> Act.leq x y 96 | | Const x, Const y -> Const.leq x y 97 | | _ -> false 98 | let compose x y = 99 | match x, y with 100 | | _, Const _ -> y 101 | | Const x, Act y -> const (Const.act x y) 102 | | Act x, Act y -> act (Act.compose x y) 103 | let dump fmt = 104 | function 105 | | Const x -> 106 | Format.fprintf fmt "@[<1>(const@ @[%a@])@]" Const.dump x 107 | | Act x -> 108 | Format.fprintf fmt "@[<1>(act@ @[%a@])@]" Act.dump x 109 | end 110 | 111 | module Product (X : S) (Y : S) : 112 | sig 113 | include S 114 | val pair : X.t -> Y.t -> t 115 | val fst : t -> X.t 116 | val snd : t -> Y.t 117 | val inl : X.t -> t 118 | val inr : Y.t -> t 119 | end 120 | = 121 | struct 122 | type t = X.t * Y.t 123 | 124 | let pair x y : t = x, y 125 | let fst (xy : t) = fst xy 126 | let snd (xy : t) = snd xy 127 | let inl x = x, Y.id 128 | let inr y = X.id, y 129 | 130 | let id = X.id, Y.id 131 | 132 | let is_id (x, y) = X.is_id x && Y.is_id y 133 | 134 | let equal (x1, y1) (x2, y2) = X.equal x1 x2 && Y.equal y1 y2 135 | 136 | let lt (x1, y1) (x2, y2) = (X.lt x1 x2 && Y.leq y1 y2) || (X.equal x1 x2 && Y.lt y1 y2) 137 | 138 | let leq (x1, y1) (x2, y2) = X.leq x1 x2 && Y.leq y1 y2 139 | 140 | let compose (x1, y1) (x2, y2) = X.compose x1 x2, Y.compose y1 y2 141 | 142 | let dump fmt (x, y) = 143 | Format.fprintf fmt "@[<1>(pair@ @[%a@]@ @[%a@])@]" X.dump x Y.dump y 144 | end 145 | 146 | module Lexicographic (X : S) (Y : S) : 147 | sig 148 | include S 149 | val pair : X.t -> Y.t -> t 150 | val fst : t -> X.t 151 | val snd : t -> Y.t 152 | val inl : X.t -> t 153 | val inr : Y.t -> t 154 | end 155 | = 156 | struct 157 | type t = X.t * Y.t 158 | 159 | let pair x y : t = x, y 160 | let fst (xy : t) = fst xy 161 | let snd (xy : t) = snd xy 162 | let inl x = x, Y.id 163 | let inr y = X.id, y 164 | 165 | let id = X.id, Y.id 166 | 167 | let is_id (x, y) = X.is_id x && Y.is_id y 168 | 169 | let equal (x1, y1) (x2, y2) = X.equal x1 x2 && Y.equal y1 y2 170 | 171 | let lt (x1, y1) (x2, y2) = X.lt x1 x2 || (X.equal x1 x2 && Y.lt y1 y2) 172 | 173 | let leq (x1, y1) (x2, y2) = X.lt x1 x2 || (X.equal x1 x2 && Y.leq y1 y2) 174 | 175 | let compose (x1, y1) (x2, y2) = X.compose x1 x2, Y.compose y1 y2 176 | 177 | let dump fmt (x, y) = 178 | Format.fprintf fmt "@[<1>(pair@ @[%a@]@ @[%a@])@]" X.dump x Y.dump y 179 | end 180 | 181 | module NearlyConstant (Base : S) : 182 | sig 183 | include S 184 | val of_based_list : Base.t * Base.t list -> t 185 | val to_based_list : t -> Base.t * Base.t list 186 | end 187 | = 188 | struct 189 | (* invariants: no trailing elements equal to base *) 190 | type t = Base.t * Base.t list 191 | 192 | let rec strip_right base : Base.t list -> Base.t list = 193 | function 194 | | [] -> [] 195 | | [s] -> if Base.equal s base then [] else [s] 196 | | s::ss -> 197 | let ss = strip_right base ss in 198 | if ss = [] && Base.equal s base then [] else s::ss 199 | 200 | let of_based_list (b, l) : t = b, strip_right b l 201 | let to_based_list (l : t) = l 202 | 203 | let id : t = Base.id, [] 204 | 205 | let is_id ((b, l) : t) = Base.is_id b && l = [] 206 | 207 | let rec for_all2 f (b1, l1) (b2, l2) = 208 | match l1, l2 with 209 | | [], [] -> f b1 b2 210 | | l1, [] -> List.for_all (fun x1 -> f x1 b2) l1 211 | | [], l2 -> List.for_all (fun x2 -> f b1 x2) l2 212 | | x1::l1, x2::l2 -> f x1 x2 && for_all2 f (b1, l1) (b2, l2) 213 | 214 | let rec exists2 f (b1, l1) (b2, l2) = 215 | match l1, l2 with 216 | | [], [] -> f b1 b2 217 | | l1, [] -> List.exists (fun x1 -> f x1 b2) l1 218 | | [], l2 -> List.exists (fun x2 -> f b1 x2) l2 219 | | x1::l1, x2::l2 -> f x1 x2 || exists2 f (b1, l1) (b2, l2) 220 | 221 | let equal l1 l2 = for_all2 Base.equal l1 l2 222 | 223 | let lt l1 l2 = for_all2 Base.leq l1 l2 && exists2 Base.lt l1 l2 224 | 225 | let leq l1 l2 = for_all2 Base.leq l1 l2 226 | 227 | let rec compose_ (b1, l1) (b2, l2) = 228 | match l1, l2 with 229 | | [], [] -> [] 230 | | l1, [] -> List.map (fun x1 -> Base.compose x1 b2) l1 231 | | [], l2 -> List.map (fun x2 -> Base.compose b1 x2) l2 232 | | x1::l1, x2::l2 -> Base.compose x1 x2 :: compose_ (b1, l1) (b2, l2) 233 | 234 | let compose (b1, l1) (b2, l2) = 235 | let b = Base.compose b1 b2 in 236 | b, strip_right b @@ compose_ (b1, l1) (b2, l2) 237 | 238 | let dump fmt (b, l) = 239 | Format.fprintf fmt "@[<1>[%a;@,%a...]@]" 240 | (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ";@,") Base.dump) l 241 | Base.dump b 242 | end 243 | 244 | module FiniteSupport (Base : S) : 245 | sig 246 | include S 247 | val of_list : Base.t list -> t 248 | val to_list : t -> Base.t list 249 | end 250 | = 251 | struct 252 | include NearlyConstant (Base) 253 | 254 | let of_list l = of_based_list (Base.id, l) 255 | let to_list bl = 256 | let b, l = to_based_list bl in 257 | assert (Base.is_id b); 258 | l 259 | end 260 | 261 | module Prefix (Base : EqualityType) : 262 | sig 263 | include S 264 | val prepend : Base.t -> t -> t 265 | val to_list : t -> Base.t list 266 | end 267 | = 268 | struct 269 | type t = Base.t list 270 | 271 | let prepend x xs = x :: xs 272 | 273 | let to_list xs = xs 274 | 275 | let id = [] 276 | 277 | let is_id l = l = [] 278 | 279 | let equal x y = List.equal Base.equal x y 280 | 281 | let rec lt x y = 282 | match x, y with 283 | | [], [] -> false 284 | | [], _::_ -> true 285 | | _::_, [] -> false 286 | | x::xs, y::ys -> Base.equal x y && lt xs ys 287 | 288 | let rec leq x y = 289 | match x, y with 290 | | [], _ -> true 291 | | _::_, [] -> false 292 | | x::xs, y::ys -> Base.equal x y && leq xs ys 293 | 294 | let compose x y = x @ y 295 | 296 | let dump fmt x = 297 | Format.fprintf fmt "@[<1>[%a]@]" 298 | (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ";@,") Base.dump) 299 | x 300 | end 301 | 302 | module Opposite (Base : S) : 303 | sig 304 | include S 305 | val of_base : Base.t -> t 306 | val to_base : t -> Base.t 307 | end 308 | = 309 | struct 310 | type t = Base.t 311 | 312 | let id = Base.id 313 | 314 | let is_id = Base.is_id 315 | 316 | let equal = Fun.flip Base.equal 317 | 318 | let lt = Fun.flip Base.lt 319 | 320 | let leq = Fun.flip Base.leq 321 | 322 | let compose = Base.compose 323 | 324 | let dump = Base.dump 325 | 326 | let of_base (b : t) = b 327 | 328 | let to_base (b : t) = b 329 | end 330 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | 203 | 204 | --- LLVM Exceptions to the Apache 2.0 License ---- 205 | 206 | As an exception, if, as a result of your compiling your source code, portions 207 | of this Software are embedded into an Object form of such source code, you 208 | may redistribute such embedded portions in such Object form without complying 209 | with the conditions of Sections 4(a), 4(b) and 4(d) of the License. 210 | 211 | In addition, if you combine or link compiled forms of this Software with 212 | software that is licensed under the GPLv2 ("Combined Software") and if a 213 | court of competent jurisdiction determines that the patent provision (Section 214 | 3), the indemnity provision (Section 9) or other Section of the License 215 | conflicts with the conditions of the GPLv2, you may retroactively and 216 | prospectively choose to deem waived or otherwise exclude such Section(s) of 217 | the License, but only in their entirety and only with respect to the Combined 218 | Software. 219 | --------------------------------------------------------------------------------