├── lib ├── simple │ ├── jbuild │ ├── record.ml │ ├── simple.opam │ ├── ast.ml │ ├── pp.ml │ └── of_onix.ml ├── common │ ├── jbuild │ ├── strMap.ml │ ├── common.opam │ ├── warning.ml │ ├── location.ml │ ├── type_annotations.ml │ └── writer.ml ├── typing │ ├── jbuild │ ├── typing.opam │ ├── typecheck_pat.mli │ ├── environment.ml │ ├── list_or_infinite.ml │ ├── typing_env.mli │ ├── typecheck.mli │ ├── config.ml │ ├── typing_env.ml │ ├── typecheck_pat.ml │ ├── annotations.ml │ ├── types.ml │ └── typecheck.ml └── parse │ ├── jbuild │ ├── parse.opam │ ├── parser.mli │ ├── pragma.ml │ ├── regex_list.ml │ ├── ast.ml │ ├── pp.ml │ └── parser.ml ├── src └── jbuild ├── .gitignore ├── bin ├── jbuild └── tix.ml ├── tests ├── nix_tests.ml ├── jbuild ├── tests_nix_light.ml ├── tests_onix.ml └── test_typecheck.ml ├── onix.opam ├── Makefile ├── README.md ├── shell.nix └── .ocplint /lib/simple/jbuild: -------------------------------------------------------------------------------- 1 | (library 2 | ((name "simple") 3 | (public_name "simple") 4 | (libraries (parse)))) 5 | -------------------------------------------------------------------------------- /lib/common/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library 4 | ((name "common") 5 | (public_name "common") 6 | (libraries (containers)))) 7 | -------------------------------------------------------------------------------- /src/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library 4 | ((name "onix") 5 | (public_name "onix") 6 | (libraries (parse simple typing)))) 7 | 8 | -------------------------------------------------------------------------------- /lib/typing/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library 4 | ((name "typing") 5 | (public_name "typing") 6 | (libraries (cduce simple containers)))) 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # jbuilder working directory 2 | _build/ 3 | 4 | # ocplint working directory 5 | _olint/ 6 | 7 | # Autogenerated files 8 | **/.merlin 9 | **/*.install 10 | -------------------------------------------------------------------------------- /lib/parse/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library 4 | ((name "parse") 5 | (public_name "parse") 6 | (libraries (mparser containers common containers.data)))) 7 | 8 | -------------------------------------------------------------------------------- /bin/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executables 4 | ((names (tix)) 5 | (libraries (mparser parse simple typing cmdliner)))) 6 | 7 | (install 8 | ((section bin) 9 | (files ((tix.exe as tix))))) 10 | -------------------------------------------------------------------------------- /tests/nix_tests.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | let () = run_test_tt_main 4 | ("all_tests">::: [ 5 | Tests_onix.testsuite; 6 | Tests_nix_light.testsuite; 7 | Test_typecheck.testsuite; 8 | ]) 9 | -------------------------------------------------------------------------------- /lib/common/strMap.ml: -------------------------------------------------------------------------------- 1 | module M = CCMap.Make(CCString) 2 | 3 | include M 4 | 5 | let add_or key value map = 6 | match M.get key map with 7 | | Some value2 -> Error (key, value, value2) 8 | | None -> Ok (M.add key value map) 9 | -------------------------------------------------------------------------------- /tests/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executables 4 | ((names (nix_tests)) 5 | (libraries (onix mparser oUnit)))) 6 | 7 | (install 8 | ((section bin) 9 | (files ((nix_tests.exe as nix_tests))))) 10 | 11 | (alias 12 | ((name runtest) 13 | (deps (nix_tests.exe)) 14 | (action (run ${<})))) 15 | -------------------------------------------------------------------------------- /lib/simple/record.ml: -------------------------------------------------------------------------------- 1 | module StrMap = CCMap.Make(CCString) 2 | 3 | include StrMap 4 | 5 | let of_list_uniq l = 6 | List.fold_left 7 | (fun accu_map (key, value) -> 8 | if StrMap.mem key accu_map then 9 | raise (Invalid_argument "of_list_uniq") 10 | else 11 | StrMap.add key value accu_map) 12 | StrMap.empty 13 | l 14 | -------------------------------------------------------------------------------- /onix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "1.0" 3 | maintainer: "bob@sponge.com" 4 | authors: ["SpongeBob"] 5 | homepage: "https://github.com/SpongeBob/hello_world" 6 | bug-reports: "https://github.com/SpongeCob/hello_world/issues" 7 | dev-repo: "https://github.com/SpongeBob/hello_world.git" 8 | license: "Apache-2.0" 9 | build: [ 10 | ["jbuilder" "build" "--only" "onix" "--root" "." "-j" jobs "@install"] 11 | ] 12 | -------------------------------------------------------------------------------- /lib/common/common.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "1.0" 3 | maintainer: "bob@sponge.com" 4 | authors: ["SpongeBob"] 5 | homepage: "https://github.com/SpongeBob/hello_world" 6 | bug-reports: "https://github.com/SpongeCob/hello_world/issues" 7 | dev-repo: "https://github.com/SpongeBob/hello_world.git" 8 | license: "Apache-2.0" 9 | build: [ 10 | ["jbuilder" "build" "--only" "common" "--root" "." "-j" jobs "@install"] 11 | ] 12 | -------------------------------------------------------------------------------- /lib/parse/parse.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "1.0" 3 | maintainer: "bob@sponge.com" 4 | authors: ["SpongeBob"] 5 | homepage: "https://github.com/SpongeBob/hello_world" 6 | bug-reports: "https://github.com/SpongeCob/hello_world/issues" 7 | dev-repo: "https://github.com/SpongeBob/hello_world.git" 8 | license: "Apache-2.0" 9 | build: [ 10 | ["jbuilder" "build" "--only" "tests" "--root" "." "-j" jobs "@install"] 11 | ] 12 | -------------------------------------------------------------------------------- /lib/typing/typing.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "1.0" 3 | maintainer: "bob@sponge.com" 4 | authors: ["SpongeBob"] 5 | homepage: "https://github.com/SpongeBob/hello_world" 6 | bug-reports: "https://github.com/SpongeCob/hello_world/issues" 7 | dev-repo: "https://github.com/SpongeBob/hello_world.git" 8 | license: "Apache-2.0" 9 | build: [ 10 | ["jbuilder" "build" "--only" "tests" "--root" "." "-j" jobs "@install"] 11 | ] 12 | -------------------------------------------------------------------------------- /lib/simple/simple.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "1.0" 3 | maintainer: "bob@sponge.com" 4 | authors: ["SpongeBob"] 5 | homepage: "https://github.com/SpongeBob/hello_world" 6 | bug-reports: "https://github.com/SpongeCob/hello_world/issues" 7 | dev-repo: "https://github.com/SpongeBob/hello_world.git" 8 | license: "Apache-2.0" 9 | build: [ 10 | ["jbuilder" "build" "--only" "nix_light" "--root" "." "-j" jobs "@install"] 11 | ] 12 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 2 | 3 | # Default rule 4 | default: 5 | jbuilder build @install --dev 6 | 7 | install: 8 | jbuilder install $(INSTALL_ARGS) 9 | 10 | uninstall: 11 | jbuilder uninstall $(INSTALL_ARGS) 12 | 13 | reinstall: uninstall reinstall 14 | 15 | clean: 16 | rm -rf _build 17 | 18 | test: 19 | jbuilder runtest --dev 20 | 21 | .PHONY: default install uninstall reinstall clean test 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | __Abandonned__ see https://github.com/regnat/ptyx 2 | 3 | % tix 4 | % A (wip) type-inference engine for [nix](https://nixos.org/nix) 5 | 6 | There is currently not much, hardly a parser for a small subset of the language. 7 | 8 | # Build 9 | 10 | Assuming you got nix installed on your computer, run `nix-shell` to enter a 11 | well-configured environment, and then: 12 | 13 | ``` 14 | $ make configure 15 | $ make 16 | $ make test 17 | ``` 18 | -------------------------------------------------------------------------------- /lib/typing/typecheck_pat.mli: -------------------------------------------------------------------------------- 1 | (** 2 | Typechecking of patterns 3 | @see for the theory 4 | *) 5 | 6 | (** [infer p] returns the couple [(Γ, p')] where [Γ] is the new environment 7 | generated by this pattern and [p'] the pattern annotated with type 8 | informations *) 9 | val infer : ?t_constr:Types.t 10 | -> Types.Environment.t 11 | -> Simple.Ast.pattern 12 | -> ((Typing_env.t * Types.t) * Common.Warning.t list) 13 | -------------------------------------------------------------------------------- /lib/parse/parser.mli: -------------------------------------------------------------------------------- 1 | (** 2 | Parser for the nix language 3 | *) 4 | 5 | (** The type of a parser 6 | * The [string] argument represents the name of the file being parsed 7 | * *) 8 | type 'a t = ('a, string) MParser.t 9 | 10 | type 'a return = ('a, string * MParser.error) result 11 | 12 | (** Parse a nix expression. *) 13 | val expr : Ast.expr t 14 | 15 | (** Parser for a type *) 16 | val typ : Common.Type_annotations.t t 17 | 18 | 19 | val parse_string : 'a t -> string -> 'a return 20 | -------------------------------------------------------------------------------- /lib/typing/environment.ml: -------------------------------------------------------------------------------- 1 | module C = Config 2 | module TE = Types.Environment 3 | module VE = Typing_env 4 | 5 | type t = { 6 | types: TE.t; 7 | values: VE.t; 8 | config: C.t; 9 | } 10 | 11 | let default = { 12 | types = TE.default; 13 | values = VE.initial; 14 | config = C.default; 15 | } 16 | 17 | let map_values f e = { e with values = f e.values; } 18 | 19 | let map_config f e = { e with config = f e.config } 20 | 21 | let add_values e new_values = 22 | map_values (fun v -> VE.merge v new_values) e 23 | 24 | let add_value e name value = 25 | map_values (fun v -> VE.add name value v) e 26 | -------------------------------------------------------------------------------- /lib/typing/list_or_infinite.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 2 | | Finite of 'a list 3 | | Infinite 4 | 5 | let finite l = Finite l 6 | let infinite = Infinite 7 | 8 | let half_map f = function 9 | | Finite l -> finite @@ f l 10 | | Infinite -> Infinite 11 | 12 | let map f = half_map (CCList.map f) 13 | 14 | let fold f ~init ~full = function 15 | | Infinite -> full 16 | | Finite l -> CCList.fold_left f init l 17 | 18 | let merge l1 l2 = match (l1, l2) with 19 | | Finite l1, Finite l2 -> Finite (l1 @ l2) 20 | | _ -> Infinite 21 | 22 | let flatten l = fold merge ~init:(finite []) ~full:infinite l 23 | 24 | let flat_map f l = map f l |> flatten 25 | 26 | let concat l1 l2 = match (l1, l2) with 27 | | Finite l1, Finite l2 -> Finite (l1 @ l2) 28 | | _ -> Infinite 29 | -------------------------------------------------------------------------------- /lib/typing/typing_env.mli: -------------------------------------------------------------------------------- 1 | (** 2 | {2 Typing environments} 3 | *) 4 | 5 | (** 6 | A typing environment Γ 7 | *) 8 | type t 9 | 10 | (** 11 | The empty env 12 | *) 13 | val empty : t 14 | 15 | (** 16 | The initial env, containing predefined builtins 17 | *) 18 | val initial : t 19 | 20 | (** 21 | [singleton x τ] is the environment containing the only constraint {e x: τ} 22 | *) 23 | val singleton : string -> Types.t -> t 24 | 25 | (** 26 | [add x τ Γ] returns the environment {e Γ; x:τ} 27 | *) 28 | val add : string -> Types.t -> t -> t 29 | 30 | (** 31 | [merge Γ Γ'] is the environment {e Γ; Γ'} 32 | *) 33 | val merge : t -> t -> t 34 | 35 | (** 36 | [lookup Γ x] returns the type constraint associated to [x] in [Γ], on [None] 37 | if [x] isn't in [Γ] 38 | *) 39 | val lookup : t -> string -> Types.t option 40 | -------------------------------------------------------------------------------- /lib/typing/typecheck.mli: -------------------------------------------------------------------------------- 1 | (** 2 | Typecheck nix-light expressions 3 | *) 4 | 5 | module W : module type of Annotations.W 6 | 7 | (** 8 | The inference type-system 9 | *) 10 | module Infer : sig 11 | (** 12 | [expr tenv env e] infers a type of the expression [e] under the 13 | type environment [tenv] and the environment [env]. 14 | 15 | @return the type of the expression 16 | @raise TypeError if the expression is not typeable 17 | *) 18 | val expr : Environment.t 19 | -> Simple.Ast.expr 20 | -> Types.t W.t 21 | end 22 | 23 | module Check : sig 24 | (** [expr env e t] checks that under the type environment [tenv] and the 25 | environment [env], the expression [e] admits the type [t]. 26 | 27 | @raise TypeError if it is not the case. 28 | *) 29 | val expr : Environment.t 30 | -> Simple.Ast.expr 31 | -> Types.t 32 | -> unit W.t 33 | end 34 | -------------------------------------------------------------------------------- /lib/typing/config.ml: -------------------------------------------------------------------------------- 1 | module WSet = struct 2 | include CCSet.Make (Parse.Pragma.Warning) 3 | 4 | let default = empty 5 | let default_err = of_list [ Parse.Pragma.Warning.TypeError ] 6 | 7 | let proceed_annot warns (sign, warning) = 8 | match sign with 9 | | Parse.Pragma.Plus -> add warning warns 10 | | Parse.Pragma.Minus -> remove warning warns 11 | 12 | let proceed_annots = List.fold_left proceed_annot 13 | end 14 | 15 | type t = { 16 | warnings: WSet.t; 17 | errors: WSet.t; 18 | } 19 | 20 | let default = { 21 | warnings = WSet.default; 22 | errors = WSet.default_err; 23 | } 24 | 25 | let map_warnings f t = { t with warnings = f t.warnings; } 26 | let map_errors f t = { t with errors = f t.errors; } 27 | 28 | let proceed_warnings_annot t annot = 29 | map_warnings (fun w -> WSet.proceed_annots w annot) t 30 | let proceed_errors_annot t annot = 31 | map_errors (fun w -> WSet.proceed_annots w annot) t 32 | -------------------------------------------------------------------------------- /lib/common/warning.ml: -------------------------------------------------------------------------------- 1 | type kind = Error | Warning 2 | 3 | let show_kind = function 4 | | Error -> "error" 5 | | Warning -> "warning" 6 | 7 | let pp_kind fmt k = Format.pp_print_string fmt (show_kind k) 8 | 9 | type t = { 10 | location : Location.t; 11 | kind: kind; 12 | error: string; 13 | } 14 | 15 | let make ?(kind=Error) location error = { error; location; kind} 16 | 17 | let format location f = Format.ksprintf (make location) f 18 | 19 | let pp fmt t = 20 | Format.fprintf fmt 21 | "%a: %s at %a" 22 | pp_kind t.kind 23 | t.error 24 | Location.pp t.location 25 | 26 | let show t = 27 | pp Format.str_formatter t; 28 | Format.flush_str_formatter () 29 | 30 | let get_kind t = t.kind 31 | 32 | module List = struct 33 | type nonrec t = t list 34 | 35 | let empty : t = [] 36 | let append : t -> t -> t = CCList.append 37 | 38 | let contains_error = 39 | CCList.exists (fun w -> w.kind = Error) 40 | end 41 | -------------------------------------------------------------------------------- /lib/parse/pragma.ml: -------------------------------------------------------------------------------- 1 | module F = Format 2 | 3 | type sign = Plus | Minus 4 | 5 | let show_sign = function 6 | | Plus -> "+" 7 | | Minus -> "-" 8 | 9 | module Warning = struct 10 | type t = 11 | | TypeError 12 | 13 | let compare (a: t) b = Pervasives.compare a b 14 | 15 | let show = function 16 | | TypeError -> "TypeError" 17 | 18 | let read = function 19 | | "TypeError" -> Some TypeError 20 | | _ -> None 21 | end 22 | 23 | type t = 24 | | Warnings of (sign * Warning.t) list 25 | | Errors of (sign * Warning.t) list 26 | 27 | let pp_signValue_pair fmt (sign, value) = 28 | F.fprintf fmt "%s%s" 29 | (show_sign sign) 30 | (Warning.show value) 31 | 32 | let pp_warn_list fmt = 33 | F.pp_print_list ~pp_sep:(fun _ () -> ()) pp_signValue_pair fmt 34 | 35 | let pp fmt = function 36 | | Warnings warns -> 37 | F.fprintf fmt "WARN %a" pp_warn_list warns 38 | | Errors errors -> 39 | F.fprintf fmt "ERRORS %a" pp_warn_list errors 40 | -------------------------------------------------------------------------------- /lib/common/location.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Simple data structure to add location information to AST nodes 3 | *) 4 | type t = { 5 | file_name: string; 6 | lnum: int; 7 | cnum: int; 8 | } 9 | 10 | let mk ?(file_name = "") ?(lnum = -1) ?(cnum = -1) () = { 11 | file_name; 12 | lnum; 13 | cnum; 14 | } 15 | 16 | let pp fmt t = 17 | Format.fprintf fmt "file %s, line %i, character %i" 18 | t.file_name 19 | t.lnum 20 | t.cnum 21 | 22 | module With_loc = 23 | struct 24 | (* Nonrec types seem to mess with ppx_deriving, so let's not use it *) 25 | type 'a _t = { 26 | description: 'a; 27 | location: t; 28 | } 29 | 30 | type 'a t = 'a _t 31 | 32 | let mk' ?file_name ?lnum ?cnum elt = { 33 | description = elt; 34 | location = mk ?file_name ?lnum ?cnum () 35 | } 36 | 37 | let mk location description = { location; description; } 38 | 39 | let map f x = { 40 | x with 41 | description = f x.description; 42 | } 43 | 44 | let description { description = it; _ } = it 45 | let loc { location = l; _ } = l 46 | end 47 | -------------------------------------------------------------------------------- /lib/typing/typing_env.ml: -------------------------------------------------------------------------------- 1 | module StrMap = CCMap.Make(String) 2 | 3 | type t = Types.t StrMap.t 4 | 5 | let empty = StrMap.empty 6 | 7 | let singleton = StrMap.singleton 8 | 9 | let add = StrMap.add 10 | 11 | let merge = 12 | let merge_fun _ x y = match x,y with 13 | | _, Some a 14 | | Some a, None -> Some a 15 | | None, None -> None 16 | in 17 | StrMap.merge merge_fun 18 | 19 | let lookup map elt = 20 | try 21 | Some (StrMap.find elt map) 22 | with Not_found -> None 23 | 24 | let initial_values = 25 | let open Types.Builtins in 26 | let node = Types.node in 27 | let int = Types.node int 28 | and string = Types.node string 29 | and true_type = Types.node true_type 30 | and any = Types.node any 31 | and empty = Types.node empty 32 | and undef = Types.node undef 33 | and false_type = Types.node false_type in 34 | [ 35 | "nil", nil; 36 | "__add", arrow int (Types.node @@ arrow int int); 37 | "__sub", arrow int (Types.node @@ arrow int int); 38 | "__not", cap (arrow true_type false_type) (arrow false_type true_type); 39 | "head_int", arrow (Types.node @@ cons int any) int; 40 | "raise", arrow string any; 41 | "isInt", cap 42 | (arrow int true_type) 43 | (arrow (Types.node Types.Builtins.(neg int)) false_type); 44 | "%%isUndef", cap 45 | (arrow undef true_type) 46 | (arrow (Types.node Types.Builtins.(neg undef)) false_type); 47 | "builtins", Types.Builtins.record 48 | false 49 | (Simple.Record.of_list 50 | [ 51 | "abort", Types.node @@ arrow string empty; 52 | "compareVersions", node @@ arrow string (node @@ arrow string int); 53 | "currentSystem", string; 54 | "nixVersion", string; 55 | ]); 56 | ] 57 | 58 | let initial = StrMap.of_list initial_values 59 | -------------------------------------------------------------------------------- /lib/simple/ast.ml: -------------------------------------------------------------------------------- 1 | (** 2 | AST for nix-light, a simplified version of the nix language 3 | @see for a description of the language 4 | *) 5 | 6 | module Type_annotations = Common.Type_annotations 7 | 8 | type 'a with_loc = 'a Common.Location.With_loc.t 9 | 10 | type binop = 11 | | Ocons 12 | | Oeq 13 | | Oplus 14 | | Ominus 15 | | Oand | Oor 16 | | OrecordMember 17 | | Omerge 18 | | Oconcat 19 | 20 | type monop = Oneg| Onot 21 | 22 | type expr = expr_desc with_loc 23 | 24 | and expr_desc = 25 | | Evar of string 26 | | EaccessPath of expr * access_path * expr option 27 | (** 28 | x 29 | x.y 30 | x.y or e 31 | *) 32 | | Econstant of constant 33 | | Elambda of lambda 34 | | EfunApp of expr * expr 35 | | Ebinop of binop * expr * expr 36 | | Emonop of monop * expr 37 | | Eite of expr * expr * expr 38 | | Erecord of record 39 | | Ewith of expr * expr 40 | (* with e; e *) 41 | | Elet of binding list * expr 42 | | EtyAnnot of expr * Type_annotations.t 43 | | Epragma of Parse.Pragma.t * expr 44 | | Eimport of expr 45 | 46 | and access_path = ap_field list 47 | 48 | and ap_field = expr 49 | 50 | and constant = 51 | | Cint of int 52 | | Cbool of bool 53 | | Cstring of string 54 | | Cpath of string 55 | | Cbracketed of string 56 | | Cundef (* Used for pattern-matching against records with optinal fields *) 57 | 58 | and lambda = pattern * expr 59 | 60 | and pattern = pattern_desc with_loc 61 | 62 | and pattern_desc = 63 | | Pvar of pattern_var 64 | | Pnontrivial of nontrivial_pattern * string option 65 | 66 | and nontrivial_pattern = 67 | | NPrecord of (bool * Type_annotations.t option) Record.t * closed_flag 68 | (** fields * '...' 69 | * For each field, the boolean indicates whether the field is optional 70 | * *) 71 | 72 | and pattern_var = string * Type_annotations.t option 73 | 74 | and closed_flag = 75 | | Closed 76 | | Open 77 | 78 | and record = field list 79 | 80 | and field = expr * Type_annotations.t option * expr 81 | 82 | and binding = pattern_var * expr 83 | 84 | and interpol = expr 85 | -------------------------------------------------------------------------------- /lib/parse/regex_list.ml: -------------------------------------------------------------------------------- 1 | let (%>) f g x = g (f x) 2 | 3 | module L = Common.Location.With_loc 4 | module T = Common.Type_annotations 5 | 6 | module Counter = functor () -> struct 7 | let counter = ref 0 8 | 9 | let incr () = incr counter 10 | let get () = !counter 11 | 12 | let pop () = 13 | let res = get () in 14 | incr (); res 15 | end 16 | 17 | module FreshVars = functor () -> struct 18 | module C = Counter () 19 | 20 | let get () = "X" ^ (string_of_int @@ C.get ()) 21 | let pop () = "X" ^ (string_of_int @@ C.pop ()) 22 | end 23 | 24 | type _t = 25 | | Type of T.t 26 | | Or of t * t 27 | | Concat of t * t 28 | | Star of t 29 | | Plus of t 30 | | Maybe of t 31 | | Empty 32 | 33 | and t = _t L.t 34 | 35 | let to_type (regex: t) : T.t = 36 | let module V = FreshVars () in 37 | let rec aux (regex : t) : (T.t * string) = 38 | let loc = L.loc regex in 39 | match L.description regex with 40 | | Type t -> 41 | let tail = V.pop () in 42 | (L.mk loc @@ T.Cons (t, L.mk loc @@ T.Var tail), tail) 43 | | Or (r1, r2) -> 44 | let (t1, tl1) = aux r1 45 | and (t2, tl2) = aux r2 46 | in 47 | (L.mk loc @@ T.TyBind ( 48 | [tl1, L.mk loc @@ T.Var tl2], 49 | L.mk loc @@ T.Infix (T.Infix_constructors.Or, t1, t2)), 50 | tl2) 51 | | Concat (r1, r2) -> 52 | let (t1, tl1) = aux r1 53 | and (t2, tl2) = aux r2 54 | in 55 | (L.mk loc @@ T.TyBind ([tl1, t2], t1), tl2) 56 | | Star r -> 57 | let (t, tl) = aux r 58 | and new_tail = V.pop () in 59 | (L.mk loc @@ T.TyBind ([( 60 | tl, L.mk loc @@ T.Infix (T.Infix_constructors.Or, 61 | t, L.mk loc @@ T.Var new_tail))], 62 | L.mk loc @@ T.Var tl), 63 | new_tail) 64 | | Plus r -> aux (L.mk loc @@ Concat(r, L.mk loc @@ Star r)) 65 | | Maybe r -> aux (L.mk loc @@ Or (r, L.mk loc @@ Empty)) 66 | | Empty -> 67 | let tail = V.pop () in 68 | (L.mk loc @@ T.Var tail, tail) 69 | in 70 | let (typ, tail) = aux regex in 71 | let loc = L.loc regex in 72 | L.mk loc @@ T.TyBind ([tail, L.mk loc @@ T.Var "nil"], typ) 73 | -------------------------------------------------------------------------------- /lib/typing/typecheck_pat.ml: -------------------------------------------------------------------------------- 1 | module P = Simple.Ast 2 | module L = Common.Location.With_loc 3 | module TE = Typing_env 4 | 5 | module W = Common.Writer.Make(Common.Warning.List) 6 | 7 | open W.Infix 8 | 9 | let infer_var ?t_constr tenv maybe_t = 10 | match t_constr, maybe_t with 11 | | None, None -> W.pure Types.Builtins.grad 12 | | _, _ -> 13 | let real_constraint = CCOpt.get_or ~default:Types.Builtins.any t_constr 14 | and annoted = 15 | CCOpt.fold 16 | (fun _ annot -> Annotations.to_type tenv annot) 17 | (W.pure Types.Builtins.any) 18 | maybe_t 19 | in 20 | W.map (Types.Builtins.cap real_constraint) annoted 21 | 22 | let infer_field ?t_constr tenv (name, (is_optional, maybe_annot)) = 23 | infer_var ?t_constr tenv maybe_annot >|= fun t -> 24 | let accepted_typ, produced_typ = 25 | if is_optional then 26 | let accepted_typ = Cduce_lib.Types.Record.or_absent t 27 | and produced_typ = Types.Builtins.cup t Types.Builtins.undef 28 | in (accepted_typ, produced_typ) 29 | else (t, t) 30 | in 31 | (TE.singleton name produced_typ, (name, Types.node accepted_typ)) 32 | 33 | let infer_nontrivial_pattern ?t_constr tenv (P.NPrecord (fields, closed_flag)) = 34 | W.map_l (infer_field ?t_constr tenv) (Simple.Record.to_list fields) 35 | >|= CCList.split >|= fun (envs, fields) -> 36 | let is_open = match closed_flag with 37 | | P.Open -> true 38 | | P.Closed -> false 39 | in 40 | (List.fold_left TE.merge TE.empty envs, 41 | Types.Builtins.record is_open @@ Simple.Record.of_list fields) 42 | 43 | 44 | let infer_pattern_descr ?t_constr tenv p = match p with 45 | | P.Pvar (v, maybe_t) -> 46 | infer_var ?t_constr tenv maybe_t >|= fun t -> (TE.singleton v t, t) 47 | | P.Pnontrivial (sub_p, maybe_alias) -> 48 | infer_nontrivial_pattern ?t_constr tenv sub_p >|= fun (env, accepted_typ) -> 49 | (CCOpt.map_or 50 | ~default:env 51 | (fun var -> TE.add var accepted_typ env) 52 | maybe_alias, 53 | accepted_typ) 54 | 55 | let infer_pattern ?t_constr tenv { L.description; _ } = 56 | infer_pattern_descr ?t_constr tenv description 57 | 58 | let infer : ?t_constr:Types.t 59 | -> Types.Environment.t 60 | -> P.pattern 61 | -> (TE.t * Types.t) W.t = 62 | infer_pattern 63 | -------------------------------------------------------------------------------- /bin/tix.ml: -------------------------------------------------------------------------------- 1 | let parse_chan fname chan = 2 | match MParser.parse_channel Parse.Parser.expr chan fname with 3 | | MParser.Success t -> t 4 | | MParser.Failed (msg, _) -> 5 | Format.print_string msg; 6 | Format.print_flush (); 7 | exit 1 8 | 9 | let typecheck ast = 10 | Typing.(Typecheck.Infer.expr Environment.default) ast 11 | 12 | let process_file is_parse_only is_convert_only f_name = 13 | let ast = 14 | match f_name with 15 | | "-" -> parse_chan "-" stdin 16 | | _ -> CCIO.with_in f_name (parse_chan f_name) 17 | in 18 | if is_parse_only then 19 | Parse.Pp.pp_expr Format.std_formatter ast 20 | else 21 | let converted = Simple.Of_onix.expr ast in 22 | if is_convert_only then 23 | begin 24 | CCFormat.list 25 | ~sep:CCFormat.newline 26 | Common.Warning.pp 27 | Format.err_formatter 28 | (Typing.Typecheck.W.log converted); 29 | Simple.Pp.pp_expr Format.std_formatter 30 | (Typing.Typecheck.W.value converted) 31 | end 32 | else 33 | let open Typing.Typecheck.W.Infix in 34 | let typed = converted >>= fun converted -> typecheck converted in 35 | let log = Typing.Typecheck.W.log typed 36 | and value = Typing.Typecheck.W.value typed 37 | in 38 | CCList.iter (fun t -> 39 | Common.Warning.pp Format.err_formatter t; 40 | Format.pp_print_newline Format.err_formatter ()) 41 | (CCList.rev log); 42 | Format.fprintf Format.std_formatter "%a\n" Typing.Types.pp value 43 | 44 | open Cmdliner 45 | 46 | let file_in = 47 | let doc = "Input file" in 48 | Arg.(value & pos 0 string "-" & info [] ~docv:"FILE" ~doc) 49 | 50 | let parse_only = 51 | let doc = "Do not typecheck nor convert, just parse the file" in 52 | Arg.(value & flag & info [ "p"; "parse-only" ] ~docv:"PARSE_ONLY" ~doc) 53 | 54 | let convert_only = 55 | let doc = "Do not typecheck, just convert the file" in 56 | Arg.(value & flag & info [ "c"; "convert-only" ] ~docv:"CONVERT_ONLY" ~doc) 57 | 58 | let eval_stuff = Term.(const process_file $ parse_only $ convert_only $ file_in) 59 | let info = 60 | let doc = "The nix type-checker" in 61 | let man = [] in 62 | Term.info "tix" ~doc ~exits:Term.default_exits ~man 63 | 64 | let () = Term.exit @@ Term.eval (eval_stuff, info) 65 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { 2 | nixpkgs' ? null, system ? builtins.currentSystem 3 | }: 4 | let 5 | nixpkgs = if nixpkgs' != null then nixpkgs' else 6 | let nixpkgs' = import {}; in 7 | nixpkgs'.fetchFromGitHub { 8 | # Waiting for the containers library to be updated upstream 9 | owner = "regnat"; 10 | repo = "nixpkgs"; 11 | rev = "d036d882965989f38a9a414a3f34b692d146bdf6"; 12 | sha256 = "1njsk8jbwlzqgdazmxcvaxwmkxam61b8zjidsr6hawi1dmlflhfh"; 13 | }; 14 | in 15 | with import nixpkgs { inherit system; }; 16 | let 17 | ocamlPackages = ocamlPackages_4_03; 18 | ocaml = ocamlPackages.ocaml; 19 | cduce-lib = stdenv.mkDerivation rec { 20 | name = "cduce-unstable-${version}"; 21 | version = "2016-06-07"; 22 | 23 | src = fetchgit { 24 | url = "https://gitlab.math.univ-paris-diderot.fr/cduce/cduce.git/"; 25 | rev = "6d44f428306e588c8f0177a43aa7794810f02d60"; 26 | sha256 = "1czij3ndqr75ifj0sf51y8w6za6clq5plv2m8x4m15mfk8l6ir84"; 27 | }; 28 | 29 | propagatedBuildInputs = with ocamlPackages; [ 30 | ocaml 31 | findlib 32 | ocaml_pcre ulex 33 | rlwrap 34 | ]; 35 | 36 | createFindlibDestdir = true; 37 | 38 | preConfigure = '' 39 | sed -i 's@+camlp4/camlp4lib.cma @@' META.in 40 | sed -i 's@+camlp4/camlp4lib.cmxa @@' META.in 41 | sed -i 's/requires="/requires="camlp4.lib /' META.in 42 | 43 | # Also install .cmx file to prevent a compiler warning 44 | sed -i 's#lib/cduce_lib.a#lib/cduce_lib.a lib/cduce_lib.cmx#' \ 45 | Makefile.distrib 46 | ''; 47 | 48 | configureFlags = [ 49 | "--without-pxp" 50 | "--without-expat" 51 | "--without-curl" 52 | "--without-netclient" 53 | "--without-cgi" 54 | ]; 55 | 56 | installTargets = [ "install_lib" ]; 57 | 58 | }; 59 | in 60 | stdenv.mkDerivation rec { 61 | name = "onix"; 62 | version = "0.0"; 63 | propagatedBuildInputs = with ocamlPackages; [ 64 | ocaml 65 | findlib 66 | ounit 67 | containers 68 | jbuilder 69 | cduce-lib 70 | cmdliner_1_0 71 | mparser 72 | ]; 73 | 74 | src = builtins.filterSource (name: type: 75 | let baseName = baseNameOf (toString name); in !( 76 | (type == "directory" && (baseName == ".git" || 77 | baseName == "_build" || 78 | baseName == "_obuild" || 79 | baseName == ".merlin" || 80 | lib.hasSuffix ".install" baseName)) 81 | )) 82 | ./.; 83 | } 84 | -------------------------------------------------------------------------------- /lib/parse/ast.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Parsetree for the nix language 3 | *) 4 | 5 | module Type_annotations = Common.Type_annotations 6 | 7 | type 'a with_loc = 'a Common.Location.With_loc.t 8 | 9 | type binop = 10 | | Ocons 11 | | Oeq | OnonEq 12 | | Oplus | Ominus 13 | | Oand | Oor | Oimplies 14 | | Omerge 15 | | Oconcat 16 | 17 | type monop = 18 | | Oneg 19 | | Onot 20 | 21 | type expr = expr_desc with_loc 22 | 23 | and expr_desc = 24 | | Evar of string 25 | | Eaccess of expr * access_path * expr option 26 | (** 27 | e 28 | e.y 29 | e.y or e 30 | *) 31 | | Econstant of constant 32 | | Elambda of lambda 33 | | EfunApp of expr * expr 34 | | Ebinop of binop * expr * expr 35 | | Emonop of monop * expr 36 | | Eite of expr * expr * expr 37 | (* if e then e else e *) 38 | | Erecord of record 39 | | Ewith of expr * expr 40 | (** with e; e *) 41 | | Elet of binding list * expr 42 | | EtyAnnot of expr * Type_annotations.t 43 | | Epragma of Pragma.t * expr 44 | | EtestMember of expr * access_path 45 | 46 | and access_path = ap_field list 47 | 48 | and ap_field = ap_field_desc with_loc 49 | 50 | and ap_field_desc = 51 | | AFidentifier of string 52 | | AFexpr of expr 53 | 54 | and constant = 55 | | Cint of int 56 | | Cbool of bool 57 | | Cstring of string 58 | | Cpath of string 59 | | Cbracketed of string 60 | (* A bracketed path, which will be of type `Path` *) 61 | 62 | and lambda = pattern * expr 63 | 64 | and pattern = pattern_desc with_loc 65 | 66 | and pattern_desc = 67 | | Pvar of pattern_var 68 | | Pnontrivial of nontrivial_pattern * string option 69 | 70 | and nontrivial_pattern = 71 | | NPrecord of pattern_record_field list * closed_flag 72 | (* fields * '...' *) 73 | 74 | and pattern_record_field = { 75 | field_name: string; 76 | default_value: expr option; 77 | type_annot: Type_annotations.t option; 78 | } 79 | 80 | and pattern_var = string * Type_annotations.t option 81 | 82 | and pattern_access_path = access_path * Type_annotations.t option 83 | 84 | and closed_flag = 85 | | Closed 86 | | Open 87 | 88 | and record = { 89 | recursive : bool; 90 | fields : field list; 91 | } 92 | 93 | and field_desc = 94 | | Fdef of pattern_access_path * expr 95 | | Finherit of inherit_ 96 | (** inherit x y z...; 97 | inherit (e) x y z...; 98 | *) 99 | 100 | and field = field_desc with_loc 101 | 102 | and binding = field 103 | 104 | and inherit_ = expr option * (string with_loc) list 105 | 106 | and interpol = expr 107 | -------------------------------------------------------------------------------- /lib/common/type_annotations.ml: -------------------------------------------------------------------------------- 1 | (** 2 | * Definition of the types used by tix 3 | *) 4 | 5 | module F = Format 6 | 7 | let (%>) f g x = g (f x) 8 | 9 | module Infix_constructors = 10 | struct 11 | type t = 12 | | Arrow 13 | | And 14 | | Or 15 | | Diff 16 | 17 | let show = function 18 | | Arrow -> "->" 19 | | And -> "&" 20 | | Or -> "|" 21 | | Diff -> "\\" 22 | end 23 | 24 | module Singleton = 25 | struct 26 | type t = 27 | | Int of int 28 | | Bool of bool 29 | | String of string 30 | | Path of string 31 | 32 | let pp fmt = function 33 | | Int i -> Format.pp_print_int fmt i 34 | | Bool b -> Format.pp_print_bool fmt b 35 | | String s -> Format.fprintf fmt "\"%s\"" s 36 | | Path s -> CCFormat.string fmt s 37 | 38 | let show = function 39 | | Int i -> string_of_int i 40 | | Bool b -> string_of_bool b 41 | | String s -> "\"" ^ s ^ "\"" 42 | | Path s -> s 43 | end 44 | 45 | type _t = 46 | | Var of string 47 | | Gradual 48 | | Singleton of Singleton.t 49 | | Infix of Infix_constructors.t * t * t 50 | | Record of (string * (bool * t)) list * bool 51 | | Cons of t * t 52 | | TyBind of bindings * t 53 | 54 | and t = _t Location.With_loc.t 55 | 56 | and bindings = (string * t ) list 57 | 58 | let rec pp fmt = Location.With_loc.description %> function 59 | | Var v -> Format.pp_print_string fmt v 60 | | Infix (constr, t1, t2) -> 61 | Format.fprintf fmt "(%a) %s %a" 62 | pp t1 63 | (Infix_constructors.show constr) 64 | pp t2 65 | | Cons (t1, t2) -> 66 | Format.fprintf fmt "Cons(%a, %a)" 67 | pp t1 68 | pp t2 69 | | TyBind (binds, t) -> 70 | Format.fprintf fmt "%a where %a" 71 | pp t 72 | pp_bindings binds 73 | | Singleton s -> Singleton.pp fmt s 74 | | Gradual -> Format.pp_print_string fmt "?" 75 | | Record (fields, is_open) -> 76 | let open_mark = if is_open then 77 | if fields = [] then "... " 78 | else "; ... " 79 | else "" 80 | in 81 | F.fprintf fmt "{ %a%s} " 82 | pp_record_fields fields 83 | open_mark 84 | 85 | and pp_record_fields fmt f = CCList.pp ~sep:"; " pp_record_field fmt f 86 | 87 | and pp_record_field fmt (name, (is_optional, typ)) = 88 | F.fprintf fmt "%s =%s %a" name (if is_optional then "?" else "") pp typ 89 | 90 | and pp_bindings fmt = 91 | Format.pp_print_list 92 | ~pp_sep:(fun fmt () -> Format.pp_print_string fmt " and\n") 93 | pp_binding 94 | fmt 95 | 96 | and pp_binding fmt (name, typ) = 97 | Format.fprintf fmt "%s = %a" 98 | name 99 | pp typ 100 | 101 | let show t = 102 | let () = pp Format.str_formatter t in 103 | Format.flush_str_formatter () 104 | -------------------------------------------------------------------------------- /lib/common/writer.ml: -------------------------------------------------------------------------------- 1 | module type MONOID = sig 2 | type t 3 | 4 | val empty : t 5 | 6 | val append : t -> t -> t 7 | end 8 | 9 | module type S = sig 10 | type log 11 | type 'a t 12 | 13 | val map : ('a -> 'b) -> 'a t -> 'b t 14 | 15 | val pure : 'a -> 'a t 16 | val ap : ('a -> 'b) t -> 'a t -> 'b t 17 | 18 | val return : 'a -> 'a t 19 | val bind : ('a -> 'b t) -> 'a t -> 'b t 20 | 21 | val join : ('a t) t -> 'a t 22 | 23 | val iter : ('a -> unit) -> 'a t -> unit 24 | 25 | val append : log -> 'a t -> 'a t 26 | val value : 'a t -> 'a 27 | val log : 'a t -> log 28 | 29 | val map2 : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t 30 | 31 | val map_l : ('a -> 'b t) -> 'a list -> 'b list t 32 | val iter_l : ('a -> unit t) -> 'a list -> unit t 33 | 34 | val map_pair : ('a -> 'b t) -> ('c -> 'd t) -> ('a * 'c) -> ('b * 'd) t 35 | 36 | val map_opt : ('a -> 'b t) -> 'a option -> 'b option t 37 | 38 | module Infix : sig 39 | val (<$>) : ('a -> 'b) -> 'a t -> 'b t 40 | val (>|=) : 'a t -> ('a -> 'b) -> 'b t 41 | 42 | val (<*>) : 'a t -> ('a -> 'b) t -> 'b t 43 | 44 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 45 | val (>>) : 'a t -> 'b t -> 'b t 46 | end 47 | end 48 | 49 | module Make(M: MONOID) : S with type 'a t = ('a * M.t) and type log = M.t = 50 | struct 51 | type log = M.t 52 | type 'a t = ('a * M.t) 53 | 54 | (* Functor *) 55 | let map f (x, log) = (f x, log) 56 | 57 | (* Applicative *) 58 | let pure x = (x, M.empty) 59 | let ap (f, log) (x, log') = 60 | (f x, M.append log log') 61 | 62 | (* Monad *) 63 | let return x = pure x 64 | let bind f (x, log) = 65 | let (x', log') = f x in 66 | (x', M.append log' log) 67 | 68 | let join ((x, log), log') = (x, M.append log log') 69 | 70 | let iter f x = ignore (map f x) 71 | 72 | let append log (x, log') = (x, M.append log' log) 73 | 74 | let value = fst 75 | let log = snd 76 | 77 | let map2 f (x, log) (y, log') = (f x y, M.append log log') 78 | 79 | let map_l f l = 80 | CCList.map f l 81 | |> CCList.rev 82 | |> List.fold_left (fun accu (elt, log) -> 83 | bind (fun partial_list -> (elt :: partial_list, log)) accu) 84 | (pure []) 85 | 86 | let iter_l f l = 87 | map (fun _ -> ()) (map_l f l) 88 | 89 | let map_pair f_x f_y (x, y) = 90 | let (x', log_x) = f_x x 91 | and (y', log_y) = f_y y 92 | in 93 | ((x', y'), M.append log_x log_y) 94 | 95 | let map_opt f opt = 96 | match CCOpt.map f opt with 97 | | Some (x, log) -> (Some x), log 98 | | None -> None, M.empty 99 | 100 | module Infix = struct 101 | let (<$>) = map 102 | let (>|=) x f = map f x 103 | 104 | let (<*>) x f = ap f x 105 | 106 | let (>>=) x f = bind f x 107 | let (>>) x y = bind (CCFun.const y) x 108 | end 109 | end 110 | -------------------------------------------------------------------------------- /tests/tests_nix_light.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | module W = Typing.Typecheck.W 4 | (* open W.Infix *) 5 | 6 | exception ParseError 7 | 8 | 9 | let test_parse_pp_str ?(isTodo=false) input expected_output _ = 10 | if isTodo then todo "Not implemented yet"; 11 | let output = 12 | begin 13 | match Parse.Parser.parse_string Parse.Parser.expr input with 14 | | Ok x -> 15 | let simple = Simple.Of_onix.expr x in 16 | if W.log simple = [] then 17 | Simple.Pp.pp_expr Format.str_formatter (W.value simple) 18 | else 19 | () 20 | | Error _ -> raise ParseError 21 | end; 22 | Format.flush_str_formatter () 23 | in 24 | assert_equal 25 | ~printer:(fun x -> x) 26 | expected_output 27 | output 28 | 29 | let test_parse_pp_str_fail ?(isTodo=false) input _ = 30 | if isTodo then todo "Not implemented yet"; 31 | begin 32 | match Parse.Parser.parse_string Parse.Parser.expr input with 33 | | Ok x -> 34 | begin 35 | try 36 | let s = Simple.Of_onix.expr x in 37 | if W.log s = [] then 38 | assert_failure "Translation error not raised" 39 | else () 40 | with 41 | Failure _ -> () 42 | end 43 | 44 | | Error _ -> raise ParseError 45 | end 46 | 47 | let isTodo = true (* To use [~isTodo] as a shortcut for [~isTodo=true] *) 48 | 49 | let testsuite = 50 | "nix_light">::: 51 | List.map (fun (name, input, output) -> 52 | name >:: test_parse_pp_str input output) 53 | [ 54 | "test_var", "x", "x"; 55 | "test_const_int", "1234", "1234"; 56 | "test_const_true", "true", "true"; 57 | "test_const_false", "false", "false"; 58 | "test_lambda", "x: x", "(x: x)"; 59 | "test_app", "x y", "x y"; 60 | "test_lambda_app", "(x: y) z", "(x: y) z"; 61 | "test_app_lambda", "x: y z", "(x: y z)"; 62 | "test_Y_comb", "(x: x x) (x: x x)", "(x: x x) (x: x x)"; 63 | "test_annot", "(x /*: int */)", "(x /*: int */)"; 64 | "test_annot_arrow", "(x /*: int -> int */)", "(x /*: (int) -> int */)"; 65 | "test_string", "\"x\"", "\"x\""; 66 | "test_list", "[1 2 3]", "(1 :: (2 :: (3 :: nil)))"; 67 | "test_record_1", "{ x = 1; y = 2; }", "{ \"x\" = 1; \"y\" = 2; }"; 68 | "test_record_2", "{ x.y = 1; }", "{ \"x\" = { \"y\" = 1; }; }"; 69 | ("test_record_3", 70 | "{ x.y = 1; x.z = 2; }", 71 | "{ \"x\" = { \"y\" = 1; \"z\" = 2; }; }"); 72 | "test_apath", "x.y.${\"z\"}", "x.\"y\".\"z\""; 73 | "test_pattern_record", "{}:x", "({ }: x)"; 74 | "test_pattern_record_alias", "{}@x:x", "({ }@x: x)"; 75 | ("test_pattern_record_default", "{ x ? 1 }: x", 76 | "({ x? }: let %%x = x; in let x = if (%%isUndef %%x) \ 77 | then 1 else %%x; in x)"); 78 | ("test_recursive_record", 79 | "rec { x = 1; y = x; }", 80 | "let x = 1; y = x; in { \"x\" = x; \"y\" = y; }"); 81 | "test_path", "./foo", "./foo"; 82 | "test_with", "with e1; e2", "with e1; e2"; 83 | "test_apath_or", "x.y or z", "x.\"y\" or z"; 84 | "test_bracket", "", ""; 85 | "record_merge", "{} // { x = 1; }", "({ } // { \"x\" = 1; })"; 86 | ("test_inherit", 87 | "{ inherit x; inherit (foo) y; }", 88 | "{ \"x\" = x; \"y\" = foo.\"y\"; }"); 89 | "interpol_string", "\"${foo}\"", "(foo + \"\")"; 90 | "interpol_string2", "\"blah${foo}bar\"", "(\"blah\" + (foo + \"bar\"))"; 91 | ] @ 92 | List.map (fun (name, input) -> 93 | name >:: test_parse_pp_str_fail input) 94 | [ 95 | "test_record_fail_1", "{ x = 1; x = 2; }"; 96 | "test_record_fail_2", "{ x.y = 1; x.y = 2; }"; 97 | "test_record_pattern_fail", "{ x, x }: x"; 98 | ] 99 | -------------------------------------------------------------------------------- /lib/typing/annotations.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Conversion of type annotations into actual types 3 | *) 4 | 5 | module A = Common.Type_annotations 6 | module L = Common.Location 7 | module T = Types 8 | 9 | module W = Common.Writer.Make (Common.Warning.List) 10 | 11 | open W.Infix 12 | 13 | let singleton = 14 | let module S = A.Singleton in 15 | function 16 | | S.Bool b -> W.pure @@ T.Singleton.bool b 17 | | S.Int i -> W.pure @@ T.Singleton.int i 18 | | S.String s -> W.pure @@ T.Singleton.string s 19 | | S.Path s -> W.pure @@ T.Singleton.path s 20 | 21 | (* When typing recursive type-annotations, we need to keep an environment to 22 | * trace the local and yet undefined type variables. 23 | * Those can't be tracked in the global type environment as it is a map from 24 | * names to types, and we need a map from names to nodes (because we later 25 | * unify those types with their definition, and we only can do this with nodes. 26 | * 27 | * So we keep a separate environment. 28 | * *) 29 | module Nodes_env = struct 30 | module M = CCMap.Make (CCString) 31 | 32 | type t = T.Node.t M.t 33 | 34 | let empty = M.empty 35 | 36 | let add = M.add 37 | 38 | let lookup t key = M.get key t 39 | end 40 | 41 | let (<+>) = CCOpt.(<+>) 42 | (* let (||>) opt msg = CCOpt.to_result msg opt *) 43 | let (%>) = CCFun.(%>) 44 | 45 | let rec to_node (nodes_env : Nodes_env.t) env (annot: A.t) 46 | : Cduce_lib.Types.Node.t W.t = 47 | let loc = L.With_loc.loc annot in 48 | L.With_loc.description annot |> 49 | function 50 | | A.Var v -> 51 | begin 52 | Nodes_env.lookup nodes_env v 53 | <+> 54 | (CCOpt.map T.node @@ Types.Environment.lookup env v) 55 | |> function 56 | | Some t -> W.pure t 57 | | None -> 58 | W.append 59 | [Common.Warning.make loc ("Unbound type variable " ^ v)] 60 | (W.pure @@ T.node T.Builtins.grad) 61 | end 62 | | A.Infix (A.Infix_constructors.Arrow, t1, t2) -> 63 | W.map2 64 | T.Builtins.arrow 65 | (to_node nodes_env env t1) 66 | (to_node nodes_env env t2) 67 | >|= T.node 68 | | A.Infix (A.Infix_constructors.And, t1, t2) -> 69 | W.map2 70 | T.Builtins.cap 71 | (to_type nodes_env env t1) 72 | (to_type nodes_env env t2) 73 | >|= T.node 74 | | A.Infix (A.Infix_constructors.Or, t1, t2) -> 75 | W.map2 76 | T.Builtins.cup 77 | (to_type nodes_env env t1) 78 | (to_type nodes_env env t2) 79 | >|= T.node 80 | | A.Infix (A.Infix_constructors.Diff, t1, t2) -> 81 | W.map2 82 | T.Builtins.diff 83 | (to_type nodes_env env t1) 84 | (to_type nodes_env env t2) 85 | >|= T.node 86 | | A.Singleton s -> singleton s >|= T.node 87 | | A.TyBind (binds, t) -> 88 | let new_nodes_env, defs = 89 | List.fold_left 90 | (fun (env, defs) (name, def) -> 91 | let new_typ = T.fresh () in 92 | (Nodes_env.add name new_typ env, 93 | (new_typ, def) :: defs)) 94 | (nodes_env, []) 95 | binds 96 | in 97 | let binds_errors = 98 | W.iter_l 99 | (fun (typ, def) -> 100 | to_type new_nodes_env env def >|= fun type_def -> 101 | T.define typ type_def 102 | ) 103 | defs 104 | in 105 | binds_errors >> 106 | (to_node new_nodes_env env t) 107 | | A.Cons (t1, t2) -> 108 | W.map2 109 | T.Builtins.cons 110 | (to_node nodes_env env t1) 111 | (to_node nodes_env env t2) 112 | >|= T.node 113 | | A.Record (fields, is_open) -> 114 | let real_fields = 115 | W.map_l ( 116 | fun (n, (is_optional, typ)) -> 117 | to_node nodes_env env typ >|= fun t -> 118 | let _ = if is_optional then 119 | Cduce_lib.Types.define 120 | t 121 | (Cduce_lib.Types.Record.or_absent (T.typ t)) 122 | in 123 | (n, t)) 124 | fields 125 | in 126 | real_fields >|= fun f -> 127 | T.node @@ T.Builtins.record is_open (Simple.Record.of_list_uniq f) 128 | | A.Gradual -> W.pure @@ T.node T.Builtins.grad 129 | 130 | and to_type nodes_env env p = to_node nodes_env env p >|= T.typ 131 | 132 | let to_type = to_type Nodes_env.empty 133 | -------------------------------------------------------------------------------- /tests/tests_onix.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | 3 | exception ParseError 4 | 5 | let test_parse_pp_str ?(isTodo=false) input expected_output _ = 6 | if isTodo then todo "Not implemented yet"; 7 | let output = 8 | begin 9 | match Parse.Parser.parse_string Parse.Parser.expr input with 10 | | Ok s -> Parse.Pp.pp_expr Format.str_formatter s; 11 | | Error (msg, _) -> 12 | output_string stderr msg; 13 | raise ParseError 14 | end; 15 | Format.flush_str_formatter () 16 | in 17 | assert_equal 18 | ~printer:(fun x -> x) 19 | expected_output 20 | output 21 | 22 | let isTodo = true (* To use [~isTodo] as a shortcut for [~isTodo=true] *) 23 | 24 | let testsuite = 25 | "onix_parser">::: 26 | List.map (fun (name, input, output) -> 27 | name >:: test_parse_pp_str input output) 28 | [ 29 | "test_var", "x", "x"; 30 | "test_const_int", "1234", "1234"; 31 | "test_const_true", "true", "true"; 32 | "test_const_false", "false", "false"; 33 | "test_lambda", "x: x", "(x: x)"; 34 | "test_app", "x y", "(x y)"; 35 | "test_multi_app", "x y z w", "(((x y) z) w)"; 36 | "test_multi_app_2", "x y (z w)", "((x y) (z w))"; 37 | "test_lambda_app", "(x: y) z", "((x: y) z)"; 38 | "test_app_lambda", "x: y z", "(x: (y z))"; 39 | "test_annotated_pattern", "x /*: int */: x", "(x /*: int */: x)"; 40 | "test_Y_comb", "(x: x x) (x: x x)", "((x: (x x)) (x: (x x)))"; 41 | "test_annot", "(x /*: int */)", "(x /*: int */)"; 42 | "test_annot_arrow", "(x /*: int -> int */)", "(x /*: (int) -> int */)"; 43 | "test_arith", "x + y - z + (- a)", "(((x + y) - z) + (-a))"; 44 | "test_string", "\"x\"", "\"x\""; 45 | "test_comment", "1 /* 12?3 */ /* /* 1 */", "1"; 46 | ("test_list_annot_1", "(x /*: [ Int ] */)", 47 | "(x /*: Cons(Int, X0) where X0 = nil */)"); 48 | ("test_list_annot_2", "(x /*: [ Int* ] */)", 49 | "(x /*: X0 where X0 = (Cons(Int, X0)) | X1 where X1 = nil */)"); 50 | ("test_list_annot_3", "(x /*: [ A|B ] */)", 51 | "(x /*: (Cons(A, X0)) | Cons(B, X1) where X0 = X1 where X1 = nil */)"); 52 | "test_annot_singleton_int", "x /*: 1 */: x", "(x /*: 1 */: x)"; 53 | "test_annot_singleton_true", "x /*: true */: x", "(x /*: true */: x)"; 54 | "test_annot_singleton_false", "x /*: false */: x", "(x /*: false */: x)"; 55 | "test_list", "[1 2 3]", "(1 :: (2 :: (3 :: nil)))"; 56 | "test_line_comment", "x: #fooooo \n x", "(x: x)"; 57 | "test_ite", "if e0 then e1 else e2", "if (e0) then e1 else e2"; 58 | ("test_assert", 59 | "assert true; 1", 60 | "if (true) then 1 else (raise \"assertion failed\")"); 61 | "test_record_1", "{ x = 1; y = 2; }", "{ x = 1; y = 2; }"; 62 | "test_record_access", "x.y.z.a.b", "x.y.z.a.b"; 63 | "test_record_access_dynamic", "x.${y}", "x.${y}"; 64 | "test_record_def_dynamec", "{ ${foo} = x; }" , "{ ${foo} = x; }"; 65 | ("test_pattern_record", 66 | "{ f, y ? f 3 /*: Int */ }: 1", 67 | "({ f, y ? (f 3) /*: Int */ }: 1)"); 68 | "test_pattern_record_trailing_comma", "{x,}:x", "({ x }: x)"; 69 | "test_pattern_record_open", "{x, ...}:x", "({ x, ... }: x)"; 70 | "test_pattern_alias", "{}@x:x", "({ }@x: x)"; 71 | ("test_record_annot", 72 | "(x /*: { x = Int; y =? Bool } */)", 73 | "(x /*: { x = Int; y =? Bool} */)"); 74 | ("test_record_annot_trailing_semi", 75 | "(x /*: { x = Int; y =? Bool; } */)", 76 | "(x /*: { x = Int; y =? Bool} */)"); 77 | ("test_record_annot_empty", "(x /*: { } */)", "(x /*: { } */)"); 78 | ("test_record_annot_dots", "(x /*: { ... } */)", "(x /*: { ... } */)"); 79 | ("test_record_annot_open", 80 | "(x /*: { x = Int; ... } */)", 81 | "(x /*: { x = Int; ... } */)"); 82 | "test_gradual", "(1 /*: ? */)", "(1 /*: ? */)"; 83 | "test_nested_record_let", "let x.y = 1; in x", "let x.y = 1; in x"; 84 | ("test_let_annot", 85 | "let x /*: Int */ = 1; in x", 86 | "let x /*: Int */ = 1; in x"); 87 | ("test_multiple_let", 88 | "let x = 1; y = 2; in x", 89 | "let x = 1; y = 2; in x"); 90 | "test_path", "./foo.nix", "./foo.nix"; 91 | "test_path2", "../foo.nix", "../foo.nix"; 92 | "test_with", "with e1; e2", "with e1; e2"; 93 | "test_or", "x.y or z", "x.y or z"; 94 | "test_bracket", "", ""; 95 | "record_merge", "{} // { x = 1; }", "({ } // { x = 1; })"; 96 | "interpol_string", "\"${foo}\"", "(foo + \"\")"; 97 | "interpol_string2", "\"blah${foo}bar\"", "(\"blah\" + (foo + \"bar\"))"; 98 | ] 99 | -------------------------------------------------------------------------------- /lib/simple/pp.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Pretty-printer the [Ast.t] 3 | *) 4 | module P = Ast 5 | module F = Format 6 | 7 | let drop_loc { Common.Location.With_loc.description = it; _ } = it 8 | let (%>) f g x = g (f x) 9 | 10 | let pp_ident = F.pp_print_string 11 | let kwd = F.pp_print_string 12 | 13 | let pp_option printer (fmt : F.formatter) = CCOpt.iter (fun x -> printer fmt x) 14 | 15 | let pp_binop fmt = function 16 | | P.Ocons -> F.pp_print_string fmt "::" 17 | | P.Oeq -> F.pp_print_string fmt "==" 18 | | P.Oplus -> F.pp_print_string fmt "+" 19 | | P.Ominus -> F.pp_print_string fmt "-" 20 | | P.Oand -> F.pp_print_string fmt "&&" 21 | | P.Oor -> F.pp_print_string fmt "||" 22 | | P.Omerge -> F.pp_print_string fmt "//" 23 | | P.Oconcat -> F.pp_print_string fmt "++" 24 | | P.OrecordMember -> F.pp_print_string fmt "?" 25 | 26 | and pp_monop fmt = function 27 | | P.Onot -> F.pp_print_string fmt "!" 28 | | P.Oneg -> F.pp_print_string fmt "-" 29 | 30 | let const fmt = function 31 | | P.Cbool b -> F.pp_print_bool fmt b 32 | | P.Cint i-> F.pp_print_int fmt i 33 | | P.Cstring s -> F.fprintf fmt "\"%s\"" s 34 | | P.Cpath s -> F.pp_print_string fmt s 35 | | P.Cbracketed s -> F.fprintf fmt "<%s>" s 36 | | P.Cundef -> F.pp_print_string fmt "%%undef" 37 | 38 | let rec pp_expr fmt = drop_loc %> function 39 | | P.Evar v -> 40 | pp_ident fmt v 41 | | P.Econstant c -> 42 | const fmt c 43 | | P.Elambda (p, e) -> 44 | F.fprintf fmt "@[<2>(%a:@ %a)@]" 45 | pp_pattern p 46 | pp_expr e 47 | | P.EfunApp (e1, e2) -> 48 | F.fprintf fmt "@[%a@ %a@]" 49 | pp_expr e1 50 | pp_expr e2 51 | | P.EtyAnnot (e, ty) -> 52 | F.fprintf fmt "@[(%a /*:@ %a */)@]" 53 | pp_expr e 54 | pp_typ ty 55 | | P.Ebinop (op, e1, e2) -> 56 | F.fprintf fmt "@[(%a %a %a)@]" 57 | pp_expr e1 58 | pp_binop op 59 | pp_expr e2 60 | | P.Emonop (op, e) -> 61 | F.fprintf fmt "@[(%a%a)]" 62 | pp_monop op 63 | pp_expr e 64 | | P.Erecord r -> 65 | F.fprintf fmt "@[{@;%a}@]" 66 | pp_fields r 67 | | P.EaccessPath (e, ap, None) -> pp_ap fmt e ap 68 | | P.EaccessPath (e, ap, Some guard) -> 69 | pp_ap fmt e ap; 70 | F.fprintf fmt " or %a" pp_expr guard 71 | | P.Elet (bindings, e) -> 72 | F.fprintf fmt "@[let %ain@;%a@]" 73 | pp_bindings bindings 74 | pp_expr e 75 | | P.Eite (eif, ethen, eelse) -> 76 | F.fprintf fmt "@[if (%a)@;then@ %a@;else@ %a@]" 77 | pp_expr eif 78 | pp_expr ethen 79 | pp_expr eelse 80 | | P.Ewith (e1, e2) -> 81 | F.fprintf fmt "with %a; %a" 82 | pp_expr e1 83 | pp_expr e2 84 | | _ -> failwith "TODO" 85 | 86 | and pp_bindings fmt = 87 | Format.pp_print_list 88 | ~pp_sep:(fun _ () -> ()) 89 | pp_binding 90 | fmt 91 | 92 | and pp_binding fmt = function 93 | (pat, e) -> 94 | Format.fprintf fmt "%a = %a; " 95 | pp_pattern_var pat 96 | pp_expr e 97 | 98 | and pp_ap fmt e ap = 99 | F.pp_print_list 100 | ~pp_sep:(fun fmt () -> F.pp_print_char fmt '.') 101 | pp_expr 102 | fmt 103 | (e::ap) 104 | 105 | and pp_fields fmt = 106 | F.pp_print_list pp_field fmt 107 | 108 | and pp_field fmt = function (e1, maybe_annot, e2) -> 109 | F.fprintf fmt "%a%a = %a; " 110 | pp_expr e1 111 | (pp_option pp_type_annot) maybe_annot 112 | pp_expr e2 113 | 114 | and pp_pattern fmt = drop_loc %> function 115 | | P.Pvar (v, None) -> pp_ident fmt v 116 | | P.Pvar (v, Some t) -> 117 | F.fprintf fmt "(%a: %a)" 118 | pp_ident v 119 | pp_typ t 120 | | P.Pnontrivial (sub_pattern, alias) -> 121 | pp_nontrivial_pattern fmt sub_pattern; 122 | pp_option (fun fmt var -> F.fprintf fmt "@%s" var) fmt alias 123 | 124 | and pp_pattern_var fmt = function 125 | | (v, None) -> pp_ident fmt v 126 | | (v, Some t) -> 127 | F.fprintf fmt "%a %a" 128 | pp_ident v 129 | pp_type_annot t 130 | 131 | and pp_nontrivial_pattern fmt = function 132 | | P.NPrecord (f, P.Open) when Record.is_empty f -> 133 | F.pp_print_string fmt "{ ... }" 134 | | P.NPrecord (fields, open_flag) -> 135 | F.fprintf fmt "{ %a%s }" 136 | pp_pat_record_fields fields 137 | (match open_flag with 138 | | P.Closed -> "" 139 | | P.Open -> ", ...") 140 | 141 | and pp_pat_record_fields fmt = 142 | Record.pp 143 | ~arrow:"" 144 | ~sep:", " 145 | Format.pp_print_string 146 | pp_pat_record_field_args 147 | fmt 148 | 149 | and pp_pat_record_field_args fmt (optional, type_annot) = 150 | F.fprintf fmt "%s%a" 151 | (if optional then "?" else "") 152 | (pp_option (fun fmt -> F.fprintf fmt " %a" pp_type_annot)) type_annot 153 | 154 | and pp_type_annot fmt = F.fprintf fmt "/*: %a */" pp_typ 155 | 156 | and pp_typ fmt = Common.Type_annotations.pp fmt 157 | 158 | and pp_op_args fmt = function 159 | | [] -> () 160 | | [a] -> 161 | pp_expr fmt a 162 | | a::tl -> 163 | F.fprintf fmt "%a,@ %a" 164 | pp_expr a 165 | pp_op_args tl 166 | -------------------------------------------------------------------------------- /lib/parse/pp.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Pretty-printer the [Ast.t] 3 | *) 4 | 5 | module P = Ast 6 | module T = Common.Type_annotations 7 | module F = Format 8 | 9 | let drop_loc = Common.Location.With_loc.description 10 | let (%>) f g x = g (f x) 11 | 12 | let pp_ident = F.pp_print_string 13 | let kwd = F.pp_print_string 14 | 15 | let pp_option printer (fmt : F.formatter) = CCOpt.iter (fun x -> printer fmt x) 16 | 17 | let const fmt = function 18 | | P.Cbool b -> F.pp_print_bool fmt b 19 | | P.Cint i-> F.pp_print_int fmt i 20 | | P.Cstring s -> F.fprintf fmt "\"%s\"" s 21 | | P.Cpath s -> CCFormat.string fmt s 22 | | P.Cbracketed s -> 23 | CCFormat.fprintf fmt "<%s>" s 24 | 25 | let pp_binop fmt = function 26 | | P.Ocons -> F.pp_print_string fmt "::" 27 | | P.Oeq -> F.pp_print_string fmt "==" 28 | | P.OnonEq -> F.pp_print_string fmt "!=" 29 | | P.Oplus -> F.pp_print_string fmt "+" 30 | | P.Ominus -> F.pp_print_string fmt "-" 31 | | P.Oand -> F.pp_print_string fmt "&&" 32 | | P.Oor -> F.pp_print_string fmt "||" 33 | | P.Oimplies -> F.pp_print_string fmt "->" 34 | | P.Omerge -> F.pp_print_string fmt "//" 35 | | P.Oconcat -> F.pp_print_string fmt "++" 36 | 37 | and pp_monop fmt = function 38 | | P.Onot -> F.pp_print_string fmt "!" 39 | | P.Oneg -> F.pp_print_string fmt "-" 40 | 41 | let rec pp_expr fmt = drop_loc %> function 42 | | P.Evar v -> 43 | pp_ident fmt v 44 | | P.Econstant c -> 45 | const fmt c 46 | | P.Elambda (p, e) -> 47 | F.fprintf fmt "@[<2>(%a:@ %a)@]" 48 | pp_pattern p 49 | pp_expr e 50 | | P.EfunApp (e1, e2) -> 51 | F.fprintf fmt "(@[%a@ %a@])" 52 | pp_expr e1 53 | pp_expr e2 54 | | P.EtyAnnot (e, ty) -> 55 | F.fprintf fmt "@[(%a %a)@]" 56 | pp_expr e 57 | pp_type_annot ty 58 | | P.Ebinop (op, e1, e2) -> 59 | F.fprintf fmt "@[(%a %a %a)@]" 60 | pp_expr e1 61 | pp_binop op 62 | pp_expr e2 63 | | P.Emonop (op, e) -> 64 | F.fprintf fmt "@[(%a%a)@]" 65 | pp_monop op 66 | pp_expr e 67 | | P.Elet (bindings, e) -> 68 | F.fprintf fmt "@[let %ain@;%a@]" 69 | pp_bindings bindings 70 | pp_expr e 71 | | P.Erecord r -> pp_record fmt r 72 | | P.Epragma (pragma, e) -> 73 | F.fprintf fmt "#:: %a\n%a" 74 | Pragma.pp pragma 75 | pp_expr e 76 | | P.Eite (eif, ethen, eelse) -> 77 | F.fprintf fmt "@[if (%a)@;then@ %a@;else@ %a@]" 78 | pp_expr eif 79 | pp_expr ethen 80 | pp_expr eelse 81 | | P.Eaccess (e, ap, default) -> 82 | F.fprintf fmt "%a.%a%a" 83 | pp_expr e 84 | pp_ap ap 85 | pp_access_guard default 86 | | P.EtestMember (e, ap) -> 87 | F.fprintf fmt "%a ? %a" 88 | pp_expr e 89 | pp_ap ap 90 | | P.Ewith (e1, e2) -> 91 | F.fprintf fmt "with %a; %a" 92 | pp_expr e1 93 | pp_expr e2 94 | 95 | and pp_ap fmt = F.pp_print_list 96 | ~pp_sep:(fun fmt () -> F.pp_print_char fmt '.') 97 | pp_ap_field 98 | fmt 99 | 100 | and pp_ap_field fmt = drop_loc %> function 101 | | P.AFexpr e -> 102 | F.fprintf fmt "${%a}" pp_expr e 103 | | P.AFidentifier s -> F.pp_print_string fmt s 104 | 105 | and pp_pattern fmt = drop_loc %> function 106 | | P.Pvar (v, a) -> pp_pattern_var fmt (v, a) 107 | | P.Pnontrivial (sub_pattern, alias) -> 108 | pp_nontrivial_pattern fmt sub_pattern; 109 | pp_option (fun fmt var -> F.fprintf fmt "@%s" var) fmt alias 110 | 111 | and pp_pattern_var fmt = function 112 | | (v, None) -> pp_ident fmt v 113 | | (v, Some t) -> 114 | F.fprintf fmt "%a %a" 115 | pp_ident v 116 | pp_type_annot t 117 | 118 | and pp_pattern_ap fmt = function 119 | | (v, None) -> pp_ap fmt v 120 | | (v, Some t) -> 121 | F.fprintf fmt "%a %a" 122 | pp_ap v 123 | pp_type_annot t 124 | 125 | and pp_nontrivial_pattern fmt = function 126 | | P.NPrecord ([], P.Open) -> 127 | F.pp_print_string fmt "{ ... }" 128 | | P.NPrecord (fields, open_flag) -> 129 | F.fprintf fmt "{ %a%s }" 130 | pp_pat_record_fields fields 131 | (match open_flag with 132 | | P.Closed -> "" 133 | | P.Open -> ", ...") 134 | 135 | and pp_pat_record_fields fmt = function 136 | | [] -> () 137 | | [f] -> pp_pat_record_field fmt f 138 | | f::tl -> 139 | pp_pat_record_field fmt f; 140 | F.pp_print_string fmt ", "; 141 | pp_pat_record_fields fmt tl 142 | 143 | and pp_pat_record_field fmt = function 144 | | { P.field_name; default_value; type_annot; } -> 145 | F.fprintf fmt "%a%a%a" 146 | pp_ident field_name 147 | (pp_option (fun fmt -> F.fprintf fmt " ? %a" pp_expr)) default_value 148 | (pp_option (fun fmt -> F.fprintf fmt " %a" pp_type_annot)) type_annot 149 | 150 | and pp_type_annot fmt = F.fprintf fmt "/*: %a */" pp_typ 151 | 152 | and pp_typ fmt = T.pp fmt 153 | 154 | and pp_op_args fmt = function 155 | | [] -> () 156 | | [a] -> 157 | pp_expr fmt a 158 | | a::tl -> 159 | F.fprintf fmt "%a,@ %a" 160 | pp_expr a 161 | pp_op_args tl 162 | 163 | and pp_record fmt { P.recursive; fields } = 164 | if recursive then F.pp_print_string fmt "rec "; 165 | F.fprintf fmt "@[{@ %a@]}" 166 | (fun fmt -> List.iter (pp_record_field fmt)) fields 167 | 168 | and pp_record_field fmt = drop_loc %> function 169 | | P.Fdef (ap, value) -> 170 | F.fprintf fmt "%a = %a;@ " 171 | pp_pattern_ap ap 172 | pp_expr value 173 | | P.Finherit (base_expr, fields) -> 174 | F.fprintf fmt "inherit %a%a;@ " 175 | (pp_option pp_base_expr) base_expr 176 | pp_fields fields 177 | 178 | and pp_base_expr fmt = F.fprintf fmt "(%a) " pp_expr 179 | 180 | and pp_fields fmt = 181 | F.pp_print_list 182 | ~pp_sep:F.pp_print_space 183 | (fun fmt -> drop_loc %> F.pp_print_string fmt) 184 | fmt 185 | 186 | and pp_bindings fmt = 187 | Format.pp_print_list 188 | ~pp_sep:(fun _ () -> ()) 189 | pp_binding 190 | fmt 191 | 192 | and pp_binding fmt = pp_record_field fmt 193 | 194 | and pp_access_guard fmt = function 195 | | Some guard -> CCFormat.fprintf fmt " or %a" pp_expr guard 196 | | None -> CCFormat.silent fmt () 197 | -------------------------------------------------------------------------------- /.ocplint: -------------------------------------------------------------------------------- 1 | 2 | 3 | (*************************************) 4 | (* Never edit options files while *) 5 | (* the program is running *) 6 | (*************************************) 7 | (* SECTION : Header *) 8 | (* These options must be read first *) 9 | (*************************************) 10 | 11 | 12 | 13 | (* [ignore]: Module to ignore during the lint. *) 14 | ignore = [ 15 | ] 16 | 17 | (* [db_persistence]: Time before erasing cached results (in days). *) 18 | db_persistence = 1 19 | plugin_typedtree = { 20 | 21 | (* [enabled]: A plugin with linters on typed tree. *) 22 | enabled = true 23 | fully_qualified_identifiers = { 24 | 25 | (* [enabled]: Enable/Disable linter "Fully-Qualified Identifiers". *) 26 | enabled = true 27 | 28 | (* [ignore]: Module to ignore durint the lint of "Fully-Qualified Identifiers" *) 29 | ignore = [ 30 | ] 31 | 32 | (* [warnings]: Enable/Disable warnings from "Fully-Qualified Identifiers" *) 33 | warnings = "+A" 34 | ignored_modules = [ 35 | Pervasives; 36 | Opal; 37 | ] 38 | ignore_operators = true 39 | ignore_depth = 2 40 | } 41 | polymorphic_function = { 42 | 43 | (* [enabled]: Enable/Disable linter "Polymorphic function". *) 44 | enabled = true 45 | 46 | (* [ignore]: Module to ignore durint the lint of "Polymorphic function" *) 47 | ignore = [ 48 | ] 49 | 50 | (* [warnings]: Enable/Disable warnings from "Polymorphic function" *) 51 | warnings = "+A" 52 | } 53 | } 54 | plugin_text = { 55 | 56 | (* [enabled]: A plugin with linters on the source. *) 57 | enabled = true 58 | code_length = { 59 | 60 | (* [enabled]: Enable/Disable linter "Code Length". *) 61 | enabled = true 62 | 63 | (* [ignore]: Module to ignore durint the lint of "Code Length" *) 64 | ignore = [ 65 | ] 66 | 67 | (* [warnings]: Enable/Disable warnings from "Code Length" *) 68 | warnings = "+A" 69 | 70 | (* [max_line_length]: Maximum line length *) 71 | max_line_length = 80 72 | } 73 | useless_space_line = { 74 | 75 | (* [enabled]: Enable/Disable linter "Useless space character and empty line at the end of file.". *) 76 | enabled = true 77 | 78 | (* [ignore]: Module to ignore durint the lint of "Useless space character and empty line at the end of file." *) 79 | ignore = [ 80 | ] 81 | 82 | (* [warnings]: Enable/Disable warnings from "Useless space character and empty line at the end of file." *) 83 | warnings = "+A" 84 | } 85 | not_that_char = { 86 | 87 | (* [enabled]: Enable/Disable linter "Detect use of unwanted chars in files". *) 88 | enabled = true 89 | 90 | (* [ignore]: Module to ignore durint the lint of "Detect use of unwanted chars in files" *) 91 | ignore = [ 92 | ] 93 | 94 | (* [warnings]: Enable/Disable warnings from "Detect use of unwanted chars in files" *) 95 | warnings = "+A" 96 | } 97 | } 98 | plugin_patch = { 99 | 100 | (* [enabled]: Detect pattern with semantic patch. *) 101 | enabled = true 102 | sempatch_lint_default = { 103 | 104 | (* [enabled]: Enable/Disable linter "Lint from semantic patches (default)". *) 105 | enabled = true 106 | 107 | (* [ignore]: Module to ignore durint the lint of "Lint from semantic patches (default)" *) 108 | ignore = [ 109 | ] 110 | 111 | (* [warnings]: Enable/Disable warnings from "Lint from semantic patches (default)" *) 112 | warnings = "+A" 113 | } 114 | sempatch_lint_user_defined = { 115 | 116 | (* [enabled]: Enable/Disable linter "Lint from semantic patches (user defined).". *) 117 | enabled = true 118 | 119 | (* [ignore]: Module to ignore durint the lint of "Lint from semantic patches (user defined)." *) 120 | ignore = [ 121 | ] 122 | 123 | (* [warnings]: Enable/Disable warnings from "Lint from semantic patches (user defined)." *) 124 | warnings = "+A" 125 | } 126 | } 127 | plugin_parsing = { 128 | 129 | (* [enabled]: Analyses requiring to re-parse the file *) 130 | enabled = true 131 | raw_syntax = { 132 | 133 | (* [enabled]: Enable/Disable linter "Raw Syntax". *) 134 | enabled = true 135 | 136 | (* [ignore]: Module to ignore durint the lint of "Raw Syntax" *) 137 | ignore = [ 138 | ] 139 | 140 | (* [warnings]: Enable/Disable warnings from "Raw Syntax" *) 141 | warnings = "+A" 142 | } 143 | } 144 | plugin_parsetree = { 145 | 146 | (* [enabled]: A plugin with linters on parsetree. *) 147 | enabled = true 148 | code_identifier_length = { 149 | 150 | (* [enabled]: Enable/Disable linter "Code Identifier Length". *) 151 | enabled = false 152 | 153 | (* [ignore]: Module to ignore durint the lint of "Code Identifier Length" *) 154 | ignore = [ 155 | ] 156 | 157 | (* [warnings]: Enable/Disable warnings from "Code Identifier Length" *) 158 | warnings = "+A" 159 | 160 | (* [min_identifier_length]: Identifiers with a shorter name will trigger a warning *) 161 | min_identifier_length = 2 162 | 163 | (* [max_identifier_length]: Identifiers with a longer name will trigger a warning *) 164 | max_identifier_length = 30 165 | } 166 | code_list_on_singleton = { 167 | 168 | (* [enabled]: Enable/Disable linter "List function on singleton". *) 169 | enabled = true 170 | 171 | (* [ignore]: Module to ignore durint the lint of "List function on singleton" *) 172 | ignore = [ 173 | ] 174 | 175 | (* [warnings]: Enable/Disable warnings from "List function on singleton" *) 176 | warnings = "+A" 177 | } 178 | phys_comp_allocated_lit = { 179 | 180 | (* [enabled]: Enable/Disable linter "Physical comparison between allocated litterals.". *) 181 | enabled = true 182 | 183 | (* [ignore]: Module to ignore durint the lint of "Physical comparison between allocated litterals." *) 184 | ignore = [ 185 | ] 186 | 187 | (* [warnings]: Enable/Disable warnings from "Physical comparison between allocated litterals." *) 188 | warnings = "+A" 189 | } 190 | fabrice_good_practices = { 191 | 192 | (* [enabled]: Enable/Disable linter "Good Practices". *) 193 | enabled = true 194 | 195 | (* [ignore]: Module to ignore durint the lint of "Good Practices" *) 196 | ignore = [ 197 | ] 198 | 199 | (* [warnings]: Enable/Disable warnings from "Good Practices" *) 200 | warnings = "+A" 201 | } 202 | check_constr_args = { 203 | 204 | (* [enabled]: Enable/Disable linter "Check Constructor Arguments". *) 205 | enabled = true 206 | 207 | (* [ignore]: Module to ignore durint the lint of "Check Constructor Arguments" *) 208 | ignore = [ 209 | ] 210 | 211 | (* [warnings]: Enable/Disable warnings from "Check Constructor Arguments" *) 212 | warnings = "+A" 213 | } 214 | code_redefine_stdlib_module = { 215 | 216 | (* [enabled]: Enable/Disable linter "Refedine Stdlib Module". *) 217 | enabled = false 218 | 219 | (* [ignore]: Module to ignore durint the lint of "Refedine Stdlib Module" *) 220 | ignore = [ 221 | ] 222 | 223 | (* [warnings]: Enable/Disable warnings from "Refedine Stdlib Module" *) 224 | warnings = "+A" 225 | } 226 | } 227 | plugin_indent = { 228 | 229 | (* [enabled]: A plugin with linters on the source. *) 230 | enabled = true 231 | ocp_indent = { 232 | 233 | (* [enabled]: Enable/Disable linter "Indention with ocp-indent". *) 234 | enabled = true 235 | 236 | (* [ignore]: Module to ignore durint the lint of "Indention with ocp-indent" *) 237 | ignore = [ 238 | ] 239 | 240 | (* [warnings]: Enable/Disable warnings from "Indention with ocp-indent" *) 241 | warnings = "+A" 242 | } 243 | } 244 | plugin_file_system = { 245 | 246 | (* [enabled]: A plugin with linters on file system like interface missing, etc. *) 247 | enabled = true 248 | interface_missing = { 249 | 250 | (* [enabled]: Enable/Disable linter "Missing interface". *) 251 | enabled = false 252 | 253 | (* [ignore]: Module to ignore durint the lint of "Missing interface" *) 254 | ignore = [ 255 | ] 256 | 257 | (* [warnings]: Enable/Disable warnings from "Missing interface" *) 258 | warnings = "+A" 259 | } 260 | project_files = { 261 | 262 | (* [enabled]: Enable/Disable linter "File Names". *) 263 | enabled = true 264 | 265 | (* [ignore]: Module to ignore durint the lint of "File Names" *) 266 | ignore = [ 267 | ] 268 | 269 | (* [warnings]: Enable/Disable warnings from "File Names" *) 270 | warnings = "+A" 271 | } 272 | } 273 | plugin_complex = { 274 | 275 | (* [enabled]: A plugin with linters on different inputs. *) 276 | enabled = true 277 | interface_module_type_name = { 278 | 279 | (* [enabled]: Enable/Disable linter "Checks on module type name.". *) 280 | enabled = true 281 | 282 | (* [ignore]: Module to ignore durint the lint of "Checks on module type name." *) 283 | ignore = [ 284 | ] 285 | 286 | (* [warnings]: Enable/Disable warnings from "Checks on module type name." *) 287 | warnings = "+A" 288 | } 289 | } 290 | -------------------------------------------------------------------------------- /tests/test_typecheck.ml: -------------------------------------------------------------------------------- 1 | open OUnit2 2 | module TA = Common.Type_annotations 3 | module T = Typing.Types 4 | 5 | module W = Typing.Typecheck.W 6 | 7 | open W.Infix 8 | 9 | exception ParseError of string 10 | 11 | let parse str = 12 | match Parse.Parser.(parse_string expr) str with 13 | | Ok s -> Simple.Of_onix.expr s 14 | | Error (msg, _) -> raise (ParseError msg) 15 | 16 | let typ str = 17 | match Parse.Parser.(parse_string typ) str with 18 | | Ok t -> Typing.Typecheck.W.value 19 | Typing.(Annotations.to_type Types.Environment.default t) 20 | | Error (msg, _) -> raise (ParseError msg) 21 | 22 | let infer env tokens = 23 | parse tokens >>= 24 | Typing.(Typecheck.Infer.expr env) 25 | 26 | let check env tokens expected_type = 27 | parse tokens >>= fun ast -> 28 | Typing.(Typecheck.Check.expr env ast expected_type) 29 | 30 | let test_infer_expr input expected_type _ = 31 | let expected_type = typ expected_type in 32 | let typ = 33 | let open Typing in 34 | infer Environment.default input 35 | in 36 | Typing.Typecheck.W.iter 37 | (assert_equal 38 | ~cmp:T.T.equiv 39 | ~printer:T.T.Print.string_of_type 40 | expected_type) 41 | typ 42 | 43 | let test_check input expected_type _= 44 | let expected_type = typ expected_type in 45 | let tast = 46 | let open Typing in 47 | check 48 | Environment.default 49 | input 50 | expected_type 51 | in ignore tast 52 | 53 | let test_var _ = 54 | let typ = 55 | infer 56 | Typing.Environment.(add_value default "x" Typing.Types.Builtins.int) 57 | "x" 58 | in 59 | Typing.Typecheck.W.iter (assert_equal Typing.Types.Builtins.int) typ 60 | 61 | let test_fail typefun _ = 62 | let result = typefun () in 63 | if Typing.Typecheck.W.log result = Common.Warning.List.empty then 64 | assert_failure "type error not detected" 65 | 66 | let test_infer_expr_fail input = 67 | test_fail @@ fun () -> 68 | let open Typing in 69 | infer Environment.default input 70 | 71 | let test_check_fail input expected_type = 72 | let expected_type = typ expected_type in 73 | test_fail @@ fun () -> 74 | let open Typing in 75 | check Environment.default input 76 | expected_type 77 | 78 | let one_singleton = T.Builtins.interval @@ T.Intervals.singleton_of_int 1 79 | 80 | let testsuite = 81 | "typecheck">::: 82 | 83 | ("infer_var">::test_var) :: 84 | (* ----- Positive tests ----- *) 85 | List.map (fun (name, expr, result) -> name >:: test_infer_expr expr result) 86 | [ 87 | "infer_const_int", "1", "1"; 88 | "infer_const_bool", "true", "true"; 89 | "infer_builtins_not", "__not", "((true -> false) & (false -> true))"; 90 | "infer_lambda", "x /*: Int */: 1", "Int -> 1"; 91 | "infer_lambda_var", "x /*: Int */: x", "Int -> Int"; 92 | "infer_apply", "(x /*: Int */: x) 1", "Int"; 93 | ("infer_arrow_annot", "x /*: Int -> Int */: x", 94 | "(Int -> Int) -> Int -> Int"); 95 | "infer_let_1", "let x = 1; in x", "1"; 96 | "infer_let_2", "let x /*:Int*/ = 1; in x", "Int"; 97 | "infer_let_3", "let x /*:Int*/ = 1; y = x; in y", "Int"; 98 | "infer_let_4", "let x = 1; y = x; in y", "?"; 99 | "infer_let_5", "let x = x; in x", "?"; 100 | "infer_let_6", "let x /*: Int -> Int */ = y: y; in x", "Int -> Int"; 101 | ("infer_let_7", "let x /*: Int -> Int -> Int */ = y: y: y; in x", 102 | "Int -> Int -> Int"); 103 | "infer_shadowing", "let x = true; in let x = 1; in x", "1"; 104 | "infer_union", "x /*: Int | Bool */: x", "(Int | Bool) -> (Int | Bool)"; 105 | "infer_intersection", "x /*: Int & Int */: x", "Int -> Int"; 106 | "test_not_true", "__not true", "false"; 107 | "test_list", "[1 true false]", "[1 true false]"; 108 | ("infer_ite_classic", "let x /*: Bool */ = true; in if x then 1 else 2", 109 | "1 | 2"); 110 | "infer_ite_dead_branch", "if true then 1 else __add 1 true", "1"; 111 | ("infer_ite_typecase_1", 112 | "let x /*: Int | Bool */ = 1; in if isInt x then x else __not x", 113 | "Int | Bool"); 114 | "infer_plus", "1 + 1", "Int"; 115 | "infer_string", "\"aze\"", "\"aze\""; 116 | "infer_string_annot", "x /*: \"foo\" */: x", "\"foo\" -> \"foo\""; 117 | ("infer_record_pattern", 118 | "{ x /*: Bool */, y ? 1 /*: Int */ }: x", 119 | "{ x= Bool; y =? Int } -> Bool"); 120 | "infer_arrow_no_annot_1", "x: x", "? -> ?"; 121 | "infer_arrow_no_annot_2", "x: y: y", "? -> ? -> ?"; 122 | "gradual_apply", "(x: x) 1", "?"; 123 | "gradual_apply_2", "let z = z; in z 1", "?"; 124 | "gradual_apply_3", "let z = z; in z z", "?"; 125 | "infer_record_1", "{ x = 1; y = 2; }", "{ x = 1; y = 2; }"; 126 | ("infer_recursive_record", 127 | "rec { x = 1; y = x; z /*: Int */ = x; }", 128 | "{ x = 1; y = ?; z = Int; }"); 129 | "infer_path", "./foo", "./foo"; 130 | "infer_record_access1", "{ x = 1; }.x", "1"; 131 | "infer_record_access2", "{ x.y = 1; }.x.y", "1"; 132 | "infer_record_access_dynamic", "{ x = 1; }.${\"x\"}", "1"; 133 | "infer_record_access_guarded", "{ x = 1; }.y or 2", "2"; 134 | ("infer_record_access_guarded_optional", 135 | "({ x = 1; } /*: { x =? 1; } */).x or 2", 136 | "1|2"); 137 | "infer_record_access_guarded_useless", "{ x = 1; }.x or 2", "1"; 138 | "infer_record_access_guarded_norecord", "1.x or 2", "2"; 139 | ("infer_record_access_guarded_infinite", 140 | "{ x = 1; }.${(\"y\" /*: String */)} or 2", 141 | "1 | 2"); 142 | ("infer_record_access_guarded_infinite2", 143 | "({ x = 1; } /*: { x = 1; ... } */).${(\"y\" /*: String */)} or 2", 144 | "Any"); 145 | "infer_bracket", "", "Path"; 146 | "infer_rmerge", "{ y = 2; } // { x = 1; }", "{ x = 1; y = 2; }"; 147 | "infer_rmerge_same_field", "{ x = 2; } // { x = 1; }", "{ x = 1; }"; 148 | ] @ 149 | (* ----- Negative tests ----- *) 150 | List.map (fun (name, expr) -> name >:: test_infer_expr_fail expr) 151 | [ 152 | "infer_fail_unbound_var", "x"; 153 | "infer_fail_apply", "1 1"; 154 | "infer_fail_apply2", "(x /*: Bool */: x) 1"; 155 | "infer_fail_apply3", "(x /*: Int */: x) true"; 156 | ("infer_fail_ite_not_bool_cond", 157 | "let x /*: Int | Bool */ = 1; in if x then 1 else 1"); 158 | ("infer_fail_ite_no_refine_1", 159 | "let x /*: Bool */ = true; in if x then __add x 1 else x"); 160 | ("infer_fail_ite_no_refine_2", 161 | "let f /*: Int -> Bool */ = x: true; x = 1; \ 162 | in if f x then __add x 1 else __not x"); 163 | "infer_fail_plus_not_int", "1 + true"; 164 | "infer_fail_false_string", "(\"false\" /*: false*/)"; 165 | "infer_fail_record_access", "{ x = 1; }.y"; 166 | "infer_fail_record_access_dynamic", "{ x = 1; }.${(\"x\" /*: String */)}"; 167 | ] @ 168 | (* ------ positive check ----- *) 169 | List.map (fun (name, expr, result) -> name >:: test_check expr result) 170 | [ 171 | "check_const_one", "1", "1"; 172 | "check_const_int", "1", "Int"; 173 | "check_const_union", "1", "1 | Bool"; 174 | "check_arrow_1", "x: x", "Int -> Int"; 175 | "check_arrow_2", "x: x", "1 -> Int"; 176 | "check_intersect_arrow", "x: x", "(Int -> Int) & (Bool -> Bool)"; 177 | "check_let", "let x = 1; in y: y", "Int -> Int"; 178 | "check_ite", "let x /*: Bool */ = true; in if x then 1 else 2", "Int"; 179 | ("check_ite_refine", 180 | "let x /*: Int | Bool */ = 1; in if isInt x then __add x 1 else true", 181 | "Int | true"); 182 | ("check_ite_dead_branch", 183 | "let x = true; in if x then true else false", 184 | "true"); 185 | "check_cons", "[1]", "[1]"; 186 | "check_cons_union", "[1]", "[1] | [ Bool ]"; 187 | "check_add", "1 + 1", "Int"; 188 | "check_minus", "1 - 1", "Int"; 189 | "check_unary_minus", "- (-1)", "1"; 190 | "check_gradual", "1", "?"; 191 | "check_gradual_lambda", "x: x", "? -> ?"; 192 | "check_annotated", "(1 /*: 1 */)", "Int"; 193 | "check_record1", "{ x = 1; }", "{ x = 1 }"; 194 | "check_record2", "{ x = 1; y = 2; }", "{ x = 1; y = 2 }"; 195 | "check_record3", "{ x = 1; y = 2; }", "{ x = 1; ... }"; 196 | "check_record_ap", "{ x = 1; }.x", "1"; 197 | "check_record_ap_dynamic", "{ x = 1; }.${\"x\"}", "1"; 198 | "check_record_ap_guarded", "{ x = 1; }.y or 2", "2"; 199 | "check_record_ap_guarded_useless", "{ x = 1; }.x or 2", "1"; 200 | ("check_record_ap_guarded_optional", 201 | "({ } /*: { x =? 1; } */).x or 2", 202 | "1|2"); 203 | "check_rmerge", "{ y = 2; } // { x = 1; }", "{ x = 1; y = 2; }"; 204 | "check_rmerge_same_field", "{ x = 2; } // { x = 1; }", "{ x = 1; }"; 205 | ] @ 206 | List.map (fun (name, expr, result) -> name >:: test_check_fail expr result) 207 | [ 208 | (* ------ negative check ----- *) 209 | "check_fail_const_int", "1", "Bool"; 210 | "check_fail_unbound_var", "x", "1"; 211 | "check_fail_bad_intersect_arrow", "x: x", "(Int -> Bool) & (Bool -> Int)"; 212 | "check_fail_inside_let", "let x = y /*: Bool */: y; in x", "Int -> Int"; 213 | "check_fail_ite_not_bool", "if 1 then 1 else 1", "Int"; 214 | "check_fail_cons", "[1]", "[ Bool ]"; 215 | "check_fail_cons_length", "[1]", "[ 1 1 ]"; 216 | "check_fail_unary_minus", "-1", "1"; 217 | "check_fail_annot_too_large", "(1 /*: Int */)", "1"; 218 | "check_fail_annot_too_restrictive", "(1 /*: 2 */)", "Int"; 219 | "check_fail_record_bad_label", "{ x = 1; }", "{ y = 1 }"; 220 | "check_fail_record_bad_field_value", "{ x = 1; }", "{ x = 2; }"; 221 | "check_fail_record_too_many_fields", "{ x = 1; }", "{}"; 222 | "check_fail_record_too_fiew_fields", "{ }", "{ x = 1 }"; 223 | ] 224 | -------------------------------------------------------------------------------- /lib/simple/of_onix.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Conversion between [Parse.Ast.t] and [Ast.t] 3 | *) 4 | module A = Common.Type_annotations 5 | module O = Parse.Ast 6 | module N = Ast 7 | 8 | module Loc = Common.Location 9 | module W = Common.Writer.Make (Common.Warning.List) 10 | module WL = Loc.With_loc 11 | 12 | open W.Infix 13 | 14 | let map_loc = WL.map 15 | 16 | let rec partition_binop op = function 17 | | [] -> [] 18 | | hd::_ as l -> 19 | let (partition_elt, rest) = 20 | CCList.partition (op hd) l 21 | in partition_elt :: partition_binop op rest 22 | 23 | let filter_inherit fields = 24 | CCList.partition_map 25 | (function 26 | | { WL.description = O.Finherit (e, fields); _ } -> `Right (e, fields) 27 | | { WL.description = O.Fdef (ap, value); location} -> 28 | `Left { WL.description = (ap, value); location; }) 29 | fields 30 | 31 | let rec flatten (fields : ((O.access_path * A.t option) * O.expr) WL.t list) : 32 | ((O.ap_field * A.t option) * O.expr) WL.t list W.t = 33 | let flattened_record fields = 34 | O.(Erecord { 35 | recursive = false; 36 | fields = 37 | List.map 38 | (WL.map 39 | (fun ((apf, annot), expr) -> 40 | Fdef (([apf], annot), expr))) fields; 41 | }) 42 | in 43 | (* Invariant: all the access paths are non-empty *) 44 | let partitionned_by_first_element = partition_binop 45 | (CCFun.compose_binop (fun f -> 46 | (CCList.hd @@ fst @@ fst f.WL.description).WL.description) 47 | (=)) 48 | fields 49 | in 50 | W.map_l 51 | (function 52 | | { WL.description = (([], _), _); _ } :: _ -> assert false 53 | (* The access-path can't be empty *) 54 | | [] -> assert false (* A record must have at least one field *) 55 | | [ { WL.description = (([ident], annot),e); location = _ } as field ] -> 56 | W.return { field with WL.description = ((ident, annot), e) } 57 | | { WL.description = ((ident::_, annot), _); location = loc } :: _ 58 | as fields -> 59 | let module E = struct 60 | exception MultipleField of Common.Location.t * O.expr 61 | end in 62 | begin try 63 | let sub_fields = 64 | W.map_l 65 | (fun { WL.description; location } -> 66 | let description = match description with 67 | | ((_::(_::_ as tl), annot), e) -> 68 | W.return ((tl, annot), e) 69 | | ((_::_, _), e) -> 70 | raise (E.MultipleField (location, e)) 71 | | (([],_),_) -> assert false (* This shouldn't happen *) 72 | in 73 | W.append 74 | (W.log description) 75 | (W.return 76 | { WL.description = W.value description; location; })) 77 | 78 | fields 79 | in 80 | sub_fields >>= fun sub_fields -> 81 | flatten sub_fields >|= fun flattened -> 82 | {WL.description = ((ident, None), 83 | WL.mk loc @@ flattened_record flattened); 84 | location = loc; 85 | } 86 | with 87 | E.MultipleField (loc, e) -> 88 | W.append 89 | [ Common.Warning.make loc @@ 90 | Format.sprintf 91 | "The field %s is defined several times" 92 | (Parse.Pp.pp_ap_field Format.str_formatter ident; 93 | Format.flush_str_formatter ())] 94 | (W.return 95 | { WL.description = ((ident, annot), e); location = loc }) 96 | end 97 | ) 98 | partitionned_by_first_element 99 | 100 | let binop : O.binop -> N.binop = function 101 | | O.Ocons -> N.Ocons 102 | | O.Oeq -> N.Oeq 103 | | O.Oplus -> N.Oplus 104 | | O.Ominus-> N.Ominus 105 | | O.Oand-> N.Oand 106 | | O.Oor-> N.Oor 107 | | O.Omerge -> N.Omerge 108 | | O.Oconcat -> N.Oconcat 109 | | O.OnonEq 110 | | O.Oimplies -> assert false (* treated separately *) 111 | 112 | let monop : O.monop -> N.monop = function 113 | | O.Onot-> N.Onot 114 | | O.Oneg -> N.Oneg 115 | 116 | let rec expr_desc : O.expr_desc -> N.expr_desc W.t = function 117 | | O.Evar s -> W.return @@ N.Evar s 118 | | O.Econstant c -> W.return @@ N.Econstant (constant c) 119 | | O.Elambda (pat, e) -> lambda pat e 120 | | O.EfunApp (e1, e2) -> 121 | funApp e1 e2 122 | | O.EtyAnnot (e, t) -> expr e >|= fun e -> N.EtyAnnot (e, t) 123 | | O.Ebinop (O.OnonEq, e1, e2) -> 124 | expr e1 >>= fun e1 -> 125 | expr e2 >|= fun e2 -> 126 | N.Emonop (N.Onot, WL.mk 127 | (WL.loc e1) 128 | (N.Ebinop (N.Oeq, e1, e2))) 129 | | O.Ebinop (O.Oimplies, e1, e2) -> 130 | let e1_loc = WL.loc e1 in 131 | expr e1 >>= fun e1 -> 132 | expr e2 >|= fun e2 -> 133 | N.Ebinop (N.Oor, e2, WL.mk e1_loc (N.Emonop (N.Onot, e1))) 134 | | O.Ebinop (o, e1, e2) -> 135 | expr e1 >>= fun e1 -> 136 | expr e2 >|= fun e2 -> 137 | N.Ebinop (binop o, e1, e2) 138 | | O.Emonop (o, e) -> 139 | expr e >|= fun e -> 140 | N.Emonop (monop o, e) 141 | | O.Elet (binds, e) -> 142 | bindings binds >>= fun binds -> 143 | expr e >|= fun e -> 144 | N.Elet (binds, e) 145 | | O.Eite (e0, e1, e2) -> 146 | expr e0 >>= fun e0 -> 147 | expr e1 >>= fun e1 -> 148 | expr e2 >|= fun e2 -> 149 | N.Eite (e0, e1, e2) 150 | (* TODO: smarter compilation of some form of if-then-else *) 151 | | O.Epragma (p, e) -> expr e >|= fun e -> N.Epragma (p, e) 152 | | O.Erecord r -> record r 153 | | O.Eaccess (e, ap, default) -> 154 | expr e >>= fun e -> 155 | access_path ap >>= fun ap -> 156 | W.map_opt expr default >|= fun default -> 157 | N.EaccessPath (e, ap, default) 158 | | O.EtestMember (e, ap) -> 159 | expr e >>= fun e -> 160 | (access_path ap 161 | |> if List.length ap > 1 then 162 | W.append 163 | [Common.Warning.(make ~kind:Warning (WL.loc (CCList.hd ap)) 164 | "The tail of this access_path has been dropped")] 165 | else fun x -> x) 166 | >|= fun ap -> 167 | N.Ebinop (N.OrecordMember, e, List.hd ap) 168 | (* FIXME: don't drop the tail of the access_path *) 169 | | O.Ewith (e1, e2) -> 170 | expr e1 >>= fun e1 -> 171 | expr e2 >|= fun e2 -> 172 | N.Ewith (e1, e2) 173 | 174 | and access_path ap = W.map_l ap_field ap 175 | 176 | and apf_to_expr = function 177 | | O.AFexpr e -> e.WL.description 178 | | O.AFidentifier s -> O.Econstant (O.Cstring s) 179 | 180 | and ap_field f = expr @@ map_loc apf_to_expr f 181 | 182 | and bindings b = 183 | let non_inherit_fields, _ = filter_inherit b in 184 | flatten non_inherit_fields >>= fun b -> 185 | W.map_l binding b 186 | 187 | and binding b = 188 | let ((apf, annot), e) = WL.description b in 189 | expr e >>= fun e -> 190 | match WL.description apf with 191 | | O.AFidentifier s -> 192 | W.return ((s, annot), e) 193 | | O.AFexpr e' -> 194 | W.append [Common.Warning.make 195 | ~kind:Common.Warning.Error 196 | (WL.loc e') 197 | "Dynamic let-bindings are not allowed"] @@ 198 | W.return (("%%INVALID_LHS%%", annot), e) 199 | 200 | and expr e = 201 | expr_desc (WL.description e) >|= fun description -> 202 | { e with WL.description } 203 | 204 | 205 | and open_flag = function 206 | | O.Open -> N.Open 207 | | O.Closed -> N.Closed 208 | 209 | and pattern_record_field { O.field_name; default_value; type_annot } = 210 | W.map_opt (fun e -> 211 | expr e >|= fun e -> 212 | (field_name, type_annot), e) 213 | default_value 214 | >|= fun value -> 215 | ((field_name, (CCOpt.is_some default_value, type_annot)), value) 216 | 217 | 218 | and nontrivial_pattern loc : 219 | O.nontrivial_pattern -> (N.nontrivial_pattern * N.binding list) W.t 220 | = function 221 | | O.NPrecord (fields, flag) -> 222 | W.map_l pattern_record_field fields >|= 223 | List.split >>= fun (new_fields, default_values) -> 224 | let default_values = CCList.flat_map CCOpt.to_list default_values 225 | in 226 | begin 227 | try W.return @@ Record.of_list_uniq new_fields 228 | with Invalid_argument _ -> 229 | W.append 230 | [Common.Warning.make loc "Duplicate element in pattern"] 231 | (W.return Record.empty) 232 | end 233 | >|= fun fields -> 234 | N.NPrecord (fields, open_flag flag), default_values 235 | 236 | and pattern_desc loc : O.pattern_desc -> (N.pattern_desc * N.binding list) W.t 237 | = function 238 | | O.Pvar (s, mt) -> W.return (N.Pvar (s, mt), []) 239 | | O.Pnontrivial (sub_pat, alias) -> 240 | nontrivial_pattern loc sub_pat >|= fun (sub_pat, default_values) -> 241 | N.Pnontrivial (sub_pat, alias), default_values 242 | 243 | and pattern p = 244 | let loc = WL.loc p in 245 | pattern_desc loc @@ WL.description p >|= fun (new_pat, default_values) -> 246 | (WL.mk loc new_pat, default_values) 247 | 248 | and constant = function 249 | | O.Cint i -> N.Cint i 250 | | O.Cbool b -> N.Cbool b 251 | | O.Cstring s -> N.Cstring s 252 | | O.Cpath s -> N.Cpath s 253 | | O.Cbracketed s -> N.Cbracketed s 254 | 255 | and record r = 256 | let { O.fields; recursive } = r in 257 | if recursive then 258 | let loc = List.hd fields 259 | |> WL.loc 260 | in 261 | bindings fields >|= fun created_bindings -> 262 | let new_record = 263 | N.Erecord (List.map (fun ((var, annot), { WL.location = loc; _}) -> 264 | (WL.mk loc @@ N.Econstant (N.Cstring var), 265 | annot, 266 | WL.mk loc @@ N.Evar var)) 267 | created_bindings) 268 | in 269 | N.Elet (created_bindings, WL.mk loc new_record) 270 | else 271 | let non_inherit_fields, inherit_fields = filter_inherit fields 272 | in 273 | W.map_l inherit_to_classic inherit_fields >>= fun inherit_fields -> 274 | flatten non_inherit_fields >>= fun flattened -> 275 | W.map_l 276 | (fun { WL.description = ((apf, annot), e); location } -> 277 | apf_to_expr (WL.description apf) 278 | |> WL.mk location 279 | |> expr 280 | >>= fun label_expr -> 281 | expr e >|= fun rhs_expr -> 282 | (label_expr, annot, rhs_expr)) 283 | flattened 284 | >|= fun new_record -> 285 | N.Erecord (new_record @ CCList.flatten inherit_fields) 286 | 287 | and lambda pat e = 288 | pattern pat >>= fun (new_pat, default_values) -> 289 | let loc = WL.loc e in 290 | let mangle_name = (^) "%%" in 291 | let mangled_values_def = 292 | List.map 293 | (* [let %%x /*: t | %%undef */ = x ] *) 294 | (fun ((var, annot), e) -> 295 | let annot = CCOpt.map 296 | (fun a -> 297 | let loc = WL.loc a in 298 | WL.mk loc 299 | A.(Infix ( 300 | Infix_constructors.Or, WL.mk loc (Var "%%undef"), a))) 301 | annot 302 | in 303 | ((mangle_name var, annot), 304 | WL.mk (WL.loc e) @@ N.Evar var)) 305 | default_values 306 | in 307 | let substitute_values = 308 | List.map 309 | (fun ((var, annot), e) -> 310 | let loc = WL.loc e in 311 | let al = WL.mk loc in 312 | let new_expr = 313 | (* [if isUndef [%e %%var] then [%e e] else [%e %%var]] *) 314 | al @@ N.Eite 315 | (al @@ N.EfunApp 316 | (al @@ N.Evar "%%isUndef", al @@ N.Evar (mangle_name var)), 317 | e, 318 | al @@ N.Evar (mangle_name var)) 319 | in 320 | ((var, annot), new_expr)) 321 | default_values 322 | in 323 | expr e >|= fun body -> 324 | let body = 325 | if default_values = [] then body else 326 | WL.mk loc 327 | (N.Elet (mangled_values_def, 328 | (WL.mk loc 329 | (N.Elet (substitute_values, body))))) 330 | in 331 | N.Elambda (new_pat, body) 332 | 333 | and funApp e1 e2 = 334 | expr e1 >>= fun e1 -> 335 | expr e2 >|= fun e2 -> 336 | match WL.description e1 with 337 | | N.Evar "import" -> N.Eimport e2 338 | | _ -> N.EfunApp (e1, e2) 339 | 340 | and inherit_to_classic ((base_expr, fields) : O.inherit_) 341 | : N.field list W.t = 342 | let mk_classic { WL.description = name; location = loc } = 343 | let value = match base_expr with 344 | | None -> W.return @@ WL.mk loc @@ N.Evar name 345 | | Some e -> 346 | expr e >|= fun e -> 347 | WL.mk loc 348 | @@ N.EaccessPath (e, [WL.mk loc @@ N.Econstant (N.Cstring name)], None) 349 | in 350 | value >|= fun value -> 351 | (WL.mk loc @@ N.Econstant (N.Cstring name), None, value) 352 | in 353 | W.map_l mk_classic fields 354 | 355 | -------------------------------------------------------------------------------- /lib/typing/types.ml: -------------------------------------------------------------------------------- 1 | (** Definition of the types used by Onix 2 | This is mostly a wrapper around Cduce types. 3 | *) 4 | 5 | module C = Cduce_lib 6 | module T = Cduce_lib.Types 7 | 8 | type t = T.t 9 | let pp = T.Print.pp_type 10 | let show = T.Print.string_of_type 11 | 12 | let node = T.cons 13 | let typ = T.descr 14 | 15 | let lift (direction : [> `Up | `Down ]) t = 16 | let reverse = function `Up -> `Down | `Down -> `Up in 17 | let replace_gradual direction = 18 | match direction with 19 | | `Up -> T.any 20 | | `Down -> T.empty 21 | in 22 | let map_bdd (type a b) (module S : C.Bool.S 23 | with type elem = a 24 | and type t = b) atm = 25 | let open T in 26 | S.compute ~empty ~full:any ~cup ~cap ~diff ~atom:atm 27 | in 28 | let map_vartype (type a) (module V : T.VarType with type Atom.t = a) 29 | direction atm t = 30 | map_bdd (module V) (function 31 | | `Var v when C.Var.equal v (C.Var.mk "?") -> 32 | replace_gradual direction 33 | | `Var _ -> assert false 34 | | `Atm a -> atm a) 35 | (V.proj t) 36 | in 37 | let module IntSet = CCHashSet.Make (CCInt) in 38 | let visited_set = IntSet.create 16 in 39 | let rec replace_gradual (direction : [> `Up | `Down ]) (typ : t) : t = 40 | let atoms = map_vartype (module T.VarAtoms) direction T.atom 41 | and ints = map_vartype (module T.VarIntervals) direction T.interval 42 | and chars = map_vartype (module T.VarChars) direction T.char 43 | and times = map_vartype (module T.VarTimes) direction 44 | (map_bdd (module T.Pair) @@ fun (n1, n2) -> 45 | T.times 46 | (replace_gradual_node direction n1) 47 | (replace_gradual_node direction n2)) 48 | (* and xml = Don't care, we don't use xml types *) 49 | and arrows = map_vartype (module T.VarArrow) direction 50 | (map_bdd (module T.Pair) @@ fun (n1, n2) -> 51 | T.arrow 52 | (replace_gradual_node (reverse direction) n1) 53 | (replace_gradual_node direction n2)) 54 | and records = map_vartype (module T.VarRec) direction 55 | (map_bdd (module T.Rec) @@ fun r -> 56 | CCPair.map2 (C.Ident.LabelMap.map 57 | (replace_gradual_node direction) 58 | ) r 59 | |> T.record_fields) 60 | and abstracts = map_vartype (module T.VarAbstracts) direction T.abstract 61 | in 62 | List.fold_left T.cup T.empty @@ List.map (fun f -> f typ) 63 | [arrows; ints; atoms; chars; times; records; abstracts] 64 | and replace_gradual_node direction n = 65 | if IntSet.mem visited_set (T.id n) then 66 | n 67 | else begin 68 | IntSet.insert visited_set (T.id n); 69 | T.cons @@ replace_gradual direction (T.descr n) 70 | end 71 | in 72 | replace_gradual direction t 73 | 74 | let lazy_preprocess t = 75 | let bottom = T.atom (C.Atoms.(atom @@ V.mk_ascii "#")) in 76 | let add_bottom = T.cup bottom in 77 | let map_bdd (type a b) (module S : C.Bool.S 78 | with type elem = a 79 | and type t = b) atm = 80 | let open T in 81 | S.compute ~empty ~full:any ~cup ~cap ~diff ~atom:atm 82 | in 83 | let map_vartype (type a) (module V : T.VarType with type Atom.t = a) atm t = 84 | map_bdd (module V) (function 85 | | `Var v -> T.var v 86 | | `Atm a -> atm a) 87 | (V.proj t) 88 | in 89 | let module IntMap = CCHashtbl.Make (CCInt) in 90 | let visited_set = IntMap.create 16 in 91 | let rec rewrite_for_lazy (typ : t) : t = 92 | let atoms = map_vartype (module T.VarAtoms) T.atom 93 | and ints = map_vartype (module T.VarIntervals) T.interval 94 | and chars = map_vartype (module T.VarChars) T.char 95 | and abstracts = map_vartype (module T.VarAbstracts) T.abstract 96 | and times = map_vartype (module T.VarTimes) 97 | (map_bdd (module T.Pair) @@ fun (n1, n2) -> 98 | T.times 99 | (rewrite_for_lazy_node n1) 100 | (rewrite_for_lazy_node n2)) 101 | (* and xml = Don't care, we don't use xml types *) 102 | and arrows = map_vartype (module T.VarArrow) 103 | (map_bdd (module T.Pair) @@ fun (n1, n2) -> 104 | T.arrow 105 | (rewrite_for_lazy_node n1) 106 | (rewrite_for_lazy_node n2)) 107 | and records = map_vartype (module T.VarRec) 108 | (map_bdd (module T.Rec) @@ fun r -> 109 | CCPair.map2 (C.Ident.LabelMap.map 110 | (fun n -> rewrite_for_lazy_node n) 111 | ) r 112 | |> T.record_fields) 113 | in 114 | List.fold_left T.cup T.empty @@ 115 | List.map (fun f -> f typ) 116 | [arrows; ints; atoms; chars; times; records; abstracts] 117 | and rewrite_for_lazy_node n = 118 | let id = T.id n in 119 | begin match IntMap.get visited_set id with 120 | | Some node -> node 121 | | None -> 122 | let new_node = T.make () in 123 | IntMap.add visited_set id new_node; 124 | T.define new_node @@ add_bottom @@ rewrite_for_lazy (T.descr n); 125 | new_node 126 | end 127 | in 128 | rewrite_for_lazy t 129 | 130 | let sub t1 t2 = 131 | C.Type_tallying.is_squaresubtype C.Var.Set.empty 132 | (lazy_preprocess @@ lift `Down t1) 133 | (lazy_preprocess @@ lift `Up t2) 134 | 135 | let applicative_lift t = 136 | assert (sub t T.Arrow.any); 137 | T.Iter.compute 138 | ~default:T.empty 139 | ~cup:(List.fold_left T.cup T.empty) 140 | ~cap:(List.fold_left T.cap T.any) 141 | ~neg:T.neg 142 | ~var:(fun v -> 143 | if C.Var.equal v (C.Var.mk "?") then 144 | T.arrow (T.cons @@ T.any) (T.cons @@ T.var v) 145 | else assert false) 146 | ~arrow:(fun (n1, n2) -> 147 | T.arrow 148 | (T.cons @@ (lift `Up (T.descr n1))) 149 | n2) 150 | t 151 | 152 | let get_arrow t = applicative_lift t |> T.Arrow.get 153 | let arrow_apply arrow arg = 154 | T.Arrow.apply arrow (T.cap (T.Arrow.domain arrow) (lift `Up arg)) 155 | 156 | let equiv = T.equiv 157 | 158 | (** Creates a fresh new node *) 159 | let fresh = T.make 160 | 161 | (** [unify t1 t2] adds the equation [t1 = t2] to the environment *) 162 | let define = T.define 163 | 164 | module Intervals : sig 165 | include module type of C.Intervals 166 | 167 | val singleton_of_int : int -> t 168 | end = struct 169 | include C.Intervals 170 | 171 | let singleton i = bounded i i 172 | let singleton_of_int i = 173 | let i = C.Intervals.V.from_int i in 174 | singleton i 175 | end 176 | 177 | module Node = struct 178 | type t = T.Node.t 179 | end 180 | 181 | module Bool = struct 182 | let all = C.Builtin_defs.bool 183 | let true_type = C.Builtin_defs.true_type 184 | let false_type = C.Builtin_defs.false_type 185 | 186 | (** [tnot t] returns the negation of the boolean type [t]. 187 | Raise [Invalid_argument] if [t] is not a boolean type (a subtype of 188 | [Bool]) *) 189 | let tnot t = 190 | if sub t true_type then 191 | false_type 192 | else if sub t false_type then 193 | true_type 194 | else raise (Invalid_argument "Types.Bool.tnot") 195 | 196 | (** See [lnot] 197 | Raise [Invalid_argument] if one of both arguments is not a subtype of 198 | [Bool]. *) 199 | let tand t1 t2 = 200 | if sub t1 all && sub t2 all then 201 | if sub t1 true_type && sub t2 true_type then 202 | true_type 203 | else false_type 204 | else raise (Invalid_argument "Types.Bool.tand") 205 | 206 | (** See [lnot] 207 | Raise [Invalid_argument] if one of both arguments is not a subtype of 208 | [Bool]. *) 209 | let tor t1 t2 = 210 | if sub t1 all && sub t2 all then 211 | if sub t1 true_type || sub t2 true_type then 212 | true_type 213 | else false_type 214 | else raise (Invalid_argument "Types.Bool.tand") 215 | end 216 | 217 | module Record = struct 218 | let of_list is_open fields = 219 | T.rec_of_list 220 | is_open 221 | (CCList.map (fun (is_optional, key, value) -> 222 | (is_optional, Cduce_lib.Ns.Label.mk_ascii key, value)) 223 | fields 224 | ) 225 | 226 | let make is_open fields = 227 | let label_fields = 228 | fields 229 | |> Simple.Record.to_list 230 | |> List.map (fun (key, value) -> 231 | (Cduce_lib.Ns.Label.mk_ascii key, value)) 232 | |> Cduce_lib.Ident.LabelMap.from_list_disj 233 | in 234 | Cduce_lib.Types.record_fields (is_open, label_fields) 235 | 236 | let any = of_list true [] 237 | 238 | let get_field f_name = 239 | T.Record.pi (C.Ident.Label.mk_ascii f_name) 240 | 241 | let labels r : string list = 242 | T.Record.all_labels r 243 | |> C.Ident.LabelSet.get 244 | |> List.map C.Ident.Label.get_ascii 245 | 246 | let absent = T.Record.absent 247 | 248 | let is_open r = 249 | T.Rec.compute 250 | ~empty:false 251 | ~full:true 252 | ~cup:(||) 253 | ~cap:(&&) 254 | ~atom:fst 255 | ~diff:(fun a b -> a && not b) 256 | (T.VarRec.leafconj @@ T.VarRec.proj r) 257 | 258 | let def r = 259 | if is_open r then 260 | T.cup absent T.any 261 | else 262 | absent 263 | 264 | let all_values r = 265 | CCList.fold_left 266 | (fun accu label -> T.cup accu (get_field label r)) 267 | (def r) 268 | (labels r) 269 | 270 | let merge = T.Record.merge 271 | end 272 | 273 | module GeneralizedString = struct 274 | module type NS = sig val namespace : string end 275 | module Make (NS: NS) = struct 276 | module StrSet = CCSet.Make(CCString) 277 | 278 | let str_ns = C.Ns.Uri.mk @@ C.Encodings.Utf8.mk NS.namespace 279 | 280 | let any = T.atom @@ C.Atoms.any_in_ns str_ns 281 | 282 | let singleton s = 283 | T.atom @@ C.Atoms.atom (C.Atoms.V.mk (str_ns, C.Encodings.Utf8.mk s)) 284 | 285 | (** [get t] returns either [List_or_infinite.Finite l] where [l] is the list 286 | of the strings that the type [t] contains or [List_or_infinite.Infinite]. 287 | No check is done to ensure that [t] is a subtype of [string] *) 288 | let get t : string List_or_infinite.t = 289 | let atoms = T.Atom.get t in 290 | let cup x1 x2 = match (x1, x2) with 291 | | `Finite l1, `Finite l2 -> `Finite (StrSet.union l1 l2) 292 | | `Cofinite l1, `Cofinite l2 -> `Cofinite (StrSet.inter l1 l2) 293 | | `Cofinite l1, `Finite l2 -> `Cofinite (StrSet.diff l1 l2) 294 | | `Finite l1, `Cofinite l2 -> `Cofinite (StrSet.diff l2 l1) 295 | | `Variable, _ 296 | | _, `Variable -> `Variable 297 | and neg = function 298 | | `Finite l -> `Cofinite l 299 | | `Cofinite l -> `Finite l 300 | | `Variable -> `Variable 301 | in 302 | let cap x1 x2 = neg @@ cup (neg x1) (neg x2) in 303 | let diff x1 x2 = cap x1 (neg x2) in 304 | let get_from_atom atm = 305 | let get_name atom_elt = 306 | let (_, unicode_name) = C.Atoms.V.value atom_elt in 307 | C.Encodings.Utf8.get_str unicode_name 308 | in 309 | let (direction, sub_atoms) = 310 | match C.Atoms.extract atm with 311 | | `Finite s -> (`Finite, s) 312 | | `Cofinite s -> (`Cofinite, s) 313 | in 314 | let string_atoms = CCList.find_map 315 | (fun (ns, atms) -> 316 | if C.Ns.Uri.equal str_ns ns then Some atms else None) 317 | sub_atoms 318 | |> CCOpt.get_or ~default:(`Finite []) 319 | in 320 | begin match string_atoms with 321 | | `Finite elts -> `Finite (StrSet.of_list (List.map get_name elts)) 322 | | `Cofinite elts -> `Cofinite (StrSet.of_list (List.map get_name elts)) 323 | end 324 | |> (fun s -> if direction = `Cofinite then neg s else s) 325 | in 326 | match 327 | T.VarAtoms.compute atoms 328 | ~atom:(function `Var _ -> `Variable | `Atm a -> get_from_atom a) 329 | ~empty:(`Finite StrSet.empty) 330 | ~full:(`Cofinite StrSet.empty) 331 | ~cup 332 | ~cap 333 | ~diff 334 | with 335 | | `Cofinite _ -> List_or_infinite.Infinite 336 | | `Variable -> List_or_infinite.Infinite 337 | | `Finite l -> List_or_infinite.Finite (StrSet.to_list l) 338 | end 339 | end 340 | 341 | module String = GeneralizedString.Make(struct let namespace = "str" end) 342 | 343 | module Path = GeneralizedString.Make(struct let namespace = "path" end) 344 | 345 | (** Builtin types *) 346 | module Builtins : sig 347 | val true_type : t (* [true] is a keyword in OCaml *) 348 | val false_type : t (* [false] is a keyword in OCaml *) 349 | 350 | val int : t 351 | val bool : t 352 | val char : t 353 | val string : t 354 | val path : t 355 | val nil : t 356 | val any : t 357 | val empty : t 358 | val grad : t 359 | val undef : t 360 | 361 | val interval : Intervals.t -> t 362 | 363 | val cons : Node.t -> Node.t -> t 364 | val arrow : Node.t -> Node.t -> t 365 | val cup : t -> t -> t 366 | val cap : t -> t -> t 367 | val diff : t -> t -> t 368 | val neg : t -> t 369 | val record : bool -> Node.t Simple.Record.t -> t 370 | end 371 | = struct 372 | include C.Builtin_defs 373 | 374 | let empty = T.empty 375 | 376 | let grad = T.var (C.Var.mk "?") 377 | 378 | let undef = T.atom (C.Atoms.(atom @@ V.mk_ascii "%%undef")) 379 | 380 | let interval = C.Types.interval 381 | 382 | (* We don't use CDuce's strings because these are lists of chars (which isn't 383 | the case in Nix) *) 384 | let string = String.any 385 | 386 | let path = Path.any 387 | 388 | let arrow = C.Types.arrow 389 | 390 | let cons = C.Types.times 391 | 392 | let cup = C.Types.cup 393 | let cap = C.Types.cap 394 | let diff = C.Types.diff 395 | let neg = C.Types.neg 396 | 397 | let record = Record.make 398 | end 399 | 400 | module Singleton = struct 401 | let int i = C.(Types.interval Intervals.(bounded 402 | (V.from_int i) 403 | (V.from_int i))) 404 | 405 | let bool = function 406 | | true -> C.Builtin_defs.true_type 407 | | false -> C.Builtin_defs.false_type 408 | 409 | let string = String.singleton 410 | 411 | let path = Path.singleton 412 | end 413 | 414 | module Environment : sig 415 | (** The type representing a type environment. 416 | A type environment is a map from type variables to their definition 417 | *) 418 | type t 419 | 420 | (** The empty environment *) 421 | val empty : t 422 | 423 | (** The default environment containing all the builtin types *) 424 | val default : t 425 | 426 | val lookup : t -> string -> T.t option 427 | 428 | (** [add nam typ env] adds a new type named [nam] and defined by [typ] to the 429 | environment [env], relpacing any previously defined typ with that name 430 | * *) 431 | val add : string -> T.t -> t -> t 432 | end = struct 433 | module M = CCMap.Make(CCString) 434 | type t = T.t M.t 435 | 436 | let empty = M.empty 437 | 438 | let builtin_types = 439 | let module B = Builtins in 440 | [ 441 | "Int", B.int; 442 | "Bool", B.bool; 443 | "Char", B.char; 444 | "String", B.string; 445 | "Path", B.path; 446 | "true", B.true_type; 447 | "false", B.false_type; 448 | "?", B.grad; 449 | "nil", B.nil; 450 | "%%undef", B.undef; 451 | "Empty", B.empty; 452 | "Any", B.any; 453 | ] 454 | 455 | let default = 456 | M.of_list builtin_types 457 | 458 | let lookup env name = M.get name env 459 | 460 | let add = M.add 461 | end 462 | -------------------------------------------------------------------------------- /lib/parse/parser.ml: -------------------------------------------------------------------------------- 1 | module Location = Common.Location 2 | 3 | module A = Ast 4 | module P = MParser 5 | module T = Common.Type_annotations 6 | module W = Location.With_loc 7 | 8 | module StrHash = CCHashSet.Make(CCString) 9 | 10 | let (>>=) = P.(>>=) 11 | let (|>>) = P.(|>>) 12 | let (<|>) = P.(<|>) 13 | let () = P.() 14 | let (>>) = P.(>>) 15 | let (<<) = P.(<<) 16 | 17 | type 'a t = ('a, string) MParser.t 18 | 19 | type 'a return = ('a, string * MParser.error) result 20 | 21 | let keywords = StrHash.of_list [ 22 | "if"; "then"; "else"; 23 | "let"; "in"; 24 | "true"; "false"; 25 | "assert"; 26 | "rec"; 27 | "with"; 28 | "or"; 29 | ] 30 | 31 | let get_loc = 32 | P.get_user_state >>= fun file_name -> 33 | P.get_pos |>> fun (_, lnum, cnum) -> 34 | Location.{ file_name; lnum; cnum; } 35 | 36 | let add_loc x = 37 | get_loc >>= fun loc -> 38 | x |>> fun x -> 39 | W.mk loc x 40 | 41 | (** {2 Some utility functions } *) 42 | let any x = P.choice @@ List.map P.attempt x 43 | 44 | let block_comment = 45 | (P.attempt (P.string "/*" << P.not_followed_by (P.char ':') "colon")) >> 46 | P.skip_many_chars_until P.any_char_or_nl (P.char '*' << P.char '/') 47 | 48 | let line_comment = P.char '#' << P.not_followed_by (P.string "::") "" 49 | >> P.skip_many_until P.any_char P.newline 50 | 51 | let comment = P.choice [ block_comment; line_comment; ] "comment" 52 | 53 | let one_space = (P.skip P.space <|> comment "whitespace") 54 | let space = P.skip_many one_space 55 | 56 | let keyword k = P.string k << 57 | P.not_followed_by P.alphanum "not a keyword" << space 58 | 59 | let alphanum_ = P.alphanum <|> P.any_of "_-'" 60 | let letter_ = P.letter <|> P.char '_' 61 | 62 | let isolated_dot = 63 | P.char '.' << P.not_followed_by (P.any_of "./") "begin of path" 64 | 65 | let ident = 66 | P.attempt @@ (letter_ >>= fun c0 -> 67 | P.many_chars alphanum_ << space >>= fun end_name -> 68 | let name = (CCString.of_char c0) ^ end_name in 69 | if StrHash.mem keywords name then 70 | P.zero 71 | else 72 | P.return name) 73 | "ident" 74 | 75 | let uri = 76 | let scheme = 77 | P.letter >>= fun c0 -> 78 | P.many_chars (P.alphanum <|> P.any_of "+-.") |>> fun end_scheme -> 79 | (CCString.of_char c0) ^ end_scheme 80 | and uriEnd = P.many1_chars (P.alphanum <|> P.any_of "%/?:@&=+$,-_.!~*'") 81 | in 82 | P.attempt (scheme << P.char ':') >>= fun s -> 83 | uriEnd << space |>> fun e -> 84 | s ^ ":" ^ e 85 | 86 | let int = P.many1_chars P.digit << space |>> int_of_string 87 | 88 | let parens x = P.char '(' >> space >> x << P.char ')' << space 89 | 90 | let bool = P.choice 91 | [keyword "true" >> P.return true; 92 | keyword "false" >> P.return false] 93 | << space 94 | "boolean" 95 | 96 | let schar escape delim = 97 | (escape >> P.any_char_or_nl) 98 | <|> 99 | (P.not_followed_by delim "end of string" >> P.any_char_or_nl) 100 | 101 | let antiQuot expr = 102 | (P.attempt @@ P.string "${" >> expr) << P.char '}' 103 | (* Don't skip spaces because it is used in strings *) 104 | "anti quotation" 105 | 106 | let string (expr : (A.expr, string) P.t) = 107 | let antiQuot = 108 | add_loc (antiQuot expr) |>> fun e -> `Expr e 109 | and plainChar escape delim = 110 | (add_loc @@ schar escape delim) 111 | |>> fun c -> `Char c 112 | and flattenString loc l = 113 | let rec aux loc cur_buf_opt lst = 114 | match (cur_buf_opt, lst) with 115 | | Some b, `Char { W.description = c; _ }::tl -> 116 | Buffer.add_char b c; 117 | aux loc (Some b) tl 118 | | Some b, (`Expr e_wl::_ as l) -> 119 | let current_string = Buffer.contents b in 120 | Buffer.clear b; 121 | let e = aux loc None l in 122 | W.mk (W.loc e_wl) 123 | @@ A.Ebinop (A.Oplus, 124 | W.mk loc 125 | @@ A.Econstant (A.Cstring current_string), 126 | e) 127 | | None, `Char { W.description = c; location = loc; }::tl -> 128 | let b = Buffer.create 127 in 129 | Buffer.add_char b c; 130 | aux loc (Some b) tl 131 | | None, `Expr e_wl::tl -> 132 | let e = W.description e_wl in 133 | W.mk (W.loc e_wl) @@ A.Ebinop (A.Oplus, e, (aux loc None tl)) 134 | | None, [] -> W.mk loc @@ A.Econstant (A.Cstring "") 135 | | Some b, [] -> W.mk loc @@ A.Econstant (A.Cstring (Buffer.contents b)) 136 | in aux loc None l 137 | in 138 | let str escape delim = delim >> 139 | get_loc >>= fun loc -> 140 | P.many (antiQuot <|> plainChar escape delim) << delim << space |>> flattenString loc 141 | in 142 | let simple_string = 143 | str (P.char '\\') (P.char '"') 144 | "simple string" 145 | and indented_string = 146 | str 147 | (P.attempt (P.string "''" << P.followed_by (P.char '$') "dollar escape")) 148 | (P.string "''") 149 | "indented string" 150 | in 151 | simple_string <|> indented_string 152 | 153 | let litteral_string = 154 | P.char '"' >> P.many_chars_until (schar (P.char '\\') (P.char '"')) (P.char '"') << space 155 | 156 | let litteral_path = 157 | ((P.attempt @@ P.string "./" <|> P.string "../") >>= fun prefix -> 158 | P.many_chars (P.choice [ P.alphanum; P.any_of "-/_.+" ]) << space |>> fun path -> 159 | prefix ^ path) 160 | "Path" 161 | 162 | let bracketed_path = 163 | (P.char '<' >> 164 | P.many_chars (P.choice [ P.alphanum; P.any_of "-/_." ]) << 165 | P.char '>' << space |>> fun content -> 166 | content) 167 | "Bracketed path" 168 | 169 | let infix_ops = 170 | let infix sym f assoc = P.Infix ( 171 | (get_loc >>= fun loc -> 172 | P.skip_string sym >> space >> 173 | P.return (fun e1 e2 -> 174 | W.mk loc (f e1 e2))), 175 | assoc) 176 | and prefix sym f = P.Prefix ( 177 | get_loc >>= fun loc -> 178 | P.skip_string sym >> space >> 179 | P.return (fun e -> W.mk loc (f e))) 180 | in 181 | [ 182 | [ prefix "-" (fun e -> A.Emonop (A.Oneg, e)); 183 | prefix "!" (fun e -> A.Emonop (A.Onot, e)); 184 | ]; 185 | [ 186 | infix "==" (fun e1 e2 -> A.Ebinop (A.Oeq, e1, e2)) P.Assoc_left; 187 | infix "!=" (fun e1 e2 -> A.Ebinop (A.OnonEq, e1, e2)) P.Assoc_left; 188 | infix "+" (fun e1 e2 -> A.Ebinop (A.Oplus, e1, e2)) P.Assoc_left; 189 | infix "-" (fun e1 e2 -> A.Ebinop (A.Ominus, e1, e2)) P.Assoc_left; 190 | infix "//" (fun e1 e2 -> A.Ebinop (A.Omerge, e1, e2)) P.Assoc_left; 191 | infix "++" (fun e1 e2 -> A.Ebinop (A.Oconcat, e1, e2)) P.Assoc_left; 192 | ]; 193 | [ 194 | infix "&&" (fun e1 e2 -> A.Ebinop (A.Oand, e1, e2)) P.Assoc_left; 195 | infix "||" (fun e1 e2 -> A.Ebinop (A.Oor, e1, e2)) P.Assoc_left; 196 | infix "->" (fun e1 e2 -> A.Ebinop (A.Oimplies, e1, e2)) P.Assoc_left; 197 | ]; 198 | ] 199 | 200 | (** {2 Begining of the parser } *) 201 | 202 | (** {3 Type annotations} *) 203 | 204 | let typ_op = 205 | let module I = T.Infix_constructors in 206 | let infix sym op assoc = P.Infix ( 207 | (get_loc >>= fun loc -> P.skip_string sym >> space >> 208 | P.return (fun t1 t2 -> 209 | W.mk loc (T.Infix (op, t1, t2)))), 210 | assoc) 211 | in 212 | [ 213 | [ infix "&" I.And P.Assoc_left ]; 214 | [ infix "|" I.Or P.Assoc_left ]; 215 | [ infix "\\" I.Diff P.Assoc_left ]; 216 | [ infix "->" I.Arrow P.Assoc_right ]; 217 | ] 218 | 219 | 220 | let typ_regex_postfix_op = 221 | get_loc >>= fun loc -> 222 | let mkloc = W.mk loc in 223 | P.choice [ 224 | P.char '*' >> space >> P.return (fun r -> mkloc @@ Regex_list.Star r); 225 | P.char '+' >> space >> P.return (fun r -> mkloc @@ Regex_list.Plus r); 226 | P.char '?' >> space >> P.return (fun r -> mkloc @@ Regex_list.Maybe r); 227 | ] 228 | 229 | let typ_int = 230 | int |>> fun nb -> 231 | T.(Singleton (Singleton.Int nb)) 232 | 233 | let typ_bool = 234 | bool |>> fun b -> 235 | T.(Singleton (Singleton.Bool b)) 236 | 237 | let typ_string = 238 | litteral_string |>> fun s -> 239 | T.(Singleton (Singleton.String s)) 240 | 241 | let typ_path = 242 | litteral_path |>> fun s -> 243 | T.(Singleton (Singleton.Path s)) 244 | 245 | let typ_ident i = i |> add_loc ( 246 | (ident |>> fun t -> T.Var t) 247 | <|> 248 | (P.char '?' >> space >> P.return T.Gradual)) 249 | and typ_singleton i = i |> add_loc 250 | @@ P.choice [typ_int; typ_bool; typ_string; typ_path ] 251 | 252 | let rec typ i = 253 | i |> ( 254 | typ_simple >>= fun t -> 255 | P.many_fold_left 256 | (fun accu_ty -> W.map (fun c -> T.TyBind (c, accu_ty))) 257 | t 258 | where_clause) 259 | 260 | and where_clause i = 261 | i |> add_loc ( 262 | keyword "where" >> 263 | P.sep_by typ_binding (keyword "and") 264 | ) 265 | 266 | and typ_binding i = 267 | i |> ( 268 | ident >>= fun name -> 269 | P.char '=' >> space >> 270 | typ |>> fun t -> 271 | (name, t) 272 | ) 273 | 274 | and typ_simple i = i |> (P.expression typ_op 275 | (P.choice [typ_list; typ_record; typ_atom;]) 276 | "type") 277 | 278 | and typ_atom i = i |> P.choice [ typ_singleton; typ_ident; parens typ] 279 | 280 | and typ_regex i = 281 | i |> ( 282 | any [typ_regex_alt; typ_regex_concat; ] 283 | "type regex") 284 | 285 | and typ_regex_alt i = 286 | i |> add_loc ( 287 | typ_regex_concat >>= fun t1 -> 288 | P.char '|' >> space >> 289 | typ_regex |>> fun t2 -> 290 | Regex_list.Or (t1, t2)) 291 | 292 | and typ_regex_postfix i = 293 | i |> ( 294 | typ_regex_atom >>= fun r0 -> 295 | P.many typ_regex_postfix_op |>> fun ops -> 296 | List.fold_left (fun r op -> op r) r0 ops 297 | ) 298 | 299 | and typ_regex_atom i = 300 | i |> ( 301 | parens typ_regex 302 | <|> 303 | (add_loc (typ_atom |>> fun t -> Regex_list.Type t))) 304 | 305 | and typ_regex_concat i = 306 | i |> ( 307 | get_loc >>= fun loc -> 308 | typ_regex_postfix >>= fun r0 -> 309 | P.many typ_regex_postfix |>> fun tl -> 310 | List.fold_left (fun accu r -> 311 | W.mk loc (Regex_list.Concat (accu, r))) 312 | r0 313 | tl 314 | ) 315 | 316 | and typ_list i = 317 | i |> ( 318 | P.char '[' >> space >> typ_regex << P.char ']' << space |>> 319 | Regex_list.to_type) 320 | 321 | and typ_record i = 322 | i |> add_loc (( 323 | P.char '{' >> space >> typ_record_fields << P.char '}' << space 324 | |>> fun (fields, is_open) -> 325 | T.Record (fields, is_open)) 326 | "type record") 327 | 328 | and typ_record_fields i = 329 | i |> P.choice [ 330 | (typ_record_field << P.optional (P.char ';') << space >>= fun field -> 331 | typ_record_fields |>> fun (fields, is_open) -> 332 | (field :: fields, is_open)); 333 | (P.string "..." >> space >> P.return ([], true)); 334 | (P.return ([], false)); 335 | ] 336 | 337 | and typ_record_field i = 338 | i |> ( 339 | ident >>= fun name -> 340 | (P.char '=' >> P.option (P.char '?') << space |>> CCOpt.is_some) 341 | >>= fun is_optional -> 342 | typ |>> fun t -> (name, (is_optional, t)) 343 | ) 344 | 345 | let type_annot = (P.string "/*:" >> space >> typ << P.string "*/" << space) 346 | "type annotation" 347 | 348 | (** {3 Expressions} *) 349 | 350 | let expr_int = add_loc ( 351 | int |>> fun nb -> 352 | A.Econstant (A.Cint nb) 353 | ) 354 | 355 | let expr_bool = add_loc ( 356 | bool |>> fun b -> 357 | A.Econstant (A.Cbool b) 358 | ) 359 | 360 | let expr_path = add_loc ( 361 | litteral_path |>> fun s -> 362 | A.Econstant (A.Cpath s) 363 | ) 364 | 365 | let expr_uri = add_loc ( 366 | uri |>> fun s -> 367 | A.Econstant (A.Cstring s) 368 | ) 369 | 370 | let expr_bracket = add_loc ( 371 | bracketed_path |>> fun brack -> 372 | A.Econstant (A.Cbracketed brack) 373 | ) 374 | 375 | let expr_ident = add_loc ( 376 | ident |>> fun id -> 377 | A.Evar id 378 | ) 379 | 380 | let pattern_var = 381 | ident >>= fun id -> 382 | P.option (P.attempt type_annot) |>> fun annot -> 383 | (id, annot) 384 | 385 | let pattern_ident = add_loc ( 386 | pattern_var |>> fun (id, annot) -> 387 | A.Pvar (id, annot) 388 | ) 389 | 390 | and expr_const = 391 | (P.choice [expr_int; expr_bool; expr_path; expr_uri; expr_bracket]) 392 | "constant" 393 | 394 | let rec expr i = 395 | i |> ( 396 | P.choice [ 397 | expr_pragma; 398 | expr_let; 399 | expr_if; 400 | expr_assert; 401 | expr_with; 402 | expr_lambda; 403 | P.attempt expr_infix; 404 | expr_apply_or_member; 405 | ] 406 | ) 407 | 408 | and expr_pragma i = 409 | i |> (add_loc ( 410 | P.string "#::" >> 411 | space >> 412 | keyword "WARN" >> 413 | P.many1 warning_annot >>= fun warnings -> 414 | P.skip_many P.blank >> P.newline >> space >> 415 | expr |>> fun e -> 416 | A.Epragma (Pragma.Warnings warnings, e)) 417 | "Pragma" 418 | ) 419 | 420 | and warning_annot i = 421 | i |> ( 422 | P.any_of "+-" >>= fun sign_char -> 423 | let sign = if sign_char = '+' then Pragma.Plus else Pragma.Minus in 424 | ident >>= fun name -> 425 | match Pragma.Warning.read name with 426 | | Some w -> P.return (sign, w) 427 | | None -> P.fail "Invalid warning name") 428 | 429 | and expr_with i = 430 | i |> add_loc ( 431 | keyword "with" >> 432 | expr << P.char ';' << space >>= fun e1 -> 433 | expr |>> fun e2 -> 434 | A.Ewith (e1, e2)) 435 | 436 | and expr_assert i = 437 | i |> add_loc ( 438 | get_loc >>= fun loc -> 439 | keyword "assert" >> 440 | expr >>= fun assertion -> 441 | P.char ';' >> space >> 442 | expr |>> fun k -> 443 | A.Eite ( assertion, k, W.mk loc @@ A.EfunApp ( 444 | W.mk loc (A.Evar "raise"), 445 | W.mk loc (A.Econstant (A.Cstring "assertion failed"))))) 446 | 447 | and expr_infix i = 448 | i |> (P.expression infix_ops expr_apply_or_member) 449 | 450 | and expr_infix_member i = 451 | i |> add_loc ( 452 | expr_apply >>= fun e -> 453 | P.char '?' >> space >> 454 | ap |>> fun ap -> 455 | A.EtestMember (e, ap) 456 | ) 457 | 458 | and expr_apply_or_member i = 459 | i |> ( 460 | P.attempt expr_infix_member 461 | <|> expr_apply 462 | ) 463 | 464 | and expr_if i = 465 | i |> (add_loc 466 | (keyword "if" >> 467 | expr >>= fun e_if -> 468 | keyword "then" >> 469 | expr >>= fun e_then -> 470 | keyword "else" >> 471 | expr |>> fun e_else -> 472 | A.Eite (e_if, e_then, e_else) 473 | ) 474 | "if-then-else") 475 | 476 | and expr_atom i = 477 | i |> ( 478 | P.choice [ 479 | expr_record; expr_list; 480 | expr_string; expr_const; expr_ident; 481 | expr_paren 482 | ] 483 | "atomic expression" 484 | ) 485 | 486 | and expr_string i = string expr i 487 | 488 | and expr_record i = 489 | i|> add_loc ( 490 | P.option (P.attempt @@ keyword "rec") >>= fun maybe_isrec -> 491 | let recursive = CCOpt.is_some maybe_isrec in 492 | expr_record_nonrec |>> fun fields -> 493 | A.(Erecord { recursive; fields })) 494 | 495 | and expr_record_nonrec i = 496 | i |> ( 497 | P.char '{' >> space >> 498 | P.many (expr_record_field <|> expr_inherit) 499 | << P.char '}' << space 500 | "record" 501 | ) 502 | 503 | and expr_record_field i = 504 | i |> add_loc (P.attempt ( 505 | ap_pattern >>= fun ap -> 506 | P.char '=' >> space >> 507 | expr << P.char ';' << space |>> fun value -> 508 | A.Fdef (ap, value)) 509 | "record field or binding" 510 | ) 511 | 512 | and expr_inherit i = 513 | i |> add_loc (P.attempt ( 514 | keyword "inherit" >> 515 | P.option (P.char '(' >> space >> expr << P.char ')' << space) >>= fun base_def -> 516 | P.sep_by1 (add_loc @@ ident) space << P.char ';' << space |>> fun fields -> 517 | A.Finherit (base_def, fields) 518 | ) 519 | ) 520 | 521 | and expr_list i = 522 | i |> ( 523 | get_loc >>= fun loc -> 524 | P.char '[' >> space >> 525 | P.many_rev_fold_left 526 | (fun accu elt -> W.mk loc (A.Ebinop (A.Ocons, elt, accu))) 527 | (W.mk loc @@ A.Evar "nil") 528 | expr_select 529 | << P.char ']' << space 530 | ) 531 | 532 | and expr_paren i = 533 | i |> ( 534 | get_loc >>= fun loc -> 535 | parens ( 536 | expr >>= fun e -> 537 | P.option type_annot |>> function 538 | | None -> e 539 | | Some t -> W.mk loc @@ A.EtyAnnot (e, t) 540 | )) 541 | 542 | and expr_lambda i = 543 | i |> (add_loc ( 544 | P.not_followed_by uri "uri" >> 545 | P.attempt (pattern << P.char ':') >>= fun pat -> space >> 546 | expr |>> fun body -> 547 | A.Elambda (pat, body) 548 | ) 549 | "lambda") 550 | 551 | and expr_let i = 552 | i |> (add_loc ( 553 | keyword "let" >> 554 | P.many1 (expr_inherit <|> expr_record_field) >>= fun b -> 555 | keyword "in" >> 556 | expr |>> fun e -> 557 | A.Elet (b, e) 558 | ) 559 | "let binding") 560 | 561 | and pattern i = i |> (P.choice [pattern_ident; pattern_complex] "pattern") 562 | 563 | and pattern_complex i = 564 | i |> add_loc ( 565 | (pattern_record >>= fun record -> 566 | P.option (P.char '@' >> space >> ident) |>> fun alias_opt -> 567 | A.Pnontrivial (record, alias_opt)); 568 | ) 569 | 570 | 571 | and pattern_record_field i = 572 | i |> (( 573 | ident >>= fun field_name -> 574 | P.option (P.char '?' >> space >> expr) >>= fun default_value -> 575 | P.option type_annot |>> fun type_annot -> 576 | A.{ field_name; default_value; type_annot }) 577 | "pattern record field") 578 | 579 | and pattern_inside i = 580 | i |> P.choice [ 581 | (pattern_record_field << P.optional (P.char ',') << space >>= fun field -> 582 | pattern_inside |>> fun (A.NPrecord (fields, open_flag)) -> 583 | A.NPrecord (field::fields, open_flag)); 584 | 585 | (P.string "..." >> space >> P.return @@ A.NPrecord ([], A.Open)); 586 | 587 | P.return @@ A.NPrecord ([], A.Closed); 588 | ] 589 | 590 | and pattern_record i = 591 | i |> (( 592 | P.char '{' >> space >> 593 | pattern_inside << P.char '}' << space) 594 | "record pattern") 595 | 596 | and expr_apply i = 597 | i |> 598 | (get_loc >>= fun loc -> 599 | expr_select >>= fun e0 -> 600 | P.many expr_select |>> 601 | List.fold_left (fun accu e -> W.mk loc (A.EfunApp (accu, e))) e0) 602 | 603 | and expr_select i = 604 | i |> (add_loc ( 605 | P.attempt (expr_atom << isolated_dot) >>= fun e -> 606 | space >> 607 | ap >>= fun a -> 608 | P.option (P.attempt expr_select_guard) |>> fun guard -> 609 | A.Eaccess (e, a, guard)) 610 | <|> 611 | expr_atom 612 | ) 613 | 614 | and ap i = i |> P.sep_by1 ap_field (P.attempt isolated_dot >> space) 615 | 616 | and expr_select_guard i = i |> ( keyword "or" >> expr) 617 | 618 | and ap_pattern i = 619 | i |> ( 620 | ap >>= fun access_path -> 621 | P.option (P.attempt type_annot) |>> fun annot -> 622 | (access_path, annot)) 623 | 624 | and ap_field i = 625 | i |> add_loc ( 626 | (antiQuot expr << space |>> fun e -> A.AFexpr e) 627 | <|> 628 | (expr_string |>> fun e -> A.AFexpr e) 629 | <|> 630 | (ident |>> fun f_name -> A.AFidentifier f_name) 631 | ) 632 | 633 | let expr = 634 | space >> expr << P.eof 635 | 636 | let typ = 637 | space >> typ << P.eof 638 | 639 | let mpresult_to_result = function 640 | | MParser.Success x -> Ok x 641 | | MParser.Failed (msg, e) -> Error (msg, e) 642 | 643 | let parse_string parser str = 644 | MParser.parse_string parser str "-" 645 | |> mpresult_to_result 646 | -------------------------------------------------------------------------------- /lib/typing/typecheck.ml: -------------------------------------------------------------------------------- 1 | module C = Common 2 | module P = Simple.Ast 3 | module E = Environment 4 | module L = Common.Location 5 | module Loi = List_or_infinite 6 | module T = Types 7 | module TE = T.Environment 8 | module VE = Typing_env 9 | module WL = L.With_loc 10 | module Warning = Common.Warning 11 | 12 | module Pattern = Typecheck_pat 13 | 14 | module W = Common.Writer.Make(Common.Warning.List) 15 | 16 | open W.Infix 17 | let (>>) e1 e2 = e1 >>= (fun _ -> e2) 18 | 19 | module Flagged = 20 | struct 21 | (** The boolean flag is false by default, and may be marked true *) 22 | type 'a t = 'a * bool 23 | 24 | let pure x = (x, false) 25 | 26 | let flagged x = (x, true) 27 | end 28 | module FlaggedWriter = 29 | struct 30 | type 'a t = 'a Flagged.t W.t 31 | 32 | let pure x = W.pure @@ Flagged.pure x 33 | let bind (f : 'a -> 'b t) : 'a t -> 'b t = 34 | W.bind (fun (x, flag) -> 35 | W.map 36 | (fun (x', flag') -> (x', flag || flag')) 37 | (f x)) 38 | let map f = bind (fun x -> pure @@ f x) 39 | 40 | (* let lift x = W.map Flagged.pure x *) 41 | let lift_flagged x = W.map Flagged.flagged x 42 | 43 | let map_l f l = 44 | let rec lift_list_option = function 45 | | [] -> ([], false) 46 | | hd::tl -> 47 | let (hd_elt, hd_flg) = hd 48 | and (tl_elt, tl_flg) = lift_list_option tl in 49 | (hd_elt::tl_elt, hd_flg || tl_flg) 50 | in 51 | W.map_l f l >|= 52 | lift_list_option 53 | 54 | module Infix = 55 | struct 56 | let (>>=) x f = bind f x 57 | let (>|=) x f = map f x 58 | let (>>) e1 e2 = e1 >>= fun _ -> e2 59 | end 60 | end 61 | 62 | let default_typ = T.Builtins.grad 63 | let log_only l = 64 | W.append l @@ W.pure default_typ 65 | 66 | let check_subtype loc ~inferred ~expected = 67 | if Types.sub inferred expected then 68 | W.pure () 69 | else 70 | W.append 71 | [Warning.format loc 72 | "This expression has type %s while a subtype of %s was expected" 73 | (Types.show inferred) 74 | (Types.show expected)] 75 | (W.pure ()) 76 | 77 | module Bindings = struct 78 | let explicit_annotations (tenv : TE.t) (bindings : P.binding list) 79 | : ((string * Types.t option * P.expr) list * VE.t) W.t = 80 | let half_typed_bindings = 81 | List.map 82 | (fun ((var, maybe_annot), e) -> 83 | CCOpt.map (Annotations.to_type tenv) maybe_annot 84 | |> CCOpt.map_or 85 | ~default:(W.pure (var, None, e)) 86 | (W.map (fun x -> (var, Some x, e))) 87 | ) 88 | bindings 89 | |> List.fold_left (CCFun.flip @@ W.map2 CCList.cons) (W.pure []) 90 | in 91 | W.map 92 | (fun half_typed_bindings -> 93 | let new_env = 94 | List.fold_left 95 | (fun accu (x, annot, _) -> 96 | VE.add x (CCOpt.get_or ~default:Types.Builtins.grad annot) accu) 97 | VE.empty 98 | half_typed_bindings 99 | in 100 | half_typed_bindings, new_env 101 | ) 102 | half_typed_bindings 103 | 104 | let report_inference_results 105 | (typed_binds : (string * Types.t option * Types.t) list) 106 | : VE.t = 107 | List.fold_left 108 | (fun accu (x, constr, rhs_typ) -> 109 | VE.add x (CCOpt.get_or ~default:rhs_typ constr) accu) 110 | VE.empty 111 | typed_binds 112 | end 113 | 114 | let typeof_const = function 115 | | P.Cbool b -> T.Singleton.bool b 116 | | P.Cint i -> T.Singleton.int i 117 | | P.Cstring s -> Types.Singleton.string s 118 | | P.Cpath s -> Types.Singleton.path s 119 | | P.Cbracketed _ -> Types.Path.any 120 | | P.Cundef -> Types.Builtins.undef 121 | 122 | (* [get_discriminer t] returns [Some t1] if [t] is of the form 123 | `(t1 -> true) & (not t1 -> false)`, and [None] otherwise. *) 124 | and get_discriminer typ = 125 | if T.sub typ T.Builtins.(arrow (T.node empty) (T.node any)) then 126 | let (_, arrows) = Cduce_lib.Types.Arrow.get typ in 127 | match arrows with 128 | | [[ (t1, b1); (t2, b2) ]] 129 | when T.equiv b1 T.Builtins.true_type && 130 | T.equiv b2 T.Builtins.false_type 131 | && T.equiv t2 (T.Builtins.neg t1) 132 | -> Some t1 133 | | [[ (t2, b2); (t1, b1) ]] 134 | when T.equiv b1 T.Builtins.true_type && 135 | T.equiv b2 T.Builtins.false_type 136 | && T.equiv t2 (T.Builtins.neg t1) 137 | -> Some t1 138 | | _ -> None 139 | else None 140 | 141 | module rec Infer : sig 142 | val expr : Environment.t -> P.expr -> Types.t W.t 143 | 144 | val typeError : L.t -> ('a, unit, string, Types.t W.t) format4 -> 'a 145 | end = struct 146 | 147 | let typeError loc e = Format.ksprintf 148 | (fun s -> log_only [Warning.make loc s]) 149 | e 150 | 151 | let rec expr (env : Environment.t) (e : P.expr) : Types.t W.t = 152 | let { Environment.types = tenv; values = venv; _ } = env in 153 | let loc = e.L.With_loc.location in 154 | L.With_loc.description e |> function 155 | | P.Econstant c -> W.pure @@ typeof_const c 156 | | P.Evar v -> 157 | CCOpt.map_or 158 | ~default:(typeError loc "Unbound variable %s" v) 159 | W.pure 160 | (VE.lookup venv v) 161 | | P.Elambda (pat, e) -> 162 | (Pattern.infer tenv pat) >>= fun (added_env, domain) -> 163 | expr { env with E.values = VE.merge venv added_env } e >|= fun codomain -> 164 | Types.(Builtins.arrow (node domain) (node codomain)) 165 | | P.EfunApp (e1, e2) -> 166 | expr env e1 >>= fun t1 -> 167 | expr env e2 >>= fun t2 -> 168 | if not @@ Types.sub t1 Types.(Builtins.(arrow (node empty) (node any))) 169 | then 170 | typeError loc 171 | "This expression has type %s which is not an arrow type. \ 172 | It can't be applied" 173 | (Types.show t1) 174 | else 175 | let t1arrow = T.get_arrow t1 in 176 | let dom = Cduce_lib.Types.Arrow.domain t1arrow in 177 | check_subtype e2.L.With_loc.location ~inferred:t2 ~expected:dom >> 178 | W.pure @@ T.arrow_apply t1arrow t2 179 | | P.Elet (binds, e) -> 180 | Common.let_binding expr env binds e 181 | |> W.join 182 | | P.Ebinop (op, e1, e2) -> 183 | binop env loc op e1 e2 184 | | P.Emonop (op, e) -> 185 | monop env loc op e 186 | | P.Eite (e0, e1, e2) -> 187 | if_then_else env e0 e1 e2 188 | | P.EtyAnnot (sub_e, annot) -> 189 | Annotations.to_type tenv annot >>= fun t -> 190 | expr env sub_e >>= fun inferred -> 191 | check_subtype sub_e.L.With_loc.location ~expected:t ~inferred >> 192 | W.pure @@ t 193 | | P.Epragma (pragma, e) -> 194 | let env = Common.pragma env pragma in 195 | expr env e 196 | | P.Eimport e -> Common.import expr default_typ env e 197 | | P.Erecord fields -> 198 | record env fields 199 | | P.EaccessPath (e, ap, default) -> 200 | W.map_opt (expr env) default >>= fun default_ty -> 201 | let unguarded_typing = 202 | Common.record_access env e ap (CCOpt.is_some default_ty) 203 | in 204 | let final_type = 205 | begin match (default_ty, W.value unguarded_typing) with 206 | | None, (_, true) -> 207 | typeError loc "Couldn't select this field" 208 | | _, (t, false) -> 209 | W.return t 210 | | Some tdef, (t, true) -> 211 | W.return @@ T.Builtins.cup t tdef 212 | end 213 | in W.append 214 | (W.log unguarded_typing) 215 | final_type 216 | | P.Ewith _ -> 217 | typeError loc "With constructs are not allowed" 218 | 219 | and binop env loc op e1 e2 = match op with 220 | | P.Ocons -> 221 | expr env e1 >>= fun t1 -> 222 | expr env e2 >>= fun t2 -> 223 | check_subtype 224 | loc 225 | ~inferred:t2 226 | ~expected:Types.(Builtins.(cup (cons (node any) (node any)) nil)) >> 227 | W.pure Types.Builtins.(cons (Types.node t1) (Types.node t2)) 228 | | P.Oeq -> 229 | expr env e1 >> 230 | expr env e2 >> 231 | W.pure Types.Builtins.bool 232 | | P.Oplus 233 | | P.Ominus 234 | -> 235 | expr env e1 >>= fun t1 -> 236 | expr env e2 >>= fun t2 -> 237 | check_subtype loc ~inferred:t1 ~expected:T.Builtins.int >> 238 | check_subtype loc ~inferred:t2 ~expected:T.Builtins.int >> 239 | W.pure @@ T.Builtins.int 240 | | P.Oor 241 | | P.Oand -> 242 | expr env e1 >>= fun t1 -> 243 | expr env e2 >>= fun t2 -> 244 | check_subtype loc ~inferred:t1 ~expected:T.Builtins.bool >> 245 | check_subtype loc ~inferred:t2 ~expected:T.Builtins.bool >> 246 | let op = if op = P.Oand then T.Bool.tand else T.Bool.tor in 247 | begin try 248 | W.pure @@ op t1 t2 249 | with Invalid_argument _ -> W.pure T.Bool.all 250 | end 251 | | P.OrecordMember -> 252 | let record = e1 and fname_expr = e2 in 253 | expr env fname_expr >>= fun t1 -> 254 | expr env record >>= fun t_record -> 255 | check_subtype loc ~inferred:t1 ~expected:T.Builtins.string >> 256 | check_subtype loc ~inferred:t_record ~expected:T.Record.any >> 257 | begin match T.String.get t1 with 258 | | Infinite -> W.pure @@ T.Bool.all 259 | | Finite strings -> 260 | let memberships = CCList.map 261 | (fun s -> 262 | T.sub t_record 263 | (T.Record.of_list true [ (false, s, T.Builtins.any) ])) 264 | strings 265 | in 266 | if CCList.for_all ((=) true) memberships 267 | then 268 | W.pure @@ T.Bool.true_type 269 | else if CCList.for_all ((=) false) memberships then 270 | W.pure @@ T.Bool.false_type 271 | else W.pure @@ T.Bool.all 272 | end 273 | | P.Omerge -> 274 | expr env e1 >>= fun t1 -> 275 | expr env e2 >>= fun t2 -> 276 | check_subtype loc ~inferred:t1 ~expected:T.Record.any >> 277 | check_subtype loc ~inferred:t2 ~expected:T.Record.any >> 278 | W.pure @@ T.Record.merge t1 t2 279 | | P.Oconcat -> 280 | expr env e1 >>= fun t1 -> 281 | expr env e2 >>= fun t2 -> 282 | let any_list = 283 | let any_node = T.node T.Builtins.any in 284 | T.Builtins.cons any_node any_node 285 | in 286 | check_subtype loc ~inferred:t1 ~expected:any_list >> 287 | check_subtype loc ~inferred:t2 ~expected:any_list >> 288 | W.pure @@ any_list (* TODO *) 289 | 290 | 291 | and monop env loc op e = match op with 292 | | P.Oneg -> 293 | expr env e >>= fun t -> 294 | check_subtype 295 | loc 296 | ~inferred:t 297 | ~expected:Types.Builtins.int >> 298 | let ivl = Cduce_lib.Types.Int.get t in 299 | let negated_ivl = Common.negate_interval ivl in 300 | W.pure @@ negated_ivl 301 | | P.Onot -> 302 | expr env e >>= fun t -> 303 | check_subtype loc ~inferred:t ~expected:T.Builtins.bool >> 304 | begin try 305 | W.pure @@ T.Bool.tnot t 306 | with Invalid_argument _ -> W.pure T.Bool.all 307 | end 308 | 309 | and if_then_else env e0 e1 e2 = 310 | (* [type_with_exfalso var typ e] types [e] using current env + the 311 | * hypothesis [var:typ], and an exfalso rule stating that if [typ] is 312 | * [empty], then [e] can be given any type -- and in particular [empty] *) 313 | let type_with_exfalso var typ e = 314 | if Types.equiv typ Types.Builtins.empty then 315 | W.pure Types.Builtins.empty 316 | else 317 | expr (E.add_value env var typ) e 318 | in 319 | let type_default () = 320 | expr env e0 >>= fun t0 -> 321 | type_with_exfalso "_" Types.Builtins.(cap t0 true_type) e1 >>= fun t1 -> 322 | type_with_exfalso "_" Types.Builtins.(cap t0 false_type) e2 >>= fun t2 -> 323 | check_subtype 324 | e0.L.With_loc.location 325 | ~inferred:t0 326 | ~expected:Types.Builtins.bool >> 327 | W.pure @@ Types.Builtins.cup t1 t2 328 | in 329 | match WL.description e0 with 330 | | P.EfunApp (f, ({ WL.description = P.Evar x; _ } as e_x)) -> 331 | expr env f >>= fun t_f -> 332 | begin 333 | match get_discriminer t_f with 334 | | Some t -> 335 | expr env e_x >>= fun t_x -> 336 | type_with_exfalso x Types.Builtins.(cap t_x t) e1 >>= fun t1 -> 337 | type_with_exfalso x Types.Builtins.(cap t_x (neg t)) e2 >|= fun t2 -> 338 | Types.Builtins.cup t1 t2 339 | | None -> type_default () 340 | end 341 | | _ -> type_default () 342 | 343 | and record env fields = 344 | let typed_fields = W.map_l (field env) fields in 345 | let typed_labels = W.map (fun l -> fst @@ CCList.split l) typed_fields in 346 | let typed_fields = snd @@ CCList.split (W.value typed_fields) in 347 | check_empty_intersection typed_labels >> 348 | let label_choices = 349 | W.map (List.map (fun t -> T.String.get (WL.description t))) 350 | typed_labels 351 | in 352 | let possible_combinations = 353 | W.map (CCList.fold_left 354 | (fun accu labels_n -> 355 | Loi.flat_map (fun label -> 356 | Loi.map 357 | (fun partial_sequence -> label :: partial_sequence) 358 | accu) 359 | labels_n) 360 | (Loi.finite [[]])) 361 | label_choices 362 | |> W.map (Loi.map List.rev) 363 | in 364 | W.map (Loi.fold (fun partial_typ combination -> 365 | let new_typ = 366 | T.Builtins.record false @@ 367 | Simple.Record.of_list @@ 368 | CCList.map2 (fun label_str field_type -> 369 | (label_str, T.node @@ WL.description field_type)) 370 | combination 371 | typed_fields 372 | in 373 | T.Builtins.cup 374 | partial_typ 375 | new_typ) 376 | ~init:T.Builtins.empty 377 | ~full:T.Builtins.any) 378 | possible_combinations 379 | 380 | and field 381 | (env : Environment.t) 382 | ((label, maybe_annot, e) : (P.expr * 'a * P.expr)) 383 | : (T.t WL.t * T.t WL.t) W.t = 384 | let infer_keeping_loc env e = W.map (WL.mk (WL.loc e)) (expr env e) 385 | and check_keeping_loc env expected e = 386 | W.map (WL.mk (WL.loc e)) (Check.expr env e expected) >|= 387 | WL.map (CCFun.const expected) 388 | in 389 | match maybe_annot with 390 | | None -> 391 | W.map_pair (infer_keeping_loc env) (infer_keeping_loc env) (label, e) 392 | | Some annot -> 393 | Annotations.to_type env.Environment.types annot >>= fun expected -> 394 | W.map_pair 395 | (infer_keeping_loc env) 396 | (check_keeping_loc env expected) 397 | (label, e) 398 | 399 | and check_empty_intersection : 400 | Types.t WL.t list W.t -> unit W.t 401 | = 402 | let distinct_from typ = 403 | W.iter_l @@ fun typ' -> 404 | if Cduce_lib.Types.disjoint 405 | (WL.description typ) 406 | (WL.description typ') 407 | then 408 | W.pure () 409 | else 410 | W.pure () |> 411 | W.append [ 412 | Format.kasprintf 413 | (Warning.make ~kind:Warning.Error (WL.loc typ)) 414 | "This label and the one at %a may be the same" 415 | L.pp (WL.loc typ') 416 | ] 417 | in 418 | let rec aux = 419 | function 420 | | [] -> W.pure () 421 | | located_typ::tl -> 422 | distinct_from located_typ tl >> 423 | aux tl 424 | in W.bind aux 425 | end 426 | 427 | and Check : sig 428 | val expr : E.t -> P.expr -> Types.t -> unit W.t 429 | end = struct 430 | 431 | let typeError loc e = Format.kasprintf 432 | (fun s -> W.append [Warning.make loc s] (W.pure ())) e 433 | 434 | 435 | (** The \mathscr{A} operator from the paper *) 436 | let a_op (_, arrow_bdd) = 437 | let squared_union i_set j_set = 438 | List.map (fun (si, ti) -> 439 | List.map (fun (sj, tj) -> 440 | Types.Builtins.(cap si sj, cup ti tj)) 441 | i_set) 442 | j_set 443 | |> List.flatten 444 | in 445 | CCList.fold_left squared_union Types.Builtins.[(any, empty)] arrow_bdd 446 | 447 | let rec expr env e expected = 448 | let loc = L.With_loc.loc e in 449 | L.With_loc.description e |> function 450 | | P.Econstant c -> 451 | let c_ty = typeof_const c in 452 | check_subtype loc ~inferred:c_ty ~expected 453 | | P.Evar v -> 454 | begin match VE.lookup env.E.values v with 455 | | Some t -> check_subtype loc ~inferred:t ~expected 456 | | None -> 457 | W.append 458 | [Warning.format e.L.With_loc.location "Unbound variable %s" v] 459 | (W.pure ()) 460 | end 461 | | P.Elambda (pat, e) -> 462 | (check_subtype loc ~inferred:expected ~expected:Cduce_lib.Types.Arrow.any 463 | >> 464 | let expected_arrow = Cduce_lib.Types.Arrow.get expected in 465 | W.iter_l (fun (dom, codom) -> 466 | Pattern.infer ~t_constr:dom env.E.types pat 467 | >>= fun (added_env, _) -> 468 | expr (E.add_values env added_env) e codom) 469 | (a_op expected_arrow)) 470 | >> W.pure () 471 | | P.Elet (binds, e) -> 472 | Common.let_binding expr env binds e >>= fun f -> f expected 473 | | P.Eite (e0, e1, e2) -> 474 | if_then_else env e0 e1 e2 expected 475 | | P.EfunApp (e1, e2) -> 476 | Infer.expr env e2 >>= fun t1 -> 477 | expr env e1 Types.(Builtins.arrow (node t1) (node expected)) 478 | | P.Ebinop (op, e1, e2) -> 479 | binop env (L.With_loc.loc e) op e1 e2 expected 480 | | P.Emonop (op, e) -> 481 | monop env (L.With_loc.loc e) op e expected 482 | | P.Epragma (pragma, e) -> 483 | let env = Common.pragma env pragma in 484 | expr env e expected 485 | | P.Eimport e -> 486 | Common.import (fun env e -> expr env e expected) () env e 487 | | P.EtyAnnot (e, annot) -> 488 | Annotations.to_type env.Environment.types annot >>= fun ty -> 489 | check_subtype loc ~inferred:ty ~expected >> 490 | expr env e ty 491 | | P.Erecord fields -> 492 | record env fields loc expected 493 | | P.EaccessPath (e, ap, default) -> 494 | let unguarded_typing = 495 | Common.record_access env e ap (CCOpt.is_some default) 496 | in 497 | let final_check = 498 | begin match (default, W.value unguarded_typing) with 499 | | None, (_, true) -> 500 | typeError loc "Couldn't select this field" 501 | | _, (t, false) -> 502 | check_subtype loc ~inferred:t ~expected 503 | | Some guard, (t, true) -> 504 | check_subtype loc ~inferred:t ~expected >> 505 | expr env guard expected 506 | end 507 | in W.append 508 | (W.log unguarded_typing) 509 | final_check 510 | | P.Ewith (_,_) -> 511 | typeError loc "With constructs are not allowed" 512 | 513 | and binop env loc op e1 e2 expected = 514 | match op with 515 | | P.Ocons -> 516 | let products = Cduce_lib.Types.Product.get expected in 517 | if 518 | CCList.for_all 519 | (fun (t1, t2) -> 520 | expr env e1 t1 >> 521 | expr env e2 t2 522 | |> W.log |> Warning.List.contains_error 523 | ) 524 | products 525 | then 526 | typeError loc "This expression should have type %s" @@ T.show expected 527 | else W.pure () 528 | | P.Oeq -> 529 | check_subtype 530 | loc 531 | ~inferred:expected 532 | ~expected:Types.Builtins.bool >> 533 | if T.equiv expected Types.Builtins.true_type then 534 | typeError loc "Can't check thas this equality always holds" 535 | else if T.equiv expected Types.Builtins.false_type then 536 | typeError loc "Can't check thas this equality never holds" 537 | else 538 | Infer.expr env e1 >> 539 | Infer.expr env e2 >> W.pure () 540 | | P.Oplus 541 | | P.Ominus -> 542 | check_subtype 543 | loc 544 | ~inferred:expected 545 | ~expected:T.Builtins.int >> 546 | W.pure @@ 547 | ignore @@ List.map (fun e -> expr env e T.Builtins.int) [e1; e2] 548 | | P.Oor 549 | | P.Oand -> 550 | (* The [and] and [or] operators work the same way, but with the roles of 551 | [true] and [false] inverted *) 552 | let (top, bottom) = if op = P.Oand 553 | then T.Builtins.(true_type, false_type) 554 | else T.Builtins.(false_type, true_type) 555 | in 556 | let bool_part = T.Builtins.cap expected T.Builtins.bool in 557 | if T.sub bool_part top then 558 | expr env e1 top >> 559 | expr env e2 top 560 | else if T.sub bool_part bottom then 561 | (* We first try to check that the first operant has type [bottom]. 562 | If it fails, we try to check that the second has type [bottom] and 563 | the first has type [Bool] *) 564 | let first_try = expr env e1 bottom in 565 | let first_log = W.log first_try in 566 | if CCList.exists (fun w -> Warning.(get_kind w = Error)) first_log then 567 | expr env e1 T.Bool.all >> 568 | expr env e2 bottom 569 | else 570 | expr env e2 T.Bool.all 571 | else 572 | expr env e1 T.Bool.all >> 573 | expr env e2 T.Bool.all 574 | | P.OrecordMember -> 575 | let record = e1 and fname_expr = e2 in 576 | Infer.expr env fname_expr >>= fun t1 -> 577 | check_subtype loc ~inferred:t1 ~expected:T.Builtins.string >> 578 | let bool_part = T.Builtins.cap expected T.Builtins.bool in 579 | let is_true = T.sub bool_part T.Bool.true_type 580 | and is_false = T.sub bool_part T.Bool.false_type 581 | in 582 | if is_true || is_false then 583 | begin match T.String.get t1 with 584 | | Infinite -> 585 | typeError loc 586 | (if is_true then 587 | "Can't prove that this field is a member of this record" 588 | else 589 | "Can't prove that this field isn't a member of this record" 590 | ) 591 | | Finite strings -> 592 | let atomic_record f_name = 593 | let singleton_record = 594 | T.Record.of_list true [ (false, f_name, T.Builtins.any) ] 595 | in 596 | if is_true 597 | then singleton_record 598 | else T.Builtins.neg singleton_record 599 | in 600 | (W.map_l (fun s -> 601 | expr env record (atomic_record s)) 602 | strings) >> W.return () 603 | end 604 | else expr env record T.Record.any 605 | | P.Omerge -> 606 | Infer.expr env e1 >>= fun t1 -> 607 | Infer.expr env e2 >>= fun t2 -> 608 | check_subtype loc ~inferred:t1 ~expected:T.Record.any >> 609 | check_subtype loc ~inferred:t2 ~expected:T.Record.any >> 610 | let result = T.Record.merge t1 t2 in 611 | check_subtype loc ~inferred:result ~expected 612 | | P.Oconcat -> 613 | Infer.expr env e1 >>= fun t1 -> 614 | Infer.expr env e2 >>= fun t2 -> 615 | let any_list = 616 | let any_node = T.node T.Builtins.any in 617 | T.Builtins.cons any_node any_node 618 | in 619 | check_subtype loc ~inferred:t1 ~expected:any_list >> 620 | check_subtype loc ~inferred:t2 ~expected:any_list (* TODO *) 621 | 622 | 623 | and monop env loc op e expected = match op with 624 | | P.Onot -> 625 | let bool_part = T.Builtins.cap expected T.Builtins.bool in 626 | expr env e (T.Bool.tnot bool_part) 627 | | P.Oneg -> 628 | (* FIXME: Isn't this check absurd? *) 629 | check_subtype 630 | loc 631 | ~inferred:expected 632 | ~expected:Types.Builtins.int >> 633 | (* We just check that [e] has type [-expected] *) 634 | let ivl = Cduce_lib.Types.Int.get expected in 635 | let negated_ivl = Common.negate_interval ivl in 636 | expr env e negated_ivl 637 | 638 | and if_then_else env e0 e1 e2 expected = 639 | (* [check_with_exfalso var typ e expected] checks [e] against the type 640 | * [expected] using current env + the hypothesis [var:typ], and an exfalso 641 | * rule stating that if [typ] is [empty], then [e] can be given any type -- 642 | * and in particular [empty] *) 643 | let check_with_exfalso var typ e expected = 644 | if Types.equiv typ Types.Builtins.empty then 645 | W.pure () 646 | else 647 | expr (E.add_value env var typ) e expected 648 | in 649 | let default () = 650 | Infer.expr env e0 >>= fun t0 -> 651 | check_subtype 652 | (L.With_loc.loc e0) 653 | ~inferred:t0 654 | ~expected:T.Builtins.bool >> 655 | check_with_exfalso "_" T.Builtins.(cap t0 true_type) e1 expected >> 656 | check_with_exfalso "_" T.Builtins.(cap t0 false_type) e2 expected 657 | in 658 | match L.With_loc.description e0 with 659 | | P.EfunApp (f, ({ WL.description = P.Evar x; _ } as e_x)) -> 660 | Infer.expr env f >>= fun t_f -> 661 | begin 662 | match get_discriminer t_f with 663 | | Some t -> 664 | Infer.expr env e_x >>= fun t_x -> 665 | check_with_exfalso x Types.Builtins.(cap t_x t) e1 expected >> 666 | check_with_exfalso x Types.Builtins.(cap t_x (neg t)) e2 expected 667 | | None -> default () 668 | end 669 | | _ -> default () 670 | 671 | and record env fields loc expected = 672 | let to_assoc = List.map 673 | (fun (x1, x2, x3) -> (x1, (x2, x3))) 674 | in 675 | let assoc_fields = to_assoc fields in 676 | let (labels, annotated_values) = List.split assoc_fields in 677 | let annotated_values = Array.of_list annotated_values in 678 | let expr_keeping_loc env e = 679 | Infer.expr env e >|= fun t -> (t, WL.loc e) 680 | in 681 | W.map_l (fun e -> (expr_keeping_loc env e)) labels >>= fun labels_ty -> 682 | let to_singleton (x, loc) = match T.String.get x with 683 | | Finite [s] -> W.return (s, loc) 684 | | Finite _ | Infinite -> 685 | typeError loc "Can only check records with static labels" (* TODO *) >> 686 | W.return ("", loc) 687 | in 688 | W.map_l to_singleton labels_ty >>= fun labels -> 689 | let labelMap_wl = CCList.fold_left 690 | (fun map_wl (lbl, loc) -> 691 | let map = W.value map_wl in 692 | match C.StrMap.add_or lbl loc map with 693 | | Ok map -> W.return map 694 | | Error (_, _, loc2) -> 695 | typeError loc 696 | "This label and the one defined at %a are the same" L.pp loc2 >> 697 | W.return map) 698 | (W.return C.StrMap.empty) 699 | labels 700 | in 701 | labelMap_wl >>= fun labelMap -> 702 | W.iter_l (fun lbl -> 703 | if C.StrMap.mem lbl labelMap then 704 | W.return () 705 | else 706 | typeError loc "Missing field %s" lbl) 707 | (T.Record.labels expected) >> 708 | let result_list = CCList.mapi (fun idx (label, loc) -> 709 | let (annot, e) = annotated_values.(idx) in 710 | let expected_field_type = T.Record.get_field label expected in 711 | let real_expr = match annot with 712 | | None -> e 713 | | Some a -> WL.mk loc (P.EtyAnnot (e, a)) 714 | in 715 | expr env real_expr expected_field_type 716 | ) 717 | labels 718 | in W.map_l (CCFun.id) result_list >> 719 | W.return () 720 | end 721 | 722 | and Common : sig 723 | val let_binding : (E.t -> P.expr -> 'a) 724 | -> E.t 725 | -> P.binding list 726 | -> P.expr 727 | -> 'a W.t 728 | val pragma : E.t -> Parse.Pragma.t -> E.t 729 | val import : (E.t -> P.expr -> 'a W.t) -> 'a -> E.t -> P.expr -> 'a W.t 730 | val negate_interval : Cduce_lib.Types.VarIntervals.t -> T.t 731 | val record_access : E.t -> P.expr -> P.access_path -> bool -> T.t FlaggedWriter.t 732 | end = struct 733 | 734 | let let_binding expr env binds e = 735 | let module B = Bindings in 736 | B.explicit_annotations env.E.types binds >>= 737 | fun (half_typed_binds, binds_env) -> 738 | let new_env = { env with E.values = VE.merge env.E.values binds_env } in 739 | let typed_binds = 740 | List.map 741 | (fun (x, constr, rhs) -> 742 | match constr with 743 | | None -> 744 | Infer.expr new_env rhs >|= fun typed_rhs -> 745 | (x, constr, typed_rhs) 746 | | Some ty -> 747 | Check.expr new_env rhs ty >> 748 | W.pure (x, constr, ty) 749 | ) 750 | half_typed_binds 751 | |> List.fold_left 752 | (CCFun.flip @@ W.map2 CCList.cons) 753 | (W.pure []) 754 | in 755 | typed_binds >|= fun binds -> 756 | let added_env = B.report_inference_results binds in 757 | expr (E.add_values env added_env) e 758 | 759 | let pragma env = 760 | let module P = Parse.Pragma in 761 | function 762 | | P.Warnings warns -> 763 | E.map_config (fun c -> Config.proceed_warnings_annot c warns) env 764 | | P.Errors warns -> 765 | E.map_config (fun c -> Config.proceed_errors_annot c warns) env 766 | 767 | let import expr default_value env e = 768 | let typeError loc e = Format.ksprintf 769 | (fun s -> W.append [Warning.make loc s] (W.pure default_value)) e 770 | in 771 | let loc = WL.loc e in 772 | let current_path = Filename.dirname loc.L.file_name in 773 | Infer.expr env e >>= fun t -> 774 | check_subtype loc ~inferred:t ~expected:T.Builtins.(cup string path) >> 775 | let paths = 776 | List_or_infinite.concat 777 | (T.String.get t) 778 | (T.Path.get t) 779 | in 780 | match paths with 781 | | List_or_infinite.Finite [f_name] -> 782 | let absolute_f_name = 783 | if Filename.is_relative f_name then 784 | Filename.concat current_path f_name 785 | else f_name 786 | in 787 | begin try 788 | CCIO.with_in absolute_f_name (fun chan -> 789 | match 790 | MParser.parse_channel Parse.Parser.expr chan absolute_f_name 791 | with 792 | | MParser.Success e -> 793 | Simple.Of_onix.expr e >>= fun e -> 794 | expr Environment.default e 795 | | MParser.Failed (_, _) -> 796 | typeError e.WL.location "Parse error in %s"absolute_f_name ) 797 | with Sys_error _ -> 798 | typeError e.WL.location "Unable to read file %s"absolute_f_name 799 | end 800 | | _ -> typeError e.WL.location "Not a singleton string or path" 801 | 802 | let negate_interval = 803 | let module B = T.Builtins in 804 | Cduce_lib.Types.VarIntervals.compute 805 | ~empty:B.empty 806 | ~full:Cduce_lib.Types.Int.any 807 | ~cup:B.cup 808 | ~cap:B.cap 809 | ~diff:(fun t1 t2 -> B.cap t1 (B.neg t2)) 810 | ~atom:(function 811 | | `Atm i -> 812 | Cduce_lib.Types.interval @@ Cduce_lib.Intervals.negat i 813 | | `Var v -> Cduce_lib.Types.var v) 814 | 815 | let record_access env e ap is_guarded : T.t FlaggedWriter.t = 816 | Infer.expr env e >>= fun te -> 817 | W.map_l (Infer.expr env) ap >>= fun tap -> 818 | let acces_path_singletons = List.map T.String.get tap in 819 | let acces_path_locations = List.map WL.loc ap in 820 | let access_path_wl = 821 | CCList.combine acces_path_singletons acces_path_locations 822 | in 823 | let module M = FlaggedWriter in 824 | let open M.Infix in 825 | let typeErrorIfUnguarded loc fmt_str = 826 | Format.ksprintf 827 | (fun s -> 828 | if is_guarded then 829 | M.lift_flagged (W.pure default_typ) 830 | else 831 | M.lift_flagged @@ Infer.typeError loc "%s" s) 832 | fmt_str 833 | in 834 | let rec aux record_type = function 835 | | [] -> M.pure record_type 836 | | apf::ap -> 837 | let loc = snd apf in 838 | let has_to_be_record = 839 | if T.sub record_type T.Record.any then 840 | M.pure () 841 | else 842 | typeErrorIfUnguarded loc "This should be a record" >> 843 | M.pure () 844 | in 845 | has_to_be_record >> 846 | begin match fst apf with 847 | | List_or_infinite.Finite strings -> 848 | let possible_accessed = 849 | List.map (fun s -> T.Record.get_field s record_type) strings 850 | in 851 | let process_type t = 852 | if is_guarded then begin 853 | if Cduce_lib.Types.Record.has_absent t then 854 | M.lift_flagged (W.return @@ T.Builtins.diff t T.Record.absent) 855 | else 856 | M.pure @@ T.Builtins.diff t T.Record.absent 857 | end 858 | else 859 | if Cduce_lib.Types.Record.has_absent t then 860 | typeErrorIfUnguarded loc "This field may be empty" 861 | else 862 | M.pure t 863 | in 864 | let sub_types = M.map_l process_type possible_accessed in 865 | sub_types >>= 866 | M.map_l (fun t -> aux t ap) >|= fun types -> 867 | CCList.fold_left T.Builtins.cup T.Builtins.empty types 868 | | Infinite -> 869 | if is_guarded then 870 | M.lift_flagged 871 | @@ W.pure 872 | @@ T.Builtins.diff (T.Record.all_values record_type) T.Record.absent 873 | else 874 | typeErrorIfUnguarded loc "Cannot determine the value of this field" 875 | end 876 | in aux te access_path_wl 877 | end 878 | --------------------------------------------------------------------------------