├── test ├── test_lexie.ml └── dune ├── lib ├── Batteries │ ├── dune │ ├── Fun.ml │ ├── Operators.ml │ ├── Option.ml │ ├── Fun.mli │ ├── Operators.mli │ ├── List.ml │ ├── Option.mli │ ├── Int.ml │ ├── List.mli │ ├── Int.mli │ ├── Char.mli │ ├── Batteries.ml │ ├── Char.ml │ ├── Intp.ml │ ├── String.ml │ ├── Intp.mli │ ├── String.mli │ └── Painter.ml ├── Config │ ├── dune │ ├── Config.mli │ └── Config.ml ├── Custom │ ├── dune │ ├── Name.mli │ ├── Syntactic_kind.mli │ ├── Syntactic_kind.ml │ ├── Name.ml │ ├── Painter.ml │ └── Quickmap.ml ├── Hooks │ ├── Run.ml │ ├── dune │ ├── Eval.mli │ ├── Run.mli │ ├── Check.mli │ ├── Config.ml │ ├── Config.mli │ ├── Hook.ml │ ├── Check.ml │ └── Eval.ml ├── Clinic │ ├── dune │ ├── Category.ml │ ├── Category.mli │ ├── Diagnostic.mli │ ├── Diagnostic.ml │ ├── Diagnosis.mli │ ├── Diagnosis.ml │ ├── Doctor.ml │ └── Doctor.mli ├── CLI │ ├── dune │ ├── Main.mli │ ├── Run.mli │ ├── Check.mli │ ├── Config.ml │ ├── Config.mli │ ├── Check.ml │ ├── Run.ml │ ├── Main.ml │ └── Sample.ml ├── Compiler │ ├── Common │ │ ├── dune │ │ ├── Primitive.ml │ │ └── Primitive.mli │ ├── Analysis │ │ ├── dune │ │ ├── Analysis.mli │ │ └── Analysis.ml │ ├── dune │ └── AIL │ │ ├── dune │ │ └── AIL.ml ├── Runtime │ ├── dune │ ├── Outcome.ml │ ├── Exception.ml │ ├── Exception.mli │ ├── Object.mli │ ├── Unreachable.ml │ ├── Unreachable.mli │ ├── Object.ml │ ├── Core.mli │ └── Core.ml └── dune ├── .ocamlformat ├── assets └── banner.png ├── bin ├── dune └── main.ml ├── .gitignore ├── dune-project ├── README.md ├── lexie.opam └── LICENSE /test/test_lexie.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_lexie)) 3 | -------------------------------------------------------------------------------- /lib/Batteries/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name batteries)) 3 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=janestreet 2 | version=0.27.0 3 | margin=64 -------------------------------------------------------------------------------- /lib/Config/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name config) 3 | (libraries custom)) 4 | -------------------------------------------------------------------------------- /lib/Custom/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name custom) 3 | (libraries batteries)) 4 | -------------------------------------------------------------------------------- /lib/Hooks/Run.ml: -------------------------------------------------------------------------------- 1 | let execute = Hook.compose Check.execute Eval.execute 2 | -------------------------------------------------------------------------------- /assets/banner.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/qexat/lexie/HEAD/assets/banner.png -------------------------------------------------------------------------------- /lib/Clinic/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name clinic) 3 | (libraries AIL config custom)) 4 | -------------------------------------------------------------------------------- /lib/CLI/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cli) 3 | (libraries batteries cmdliner hooks)) 4 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name lexie) 3 | (name main) 4 | (libraries lexie)) 5 | -------------------------------------------------------------------------------- /lib/CLI/Main.mli: -------------------------------------------------------------------------------- 1 | (** [main ()] executes the CLI program. *) 2 | val main : unit -> int 3 | -------------------------------------------------------------------------------- /lib/Compiler/Common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name common) 3 | (libraries batteries custom)) 4 | -------------------------------------------------------------------------------- /lib/Hooks/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name hooks) 3 | (libraries AIL analysis custom runtime)) 4 | -------------------------------------------------------------------------------- /lib/Runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name runtime) 3 | (libraries AIL clinic config custom)) 4 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | open Cli.Main 2 | 3 | let () = if !Sys.interactive then () else exit (main ()) 4 | -------------------------------------------------------------------------------- /lib/Compiler/Analysis/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name analysis) 3 | (libraries AIL clinic common custom)) 4 | -------------------------------------------------------------------------------- /lib/Compiler/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name compiler) 3 | (libraries AIL analysis batteries custom)) 4 | -------------------------------------------------------------------------------- /lib/Runtime/Outcome.ml: -------------------------------------------------------------------------------- 1 | type error = (Exception.t, Unreachable.t) Either.t 2 | type t = (Object.t, error) result 3 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lexie) 3 | (libraries batteries cli clinic compiler config custom hooks runtime)) 4 | -------------------------------------------------------------------------------- /lib/Compiler/AIL/dune: -------------------------------------------------------------------------------- 1 | ; Analysis Intermediate Language 2 | 3 | (library 4 | (name AIL) 5 | (libraries common custom)) 6 | -------------------------------------------------------------------------------- /lib/CLI/Run.mli: -------------------------------------------------------------------------------- 1 | (** [execute config] executes the run hook with the given 2 | [config]. *) 3 | val execute : Config.t -> int 4 | -------------------------------------------------------------------------------- /lib/CLI/Check.mli: -------------------------------------------------------------------------------- 1 | (** [execute config] executes the check hook with the given 2 | [config]. *) 3 | val execute : Config.t -> int 4 | -------------------------------------------------------------------------------- /lib/Batteries/Fun.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Fun 2 | 3 | module Notation = struct 4 | let ( <* ) = compose 5 | let ( *> ) = fun f g -> compose g f 6 | end 7 | -------------------------------------------------------------------------------- /lib/Batteries/Operators.ml: -------------------------------------------------------------------------------- 1 | include Int.Notation 2 | include String.Notation 3 | include List.Notation 4 | include Fun.Notation 5 | 6 | let ( mod ) = Intp.modulo 7 | -------------------------------------------------------------------------------- /lib/CLI/Config.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { strict : bool 3 | ; print_program : bool 4 | ; use_compiler_intrinsics : bool 5 | ; show_styling : [ `Never | `Always | `Auto ] 6 | } 7 | -------------------------------------------------------------------------------- /lib/Batteries/Option.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Option 2 | 3 | let on_none = 4 | fun func option -> 5 | (match option with 6 | | None -> func () 7 | | Some _ -> ()); 8 | option 9 | ;; 10 | -------------------------------------------------------------------------------- /lib/CLI/Config.mli: -------------------------------------------------------------------------------- 1 | (** Config used by CLI hooks. *) 2 | type t = 3 | { strict : bool 4 | ; print_program : bool 5 | ; use_compiler_intrinsics : bool 6 | ; show_styling : [ `Always | `Auto | `Never ] 7 | } 8 | -------------------------------------------------------------------------------- /lib/Batteries/Fun.mli: -------------------------------------------------------------------------------- 1 | include module type of Stdlib.Fun 2 | 3 | module Notation : sig 4 | val ( <* ) : 'a 'b 'c. ('b -> 'c) -> ('a -> 'b) -> 'a -> 'c 5 | val ( *> ) : 'a 'b 'c. ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c 6 | end 7 | -------------------------------------------------------------------------------- /lib/Batteries/Operators.mli: -------------------------------------------------------------------------------- 1 | include module type of Int.Notation 2 | include module type of String.Notation 3 | include module type of List.Notation 4 | include module type of Fun.Notation 5 | 6 | val ( mod ) : Intp.t -> Intp.t -> Intp.t 7 | -------------------------------------------------------------------------------- /lib/Runtime/Exception.ml: -------------------------------------------------------------------------------- 1 | type kind = Incomplete_program 2 | type t = { kind : kind } 3 | 4 | let show = 5 | fun _ exn -> 6 | match exn.kind with 7 | | Incomplete_program -> 8 | "this program is incomplete (hole found)" 9 | ;; 10 | -------------------------------------------------------------------------------- /lib/Batteries/List.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.List 2 | 3 | let map_on_cons = 4 | fun func list -> 5 | match list with 6 | | [] -> None 7 | | _ -> Some (map func list) 8 | ;; 9 | 10 | module Notation = struct 11 | let ( ++ ) = append 12 | end 13 | -------------------------------------------------------------------------------- /lib/Batteries/Option.mli: -------------------------------------------------------------------------------- 1 | include module type of Stdlib.Option 2 | 3 | (** [on_none func option] calls [func] if [option] is [None] and 4 | returns [option] unchanged. *) 5 | val on_none 6 | : 'item. 7 | (unit -> unit) -> 'item option -> 'item option 8 | -------------------------------------------------------------------------------- /lib/Batteries/Int.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Int 2 | 3 | module Notation = struct 4 | let ( = ) = equal 5 | let ( != ) = fun i1 i2 -> not (i1 = i2) 6 | let ( + ) = add 7 | let ( - ) = sub 8 | let ( * ) = mul 9 | let ( / ) = div 10 | let ( % ) = rem 11 | end 12 | -------------------------------------------------------------------------------- /lib/Batteries/List.mli: -------------------------------------------------------------------------------- 1 | include module type of Stdlib.List 2 | 3 | val map_on_cons 4 | : 'item1 'item2. 5 | ('item1 -> 'item2) -> 'item1 list -> 'item2 list option 6 | 7 | module Notation : sig 8 | val ( ++ ) : 'item. 'item t -> 'item t -> 'item t 9 | end 10 | -------------------------------------------------------------------------------- /lib/Hooks/Eval.mli: -------------------------------------------------------------------------------- 1 | open Clinic 2 | open Custom 3 | 4 | (** [execute doctor painter config program] executes the hook. *) 5 | val execute 6 | : doctor:Doctor.t 7 | -> painter:(module Painter.TYPE) 8 | -> Config.t 9 | -> AIL.Program.t 10 | -> unit option 11 | -------------------------------------------------------------------------------- /lib/Hooks/Run.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | open Clinic 3 | 4 | (** [execute doctor painter config program] executes the hook. *) 5 | val execute 6 | : doctor:Doctor.t 7 | -> painter:(module Painter.TYPE) 8 | -> Config.t 9 | -> AIL.Program.t 10 | -> unit option 11 | -------------------------------------------------------------------------------- /lib/Hooks/Check.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | open Clinic 3 | 4 | (** [execute doctor painter config program] executes the hook. *) 5 | val execute 6 | : doctor:Doctor.t 7 | -> painter:(module Painter.TYPE) 8 | -> Config.t 9 | -> AIL.Program.t 10 | -> AIL.Program.t option 11 | -------------------------------------------------------------------------------- /lib/Hooks/Config.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | { print_program : bool 3 | ; use_compiler_intrinsics : bool 4 | } 5 | 6 | let create = 7 | fun ?(print_program = false) 8 | ?(use_compiler_intrinsics = false) 9 | () -> 10 | { print_program; use_compiler_intrinsics } 11 | ;; 12 | -------------------------------------------------------------------------------- /lib/Batteries/Int.mli: -------------------------------------------------------------------------------- 1 | include module type of Stdlib.Int 2 | 3 | module Notation : sig 4 | val ( = ) : t -> t -> bool 5 | val ( != ) : t -> t -> bool 6 | val ( + ) : t -> t -> t 7 | val ( - ) : t -> t -> t 8 | val ( * ) : t -> t -> t 9 | val ( / ) : t -> t -> t 10 | val ( % ) : t -> t -> t 11 | end 12 | -------------------------------------------------------------------------------- /lib/Runtime/Exception.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | (** The kind of runtime errors. *) 4 | type kind = Incomplete_program 5 | 6 | (** A runtime error. *) 7 | type t = { kind : kind } 8 | 9 | (** [show painter exn] produces a pretty-printable 10 | representation of [exn] using the [painter]. *) 11 | val show : (module Painter.TYPE) -> t -> string 12 | -------------------------------------------------------------------------------- /lib/Runtime/Object.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | open Common 3 | 4 | (** A runtime value. *) 5 | type t = 6 | | Constant of Primitive.t 7 | | Fun of Name.t * t 8 | | Late of AIL.Term.t 9 | 10 | (** [show painter obj] produces a pretty-printable 11 | representation of [obj] using the [painter]. *) 12 | val show : (module Painter.TYPE) -> t -> string 13 | -------------------------------------------------------------------------------- /lib/Runtime/Unreachable.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | type t = 4 | | Illegal_application 5 | | Undefined_name of Name.t 6 | 7 | let show = 8 | fun painter unreachable -> 9 | match unreachable with 10 | | Illegal_application -> "illegal application" 11 | | Undefined_name name -> 12 | Printf.sprintf "undefined name %s" (Name.show painter name) 13 | ;; 14 | -------------------------------------------------------------------------------- /lib/Custom/Name.mli: -------------------------------------------------------------------------------- 1 | include Batteries.String.REFINED 2 | module Type : Batteries.String.REFINED 3 | 4 | (** [is_type name] determines whether the [name] is a valid type 5 | name. *) 6 | val is_type : t -> bool 7 | 8 | (** [show painter name] produces a pretty-printable 9 | representation of the [name] using the [painter]. *) 10 | val show : (module Painter.TYPE) -> t -> string 11 | -------------------------------------------------------------------------------- /lib/Runtime/Unreachable.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | (** A runtime error that is symptomatic of a bug in the 4 | compiler. *) 5 | type t = 6 | | Illegal_application 7 | | Undefined_name of Name.t 8 | 9 | (** [show painter unreachable] produces a pretty-printable 10 | representation of the [unreachable] using the [painter]. *) 11 | val show : (module Painter.TYPE) -> t -> string 12 | -------------------------------------------------------------------------------- /lib/Hooks/Config.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | { print_program : bool 3 | ; use_compiler_intrinsics : bool 4 | } 5 | 6 | (** [create ?print_program ?use_compiler_intrinsics ()] 7 | creates a hook config without having to specify all 8 | fields, providing good defaults. *) 9 | val create 10 | : ?print_program:bool 11 | -> ?use_compiler_intrinsics:bool 12 | -> unit 13 | -> t 14 | -------------------------------------------------------------------------------- /lib/Batteries/Char.mli: -------------------------------------------------------------------------------- 1 | include module type of Stdlib.Char 2 | 3 | (** Letters of the latin alphabet in uppercase. *) 4 | val uppercase_latin_alphabet : t list 5 | 6 | (** Letters of the latin alphabet in lowercase. *) 7 | val lowercase_latin_alphabet : t list 8 | 9 | (** [is_alphabetical char] determines whether [char] is a letter 10 | of the latin alphabet. *) 11 | val is_alphabetical : t -> bool 12 | -------------------------------------------------------------------------------- /lib/Batteries/Batteries.ml: -------------------------------------------------------------------------------- 1 | let ( or ) = 2 | fun option fallback -> Option.value ~default:fallback option 3 | ;; 4 | 5 | let ( let+ ) = Option.bind 6 | let ( let* ) = Result.bind 7 | 8 | module Char = Char 9 | module Fun = Fun 10 | module Int = Int 11 | module Intp = Intp 12 | module List = List 13 | module Operators = Operators 14 | module Option = Option 15 | module Painter = Painter 16 | module String = String 17 | -------------------------------------------------------------------------------- /lib/Hooks/Hook.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Clinic 3 | 4 | type ('config, 'input, 'output) hook = 5 | doctor:Doctor.t 6 | -> painter:(module Painter.TYPE) 7 | -> 'config 8 | -> 'input 9 | -> 'output option 10 | 11 | let compose = 12 | fun left right -> 13 | fun ~doctor ~painter config input -> 14 | let+ next_input = left ~doctor ~painter config input in 15 | right ~doctor ~painter config next_input 16 | ;; 17 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | # ocamlbuild working directory 12 | _build/ 13 | 14 | # ocamlbuild targets 15 | *.byte 16 | *.native 17 | 18 | # oasis generated files 19 | setup.data 20 | setup.log 21 | 22 | # Merlin configuring file for Vim and Emacs 23 | .merlin 24 | 25 | # Dune generated files 26 | *.install 27 | 28 | # Local OPAM switch 29 | _opam/ 30 | -------------------------------------------------------------------------------- /lib/Batteries/Char.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Char 2 | 3 | let uppercase_latin_alphabet = 4 | List.of_seq 5 | (Stdlib.String.to_seq "ABCDEFGHIJKLMNOPQRSTUVWXYZ") 6 | ;; 7 | 8 | let lowercase_latin_alphabet = 9 | List.of_seq 10 | (Stdlib.String.to_seq "abcdefghijklmnopqrstuvwxyz") 11 | ;; 12 | 13 | let is_alphabetical = 14 | fun char -> 15 | List.mem char uppercase_latin_alphabet 16 | || List.mem char lowercase_latin_alphabet 17 | ;; 18 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.17) 2 | 3 | (name lexie) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github qexat/lexie)) 9 | 10 | (authors "lexa ") 11 | 12 | (maintainers "lexa ") 13 | 14 | (license LICENSE) 15 | 16 | (package 17 | (name lexie) 18 | (synopsis "a ML-style, CIC-based programming language") 19 | (description "i'll put something here later") 20 | (depends 21 | ocaml 22 | (cmdliner 23 | (>= 1.3.0)))) 24 | -------------------------------------------------------------------------------- /lib/Clinic/Category.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | type t = 4 | | Error 5 | | Warning 6 | | Info 7 | 8 | let name = function 9 | | Error -> "error" 10 | | Warning -> "warning" 11 | | Info -> "info" 12 | ;; 13 | 14 | let get_painter_function = 15 | fun (module Painter : Painter.TYPE) -> function 16 | | Error -> Painter.paint_error 17 | | Warning -> Painter.paint_warning 18 | | Info -> Painter.paint_info 19 | ;; 20 | 21 | let show = 22 | fun painter category -> 23 | get_painter_function painter category (name category) 24 | ;; 25 | -------------------------------------------------------------------------------- /lib/Compiler/Common/Primitive.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Custom 3 | 4 | type t = 5 | | Nat of Intp.t 6 | | Unit 7 | 8 | let nat = fun n -> Nat n 9 | let unit = Unit 10 | 11 | let equal = 12 | fun left right -> 13 | match left, right with 14 | | Nat ln, Nat rn -> Intp.equal ln rn 15 | | Unit, Unit -> true 16 | | Nat _, Unit | Unit, Nat _ -> false 17 | ;; 18 | 19 | let show = 20 | fun (module Painter : Painter.TYPE) prim -> 21 | (match prim with 22 | | Nat n -> Intp.to_string n 23 | | Unit -> Printf.sprintf "()") 24 | |> Painter.paint_constant 25 | ;; 26 | -------------------------------------------------------------------------------- /lib/Runtime/Object.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | open Common 3 | 4 | type t = 5 | | Constant of Primitive.t 6 | | Fun of Name.t * t 7 | | Late of AIL.Term.t 8 | 9 | let rec show = 10 | fun painter obj -> 11 | let module Painter = (val painter : Painter.TYPE) in 12 | match obj with 13 | | Constant prim -> Primitive.show painter prim 14 | | Fun (param, ret) -> 15 | Printf.sprintf 16 | "%s %s -> %s" 17 | (Painter.paint_keyword "fun") 18 | (Name.show painter param) 19 | (show painter ret) 20 | | Late _ -> Painter.paint_dim "" 21 | ;; 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | ![Logo of Lexie](./assets/banner.png) 4 | 5 | # lexie 6 | 7 | a ML-style programming language based on the calculus of constructions type theory 8 | 9 | still very early in its development so don't expect much 10 | 11 | for now there is no parser whatsoever so the sample program is hardcoded in `CLI` 12 | 13 | ## run 14 | 15 | ```sh 16 | dune exec lexie 17 | ``` 18 | 19 | --- 20 | 21 | Lexie's development does not involve any large language model. 22 | 23 | [![Lexie is entirely brain-made.](https://brainmade.org/black-logo.svg)](https://brainmade.org) 24 | -------------------------------------------------------------------------------- /lib/Compiler/Common/Primitive.mli: -------------------------------------------------------------------------------- 1 | open Batteries 2 | 3 | (** A primitive value is a value built into the language. *) 4 | type t = 5 | | Nat of Intp.t 6 | | Unit 7 | 8 | (** [nat value] constructs a [Nat] from a positive integer. *) 9 | val nat : Intp.t -> t 10 | 11 | (** A [unit] primitive value. *) 12 | val unit : t 13 | 14 | (** [equal prim1 prim2] determines whether [prim1] and 15 | [prim2] are the same. *) 16 | val equal : t -> t -> bool 17 | 18 | (** [show painter prim] produces a pretty-printable string that 19 | represents [prim] using [painter]. *) 20 | val show : (module Custom.Painter.TYPE) -> t -> string 21 | -------------------------------------------------------------------------------- /lib/Custom/Syntactic_kind.mli: -------------------------------------------------------------------------------- 1 | (** A syntactic kind is a group of term elements that have 2 | the same precedence. *) 3 | type t = 4 | | Atom 5 | | Grouping 6 | | App 7 | | Binary 8 | | Fun 9 | 10 | (** [equal sk1 sk2] determines whether [sk1] and [sk2] are 11 | the same. *) 12 | val equal : t -> t -> bool 13 | 14 | (** [compare sk1 sk2] returns whether [sk1] is greater (>0), 15 | equal (=0) or less (<0) than [sk2]. *) 16 | val compare : t -> t -> int 17 | 18 | (** [binds_tighter sk1 ~than:sk2] determines whether [sk1] 19 | binds more tightly (higher precedence) than [sk2]. *) 20 | val binds_tighter : t -> than:t -> bool 21 | -------------------------------------------------------------------------------- /lib/CLI/Check.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | open Clinic 3 | 4 | let execute = 5 | fun (config : Config.t) -> 6 | let hook_config : Hooks.Config.t = 7 | { print_program = config.print_program 8 | ; use_compiler_intrinsics = config.use_compiler_intrinsics 9 | } 10 | in 11 | let doctor = Doctor.create { strict = config.strict } in 12 | let painter = 13 | (module Painter.Make (struct 14 | let show_styling = config.show_styling 15 | end) : Painter.TYPE) 16 | in 17 | match 18 | Hooks.Check.execute 19 | ~doctor 20 | ~painter 21 | hook_config 22 | Sample.program 23 | with 24 | | None -> 1 25 | | Some _ -> 0 26 | ;; 27 | -------------------------------------------------------------------------------- /lib/CLI/Run.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | open Clinic 3 | 4 | let execute = 5 | fun (config : Config.t) -> 6 | let hook_config : Hooks.Config.t = 7 | { print_program = config.print_program 8 | ; use_compiler_intrinsics = config.use_compiler_intrinsics 9 | } 10 | in 11 | let doctor = Doctor.create { strict = config.strict } in 12 | let painter = 13 | (module Painter.Make (struct 14 | let show_styling = config.show_styling 15 | end) : Painter.TYPE) 16 | in 17 | match 18 | Hooks.Run.execute 19 | ~doctor 20 | ~painter 21 | hook_config 22 | Sample.program 23 | with 24 | | None -> 1 25 | | Some () -> 0 26 | ;; 27 | -------------------------------------------------------------------------------- /lib/Clinic/Category.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | (** Category of a diagnostic. *) 4 | type t = 5 | | Error 6 | | Warning 7 | | Info 8 | 9 | (** [name category] returns the name of the [category]. *) 10 | val name : t -> string 11 | 12 | (** [get_painter_function painter category] returns the function 13 | of the [painter] that should be used to represent the 14 | [category]. *) 15 | val get_painter_function 16 | : (module Painter.TYPE) 17 | -> t 18 | -> string 19 | -> string 20 | 21 | (** [show painter category] produces a pretty-printable 22 | representation of the [category] using the [painter]. *) 23 | val show : (module Painter.TYPE) -> t -> string 24 | -------------------------------------------------------------------------------- /lib/Clinic/Diagnostic.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | (** A diagnostic is a record of a diagnosis and which category 4 | it falls in ([Error], [Warning], etc). *) 5 | type t = 6 | { category : Category.t 7 | ; diagnosis : Diagnosis.t 8 | } 9 | 10 | (** [is_error diagnostic] determines whether the [diagnostic] 11 | falls in the [Error] category. *) 12 | val is_error : t -> bool 13 | 14 | (** [is_warning diagnostic] determines whether the [diagnostic] 15 | falls in the [Warning] category. *) 16 | val is_warning : t -> bool 17 | 18 | (** [show painter diagnostic] produces a pretty-printable 19 | representation of the [diagnostic] using the [painter]. *) 20 | val show : (module Painter.TYPE) -> t -> string 21 | -------------------------------------------------------------------------------- /lib/Config/Config.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | (** A configuration for the entire toolchain! *) 4 | type t = 5 | { strict : bool 6 | ; print_program : bool 7 | ; use_compiler_intrinsics : bool 8 | } 9 | 10 | (** [create ?strict ?print_program ?use_compiler_intrinsics ()] 11 | builds a configuration but allows not to specify certain or 12 | all fields, using default values for them. *) 13 | val create 14 | : ?strict:bool 15 | -> ?print_program:bool 16 | -> ?use_compiler_intrinsics:bool 17 | -> unit 18 | -> t 19 | 20 | (** [show painter configuration] produces a pretty-printable 21 | representation of the [configuration] using the [painter]. *) 22 | val show : (module Painter.TYPE) -> t -> string 23 | -------------------------------------------------------------------------------- /lib/Custom/Syntactic_kind.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Atom 3 | | Grouping 4 | | App 5 | | Binary 6 | | Fun 7 | 8 | let compare = 9 | fun left right -> 10 | match left, right with 11 | | Atom, Atom 12 | | Grouping, Grouping 13 | | App, App 14 | | Binary, Binary 15 | | Fun, Fun -> 0 16 | | Atom, (Grouping | App | Binary | Fun) 17 | | Grouping, (App | Binary | Fun) 18 | | App, (Binary | Fun) 19 | | Binary, Fun -> -1 20 | | (Grouping | App | Binary | Fun), Atom 21 | | (App | Binary | Fun), Grouping 22 | | (Binary | Fun), App 23 | | Fun, Binary -> 1 24 | ;; 25 | 26 | let equal = fun left right -> compare left right = 0 27 | 28 | let binds_tighter = 29 | fun left ~than:right -> compare left right <= 0 30 | ;; 31 | -------------------------------------------------------------------------------- /lib/Clinic/Diagnostic.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | type t = 4 | { category : Category.t 5 | ; diagnosis : Diagnosis.t 6 | } 7 | 8 | let is_error = 9 | fun diagnostic -> 10 | match diagnostic.category with 11 | | Error -> true 12 | | _ -> false 13 | ;; 14 | 15 | let is_warning = 16 | fun diagnostic -> 17 | match diagnostic.category with 18 | | Warning -> true 19 | | _ -> false 20 | ;; 21 | 22 | let show = 23 | fun painter diagnostic -> 24 | let module Painter = (val painter : Painter.TYPE) in 25 | Printf.sprintf 26 | "%s%s %s" 27 | (Category.show painter diagnostic.category) 28 | (Category.get_painter_function 29 | painter 30 | diagnostic.category 31 | ":") 32 | (Diagnosis.show painter diagnostic.diagnosis) 33 | ;; 34 | -------------------------------------------------------------------------------- /lib/Hooks/Check.ml: -------------------------------------------------------------------------------- 1 | open Batteries.Operators 2 | open Clinic 3 | 4 | let execute = 5 | fun ~doctor ~painter (config : Config.t) program -> 6 | if config.print_program 7 | then 8 | Printf.printf "%s\n---\n" (AIL.Program.show painter program); 9 | let context = 10 | if config.use_compiler_intrinsics 11 | then Some Analysis.intrinsics 12 | else None 13 | in 14 | let maybe_context = 15 | Analysis.check_program ~doctor ?context program 16 | in 17 | Option.iter 18 | (Analysis.Context.show painter *> Printf.printf "%s\n") 19 | maybe_context; 20 | let review = Doctor.review painter doctor in 21 | Option.iter (Printf.eprintf "%s\n") review.details; 22 | match review.decision with 23 | | Abort -> None 24 | | Pass -> Some program 25 | ;; 26 | -------------------------------------------------------------------------------- /lexie.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "a ML-style, CIC-based programming language" 4 | description: "i'll put something here later" 5 | maintainer: ["lexa "] 6 | authors: ["lexa "] 7 | license: "LICENSE" 8 | homepage: "https://github.com/qexat/lexie" 9 | bug-reports: "https://github.com/qexat/lexie/issues" 10 | depends: [ 11 | "dune" {>= "3.17"} 12 | "ocaml" 13 | "cmdliner" {>= "1.3.0"} 14 | "odoc" {with-doc} 15 | ] 16 | build: [ 17 | ["dune" "subst"] {dev} 18 | [ 19 | "dune" 20 | "build" 21 | "-p" 22 | name 23 | "-j" 24 | jobs 25 | "@install" 26 | "@runtest" {with-test} 27 | "@doc" {with-doc} 28 | ] 29 | ] 30 | dev-repo: "git+https://github.com/qexat/lexie.git" 31 | -------------------------------------------------------------------------------- /lib/Hooks/Eval.ml: -------------------------------------------------------------------------------- 1 | open Clinic 2 | 3 | let warn_about_compiler_intrinsics = 4 | fun painter config -> 5 | let review = 6 | Doctor.emit_single_warning 7 | painter 8 | config 9 | Diagnosis.Unsupported_intrinsics_at_runtime 10 | in 11 | Option.iter (Printf.eprintf "%s\n") review.details; 12 | Out_channel.flush stderr 13 | ;; 14 | 15 | let execute = 16 | fun ~doctor ~painter (config : Config.t) program -> 17 | let env = 18 | if config.use_compiler_intrinsics 19 | then ( 20 | warn_about_compiler_intrinsics 21 | painter 22 | (Doctor.get_config doctor); 23 | Some Runtime.Core.intrinsics) 24 | else None 25 | in 26 | let code = Runtime.Core.evaluate ~painter ?env program in 27 | match code = 0 with 28 | | false -> None 29 | | true -> Some () 30 | ;; 31 | -------------------------------------------------------------------------------- /lib/Clinic/Diagnosis.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | (** A record representing a type mismatch. *) 4 | type type_mismatch = 5 | { expected : AIL.Type.t 6 | ; found : AIL.Type.t 7 | } 8 | 9 | (** A record representing information about a term. *) 10 | type term_info = 11 | { term : AIL.Term.t 12 | ; ty : AIL.Type.t 13 | } 14 | 15 | (** The kind of diagnosis. *) 16 | type t = 17 | | Annotation_type_mismatch of type_mismatch 18 | | Argument_type_mismatch of type_mismatch 19 | | Expected_type of AIL.Type.t 20 | | Hole_found 21 | | Name_not_found of Custom.Name.t 22 | | Non_functional_application of term_info 23 | | Unsupported_intrinsics_at_runtime 24 | 25 | (** [show painter diagnosis] produces a pretty-printable 26 | representation of the [diagnosis] using the [painter]. *) 27 | val show : (module Painter.TYPE) -> t -> string 28 | -------------------------------------------------------------------------------- /lib/Custom/Name.ml: -------------------------------------------------------------------------------- 1 | include Batteries.String.Constrain (struct 2 | open Batteries 3 | 4 | let predicate = 5 | fun string -> 6 | String.for_all 7 | (fun char -> 8 | Char.is_alphabetical char || Char.equal char '_') 9 | string 10 | && not (String.equal string "_") 11 | ;; 12 | end) 13 | 14 | module Type = Batteries.String.Constrain (struct 15 | open Batteries 16 | 17 | let predicate = 18 | fun string -> 19 | predicate string 20 | && List.mem string.[0] Char.uppercase_latin_alphabet 21 | ;; 22 | end) 23 | 24 | let is_type = fun name -> Type.predicate (to_string name) 25 | 26 | let show = 27 | fun (module Painter : Painter.TYPE) name -> 28 | if is_type name 29 | then Painter.paint_type (to_string name) 30 | else Painter.paint_name (to_string name) 31 | ;; 32 | -------------------------------------------------------------------------------- /lib/Config/Config.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | type t = 4 | { strict : bool 5 | ; print_program : bool 6 | ; use_compiler_intrinsics : bool 7 | } 8 | 9 | let create = 10 | fun ?(strict = false) 11 | ?(print_program = false) 12 | ?(use_compiler_intrinsics = false) 13 | () -> 14 | { strict; print_program; use_compiler_intrinsics } 15 | ;; 16 | 17 | let show = 18 | let show_pair (module Painter : Painter.TYPE) key value = 19 | Printf.sprintf 20 | "%s = %s" 21 | (Painter.paint_name key) 22 | (Painter.paint_constant value) 23 | in 24 | fun painter 25 | { strict; print_program; use_compiler_intrinsics } -> 26 | Printf.sprintf 27 | "{ %s ; %s ; %s }" 28 | (show_pair painter "strict" (Bool.to_string strict)) 29 | (show_pair 30 | painter 31 | "print_program" 32 | (Bool.to_string print_program)) 33 | (show_pair 34 | painter 35 | "use_compiler_intrinsics" 36 | (Bool.to_string use_compiler_intrinsics)) 37 | ;; 38 | -------------------------------------------------------------------------------- /lib/Batteries/Intp.ml: -------------------------------------------------------------------------------- 1 | type t = int 2 | 3 | let zero = Int.zero 4 | let one = Int.one 5 | let equal = Int.equal 6 | let compare = Int.compare 7 | let succ = Int.succ 8 | let pred = fun p -> if equal p 0 then 0 else Int.pred p 9 | let add = Int.add 10 | 11 | let sub = 12 | fun p1 p2 -> if compare p1 p2 < 0 then 0 else Int.sub p1 p2 13 | ;; 14 | 15 | let mul = Int.mul 16 | let div = Int.div 17 | let modulo = Int.rem 18 | let rem = Int.rem 19 | let min = Int.min 20 | let max = Int.max 21 | let abs = fun p -> p 22 | let to_int = fun p -> p 23 | let to_float = Int.to_float 24 | let to_string = Int.to_string 25 | let of_int = fun i -> if i < 0 then None else Some i 26 | 27 | let of_int_exn = 28 | fun i -> 29 | match of_int i with 30 | | None -> invalid_arg "of_int: integer must be non-negative" 31 | | Some p -> p 32 | ;; 33 | 34 | module Notation = struct 35 | let ( + ) = add 36 | let ( - ) = sub 37 | let ( * ) = mul 38 | let ( / ) = div 39 | let ( mod ) = modulo 40 | let ( % ) = rem 41 | let ( ~++ ) = succ 42 | let ( ~-- ) = pred 43 | end 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2025 lexa 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /lib/Custom/Painter.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Operators 3 | include Painter 4 | 5 | module type TYPE = sig 6 | include TYPE 7 | 8 | val paint_constant : string -> string 9 | val paint_quoted : string -> string 10 | val paint_type : string -> string 11 | val paint_function : string -> string 12 | val paint_keyword : string -> string 13 | val paint_name : string -> string 14 | val paint_hole : string -> string 15 | val paint_error : string -> string 16 | val paint_warning : string -> string 17 | val paint_info : string -> string 18 | val paint_note : string -> string 19 | val paint_bug : string -> string 20 | end 21 | 22 | module Make (Config : CONFIG) : TYPE = struct 23 | include Make (Config) 24 | 25 | let paint_constant = paint_foreground Red 26 | let paint_quoted = paint_foreground Green 27 | let paint_type = paint_foreground Yellow 28 | let paint_function = paint_foreground Blue 29 | let paint_keyword = paint_foreground Magenta *> paint_bold 30 | let paint_name = paint_foreground Cyan 31 | let paint_hole = paint_background ~bright:true Red 32 | let paint_error = paint_foreground Red *> paint_bold 33 | let paint_warning = paint_foreground Yellow *> paint_bold 34 | let paint_info = paint_foreground Cyan *> paint_bold 35 | let paint_note = paint_foreground Magenta *> paint_bold 36 | let paint_bug = paint_background Red *> paint_bold 37 | end 38 | -------------------------------------------------------------------------------- /lib/CLI/Main.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | 3 | let make_term_with_config = 4 | fun func -> 5 | let open Term.Syntax in 6 | let+ strict = 7 | Arg.( 8 | value 9 | & flag 10 | & info [ "strict" ] ~doc:"Set type-checking strict mode") 11 | and+ print_program = 12 | Arg.( 13 | value 14 | & flag 15 | & info 16 | [ "print-program" ] 17 | ~doc:"Print the program that is being processed") 18 | and+ use_compiler_intrinsics = 19 | Arg.( 20 | value 21 | & flag 22 | & info 23 | [ "use-compiler-intrinsics" ] 24 | ~doc:"Use the compiler intrinsics when checking") 25 | and+ show_styling = 26 | Arg.( 27 | value 28 | & opt 29 | (enum 30 | [ "never", `Never 31 | ; "always", `Always 32 | ; "auto", `Auto 33 | ]) 34 | `Auto 35 | & info 36 | [ "show-styling" ] 37 | ~doc:"Print ANSI escape sequences") 38 | in 39 | let config : Config.t = 40 | { strict 41 | ; print_program 42 | ; use_compiler_intrinsics 43 | ; show_styling 44 | } 45 | in 46 | func config 47 | ;; 48 | 49 | let check_subcommand = 50 | Cmd.v (Cmd.info "check") (make_term_with_config Check.execute) 51 | ;; 52 | 53 | let run_subcommand = 54 | Cmd.v (Cmd.info "run") (make_term_with_config Run.execute) 55 | ;; 56 | 57 | let lexie_command = 58 | let doc = "TODO" in 59 | Cmd.group 60 | (Cmd.info "lexie" ~version:"" ~doc) 61 | [ check_subcommand; run_subcommand ] 62 | ;; 63 | 64 | let main () = Cmd.eval' lexie_command 65 | -------------------------------------------------------------------------------- /lib/Runtime/Core.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | module Environment : 4 | Quickmap.TYPE 5 | with type key = Name.t 6 | with type value = Object.t 7 | 8 | (** [evaluate_term ~env term] evaluates the [term] within the 9 | [env]ironment and returns the resulting object. *) 10 | val evaluate_term : env:Environment.t -> AIL.Term.t -> Outcome.t 11 | 12 | (** [apply_term ~env term1 term2] applies [term1] to [term2] 13 | within the [env]ironment and returns the resulting object. *) 14 | val apply_term 15 | : env:Environment.t 16 | -> AIL.Term.t 17 | -> AIL.Term.t 18 | -> Outcome.t 19 | 20 | (** [evaluate_statement ~env ~painter statement] evaluates the 21 | [statement] within the [env]ironment and returns the new 22 | environment. *) 23 | val evaluate_statement 24 | : env:Environment.t 25 | -> painter:(module Painter.TYPE) 26 | -> AIL.Statement.t 27 | -> ( Environment.t 28 | , (Exception.t, Unreachable.t) Either.t ) 29 | result 30 | 31 | (** [evaluate_program ~env ~painter program] evaluates the 32 | program within the [env]ironment and returns the new 33 | environment. *) 34 | val evaluate_program 35 | : env:Environment.t 36 | -> painter:(module Painter.TYPE) 37 | -> AIL.Program.t 38 | -> ( Environment.t 39 | , (Exception.t, Unreachable.t) Either.t ) 40 | result 41 | 42 | (** [evaluate ?env ~painter program] evaluates the program 43 | returns an exit code. *) 44 | val evaluate 45 | : ?env:Environment.t 46 | -> painter:(module Painter.TYPE) 47 | -> AIL.Program.t 48 | -> int 49 | 50 | (** (Incomplete) implementation of the compiler intrinsics at 51 | runtime. *) 52 | val intrinsics : Environment.t 53 | -------------------------------------------------------------------------------- /lib/Clinic/Diagnosis.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | type type_mismatch = 4 | { expected : AIL.Type.t 5 | ; found : AIL.Type.t 6 | } 7 | 8 | type term_info = 9 | { term : AIL.Term.t 10 | ; ty : AIL.Type.t 11 | } 12 | 13 | type t = 14 | | Annotation_type_mismatch of type_mismatch 15 | | Argument_type_mismatch of type_mismatch 16 | | Expected_type of AIL.Type.t 17 | | Hole_found 18 | | Name_not_found of Name.t 19 | | Non_functional_application of term_info 20 | | Unsupported_intrinsics_at_runtime 21 | 22 | let show = 23 | fun painter diagnosis -> 24 | let module Painter = (val painter : Painter.TYPE) in 25 | match diagnosis with 26 | | Annotation_type_mismatch { expected; found } -> 27 | Printf.sprintf 28 | "I expected a value of type %s (as given by the \ 29 | annotation), but found a %s instead" 30 | (AIL.Type.show painter expected) 31 | (AIL.Type.show painter found) 32 | | Argument_type_mismatch { expected; found } -> 33 | Printf.sprintf 34 | "I expected an argument of type %s, but found a %s" 35 | (AIL.Type.show painter expected) 36 | (AIL.Type.show painter found) 37 | | Expected_type ty' -> 38 | Printf.sprintf 39 | "I expect a %s here" 40 | (AIL.Type.show painter ty') 41 | | Hole_found -> Printf.sprintf "there is a hole here" 42 | | Name_not_found name -> 43 | Printf.sprintf 44 | "I could not find the name %s" 45 | (Name.show painter name) 46 | | Non_functional_application { term; ty } -> 47 | Printf.sprintf 48 | "the term %s (of type %s) is not a function, it cannot \ 49 | be applied" 50 | (AIL.Term.show painter term) 51 | (AIL.Type.show painter ty) 52 | | Unsupported_intrinsics_at_runtime -> 53 | "compiler intrinsics are not fully supported by the \ 54 | runtime and may cause unexpected crashes" 55 | ;; 56 | -------------------------------------------------------------------------------- /lib/Batteries/String.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.String 2 | 3 | let indent_line = 4 | fun ?(width = 4) ?(count = 1) ?(marker = ' ') string -> 5 | let indent = Printf.sprintf "%c%*s" marker (width - 1) " " in 6 | Printf.sprintf "%*s%s" count indent string 7 | ;; 8 | 9 | let indent = 10 | fun ?(width = 4) ?(count = 1) ?(marker = ' ') string -> 11 | split_on_char '\n' string 12 | |> List.map (indent_line ~width ~count ~marker) 13 | |> concat "\n" 14 | ;; 15 | 16 | module Notation = struct 17 | let ( <> ) = cat 18 | end 19 | 20 | module type REFINED = sig 21 | type t = private string 22 | 23 | val predicate : string -> bool 24 | val equal : t -> t -> bool 25 | val compare : t -> t -> int 26 | val length : t -> int 27 | val lift : 'r. (string -> string) -> t -> t option 28 | val lift_exn : 'r. (string -> string) -> t -> t 29 | val to_string : t -> string 30 | val to_seq : t -> char Seq.t 31 | val of_string : string -> t option 32 | val of_string_exn : string -> t 33 | end 34 | 35 | module type PREDICATE = sig 36 | val predicate : string -> bool 37 | end 38 | 39 | module Constrain (P : PREDICATE) : REFINED = struct 40 | type t = string 41 | 42 | let predicate = P.predicate 43 | let equal = equal 44 | let compare = compare 45 | let length = length 46 | 47 | let lift = 48 | fun func refined -> 49 | let result = func refined in 50 | match predicate result with 51 | | true -> Some result 52 | | false -> None 53 | ;; 54 | 55 | let lift_exn = 56 | fun func refined -> 57 | match lift func refined with 58 | | None -> 59 | failwith 60 | "func did not return a string that satisfies the \ 61 | predicate" 62 | | Some result -> result 63 | ;; 64 | 65 | let to_string = fun refined -> refined 66 | let to_seq = to_seq 67 | 68 | let of_string = 69 | fun string -> 70 | match predicate string with 71 | | false -> None 72 | | true -> Some string 73 | ;; 74 | 75 | let of_string_exn = 76 | fun string -> 77 | match of_string string with 78 | | None -> 79 | invalid_arg "string does not satisfy the predicate" 80 | | Some refined -> refined 81 | ;; 82 | end 83 | -------------------------------------------------------------------------------- /lib/Batteries/Intp.mli: -------------------------------------------------------------------------------- 1 | (** Represents a non-negative integer (Z+). *) 2 | type t = private int 3 | 4 | (** Zero. *) 5 | val zero : t 6 | 7 | (** One. *) 8 | val one : t 9 | 10 | (** [equal p1 p2] determines whether [p1] and [p2] are equal. *) 11 | val equal : t -> t -> bool 12 | 13 | (** [compare p1 p2] determines whether [p1] is greater, equal or 14 | less than [p2]. *) 15 | val compare : t -> t -> int 16 | 17 | (** [succ p] is [p + 1]. *) 18 | val succ : t -> t 19 | 20 | (** [pred p] is [p - 1], except for [0] where it returns itself. *) 21 | val pred : t -> t 22 | 23 | (** [add p1 p2] is [p1 + p2]. *) 24 | val add : t -> t -> t 25 | 26 | (** [sub p1 p2] is [p1 - p2] for [p1 >= p2] ; otherwise, it 27 | returns [0]. *) 28 | val sub : t -> t -> t 29 | 30 | (** [mul p1 p2] is [p1 * p2]. *) 31 | val mul : t -> t -> t 32 | 33 | (** [div p1 p2] is [p1 / p2]. *) 34 | val div : t -> t -> t 35 | 36 | (** [modulo p1 p2] is [p1 mod p2]. *) 37 | val modulo : t -> t -> t 38 | 39 | (** [rem p1 p2] returns the remainder of the division of [p1] by 40 | [p2]. *) 41 | val rem : t -> t -> t 42 | 43 | (** [min p1 p2] returns the smallest value between [p1] and 44 | [p2]. *) 45 | val min : t -> t -> t 46 | 47 | (** [max p1 p2] returns the largest value between [p1] and 48 | [p2]. *) 49 | val max : t -> t -> t 50 | 51 | (** [abs p] returns [p], since it is always positive. 52 | Exists for consistency with [Int]. *) 53 | val abs : t -> t 54 | 55 | (** [to_int p] converts [p] to a built-in [int]. *) 56 | val to_int : t -> int 57 | 58 | (** [to_float p] converts [p] to a built-in [float]. *) 59 | val to_float : t -> float 60 | 61 | (** [to_string p] converts [p] to a built-in [string]. *) 62 | val to_string : t -> string 63 | 64 | (** [of_int i] converts the integer [i] into a positive one. 65 | Returns [None] if [i] is negative. *) 66 | val of_int : int -> t option 67 | 68 | (** [of_int_exn i] converts the integer [i] into a positive one. 69 | Raises [Invalid_arg] if [i] is negative. *) 70 | val of_int_exn : int -> t 71 | 72 | module Notation : sig 73 | val ( + ) : t -> t -> t 74 | val ( - ) : t -> t -> t 75 | val ( * ) : t -> t -> t 76 | val ( / ) : t -> t -> t 77 | val ( mod ) : t -> t -> t 78 | val ( % ) : t -> t -> t 79 | val ( ~++ ) : t -> t 80 | val ( ~-- ) : t -> t 81 | end 82 | -------------------------------------------------------------------------------- /lib/Clinic/Doctor.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | 3 | module Config = struct 4 | type t = { strict : bool } 5 | 6 | let create = fun ?(strict = false) () -> { strict } 7 | end 8 | 9 | type t = 10 | { config : Config.t 11 | ; mutable diagnostics : Diagnostic.t list 12 | } 13 | 14 | let create = fun config -> { config; diagnostics = [] } 15 | let get_config = fun { config; _ } -> config 16 | 17 | let add_diagnostic = 18 | fun diagnostic doctor -> 19 | doctor.diagnostics <- diagnostic :: doctor.diagnostics 20 | ;; 21 | 22 | let add_error = 23 | fun diagnosis -> 24 | add_diagnostic { category = Error; diagnosis } 25 | ;; 26 | 27 | let add_warning = 28 | fun diagnosis -> 29 | add_diagnostic { category = Warning; diagnosis } 30 | ;; 31 | 32 | let add_info = 33 | fun diagnosis -> add_diagnostic { category = Info; diagnosis } 34 | ;; 35 | 36 | type decision = 37 | | Pass 38 | | Abort 39 | 40 | type review = 41 | { decision : decision 42 | ; details : string option 43 | } 44 | 45 | let make_decision = 46 | fun ~strict diagnostics -> 47 | if 48 | List.exists Diagnostic.is_error diagnostics 49 | || (strict && List.exists Diagnostic.is_warning diagnostics) 50 | then Abort 51 | else Pass 52 | ;; 53 | 54 | let review = 55 | fun painter doctor -> 56 | let decision = 57 | make_decision 58 | ~strict:doctor.config.strict 59 | doctor.diagnostics 60 | in 61 | let details = 62 | doctor.diagnostics 63 | |> List.rev 64 | |> List.map_on_cons (Diagnostic.show painter) 65 | |> Option.map (String.concat "\n") 66 | in 67 | { decision; details } 68 | ;; 69 | 70 | let emit_single_diagnostic = 71 | fun painter config diagnostic -> 72 | let doctor = create config in 73 | add_diagnostic diagnostic doctor; 74 | review painter doctor 75 | ;; 76 | 77 | let emit_single_error = 78 | fun painter config diagnosis -> 79 | emit_single_diagnostic 80 | painter 81 | config 82 | { category = Error; diagnosis } 83 | ;; 84 | 85 | let emit_single_warning = 86 | fun painter config diagnosis -> 87 | emit_single_diagnostic 88 | painter 89 | config 90 | { category = Warning; diagnosis } 91 | ;; 92 | 93 | let emit_single_info = 94 | fun painter config diagnosis -> 95 | emit_single_diagnostic 96 | painter 97 | config 98 | { category = Info; diagnosis } 99 | ;; 100 | -------------------------------------------------------------------------------- /lib/Custom/Quickmap.ml: -------------------------------------------------------------------------------- 1 | module type SHOWABLE = sig 2 | (** The showable type. *) 3 | type t 4 | 5 | (** [show painter value] produces a pretty-printable 6 | represention of the [value] using the [painter]. *) 7 | val show : (module Painter.TYPE) -> t -> string 8 | end 9 | 10 | module type TYPE = sig 11 | (** The [key] of the mapping. *) 12 | type key 13 | 14 | (** The [value] of the mapping. *) 15 | type value 16 | 17 | (** The mapping. *) 18 | type t 19 | 20 | (** A empty mapping. *) 21 | val empty : t 22 | 23 | (** [keys mapping] returns a list of the mapping keys. *) 24 | val keys : t -> key list 25 | 26 | (** [values mapping] returns a list of the mapping values. *) 27 | val values : t -> value list 28 | 29 | (** [get key mapping] returns the value associated with the 30 | [key] in the [mapping] if any. Returns [None] otherwise.*) 31 | val get : key -> t -> value option 32 | 33 | (** [add key value mapping] adds a [key] associated with 34 | [value] in the [mapping]. *) 35 | val add : key -> value -> t -> t 36 | 37 | (** [update key value mapping] updates the associated [value] 38 | of [key] if it exists in the [mapping]. *) 39 | val update : key -> value -> t -> t 40 | 41 | (** [concat mapping1 mapping2] returns a new mapping 42 | containing the entries of the two. *) 43 | val concat : t -> t -> t 44 | 45 | (** [show painter mapping] returns a pretty-printable 46 | representation of the [mapping] using the [painter]. *) 47 | val show : (module Painter.TYPE) -> t -> string 48 | end 49 | 50 | module Make (Key : SHOWABLE) (Value : SHOWABLE) : 51 | TYPE with type key = Key.t with type value = Value.t = struct 52 | type key = Key.t 53 | type value = Value.t 54 | type t = (key * value) list 55 | 56 | let empty = [] 57 | let keys = List.map fst 58 | let values = List.map snd 59 | let get = List.assoc_opt 60 | 61 | let[@tail_mod_cons] rec update = 62 | fun key value mapping -> 63 | match mapping with 64 | | [] -> [] 65 | | (key', _) :: rest when key = key' -> (key, value) :: rest 66 | | (key', value') :: rest -> 67 | (key', value') :: update key value rest 68 | ;; 69 | 70 | let add = fun key value mapping -> (key, value) :: mapping 71 | let concat = List.append 72 | 73 | let show = 74 | fun painter mapping -> 75 | mapping 76 | |> List.rev_map (fun (key, value) -> 77 | Printf.sprintf 78 | "%s : %s" 79 | (Key.show painter key) 80 | (Value.show painter value)) 81 | |> String.concat " ; " 82 | |> Printf.sprintf "[ %s ]" 83 | ;; 84 | end 85 | -------------------------------------------------------------------------------- /lib/Batteries/String.mli: -------------------------------------------------------------------------------- 1 | include module type of Stdlib.String 2 | 3 | (** [indent ~width ~count ~marker text] indents each line of 4 | [text] by [count] tabulations of [width]. [marker] can 5 | be specified if each indent should start with a non- 6 | whitespace marker. *) 7 | val indent : ?width:int -> ?count:int -> ?marker:char -> t -> t 8 | 9 | (** [indent_line ~width ~count ~marker line] indents a 10 | single [line] by [count] tabulations of [width]. 11 | [marker] can specified if the indent should start with a 12 | non-whitespace marker. *) 13 | val indent_line 14 | : ?width:int 15 | -> ?count:int 16 | -> ?marker:char 17 | -> t 18 | -> t 19 | 20 | module Notation : sig 21 | val ( <> ) : t -> t -> t 22 | end 23 | 24 | module type REFINED = sig 25 | (** String that satisfies a predicate. *) 26 | type t = private string 27 | 28 | (** Predicate that is always satisfied by the values of this 29 | type. *) 30 | val predicate : string -> bool 31 | 32 | (** [equal s1 s2] determines whether [s1] and [s2] are the 33 | same string. *) 34 | val equal : t -> t -> bool 35 | 36 | (** [compare s1 s2] determines whether [s1] is 37 | lexicographically before, at the same place or after [s2]. *) 38 | val compare : t -> t -> int 39 | 40 | (** [length s] returns the number of characters in [s]. *) 41 | val length : t -> int 42 | 43 | (** [lift func s] applies [func] to [s] as if it was a normal 44 | string, but preserves the refinement of the output. 45 | Returns [None] if the produced string does not satisfy the 46 | predicate. *) 47 | val lift : 'r. (string -> string) -> t -> t option 48 | 49 | (** [lift_exn func s] is the same as [lift func s], but a 50 | [Failure] exception is raised in the erroneous case. *) 51 | val lift_exn : 'r. (string -> string) -> t -> t 52 | 53 | (** [to_string s] "forgets" the refinement and converts [s] 54 | back to a normal string. *) 55 | val to_string : t -> string 56 | 57 | (** [to_seq s] converts [s] into a sequence of characters. *) 58 | val to_seq : t -> char Seq.t 59 | 60 | (** [of_string s] refines [s] by trying to guarantee that the 61 | output will always satisfy [predicate]. Returns [None] if 62 | it fails to do so. *) 63 | val of_string : string -> t option 64 | 65 | (** [of_string_exn s] is the same as [of_string s], but an 66 | [Invalid_arg] exception is raised in the erroneous case. *) 67 | val of_string_exn : string -> t 68 | end 69 | 70 | module type PREDICATE = sig 71 | val predicate : string -> bool 72 | end 73 | 74 | module Constrain : functor (_ : PREDICATE) -> REFINED 75 | -------------------------------------------------------------------------------- /lib/Compiler/Analysis/Analysis.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | open Clinic 3 | open Common 4 | open AIL 5 | 6 | module Context : 7 | Quickmap.TYPE with type key = Name.t with type value = Type.t 8 | 9 | (** [infer_sort_of_sort sort] infers the sort of [sort]. 10 | Returns [None] if it fails to do so. *) 11 | val infer_sort_of_sort : Sort.t -> Sort.t option 12 | 13 | (** [infer_type_of_type ~doctor ~context ty] infers the ty 14 | of [ty] given a [context]. 15 | Returns [None] if it fails to do so. *) 16 | val infer_type_of_type 17 | : doctor:Doctor.t 18 | -> context:Context.t 19 | -> Type.t 20 | -> Type.t option 21 | 22 | (** [infer_type_of_term ~doctor ~context term] infers the type 23 | of [term] given a [context]. 24 | Returns [None] if it fails to do so. *) 25 | val infer_type_of_term 26 | : doctor:Doctor.t 27 | -> context:Context.t 28 | -> Term.t 29 | -> Type.t option 30 | 31 | (** [infer_type_of_primitive primitive] infers the type of 32 | [primitive] given a [context]. 33 | Returns [None] if it fails to do so. *) 34 | val infer_type_of_primitive : Primitive.t -> Type.t option 35 | 36 | (** [infer_type_of_parameter] infers the type of [parameter] 37 | given a [context]. 38 | Returns [None] if it fails to do so. *) 39 | val infer_type_of_parameter : Parameter.t -> Type.t option 40 | 41 | (** [check_type ~doctor ~expected found] determines whether the 42 | type [found] is compatible with the [expected] one. *) 43 | val check_type 44 | : doctor:Doctor.t 45 | -> expected:Type.t 46 | -> Type.t 47 | -> bool 48 | 49 | (** [check_sort ~expected found] determines whether the sort 50 | [found] is compatible with the [expected] one. *) 51 | val check_sort : expected:Sort.t -> Sort.t -> bool 52 | 53 | (** [check_term ~doctor ~expected found] determines whether the 54 | term [found] is compatible with the [expected] one. *) 55 | val check_term 56 | : doctor:Doctor.t 57 | -> expected:Term.t 58 | -> Term.t 59 | -> bool 60 | 61 | (** [check_parameter ~doctor ~expected found] determines whether 62 | the parameter [found] is compatible with the [expected] one. *) 63 | val check_parameter 64 | : doctor:Doctor.t 65 | -> expected:Parameter.t 66 | -> Parameter.t 67 | -> bool 68 | 69 | (** [check_statement ~doctor ~context statement] infers given 70 | a [context] the type of underlying terms and checks whether 71 | the [statement] is type-safe. 72 | Returns the new context, or [None] upon failure. *) 73 | val check_statement 74 | : doctor:Doctor.t 75 | -> context:Context.t 76 | -> Statement.t 77 | -> Context.t option 78 | 79 | (** [check_program ~doctor ?context program] infers given a 80 | [context] the type of underlying terms and checks whether 81 | the [program] is type-safe. 82 | If [context] is not provided, an empty one is created. 83 | Returns the new context, or [None] upon failure. *) 84 | val check_program 85 | : doctor:Doctor.t 86 | -> ?context:Context.t 87 | -> Program.t 88 | -> Context.t option 89 | 90 | (** Compiler intrinsics. *) 91 | val intrinsics : Context.t 92 | -------------------------------------------------------------------------------- /lib/Clinic/Doctor.mli: -------------------------------------------------------------------------------- 1 | open Custom 2 | 3 | (** A doctor manages diagnostics. *) 4 | type t 5 | 6 | module Config : sig 7 | type t = { strict : bool } 8 | 9 | (** [create ?strict ()] creates a clinic configuration without 10 | having to specify all fields, providing good defaults. *) 11 | val create : ?strict:bool -> unit -> t 12 | end 13 | 14 | (** [create config] creates a new doctor given a [config]. *) 15 | val create : Config.t -> t 16 | 17 | (** [get_config doctor] returns the config that was used to 18 | create the [doctor]. *) 19 | val get_config : t -> Config.t 20 | 21 | (** [add_diagnostic diagnostic doctor] adds the [diagnostic] to 22 | the [doctor] documents. *) 23 | val add_diagnostic : Diagnostic.t -> t -> unit 24 | 25 | (** [add_error diagnosis doctor] is a shorthand to create an 26 | [Error] diagnostic given a [diagnosis] and add the latter to 27 | the [doctor] documents. *) 28 | val add_error : Diagnosis.t -> t -> unit 29 | 30 | (** [add_warning diagnosis doctor] is a shorthand to create an 31 | [Warning] diagnostic given a [diagnosis] and add the latter 32 | to the [doctor] documents. *) 33 | val add_warning : Diagnosis.t -> t -> unit 34 | 35 | (** [add_info diagnosis doctor] is a shorthand to create an 36 | [Info] diagnostic given a [diagnosis] and add the latter 37 | to the [doctor] documents. *) 38 | val add_info : Diagnosis.t -> t -> unit 39 | 40 | (** Represents a doctor decision after analysing the diagnostics 41 | it has registered. *) 42 | type decision = 43 | | Pass 44 | | Abort 45 | 46 | (** The result of a doctor review of the registered diagnostics. *) 47 | type review = 48 | { decision : decision 49 | ; details : string option 50 | } 51 | 52 | (** [review painter doctor] reviews the currently registered 53 | diagnostics and render the result using the [painter]. *) 54 | val review : (module Painter.TYPE) -> t -> review 55 | 56 | (** [emit_single_diagnostic painter config diagnostic] is a 57 | shorthand to create a temporary doctor with the given 58 | [config], add the [diagnostic], and immediately review it 59 | using the [painter]. *) 60 | val emit_single_diagnostic 61 | : (module Painter.TYPE) 62 | -> Config.t 63 | -> Diagnostic.t 64 | -> review 65 | 66 | (** [emit_single_error painter config diagnosis] is the same as 67 | [emit_single_diagnostic] but the diagnostic is an error 68 | created using the [diagnosis]. *) 69 | val emit_single_error 70 | : (module Painter.TYPE) 71 | -> Config.t 72 | -> Diagnosis.t 73 | -> review 74 | 75 | (** [emit_single_error painter config diagnosis] is the same as 76 | [emit_single_diagnostic] but the diagnostic is a warning 77 | created using the [diagnosis]. *) 78 | val emit_single_warning 79 | : (module Painter.TYPE) 80 | -> Config.t 81 | -> Diagnosis.t 82 | -> review 83 | 84 | (** [emit_single_error painter config diagnosis] is the same as 85 | [emit_single_diagnostic] but the diagnostic is an info 86 | created using the [diagnosis]. *) 87 | val emit_single_info 88 | : (module Painter.TYPE) 89 | -> Config.t 90 | -> Diagnosis.t 91 | -> review 92 | -------------------------------------------------------------------------------- /lib/Batteries/Painter.ml: -------------------------------------------------------------------------------- 1 | (** [color] represents the painter palette. *) 2 | type color = 3 | | None 4 | | Red 5 | | Yellow 6 | | Green 7 | | Cyan 8 | | Blue 9 | | Magenta 10 | | Black 11 | | White 12 | 13 | (** [check_tty ()] checks whether the stdout & stderr are TTYs. *) 14 | let check_tty () : bool = 15 | Out_channel.isatty stdout && Out_channel.isatty stderr 16 | ;; 17 | 18 | module type CONFIG = sig 19 | val show_styling : [ `Never | `Always | `Auto ] 20 | end 21 | 22 | module type TYPE = sig 23 | (** The type of a painter. *) 24 | 25 | (** [make_intelligent_painter painter] takes a dumb [painter] 26 | that always paints and make it only paint according to 27 | a configuration and/or whether the stdout & stderr are 28 | TTYs. *) 29 | val make_intelligent_painter 30 | : (string -> string) 31 | -> string 32 | -> string 33 | 34 | (** [paint_bold string] paints [string] in bold. *) 35 | val paint_bold : string -> string 36 | 37 | (** [paint_dim string] paints [string] in dim. *) 38 | val paint_dim : string -> string 39 | 40 | (** [paint_italic string] paints [string] in italic. *) 41 | val paint_italic : string -> string 42 | 43 | (** [paint_underlined string] paints [string] underlined. *) 44 | val paint_underlined : string -> string 45 | 46 | (** [paint_foreground ?bright color string] paints [string] in 47 | the [color]. *) 48 | val paint_foreground 49 | : ?bright:bool 50 | -> color 51 | -> string 52 | -> string 53 | 54 | (** [paint_background ?bright color string] paints the 55 | background of [string] in the [color]. *) 56 | val paint_background 57 | : ?bright:bool 58 | -> color 59 | -> string 60 | -> string 61 | end 62 | 63 | module Make (Config : CONFIG) : TYPE = struct 64 | let make_intelligent_painter = 65 | fun painter string -> 66 | match Config.show_styling with 67 | | `Never -> string 68 | | `Always -> painter string 69 | | `Auto -> if check_tty () then painter string else string 70 | ;; 71 | 72 | let make_ansi_painter = 73 | fun opener closer -> 74 | make_intelligent_painter (fun string -> 75 | Printf.sprintf "\x1b[%dm%s\x1b[%dm" opener string closer) 76 | ;; 77 | 78 | let paint_bold = make_ansi_painter 1 22 79 | let paint_dim = make_ansi_painter 2 22 80 | let paint_italic = make_ansi_painter 3 23 81 | let paint_underlined = make_ansi_painter 4 24 82 | 83 | let color_to_int = function 84 | | Black -> 0 85 | | Red -> 1 86 | | Green -> 2 87 | | Yellow -> 3 88 | | Blue -> 4 89 | | Magenta -> 5 90 | | Cyan -> 6 91 | | White -> 7 92 | | None -> 9 93 | ;; 94 | 95 | let paint_foreground = 96 | fun ?(bright = false) color -> 97 | let opener = 98 | color_to_int color + if bright then 40 else 30 99 | in 100 | make_ansi_painter opener 39 101 | ;; 102 | 103 | let paint_background = 104 | fun ?(bright = false) color -> 105 | let opener = 106 | color_to_int color + if bright then 100 else 90 107 | in 108 | make_ansi_painter opener 49 109 | ;; 110 | end 111 | -------------------------------------------------------------------------------- /lib/Runtime/Core.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Custom 3 | module Environment = Quickmap.Make (Name) (Object) 4 | 5 | let rec evaluate_term = 6 | fun ~env term -> 7 | let open Exception in 8 | match (term : AIL.Term.t) with 9 | | App (func, arg) -> apply_term ~env func arg 10 | | Fun (param, ret) -> 11 | Ok (Object.Fun (AIL.Parameter.name param, Object.Late ret)) 12 | | Hole -> 13 | Error (Either.Left { kind = Exception.Incomplete_program }) 14 | | Primitive prim -> Ok (Object.Constant prim) 15 | | Var name -> 16 | (match Environment.get name env with 17 | | Some obj -> Ok obj 18 | | None -> 19 | Error (Either.Right (Unreachable.Undefined_name name))) 20 | 21 | and apply_term = 22 | fun ~env func arg -> 23 | let* func_object = evaluate_term ~env func in 24 | let* arg_object = evaluate_term ~env arg in 25 | match func_object with 26 | | Fun (param, Late ret) -> 27 | let* ret' = 28 | evaluate_term 29 | ~env:(Environment.add param arg_object env) 30 | ret 31 | in 32 | Ok ret' 33 | | Fun (_, ret) -> Ok ret 34 | | _ -> Error (Either.Right Unreachable.Illegal_application) 35 | ;; 36 | 37 | let evaluate_statement = 38 | fun ~env ~painter stmt -> 39 | match (stmt : AIL.Statement.t) with 40 | | Let (name, _, body) -> 41 | let* body_object = evaluate_term ~env body in 42 | Ok (Environment.add name body_object env) 43 | | Print term -> 44 | let* term_object = evaluate_term ~env term in 45 | Printf.printf "%s\n" (Object.show painter term_object); 46 | Ok env 47 | ;; 48 | 49 | let rec evaluate_program = 50 | fun ~env ~painter program -> 51 | match program with 52 | | [] -> Ok env 53 | | first :: rest -> 54 | let* env = evaluate_statement ~env ~painter first in 55 | evaluate_program ~env ~painter rest 56 | ;; 57 | 58 | let print_exception = 59 | fun ~painter exn -> 60 | let module Painter = (val painter : Painter.TYPE) in 61 | Printf.eprintf 62 | "%s %s\n" 63 | (Painter.paint_error "runtime error:") 64 | (Exception.show painter exn) 65 | ;; 66 | 67 | let print_unreachable = 68 | fun ~painter unreachable -> 69 | let module Painter = (val painter : Painter.TYPE) in 70 | let tag = Painter.paint_error "internal error:" in 71 | let tag_ext = Painter.paint_info "unreachable:" in 72 | Printf.eprintf 73 | "%s %s %s\n" 74 | tag 75 | tag_ext 76 | (Unreachable.show painter unreachable) 77 | ;; 78 | 79 | let evaluate = 80 | fun ?env ~painter program -> 81 | let env = env or Environment.empty in 82 | match evaluate_program ~env ~painter program with 83 | | Ok _ -> 0 84 | | Error (Either.Left exn) -> 85 | print_exception ~painter exn; 86 | 1 87 | | Error (Either.Right unreachable) -> 88 | print_unreachable ~painter unreachable; 89 | 126 90 | ;; 91 | 92 | let intrinsics = 93 | let _Nat = Name.of_string_exn "Nat" in 94 | let _O = Name.of_string_exn "O" in 95 | let _S = Name.of_string_exn "S" in 96 | let n = Name.of_string_exn "n" in 97 | Environment.empty 98 | |> Environment.add _Nat (Object.Late (Var _Nat)) 99 | |> Environment.add _O (Object.Constant (Nat Intp.zero)) 100 | |> Environment.add _S (Object.Fun (n, Late Hole)) 101 | ;; 102 | -------------------------------------------------------------------------------- /lib/CLI/Sample.ml: -------------------------------------------------------------------------------- 1 | open Custom 2 | open AIL 3 | 4 | let id = Name.of_string_exn "id" 5 | let hummingbird = Name.of_string_exn "hummingbird" 6 | let vireo = Name.of_string_exn "vireo" 7 | let delta = Name.of_string_exn "delta" 8 | let _A = Name.of_string_exn "A" 9 | let _B = Name.of_string_exn "B" 10 | let _C = Name.of_string_exn "C" 11 | let a = Name.of_string_exn "a" 12 | let b = Name.of_string_exn "b" 13 | let c = Name.of_string_exn "c" 14 | let _T = Name.of_string_exn "T" 15 | let _Nat = Name.of_string_exn "Nat" 16 | let _Unit = Name.of_string_exn "Unit" 17 | let x = Name.of_string_exn "x" 18 | let _S = Name.of_string_exn "S" 19 | let _O = Name.of_string_exn "O" 20 | 21 | let lambda3 = 22 | fun param1 param2 param3 ret -> 23 | Term.lambda 24 | param1 25 | (Term.lambda param2 (Term.lambda param3 ret)) 26 | ;; 27 | 28 | let lambda6 = 29 | fun param1 param2 param3 param4 param5 param6 ret -> 30 | lambda3 31 | param1 32 | param2 33 | param3 34 | (lambda3 param4 param5 param6 ret) 35 | ;; 36 | 37 | let arrow2 = 38 | fun param1 param2 ret -> 39 | Type.arrow 40 | (Named (a, param1)) 41 | (Arrow (Named (b, param2), ret)) 42 | ;; 43 | 44 | let arrow3 = 45 | fun param1 param2 param3 ret -> 46 | Type.arrow 47 | (Named (a, param1)) 48 | (Arrow (Named (b, param2), Arrow (Named (c, param3), ret))) 49 | ;; 50 | 51 | let app3 = fun x y z -> Term.app (Term.app2 x y z) 52 | let app4 = fun x y z a -> Term.app (app3 x y z a) 53 | 54 | let faulty_program = 55 | [ Statement.let' 56 | hummingbird 57 | (lambda6 58 | (Named (_A, Sort Sort.Type)) 59 | (Named (_B, Sort Sort.Type)) 60 | (Named (_C, Sort Sort.Type)) 61 | (Named 62 | ( a 63 | , arrow3 64 | (Term (Var _B)) 65 | (Term (Var _C)) 66 | (Term (Var _B)) 67 | (Term (Var _A)) )) 68 | (Named (b, Term (Var _B))) 69 | (Named (c, Term (Var _C))) 70 | (app3 (Var a) (Var b) (Var c) (Var b))) 71 | ; Statement.let' 72 | vireo 73 | (lambda6 74 | (Named (_A, Sort Sort.Type)) 75 | (Named (_B, Sort Sort.Type)) 76 | (Named (_C, Sort Sort.Type)) 77 | (Named (a, Term (Var _A))) 78 | (Named (b, Term (Var _B))) 79 | (Named 80 | ( c 81 | , arrow2 82 | (Term (Var _A)) 83 | (Term (Var _B)) 84 | (Term (Var _C)) )) 85 | (Term.app2 (Var c) (Var a) (Var b))) 86 | ; Statement.let' 87 | delta 88 | (lambda3 89 | (Named (_A, Sort Sort.Type)) 90 | (Named (_B, Sort Sort.Type)) 91 | (Named (_C, Sort Sort.Type)) 92 | (app4 93 | (Var hummingbird) 94 | (Var _A) 95 | (Var _B) 96 | (Var _C) 97 | (app3 (Var vireo) (Var _A) (Var _B) (Var _C)))) 98 | ] 99 | ;; 100 | 101 | let working_program = 102 | [ Statement.let' 103 | id 104 | (Term.lambda 105 | (Named (_T, Sort Sort.Type)) 106 | (Term.lambda (Named (x, Term (Var _T))) (Var x))) 107 | ; Statement.print 108 | (Term.app2 (Term.var id) (Term.var _Nat) (Var _O)) 109 | ] 110 | ;; 111 | 112 | let program = working_program 113 | -------------------------------------------------------------------------------- /lib/Compiler/Analysis/Analysis.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Custom 3 | open Clinic 4 | open Common 5 | open AIL 6 | module Context = Quickmap.Make (Name) (Type) 7 | 8 | let nat = Name.of_string_exn "Nat" 9 | let unit = Name.of_string_exn "Unit" 10 | 11 | let fetch_term 12 | : doctor:Doctor.t 13 | -> context:Context.t 14 | -> Name.t 15 | -> Type.t option 16 | = 17 | fun ~doctor ~context name -> 18 | Context.get name context 19 | |> Option.on_none (fun () -> 20 | Doctor.add_error (Diagnosis.Name_not_found name) doctor) 21 | ;; 22 | 23 | let infer_sort_of_sort : Sort.t -> Sort.t option = 24 | fun _ -> Some Sort.Type 25 | ;; 26 | 27 | let infer_type_of_primitive = 28 | fun prim -> 29 | (match (prim : Primitive.t) with 30 | | Nat _ -> nat 31 | | Unit -> unit) 32 | |> Term.var 33 | |> Type.term 34 | |> Option.some 35 | ;; 36 | 37 | let infer_type_of_parameter : Parameter.t -> Type.t option = 38 | fun parameter -> 39 | match parameter with 40 | | Named (_, ty) -> Some ty 41 | ;; 42 | 43 | let rec infer_type_of_type 44 | : doctor:Doctor.t 45 | -> context:Context.t 46 | -> Type.t 47 | -> Type.t option 48 | = 49 | fun ~doctor ~context ty -> 50 | match ty with 51 | | Arrow _ -> Some (Sort Type) 52 | | Sort sort -> 53 | let+ sort_sort = infer_sort_of_sort sort in 54 | Some (Type.Sort sort_sort) 55 | | Term term -> infer_type_of_term ~doctor ~context term 56 | 57 | and infer_type_of_term 58 | : doctor:Doctor.t 59 | -> context:Context.t 60 | -> Term.t 61 | -> Type.t option 62 | = 63 | fun ~doctor ~context term -> 64 | match term with 65 | | App (func, arg) -> try_apply ~doctor ~context func arg 66 | | Fun ((Named (name, ty) as param), ret) -> 67 | let+ param_type = infer_type_of_parameter param in 68 | let+ ret_type = 69 | infer_type_of_term 70 | ~doctor 71 | ~context:(Context.add name ty context) 72 | ret 73 | in 74 | Some (Type.Arrow (Named (name, param_type), ret_type)) 75 | | Hole -> 76 | Doctor.add_warning Diagnosis.Hole_found doctor; 77 | Some (Term Hole) 78 | | Primitive prim -> infer_type_of_primitive prim 79 | | Var name -> fetch_term ~doctor ~context name 80 | 81 | and check_type 82 | : doctor:Doctor.t -> expected:Type.t -> Type.t -> bool 83 | = 84 | fun ~doctor ~expected found -> 85 | match ((expected, found) : Type.t * Type.t) with 86 | | ( Arrow (Named (_, e_type), e_ret) 87 | , Arrow (Named (_, f_type), f_ret) ) -> 88 | check_type ~doctor ~expected:e_type f_type 89 | && check_type ~doctor ~expected:e_ret f_ret 90 | | Sort e_sort, Sort f_sort -> 91 | check_sort ~expected:e_sort f_sort 92 | | Term Hole, _ -> true 93 | | _, Term Hole -> 94 | Doctor.add_info (Diagnosis.Expected_type expected) doctor; 95 | true 96 | | Term e_term, Term f_term -> 97 | check_term ~doctor ~expected:e_term f_term 98 | | _, _ -> false 99 | 100 | and check_sort : expected:Sort.t -> Sort.t -> bool = 101 | fun ~expected found -> 102 | match ((expected, found) : Sort.t * Sort.t) with 103 | | Prop, Prop -> true 104 | | Type, Type -> true 105 | | _, _ -> false 106 | 107 | and check_term 108 | : doctor:Doctor.t -> expected:Term.t -> Term.t -> bool 109 | = 110 | fun ~doctor ~expected found -> 111 | match ((expected, found) : Term.t * Term.t) with 112 | | App (e_func, e_arg), App (f_func, f_arg) -> 113 | check_term ~doctor ~expected:e_func f_func 114 | && check_term ~doctor ~expected:e_arg f_arg 115 | | Fun (e_param, e_ret), Fun (f_param, f_ret) -> 116 | check_parameter ~doctor ~expected:e_param f_param 117 | && check_term ~doctor ~expected:e_ret f_ret 118 | | Hole, _ -> true 119 | | _, Hole -> 120 | Doctor.add_info 121 | (Diagnosis.Expected_type (Term expected)) 122 | doctor; 123 | true 124 | | Primitive e_prim, Primitive f_prim -> 125 | Primitive.equal e_prim f_prim 126 | | Var e_name, Var f_name -> Name.equal e_name f_name 127 | | _, _ -> false 128 | 129 | and check_parameter 130 | : doctor:Doctor.t 131 | -> expected:Parameter.t 132 | -> Parameter.t 133 | -> bool 134 | = 135 | fun ~doctor ~expected found -> 136 | match expected, found with 137 | | Named (_, e_type), Named (_, f_type) -> 138 | check_type ~doctor ~expected:e_type f_type 139 | 140 | and try_apply 141 | : doctor:Doctor.t 142 | -> context:Context.t 143 | -> Term.t 144 | -> Term.t 145 | -> Type.t option 146 | = 147 | fun ~doctor ~context func arg -> 148 | let+ func_type = infer_type_of_term ~doctor ~context func in 149 | let+ arg_type = infer_type_of_term ~doctor ~context arg in 150 | match (func_type : Type.t) with 151 | | Arrow (Named (name, ty), ret) -> 152 | (match check_type ~doctor ~expected:ty arg_type with 153 | | false -> 154 | Doctor.add_error 155 | (Diagnosis.Argument_type_mismatch 156 | { expected = ty; found = arg_type }) 157 | doctor; 158 | None 159 | | true -> 160 | let right = 161 | propagate_parameter 162 | (Parameter.Named (name, Type.term arg)) 163 | ret 164 | in 165 | Some right) 166 | | _ -> 167 | Doctor.add_error 168 | (Diagnosis.Non_functional_application 169 | { term = func; ty = func_type }) 170 | doctor; 171 | None 172 | 173 | and propagate_parameter : Parameter.t -> Type.t -> Type.t = 174 | fun (Named (param_name, param_type)) rest -> 175 | let propagate = 176 | propagate_parameter (Named (param_name, param_type)) 177 | in 178 | match rest with 179 | | Arrow (Named (name, ty), ret) -> 180 | Type.arrow (Named (name, propagate ty)) (propagate ret) 181 | | Sort _ -> rest 182 | | Term term -> 183 | (match term with 184 | | Fun (Named (param_name', param_type'), ret') -> 185 | Type.term 186 | (Term.lambda 187 | (Named (param_name', propagate param_type')) 188 | ret') 189 | | Var name when Name.equal name param_name -> param_type 190 | | _ -> Type.term term) 191 | ;; 192 | 193 | let compare_with_annotation 194 | : doctor:Doctor.t 195 | -> annotation:Type.t option 196 | -> Type.t 197 | -> Type.t option 198 | = 199 | fun ~doctor ~annotation found_type -> 200 | match annotation with 201 | | None -> Some found_type 202 | | Some ty -> 203 | (match check_type ~doctor ~expected:ty found_type with 204 | | false -> 205 | Doctor.add_warning 206 | (Diagnosis.Annotation_type_mismatch 207 | { expected = ty; found = found_type }) 208 | doctor; 209 | Some found_type 210 | | true -> Some ty) 211 | ;; 212 | 213 | let check_statement 214 | : doctor:Doctor.t 215 | -> context:Context.t 216 | -> Statement.t 217 | -> Context.t option 218 | = 219 | fun ~doctor ~context statement -> 220 | match (statement : Statement.t) with 221 | | Let (name, annotation, body) -> 222 | let+ body_type = infer_type_of_term ~doctor ~context body in 223 | let+ assigned_type = 224 | compare_with_annotation ~doctor ~annotation body_type 225 | in 226 | Some (Context.add name assigned_type context) 227 | | Print term -> 228 | let+ _ = infer_type_of_term ~doctor ~context term in 229 | Some context 230 | ;; 231 | 232 | let rec check_program 233 | : doctor:Doctor.t 234 | -> ?context:Context.t 235 | -> Program.t 236 | -> Context.t option 237 | = 238 | fun ~doctor ?(context = Context.empty) program -> 239 | match program with 240 | | [] -> Some context 241 | | first :: rest -> 242 | let+ context = check_statement ~doctor ~context first in 243 | check_program ~doctor ~context rest 244 | ;; 245 | 246 | let intrinsics : Context.t = 247 | let _Nat = Name.of_string_exn "Nat" in 248 | let _Unit = Name.of_string_exn "Unit" in 249 | let _O = Name.of_string_exn "O" in 250 | let _S = Name.of_string_exn "S" in 251 | let n = Name.of_string_exn "n" in 252 | Context.empty 253 | |> Context.add _Nat (Type.sort Type) 254 | |> Context.add _Unit (Type.sort Type) 255 | |> Context.add _O (Type.term (Var _Nat)) 256 | |> Context.add 257 | _S 258 | (Type.arrow 259 | (Named (n, Type.term (Var _Nat))) 260 | (Term (Var _Nat))) 261 | ;; 262 | -------------------------------------------------------------------------------- /lib/Compiler/AIL/AIL.ml: -------------------------------------------------------------------------------- 1 | open Batteries.Operators 2 | open Custom 3 | open Common 4 | 5 | module Sort : sig 6 | type t = 7 | | Prop 8 | | Type 9 | 10 | (** [show painter sort] produces a pretty-printable 11 | representation of the [sort] using the [painter]. *) 12 | val show : (module Custom.Painter.TYPE) -> t -> string 13 | end = struct 14 | (* TODO: universes *) 15 | type t = 16 | | Prop 17 | | Type 18 | 19 | let show = 20 | fun (module Painter : Painter.TYPE) -> function 21 | | Prop -> Painter.paint_type "Prop" 22 | | Type -> Painter.paint_type "Type" 23 | ;; 24 | end 25 | 26 | module rec Type : sig 27 | type t = 28 | | Arrow of Parameter.t * t 29 | | Sort of Sort.t 30 | | Term of Term.t 31 | 32 | (** [arrow param ret] produces an arrow type where [param] and 33 | [ret] are on the left and right handside of the arrow 34 | respectively. *) 35 | val arrow : Parameter.t -> t -> t 36 | 37 | (** [sort s] produces a sort type where [s] is the underlying 38 | sort. *) 39 | val sort : Sort.t -> t 40 | 41 | (** [term t] produces a term type where [t] is the underlying 42 | term. *) 43 | val term : Term.t -> t 44 | 45 | (** [show painter ty] produces a pretty-printable 46 | representation of [ty]. *) 47 | val show : (module Painter.TYPE) -> t -> string 48 | end = struct 49 | type t = 50 | | Arrow of Parameter.t * t 51 | | Sort of Sort.t 52 | | Term of Term.t 53 | 54 | let arrow = fun param ret -> Arrow (param, ret) 55 | let sort = fun sort -> Sort sort 56 | let term = fun term -> Term term 57 | 58 | let rec show = 59 | fun painter ty -> 60 | match ty with 61 | | Arrow (param, ret) -> 62 | Printf.sprintf 63 | "%s -> %s" 64 | (Parameter.show painter param) 65 | (show painter ret) 66 | | Sort sort -> Sort.show painter sort 67 | | Term term -> Term.show painter term 68 | ;; 69 | end 70 | 71 | and Term : sig 72 | open Batteries 73 | open Custom 74 | 75 | type t = 76 | | App of t * t 77 | | Fun of Parameter.t * t 78 | | Hole 79 | | Primitive of Primitive.t 80 | | Var of Name.t 81 | 82 | (** {2 Constructors} *) 83 | 84 | (** [app t1 t2] produces an application term where [t1] is the 85 | functional term and [t2] is the argument. *) 86 | val app : t -> t -> t 87 | 88 | (** [lambda param term] produces the function term where 89 | [param] is the parameter and [term] the body. Note that 90 | functions are curried. *) 91 | val lambda : Parameter.t -> t -> t 92 | 93 | (** [hole] is the hole term. *) 94 | val hole : t 95 | 96 | (** [primitive prim] produces a primitive term from a 97 | primitive value. *) 98 | val primitive : Primitive.t -> t 99 | 100 | (** [var name] produces a variable term from a [name]. *) 101 | val var : Name.t -> t 102 | 103 | (** {2 Shorthands} *) 104 | 105 | (** [app2 t1 t2 t3] produces an application term where [t1] 106 | is the functional term and [t2] and [t3] are the first 107 | and second arguments respectively. *) 108 | val app2 : t -> t -> t -> t 109 | 110 | (** [nat n] produces a primitive [Nat] term given a positive 111 | integer [n].*) 112 | val nat : Intp.t -> t 113 | 114 | (** [unit] is the primitive [Unit] term. *) 115 | val unit : t 116 | 117 | (** {2 Other} *) 118 | 119 | (** [to_syntactic_kind term] returns the syntactic kind of the 120 | given [term]. *) 121 | val to_syntactic_kind : t -> Syntactic_kind.t 122 | 123 | (** [show painter term] produces a pretty-printable 124 | representation of [term]. *) 125 | val show : (module Painter.TYPE) -> t -> string 126 | end = struct 127 | open Common 128 | 129 | type t = 130 | | App of t * t 131 | | Fun of Parameter.t * t 132 | | Hole 133 | | Primitive of Primitive.t 134 | | Var of Name.t 135 | 136 | (* Constructors *) 137 | let app = fun func arg -> App (func, arg) 138 | let lambda = fun param ret -> Fun (param, ret) 139 | let hole = Hole 140 | let primitive = fun prim -> Primitive prim 141 | let var = fun name -> Var name 142 | 143 | (* Shorthands *) 144 | let app2 = fun func arg1 arg2 -> app (app func arg1) arg2 145 | let nat = fun n -> primitive (Primitive.nat n) 146 | let unit = primitive Primitive.unit 147 | 148 | (* Functions *) 149 | let to_syntactic_kind : t -> Syntactic_kind.t = function 150 | | App _ -> App 151 | | Fun _ -> Fun 152 | | Hole | Primitive _ | Var _ -> Atom 153 | ;; 154 | 155 | let rec uncurry_function = 156 | fun term -> 157 | match term with 158 | | Fun (param, ret) -> 159 | let rest, inner_ret = uncurry_function ret in 160 | param :: rest, inner_ret 161 | | _ -> [], term 162 | ;; 163 | 164 | let rec uncurry_application = 165 | fun func -> 166 | match func with 167 | | App (func', last_arg) -> 168 | let inner_func, args = uncurry_application func' in 169 | inner_func, args ++ [ last_arg ] 170 | | _ -> func, [] 171 | ;; 172 | 173 | let rec show = 174 | fun painter term -> 175 | let module Painter = (val painter : Painter.TYPE) in 176 | match term with 177 | | App (func, arg) -> 178 | let func, args = uncurry_application func in 179 | Printf.sprintf 180 | "%s %s" 181 | (show_considering_precedence painter func ~parent:term) 182 | (args ++ [ arg ] 183 | |> List.map 184 | (show_considering_precedence painter ~parent:term) 185 | |> String.concat " ") 186 | | Fun (param, ret) -> 187 | let params, ret = uncurry_function ret in 188 | Printf.sprintf 189 | "%s %s -> %s" 190 | (Painter.paint_keyword "fun") 191 | (param :: params 192 | |> List.map (Parameter.show painter) 193 | |> String.concat " ") 194 | (show_considering_precedence painter ret ~parent:term) 195 | | Hole -> Painter.paint_hole "_" 196 | | Primitive prim -> Primitive.show (module Painter) prim 197 | | Var name -> Name.show (module Painter) name 198 | 199 | and show_considering_precedence = 200 | fun painter term ~parent -> 201 | let module Painter = (val painter : Painter.TYPE) in 202 | let repr = show (module Painter) term in 203 | if 204 | Syntactic_kind.binds_tighter 205 | (to_syntactic_kind parent) 206 | ~than:(to_syntactic_kind term) 207 | then "(" <> repr <> ")" 208 | else repr 209 | ;; 210 | end 211 | 212 | and Parameter : sig 213 | type nonrec t = Named of Name.t * Type.t 214 | 215 | (** [name param] returns the name of the [param]eter. *) 216 | val name : t -> Name.t 217 | 218 | (** [ty param] returns the type annotation of the [param]eter. *) 219 | val ty : t -> Type.t 220 | 221 | (** [show painter param] produces a pretty-printable 222 | representation of the [param]eter. *) 223 | val show : (module Painter.TYPE) -> t -> string 224 | end = struct 225 | type nonrec t = Named of Name.t * Type.t 226 | 227 | let name = function 228 | | Named (name, _) -> name 229 | ;; 230 | 231 | let ty = function 232 | | Named (_, ty) -> ty 233 | ;; 234 | 235 | let show = 236 | fun painter parameter -> 237 | match parameter with 238 | | Named (name, ty) -> 239 | Printf.sprintf 240 | "(%s : %s)" 241 | (Name.show painter name) 242 | (Type.show painter ty) 243 | ;; 244 | end 245 | 246 | module Statement : sig 247 | type t = 248 | | Let of Name.t * Type.t option * Term.t 249 | | Print of Term.t 250 | 251 | (** [let' name ?annotation body] creates a [Let] statement given 252 | a binding's [name], an optional [annotation] and its [body] 253 | term. *) 254 | val let' : Name.t -> ?annotation:Type.t -> Term.t -> t 255 | 256 | (** [print term] creates a [Print] statement given a [term]. *) 257 | val print : Term.t -> t 258 | 259 | (** [show painter statement] produces a pretty-printable 260 | representation of the [statement] using the [painter]. *) 261 | val show : (module Painter.TYPE) -> t -> string 262 | end = struct 263 | type nonrec t = 264 | | Let of Name.t * Type.t option * Term.t 265 | | Print of Term.t 266 | 267 | let let' = 268 | fun name ?annotation term -> Let (name, annotation, term) 269 | ;; 270 | 271 | let print = fun term -> Print term 272 | 273 | let show = 274 | fun painter stmt -> 275 | let module Painter = (val painter : Painter.TYPE) in 276 | match stmt with 277 | | Let (name, annotation, body) -> 278 | let buffer = Buffer.create 64 in 279 | Buffer.add_string 280 | buffer 281 | (Printf.sprintf 282 | "%s %s" 283 | (Painter.paint_keyword "let") 284 | (Name.show painter name)); 285 | (match annotation with 286 | | None -> () 287 | | Some ty -> 288 | Buffer.add_string 289 | buffer 290 | (Printf.sprintf 291 | " %s %s" 292 | (Painter.paint_keyword ":") 293 | (Type.show painter ty))); 294 | Buffer.add_string 295 | buffer 296 | (Printf.sprintf 297 | " %s %s" 298 | (Painter.paint_bold "=") 299 | (Term.show painter body)); 300 | Buffer.contents buffer 301 | | Print term -> 302 | Printf.sprintf 303 | "%s %s" 304 | (Painter.paint_keyword "print") 305 | (Term.show painter term) 306 | ;; 307 | end 308 | 309 | module Program : sig 310 | type t = Statement.t list 311 | 312 | (** [show painter program] produces a pretty-printable 313 | representation of the [program] using the [painter]. *) 314 | val show : (module Painter.TYPE) -> t -> string 315 | end = struct 316 | type t = Statement.t list 317 | 318 | let show = 319 | fun painter program -> 320 | program 321 | |> List.map (Statement.show painter) 322 | |> String.concat "\n" 323 | ;; 324 | end 325 | --------------------------------------------------------------------------------