Simon Génier pushed to branch source-spans at Stefan / Typer
Commits: 73ae25a9 by Simon Génier at 2021-04-28T13:34:46-04:00 Add a backend to compile Typer to Scheme.
- - - - - f8c0ef45 by Simon Génier at 2021-04-28T13:53:58-04:00 Consolidate location related code into Source.
The purpose of this changeset is to take all the Location related code and to move it into the Source module. I kept the aliases in Util for now to reduce the size of this changeset, but it was inevitable that I had to add a few `let open Source.Location in` because of how fields work in OCaml (not great). Fortunately, most of these will disappear as I move more and more location related code inside the source object.
I rewrote a few places to use printf instead of a series of prints, which I think are clearer. The only externally visible change is that I merged two functions that printed location in a different way. Some debug code used to print something like "Ln 32, cl 1", but now prints "foo.typer:32:1" like everywhere else.
- - - - - 965cc049 by Simon Génier at 2021-04-29T11:46:14-04:00 Merge branch 'gambit'
- - - - - 8ce3d27f by Simon Génier at 2021-05-10T15:14:17-04:00 Add code to check if a type declaration is positive.
- - - - - 4d0dff15 by Simon Génier at 2021-05-12T15:55:42-04:00 Merge branch 'origin/consolidate-location'
- - - - - f2d6d5df by Simon Génier at 2021-05-12T15:56:34-04:00 Merge branch positivity
- - - - - a654161f by Simon Génier at 2021-05-12T21:23:06-04:00 Consolidate location related code in Source.
The purpose of this changeset is to take all the Location related code and to move it into the Source module. There are many changed lines, but most of them are simple renaming. I rewrote a few places to use printf instead of a series of prints, which I think are clearer. The only externally visible change is that I merged two functions that printed location in a different way. Some debug code used to print something like "Ln 32, cl 1", but now prints "foo.typer:32:1" like everywhere else.
- - - - - 4ffdb7df by Simon Génier at 2021-05-12T21:23:12-04:00 Have the source tell its own location.
Move the code that keeps track of the current line and column inside of the source object. Not only does this make sense conceptually since the source is a kind of cursor, but it will allow us to simplify the lexer code.
- - - - - bb07898a by Simon Génier at 2021-05-12T21:23:12-04:00 Rename Pretoken -> Presymbol.
- - - - - f759c254 by Simon Génier at 2021-05-12T21:23:12-04:00 Rewrite the Lexer module in terms of source objects.
This might not look useful, but it will simplify a great deal our next change of add and end point to location records since all the location related code will be in there source objects.
I ended up rewriting most of the Lexer. I tried to avoid doing that, but the offset handling code was so mixed up with the rest than that turned out to give worse code and a diff as unreadable. I'm pretty confident that that the changes are OK since we are still able to load pervasives.typer and I wrote a few tests for the trickier inner operators.
- - - - - ce15f07b by Simon Génier at 2021-05-12T21:23:12-04:00 Shorten the names of a few methods on Source.t.
- - - - - e5921ed0 by Simon Génier at 2021-05-12T21:23:12-04:00 Replace raw offsets with points which also track line and column.
- - - - - 867b76b0 by Simon Génier at 2021-05-12T21:23:12-04:00 Compute location inside the source from the given point.
- - - - - 1e086648 by Simon Génier at 2021-05-12T21:23:12-04:00 Documentation comments are now an optional.
- - - - - 46e258aa by Simon Génier at 2021-05-12T21:23:12-04:00 Locations track their end point.
- - - - -
27 changed files:
- debug_util.ml - src/debruijn.ml - src/debug.ml - src/elab.ml - src/elexp.ml - src/env.ml - src/eval.ml - + src/gambit.ml - src/heap.ml - src/inverse_subst.ml - src/lexer.ml - src/lexp.ml - src/log.ml - src/opslexp.ml - src/option.ml - + src/positivity.ml - src/prelexer.ml - src/sexp.ml - src/source.ml - src/unification.ml - src/util.ml - tests/dune - + tests/gambit_test.ml - tests/lexer_test.ml - + tests/positivity_test.ml - tests/unify_test.ml - typer.ml
Changes:
===================================== debug_util.ml ===================================== @@ -33,7 +33,6 @@ open Typerlib
(* Utilities *) -open Util open Fmt open Debug
@@ -56,7 +55,7 @@ open Builtin open Debruijn open Env
-let dloc = dummy_location +let dloc = Source.Location.dummy let dummy_decl = Imm(String(dloc, "Dummy"))
let discard _v = ()
===================================== src/debruijn.ml ===================================== @@ -81,7 +81,7 @@ let fatal = Log.log_fatal ~section:"DEBRUIJN" (* Type definitions * ---------------------------------- *)
-let dloc = dummy_location +let dloc = Source.Location.dummy let type_level_sort = mkSort (dloc, StypeLevel) let sort_omega = mkSort (dloc, StypeOmega) let type_level = mkBuiltin ((dloc, "TypeLevel"), type_level_sort)
===================================== src/debug.ml ===================================== @@ -40,21 +40,21 @@ open Prelexer open Sexp open Lexp
+let print_info (message : string) (location : Source.Location.t) : unit = + Printf.printf "%s[%s]" message (Source.Location.to_string location) + (* Print aPretokens *) let debug_pretokens_print pretoken = print_string " "; - let print_info msg loc = - print_string msg; - print_string "["; loc_print loc; print_string "]\t" in
match pretoken with - | Preblock(loc, pts,_) + | Preblock(loc, pts) -> print_info "Preblock: " loc; print_string "{"; pretokens_print pts; print_string " }"
- | Pretoken(loc, str) - -> print_info "Pretoken: " loc; - print_string ("'" ^ str ^ "'"); + | Presymbol (loc, name) + -> print_info "Pretoken: " loc; + print_string ("'" ^ name ^ "'");
| Prestring(loc, str) -> print_info "Prestring: " loc; @@ -66,14 +66,11 @@ let debug_pretokens_print_all pretokens =
(* Sexp Print *) let debug_sexp_print sexp = - let print_info msg loc = - print_string msg; - print_string "["; loc_print loc; print_string "]\t" in match sexp with | Symbol(_, "") -> print_string "Epsilon " (* "ε" *)
- | Block(loc, pts, _) + | Block(loc, pts) -> print_info "Block: " loc; print_string "{"; pretokens_print pts; print_string " }"
@@ -111,9 +108,7 @@ let debug_pexp_print ptop = print_string " "; let l = sexp_location ptop in let print_info msg loc pex = - print_string msg; print_string "["; - loc_print loc; - print_string "]\t"; + print_info msg loc; sexp_print pex in print_info (sexp_name ptop) l ptop
@@ -124,7 +119,7 @@ let debug_lexp_decls decls =
print_string " "; lalign_print_string (lexp_name lxp) 15; - print_string "["; loc_print loc; print_string "]"; + Printf.printf "[%s]" (Source.Location.to_string loc);
let str = lexp_str_decls (!debug_ppctx) [e] in
===================================== src/elab.ml ===================================== @@ -61,7 +61,7 @@ module OL = Opslexp module EL = Elexp
(* dummies *) -let dloc = dummy_location +let dloc = Source.Location.dummy
let parsing_internals = ref false let btl_folder = @@ -98,7 +98,7 @@ type sform_type = | Lazy (* Hasn't looked as the requested type, nor inferred a type. *)
type special_forms_map = - (elab_context -> location -> sexp list -> ltype option + (elab_context -> Source.Location.t -> sexp list -> ltype option -> (lexp * sform_type)) SMap.t
let special_forms : special_forms_map ref = ref SMap.empty @@ -1008,10 +1008,11 @@ and lexp_parse_inductive ctors ctx = * The actual expression doesn't matter, as long as its * scoping is right: we only use it so we can pass it to * things like `fv` and `meta_to_var`. *) - let altacc = List.fold_right - (fun (ak, n, t) aa - -> mkArrow (ak, n, t, dummy_location, aa)) - acc impossible in + let altacc = + List.fold_right + (fun (ak, n, t) aa + -> mkArrow (ak, n, t, Source.Location.dummy, aa)) + acc impossible in let g = generalize nctx altacc in let altacc' = g (fun _ne vname t l e -> mkArrow (Aerasable, vname, t, l, e)) @@ -1208,7 +1209,7 @@ and lexp_decls_1 (tokens : token list) (* Rest of input *) (ectx : elab_context) (* External ctx. *) (nctx : elab_context) (* New context. *) - (pending_decls : location SMap.t) (* Pending type decls. *) + (pending_decls : Source.Location.t SMap.t) (* Pending type decls. *) (pending_defs : (symbol * sexp) list) (* Pending definitions. *) : (vname * lexp * ltype) list * sexp list * token list * elab_context =
@@ -1288,12 +1289,16 @@ and lexp_decls_1 | [Symbol (l, vname); sexp] -> if SMap.mem vname pending_decls then let decl_loc = SMap.find vname pending_decls in - let v = ({file = l.file; - line = l.line; - column = l.column; - docstr = String.concat "\n" [decl_loc.docstr; - l.docstr]}, - vname) in + let v = + let doc = + match decl_loc.doc, l.doc with + | Some (doc), Some (doc') + -> Some (Printf.sprintf "%s\n%s" doc doc') + | Some (doc), None | None, Some (doc) -> Some (doc) + | None, None -> None; + in + ({l with doc}, vname) + in let pending_decls = SMap.remove vname pending_decls in let pending_defs = ((v, sexp) :: pending_defs) in if SMap.is_empty pending_decls then @@ -1518,7 +1523,7 @@ let sform_immediate ctx loc sargs ot = | [(String _) as se] -> mkImm (se), Inferred DB.type_string | [(Integer _) as se] -> mkImm (se), Inferred DB.type_int | [(Float _) as se] -> mkImm (se), Inferred DB.type_float - | [Block (_sl, pts, _el)] + | [Block (_sl, pts)] -> let grm = ectx_get_grammar ctx in let tokens = lex default_stt pts in let (se, _) = sexp_parse_all grm tokens None in @@ -1611,7 +1616,7 @@ let rec sform_lambda kind ctx loc sargs ot = | Symbol arg -> (elab_p_id arg, None) | _ -> sexp_error (sexp_location sarg) "Unrecognized lambda argument"; - ((dummy_location, None), None) in + ((Source.Location.dummy, None), None) in
let olt1 = match ost1 with | Some st -> Some (infer_type st ctx arg)
===================================== src/elexp.ml ===================================== @@ -33,14 +33,13 @@
open Sexp (* Sexp type *)
-module U = Util module L = Lexp
-type vname = U.vname -type vref = U.vref +type vname = Util.vname +type vref = Util.vref type label = symbol
-module SMap = U.SMap +module SMap = Util.SMap
type elexp = (* A constant, either string, integer, or float. *) @@ -53,7 +52,7 @@ type elexp = | Var of vref
(* Recursive `let` binding. *) - | Let of U.location * (vname * elexp) list * elexp + | Let of Source.Location.t * (vname * elexp) list * elexp
(* An anonymous function. *) | Lambda of vname * elexp @@ -71,8 +70,8 @@ type elexp = * Case (l, e, branches, default) * tests the value of `e`, and either selects the corresponding branch * in `branches` or branches to the `default`. *) - | Case of U.location * elexp - * (U.location * vname list * elexp) SMap.t + | Case of Source.Location.t * elexp + * (Source.Location.t * vname list * elexp) SMap.t * (vname * elexp) option
(* A Type expression. There's no useful operation we can apply to it,
===================================== src/env.ml ===================================== @@ -40,7 +40,7 @@ module L = Lexp module BI = Z (* Was Big_int *) module DB = Debruijn
-let dloc = Util.dummy_location +let dloc = Source.Location.dummy
let fatal = Log.log_fatal ~section:"ENV" let warning = Log.log_warning ~section:"ENV"
===================================== src/eval.ml ===================================== @@ -51,7 +51,7 @@ module Prelexer = Prelexer (* prelex_string *)
type eval_debug_info = elexp list * elexp list
-let dloc = dummy_location +let dloc = Source.Location.dummy let global_eval_trace = ref ([], []) let global_eval_ctx = ref make_runtime_ctx (* let eval_max_recursion_depth = ref 23000 *) @@ -62,7 +62,7 @@ let error loc ?print_action msg = Log.internal_error msg
type builtin_function = - location -> eval_debug_info -> value_type list -> value_type + Source.Location.t -> eval_debug_info -> value_type list -> value_type
(** A map of the function name to its implementation and arity. *) let builtin_functions : (builtin_function * int) SMap.t ref = ref SMap.empty @@ -355,11 +355,11 @@ let make_block loc _depth args_val = match args_val with (* From what would we like to make a block? *) | [Vstring str] -> let source = new Source.source_string str in - Vsexp (Block (loc, (Prelexer.prelex source), loc)) + Vsexp (Block (loc, (Prelexer.prelex source))) | _ -> error loc "Sexp.block expects one string as argument"
let reader_parse loc _depth args_val = match args_val with - | [Velabctx ectx; Vsexp (Block (_,toks,_))] -> + | [Velabctx ectx; Vsexp (Block (_, toks))] -> let grm = ectx_get_grammar ectx in o2v_list (sexp_parse_all_to_list grm (Lexer.lex default_stt toks) (Some ";")) | [Velabctx _; s] -> (warning loc "Reader.parse do nothing without a Block"; s) @@ -632,7 +632,7 @@ and sexp_dispatch loc depth args = | String (_ , s) -> eval_call str [Vstring s] | Integer (_ , i) -> eval_call it [Vinteger i] | Float (_ , f) -> eval_call flt [Vfloat f] - | Block (_ , _, _) as b -> + | Block (_ , _) as b -> (* I think this code breaks what Blocks are. *) (* We delay parsing but parse with default_stt and default_grammar... *) (*let toks = Lexer.lex default_stt s in @@ -678,7 +678,7 @@ and print_trace title trace default = (* Now eval trace and elab trace are the same *) let print_trace = (fun type_name type_string type_loc i expr -> (* Print location info *) - print_string (" [" ^ (loc_string (type_loc expr)) ^ "] "); + print_string (" [" ^ (Source.Location.to_string (type_loc expr)) ^ "] ");
(* Print call trace visualization *) Fmt.print_ct_tree i; print_string "+- "; @@ -784,9 +784,9 @@ let debug_doc loc _depth args_val = match args_val with | [Vstring name; Velabctx ectx] -> (try let idx = senv_lookup name ectx in let elem = lctx_lookup (ectx_to_lctx ectx) - (((dummy_location, Some name), idx)) in + (((Source.Location.dummy, Some name), idx)) in match elem with - | ((l,_),_,_) -> Vstring (l.docstr) + | ((l,_),_,_) -> Vstring (Option.value ~default:"" l.doc) with _ -> Vstring "element not found") | _ -> error loc "Elab.debug_doc takes a String and an Elab_Context as arguments"
@@ -797,13 +797,15 @@ let is_bound loc _depth args_val = match args_val with | _ -> error loc "Elab.isbound takes an Elab_Context and a String as arguments"
let constructor_p name ectx = - try let idx = senv_lookup name ectx in - (* Use `lexp_whnf` so that `name` can be indirectly - * defined as a constructor - * (e.g. as in `let foo = cons in case foo x xs | ...` *) - match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) (ectx_to_lctx ectx) with - | Cons _ -> true (* It's indeed a constructor! *) - | _ -> false + try + let idx = senv_lookup name ectx in + (* Use `lexp_whnf` so that `name` can be indirectly + * defined as a constructor + * (e.g. as in `let foo = cons in case foo x xs | ...` *) + let var = mkVar ((Source.Location.dummy, Some name), idx) in + match OL.lexp'_whnf var (ectx_to_lctx ectx) with + | Cons _ -> true (* It's indeed a constructor! *) + | _ -> false with Senv_Lookup_Fail _ -> false
let erasable_p name nth ectx = @@ -814,14 +816,16 @@ let erasable_p name nth ectx = | (k, _, _) -> k = Aerasable ) else false | _ -> false in - try let idx = senv_lookup name ectx in - match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) (ectx_to_lctx ectx) with - | Cons (e, _) when is_var e - -> (match (env_lookup_expr ectx (get_var e)) with - | Some i when is_inductive i - -> is_erasable (get_inductive_ctor (get_inductive i)) - | _ -> false) - | _ -> false + try + let idx = senv_lookup name ectx in + let var = mkVar ((Source.Location.dummy, Some name), idx) in + match OL.lexp'_whnf var (ectx_to_lctx ectx) with + | Cons (e, _) when is_var e + -> (match (env_lookup_expr ectx (get_var e)) with + | Some i when is_inductive i + -> is_erasable (get_inductive_ctor (get_inductive i)) + | _ -> false) + | _ -> false with Senv_Lookup_Fail _ -> false
let erasable_p2 t name ectx = @@ -835,14 +839,16 @@ let erasable_p2 t name ectx = | _ -> false) args) | _ -> false in - try let idx = senv_lookup t ectx in - match OL.lexp'_whnf (mkVar ((dummy_location, Some t), idx)) (ectx_to_lctx ectx) with - | Cons (e, _) when is_var e - -> (match (env_lookup_expr ectx (get_var e)) with - | Some i when is_inductive i - -> is_erasable (get_inductive_ctor (get_inductive i)) - | _ -> false) - | _ -> false + try + let idx = senv_lookup t ectx in + let var = mkVar ((Source.Location.dummy, Some t), idx) in + match OL.lexp'_whnf var (ectx_to_lctx ectx) with + | Cons (e, _) when is_var e + -> (match (env_lookup_expr ectx (get_var e)) with + | Some i when is_inductive i + -> is_erasable (get_inductive_ctor (get_inductive i)) + | _ -> false) + | _ -> false with Senv_Lookup_Fail _ -> false
let nth_ctor_arg name nth ectx = @@ -853,14 +859,16 @@ let nth_ctor_arg name nth ectx = | _ -> "_" | exception (Failure _) -> "_" ) | _ -> "_" in - try let idx = senv_lookup name ectx in - match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) (ectx_to_lctx ectx) with - | Cons (e, _) when is_var e - -> (match (env_lookup_expr ectx (get_var e)) with - | Some i when is_inductive i - -> find_nth (get_inductive_ctor (get_inductive i)) - | _ -> "_") - | _ -> "_" + try + let idx = senv_lookup name ectx in + let var = mkVar ((Source.Location.dummy, Some name), idx) in + match OL.lexp'_whnf var (ectx_to_lctx ectx) with + | Cons (e, _) when is_var e + -> (match (env_lookup_expr ectx (get_var e)) with + | Some i when is_inductive i + -> find_nth (get_inductive_ctor (get_inductive i)) + | _ -> "_") + | _ -> "_" with Senv_Lookup_Fail _ -> "_"
let ctor_arg_pos name arg ectx = @@ -874,14 +882,16 @@ let ctor_arg_pos name arg ectx = | None -> (-1) | Some n -> n ) | _ -> (-1) in - try let idx = senv_lookup name ectx in - match OL.lexp'_whnf (mkVar ((dummy_location, Some name), idx)) (ectx_to_lctx ectx) with - | Cons (e, _) when is_var e - -> (match (env_lookup_expr ectx (get_var e)) with - | Some i when is_inductive i - -> find_arg (get_inductive_ctor (get_inductive i)) - | _ -> (-1)) - | _ -> (-1) + try + let idx = senv_lookup name ectx in + let var = mkVar ((Source.Location.dummy, Some name), idx) in + match OL.lexp'_whnf var (ectx_to_lctx ectx) with + | Cons (e, _) when is_var e + -> (match (env_lookup_expr ectx (get_var e)) with + | Some i when is_inductive i + -> find_arg (get_inductive_ctor (get_inductive i)) + | _ -> (-1)) + | _ -> (-1) with Senv_Lookup_Fail _ -> (-1)
let is_constructor loc _depth args_val = match args_val with @@ -969,8 +979,7 @@ let test_info loc _depth args_val = match args_val with | _ -> error loc "Test.info takes two String as argument"
let test_location loc _depth args_val = match args_val with - | [_] -> Vstring (loc.file ^ ":" ^ string_of_int loc.line - ^ ":" ^ string_of_int loc.column) + | [_] -> Vstring (Source.Location.to_string loc) | _ -> error loc "Test.location takes a Unit as argument"
let test_true loc _depth args_val = match args_val with
===================================== src/gambit.ml ===================================== @@ -0,0 +1,302 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.ca + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see http://www.gnu.org/licenses/. *) + +open Printf + +open Debruijn +open Elexp + +type ldecls = Lexp.ldecls +type lexp = Lexp.lexp + +module Scm = struct + type t = + | Symbol of string + | List of t list + | String of string + | Integer of Z.t + | Float of float + + let begin' : t = Symbol "begin" + let case : t = Symbol "case" + let define : t = Symbol "define" + let double_right_arrow : t = Symbol "=>" + let else' : t = Symbol "else" + let lambda : t = Symbol "lambda" + let let' : t = Symbol "let" + let letrec : t = Symbol "letrec" + let quote : t = Symbol "quote" + let prim_vector : t = Symbol "##vector" + let prim_vector_ref : t = Symbol "##vector-ref" + + let is_valid_bare_symbol (name : string) : bool = + let length = String.length name in + let rec loop i = + if Int.equal length i + then true + else + match name.[i] with + | '|' | ''' | ' ' | '(' | ')' -> false + | _ -> loop (i + 1) + in loop 0 + + let escape_symbol (name : string) : string = + if is_valid_bare_symbol name + then name + else + let buffer = Buffer.create (String.length name) in + Buffer.add_char buffer '|'; + let encode_char = function + | '|' -> Buffer.add_string buffer {|||} + | c -> Buffer.add_char buffer c + in + String.iter encode_char name; + Buffer.add_char buffer '|'; + Buffer.contents buffer + + let symbol (name : string) : t = + Symbol (escape_symbol name) + + let rec string_of_exp (exp : t) : string = + match exp with + | Symbol (name) -> name + | List (elements) + -> "(" ^ String.concat " " (List.map string_of_exp elements) ^ ")" + | String (value) + -> let length = String.length value in + let buffer = Buffer.create length in + Buffer.add_char buffer '"'; + let encode_char = function + | '\x00' .. '\x06' as c + -> (Buffer.add_string buffer "\x"; + Buffer.add_string buffer (Printf.sprintf "%02d" (Char.code c))) + | '\x07' -> Buffer.add_string buffer "\a" + | '\x08' -> Buffer.add_string buffer "\b" + | '\x09' -> Buffer.add_string buffer "\t" + | '\' -> Buffer.add_string buffer "\\" + | '"' -> Buffer.add_string buffer "\"" + | c -> Buffer.add_char buffer c + in + String.iter encode_char value; + Buffer.add_char buffer '"'; + Buffer.contents buffer + | Integer (value) -> Z.to_string value + | Float (value) -> string_of_float value + + let print (output : out_channel) (exp : t) : unit = + output_string output (string_of_exp exp); + output_char output '\n' + + let describe (exp : t) : string = + match exp with + | Symbol _ -> "a symbol" + | List _ -> "a list" + | String _ -> "a string" + | Integer _ -> "an integer" + | Float _ -> "a float" + + let rec equal (l : t) (r : t) : bool = + match l, r with + | Symbol l, Symbol r | String l, String r + -> String.equal l r + | List ls, List rs -> Listx.equal equal ls rs + | Integer l, Integer r -> Z.equal l r + | Float l, Float r -> Float.equal l r + | _ -> false +end + +let gensym : string -> string = + let counter = ref 0 in + fun name -> + let i = !counter in + counter := i + 1; + let name = sprintf "%s%%%d" name i in + Scm.escape_symbol name + +module ScmContext = struct + (* Maps Debruijn indices to Scheme variable names. *) + type t = string Myers.myers + + let nil : t = Myers.nil + + let of_lctx (lctx : lexp_context) : t = + let f ((_, name), _, _) = Option.get name in + Myers.map f lctx + + let intro (sctx : t) (_, name : vname) : t * string = + let name = gensym (Option.value ~default:"g" name) in + (Myers.cons name sctx, name) + + let intro_binding (sctx : t) (name, elexp : vname * elexp) = + let sctx, name = intro sctx name in + (sctx, (name, elexp)) + + let lookup (sctx : t) (index : int) : string option = + Myers.nth_opt index sctx +end + +let rec scheme_of_expr (sctx : ScmContext.t) (elexp : elexp) : Scm.t = + match elexp with + | Elexp.Imm (Sexp.String (_, s)) -> Scm.String s + + | Elexp.Imm (Sexp.Integer (_, i)) -> Scm.Integer i + + | Elexp.Imm (Sexp.Float (_, f)) -> Scm.Float f + + | Elexp.Builtin (_, "Sexp.node") -> Scm.Symbol "cons" + + | Elexp.Builtin (_, "Sexp.symbol") -> Scm.Symbol "string->symbol" + + | Elexp.Builtin (_, name) -> failwith ("TODO: Built-in "" ^ name ^ """) + + | Elexp.Var (_, index) + -> (match ScmContext.lookup sctx index with + | None -> Scm.Symbol "TODO" + | Some name -> Scm.Symbol name) + + | Elexp.Let (_, bindings, body) + -> if List.length bindings = 0 + then scheme_of_expr sctx body + else + let sctx, bindings = + Listx.fold_left_map ScmContext.intro_binding sctx bindings + in + let scheme_of_binding (name, elexp) = + Scm.List [Scm.Symbol name; scheme_of_expr sctx elexp] + in + Scm.List [Scm.letrec; + Scm.List (List.map scheme_of_binding bindings); + scheme_of_expr sctx body] + + | Elexp.Lambda (name, body) + -> let sctx', name = ScmContext.intro sctx name in + Scm.List [Scm.lambda; + Scm.List [Scm.Symbol name]; + scheme_of_expr sctx' body] + + | Elexp.Call (head, tail) + -> let scm_head = scheme_of_expr sctx head in + let scm_tail = List.map (scheme_of_expr sctx) tail in + Scm.List (scm_head :: scm_tail) + + | Elexp.Cons (arity, (_, name)) + -> let rec make_vars i vars = + match i with + | 0 -> vars + | _ -> make_vars (i - 1) (Scm.Symbol (gensym "") :: vars) + in + let vars = make_vars arity [] in + let vector_expr = + Scm.List (Scm.prim_vector + :: Scm.List [Scm.quote; Scm.symbol name] + :: List.rev vars) + in + let rec make_curried_lambda vars body = + match vars with + | [] -> body + | var :: vars' + -> let body' = Scm.List [Scm.lambda; Scm.List [var]; body] in + make_curried_lambda vars' body' + in + make_curried_lambda vars vector_expr + + | Elexp.Case (_, target, branches, default_branch) + -> let target_name = + match target with + | Elexp.Var _ -> scheme_of_expr sctx target + | _ -> Scm.Symbol (gensym "target") + in + let scm_default_branch = + match default_branch with + | None -> [] + | Some (name, body) + -> let sctx, name = ScmContext.intro sctx name in + (* (else => (lambda (name) body)) *) + [Scm.List [Scm.else'; + Scm.double_right_arrow; + Scm.List [Scm.lambda; + Scm.List [Scm.Symbol name]; + scheme_of_expr sctx body]]] + in + let add_branch cons_name (_, field_names, branch_body) scm_branches = + let make_binding (sctx, bindings, i) (location, name) = + match name with + | Some "_" -> sctx, bindings, Z.succ i + | _ + -> let sctx, name = ScmContext.intro sctx (location, name) in + let binding = Scm.List [Scm.Symbol name; + Scm.List [Scm.prim_vector_ref; + target_name; + Scm.Integer i]] + in + sctx, binding :: bindings, Z.succ i + in + let sctx, bindings, _ = List.fold_left make_binding (sctx, [], Z.one) field_names in + let scm_branch = + Scm.List [Scm.List [Scm.symbol cons_name]; + if Int.equal (List.length bindings) 0 + then scheme_of_expr sctx branch_body + else + Scm.List [Scm.let'; + Scm.List (List.rev bindings); + scheme_of_expr sctx branch_body]] + in + scm_branch :: scm_branches + in + let scm_branches = + List.rev_append (SMap.fold add_branch branches []) scm_default_branch + in + let scm_case = + Scm.List (Scm.case + :: Scm.List [Scm.prim_vector_ref; + target_name; + Scm.Integer Z.zero] + :: scm_branches) + in + (match target with + | Elexp.Var _ -> scm_case + | _ + -> Scm.List [Scm.let'; + Scm.List [Scm.List [target_name; + scheme_of_expr sctx target]]; + scm_case]) + + | Elexp.Type _ -> Scm.Symbol "lets-hope-its-ok-if-i-erase-this" + + | _ -> failwith ("[gambit] unsupported elexp: " ^ elexp_string elexp) + +let scheme_of_decl (sctx : ScmContext.t) (name, elexp : string * elexp) : Scm.t = + Scm.List ([Scm.define; Scm.Symbol name; scheme_of_expr sctx elexp]) + +class gambit_compiler lctx output = object + inherit Backend.backend + + val mutable sctx = ScmContext.of_lctx lctx + val mutable lctx = lctx + + method process_decls ldecls = + let lctx', eldecls = Opslexp.clean_decls lctx ldecls in + let sctx', eldecls = Listx.fold_left_map ScmContext.intro_binding sctx eldecls in + let sdecls = Scm.List (Scm.begin' :: List.map (scheme_of_decl sctx') eldecls) in + + sctx <- sctx'; + lctx <- lctx'; + Scm.print output sdecls; +end
===================================== src/heap.ml ===================================== @@ -27,7 +27,7 @@ open Lexp
module IMap = Util.IMap
-type location = Util.location +type location = Source.Location.t type symbol = Sexp.symbol type value = Env.value_type
@@ -37,7 +37,7 @@ type addr = int let error ~(location : location) (message : string) : 'a = Log.log_fatal ~section:"HEAP" ~loc:location message
-let dloc = Util.dummy_location +let dloc = Source.Location.dummy let type0 = Debruijn.type0 let type_datacons_label = mkBuiltin ((dloc, "DataconsLabel"), type0) let type_heap = mkBuiltin ((dloc, "Heap"), type_arrow_0)
===================================== src/inverse_subst.ml ===================================== @@ -94,7 +94,7 @@ let sizeOf (s: (int * int) list): int = List.length s let counter = ref 0 let mkVar (idx: int) : lexp = counter := !counter + 1; - mkVar ((U.dummy_location, None), idx) + mkVar ((Source.Location.dummy, None), idx)
(** Fill the gap between e_i in the list of couple (e_i, i) by adding dummy variables.
===================================== src/lexer.ml ===================================== @@ -27,12 +27,6 @@ open Grammar
(*************** The Lexer phase *********************)
-let digit_p char = - let code = Char.code char - in Char.code '0' <= code && code <= Char.code '9' - -type num_part = | NPint | NPfrac | NPexp - let unescape str = let rec split b = if b >= String.length str then [] @@ -41,108 +35,198 @@ let unescape str = string_sub str b e :: split (e + 1) in String.concat "" (split 0)
-let nexttoken (stt : token_env) (pts : pretoken list) bpos cpos - (* The returned Sexp may not be a Node. *) - : sexp * pretoken list * bytepos * charpos = - match pts with - | [] -> (Log.internal_error "No next token!") - | (Preblock (sl, bpts, el) :: pts) -> (Block (sl, bpts, el), pts, 0, 0) - | (Prestring (loc, str) :: pts) -> (String (loc, str), pts, 0, 0) - | (Pretoken ({file;line;column;docstr}, name) :: pts') - -> let char = name.[bpos] in - if digit_p char - || (char = '-' (* FIXME: Handle '+' as well! *) - && bpos + 1 < String.length name - && digit_p (name.[bpos + 1])) then - let rec lexnum bp cp (np : num_part) = - if bp >= String.length name then - ((if np == NPint then - Integer ({file;line;column=column+cpos;docstr=docstr}, - Z.of_string (string_sub name bpos bp)) - else - Float ({file;line;column=column+cpos;docstr=docstr}, - float_of_string (string_sub name bpos bp))), - pts', 0, 0) - else - match name.[bp] with - | ('0'|'1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9') - -> lexnum (bp+1) (cp+1) np - | '.' when np == NPint -> lexnum (bp+1) (cp+1) NPfrac - | ('e'|'E') when not (np == NPexp) -> lexnum (bp+1) (cp+1) NPexp - | ('+'|'-') - when np == NPexp && (name.[bp-1] == 'e' || name.[bp-1] == 'E') - -> lexnum (bp+1) (cp+1) NPexp - | _ - -> ((if np == NPint then - Integer ({file;line;column=column+cpos;docstr=docstr}, - Z.of_string (string_sub name bpos bp)) - else - Float ({file;line;column=column+cpos;docstr=docstr}, - float_of_string (string_sub name bpos bp))), - pts, bp, cp) - in lexnum (bpos+1) (cpos+1) NPint - else if bpos + 1 >= String.length name then - (hSymbol ({file;line;column=column+cpos;docstr=docstr}, - string_sub name bpos (String.length name)), - pts', 0, 0) - else if stt.(Char.code name.[bpos]) = CKseparate then - (hSymbol ({file;line;column=column+cpos;docstr=docstr}, - string_sub name bpos (bpos + 1)), - pts, bpos+1, cpos+1) - else - let rec lexsym bpos cpos = - let mksym epos escaped - = if epos = bpos then epsilon {file;line;column=column+cpos;docstr=docstr} else - let rawstr = string_sub name bpos epos in - let str = if escaped then unescape rawstr else rawstr in - hSymbol ({file;line;column=column+cpos;docstr=docstr}, str) in - let rec lexsym' prec lf bp cp escaped = - if bp >= String.length name then - (lf (mksym (String.length name) escaped), pts', 0, 0) - else - let char = name.[bp] in - let bp' = bp + 1 in - let is_last = bp' >= String.length name in - match stt.(Char.code char) with - | _ when char == '\' && not is_last - (* Skip next char, in case it's a special token. *) - (* For utf-8, this cp+2 is risky but actually works: \ counts - * as 1 and if the input is valid utf-8 the next byte has to - * be a leading byte, so it has to count as 1 as well ;-) *) - -> lexsym' prec lf (bp+2) (cp+2) true - | CKseparate -> (lf (mksym bp escaped), pts, bp, cp) - (* Turn `inner` infix operators, such as the "." of - * "Module.elem" into the equivalent of (__.__ Module elem). *) - | CKinner prec' - (* To be considered `inner`, an operator char needs to have - * something on its LHS or its RHS, otherwise, treat it as - * a normal char, `.` can be a normal operator as well. *) - when bpos != bp - || (not is_last - && CKseparate != (stt.(Char.code name.[bp']))) - || not (lf dummy_epsilon = dummy_epsilon) - -> let left = mksym bp escaped in - let op = hSymbol ({file;line;column=column+cp;docstr=docstr}, - "__" ^ String.sub name bp 1 ^ "__") in - let bpos = bp' in - let cpos = inc_cp cp char in - let lf' = if prec' > prec then - (fun s -> lf (Node (op, [left; s]))) - else - (fun s -> Node (op, [lf left; s])) in - lexsym bpos cpos prec' lf' - bpos cpos false - | _ -> lexsym' prec lf (bp+1) (inc_cp cp char) escaped - in lexsym' - in lexsym bpos cpos 0 (fun s -> s) bpos cpos false - -let lex tenv (pts : pretoken list) : sexp list = - let rec gettokens pts bpos cpos acc = - match pts with +let lex_number + (source : #Source.t) + (start_point : Source.Point.t) + (doc : string option) + : sexp = + + let rec lex_exponent () = + match source#peek with + | Some ('0' .. '9') + -> source#advance; + lex_exponent () + + | _ + -> let source, location = source#slice ?doc start_point in + Float (location, float_of_string source) + in + + let lex_exponent_sign () = + match source#peek with + | Some ('0' .. '9' | '+' | '-') + -> source#advance; + lex_exponent () + + (* TODO: should it be an error when there are no signs or digits after the + 'e'? *) + | _ + -> let source, location = source#slice ?doc start_point in + Float (location, float_of_string source) + in + + let rec lex_fractional () = + match source#peek with + | Some ('0' .. '9') + -> source#advance; + lex_fractional () + + | Some ('e' | 'E') + -> source#advance; + lex_exponent_sign () + + | _ + -> let source, location = source#slice ?doc start_point in + Float (location, float_of_string source) + in + + let rec lex_integer () = + match source#peek with + | Some ('0' .. '9') + -> source#advance; + lex_integer () + + | Some ('.') + -> source#advance; + lex_fractional () + + | Some ('e' | 'E') + -> source#advance; + lex_exponent_sign () + + | _ + -> let source, location = source#slice ?doc start_point in + Integer (location, Z.of_string source) + in + + lex_integer () + +(* Splits one symbol from the beginning of the source. *) +let lex_symbol + (token_env : token_env) + (source : #Source.t) + (doc : string option) + (start_point : Source.Point.t) + : sexp = + + let mksym start_point escaped = + if Source.Point.equal start_point source#point + then epsilon (Source.Location.of_point source#file_name start_point ?doc) + else + let raw_name, location = source#slice start_point ?doc in + let name = if escaped then unescape raw_name else raw_name in + hSymbol (location, name) + in + + let rec loop start_point prec lf (escaped : bool) = + match source#peek with + | None + -> lf (mksym start_point escaped) + + | Some c + -> (match token_env.(Char.code c) with + | CKseparate + -> lf (mksym start_point escaped) + + | CKinner prec' + -> let left = mksym start_point escaped in + let op_start_point = source#point in + + (* To be considered `inner`, an operator char needs to have + something on its LHS or its RHS, otherwise, treat it as a + normal char. `.` can be the normal function composition + operator as well. *) + let lhs_p = not (Source.Point.equal start_point source#point) in + source#advance; + let rhs_p = + (match source#peek with + | None -> false + | Some c' -> CKseparate != token_env.(Char.code c')) + in + if lhs_p || rhs_p || lf dummy_epsilon <> dummy_epsilon + then + let op_text, op_location = source#slice ?doc op_start_point in + let op = hSymbol (op_location, Printf.sprintf "__%s__" op_text) in + let lf' = + if prec' > prec + then fun s -> lf (Node (op, [left; s])) + else fun s -> Node (op, [lf left; s]) + in + loop source#point prec' lf' false + else + loop start_point prec lf escaped + + | CKnormal + -> (source#advance; + let is_last = Option.is_none source#peek in + match c with + (* Skip next char, in case it's a special token. For utf-8, + simply advancing is risky but actually works: '' counts as 1 + and if the input is valid utf-8 the next byte has to be a + leading byte, so it has to count as 1 as well ;-) *) + | '\' when not is_last + -> source#advance; + loop start_point prec lf true + + | _ -> loop start_point prec lf escaped)) + in + loop start_point 0 (fun s -> s) false + +let split_presymbol + (token_env : token_env) + (source : #Source.t) + (doc : string option) + : sexp list = + + let rec loop (acc : sexp list) : sexp list = + match source#peek with + | None -> List.rev acc + | Some (c) + -> let start_point = source#point in + let token = + match c with + | '-' + -> (* Could be a negative number literal, or a symbol starting with + '-'. *) + (source#advance; + match source#peek with + | Some ('0' .. '9') + -> lex_number source start_point doc + | _ -> lex_symbol token_env source doc start_point) + + | '0' .. '9' + -> (source#advance; + lex_number source start_point doc) + + | _ when token_env.(Char.code c) = CKseparate + -> source#advance; + let name, location = source#slice ?doc start_point in + hSymbol (location, name) + + | _ + -> lex_symbol token_env source doc start_point + in + loop (token :: acc) + in + loop [] + +let lex (token_env : token_env) (pretokens : pretoken list) : sexp list = + let rec loop pretokens acc = + match pretokens with | [] -> List.rev acc - | _ -> let (tok, pts, bpos, cpos) = nexttoken tenv pts bpos cpos - in gettokens pts bpos cpos (tok :: acc) in - gettokens pts 0 0 [] + + | Preblock (location, block_pretokens) :: pretokens' + -> loop pretokens' (Block (location, block_pretokens) :: acc) + + | Prestring (location, text) :: pretokens' + -> loop pretokens' (String (location, text) :: acc) + + | Presymbol ({file; start_line; start_column; doc; _}, name) :: pretokens' + -> let source = new Source.source_string ~file ~line:start_line ~column:start_column name in + let tokens = split_presymbol token_env source doc in + loop pretokens' (List.rev_append tokens acc) + in + loop pretokens []
let lex_source (source : #Source.t) tenv = let pretoks = prelex source in @@ -151,4 +235,3 @@ let lex_source (source : #Source.t) tenv = let sexp_parse_source (source : #Source.t) tenv grm limit = let toks = lex_source source tenv in sexp_parse_all_to_list grm toks limit -
===================================== src/lexp.ml ===================================== @@ -63,22 +63,22 @@ type ltype = lexp and lexp' = | Imm of sexp (* Used for strings, ... *) | SortLevel of sort_level - | Sort of U.location * sort + | Sort of Source.Location.t * sort | Builtin of symbol * ltype | Var of vref | Susp of lexp * subst (* Lazy explicit substitution: e[σ]. *) (* This "Let" allows recursion. *) - | Let of U.location * (vname * lexp * ltype) list * lexp - | Arrow of arg_kind * vname * ltype * U.location * ltype + | Let of Source.Location.t * (vname * lexp * ltype) list * lexp + | Arrow of arg_kind * vname * ltype * Source.Location.t * ltype | Lambda of arg_kind * vname * ltype * lexp | Call of lexp * (arg_kind * lexp) list (* Curried call. *) - | Inductive of U.location * label + | Inductive of Source.Location.t * label * ((arg_kind * vname * ltype) list) (* formal Args *) * ((arg_kind * vname * ltype) list) SMap.t | Cons of lexp * symbol (* = Type info * ctor_name *) - | Case of U.location * lexp + | Case of Source.Location.t * lexp * ltype (* The type of the return value of all branches *) - * (U.location * (arg_kind * vname) list * lexp) SMap.t + * (Source.Location.t * (arg_kind * vname) list * lexp) SMap.t * (vname * lexp) option (* Default. *) (* The `subst` will be applied to the the metavar's value when it * gets instantiated. *) @@ -506,7 +506,7 @@ let rec lexp_location e = | Sort (l,_) -> l | SortLevel (SLsucc e) -> lexp_location e | SortLevel (SLlub (e, _)) -> lexp_location e - | SortLevel SLz -> U.dummy_location + | SortLevel SLz -> Source.Location.dummy | Imm s -> sexp_location s | Var ((l,_),_) -> l | Builtin ((l, _), _) -> l @@ -524,7 +524,7 @@ let rec lexp_location e =
(********* Normalizing a term *********)
-let vdummy = (U.dummy_location, None) +let vdummy = (Source.Location.dummy, None) let maybename n = match n with None -> "<anon>" | Some v -> v let sname (l,n) = (l, maybename n)
@@ -656,8 +656,8 @@ let clean e = | _ -> mkMetavar (idx, s, name) in clean S.identity e
-let sdatacons = Symbol (U.dummy_location, "##datacons") -let stypecons = Symbol (U.dummy_location, "##typecons") +let sdatacons = Symbol (Source.Location.dummy, "##datacons") +let stypecons = Symbol (Source.Location.dummy, "##typecons")
(* ugly printing (sexp_print (pexp_unparse (lexp_unparse e))) *) let rec lexp_unparse lxp = @@ -693,14 +693,14 @@ let rec lexp_unparse lxp = -> (* (vdef * lexp * ltype) list *) let sdecls = List.fold_left (fun acc (vdef, lxp, ltp) - -> Node (Symbol (U.dummy_location, "_=_"), + -> Node (Symbol (Source.Location.dummy, "_=_"), [Symbol (sname vdef); lexp_unparse ltp]) - :: Node (Symbol (U.dummy_location, "_=_"), + :: Node (Symbol (Source.Location.dummy, "_=_"), [Symbol (sname vdef); lexp_unparse lxp]) :: acc) [] ldecls in Node (Symbol (loc, "let_in_"), - [Node (Symbol (U.dummy_location, "_;_"), sdecls); + [Node (Symbol (Source.Location.dummy, "_;_"), sdecls); lexp_unparse body])
| Call(lxp, largs) -> (* (arg_kind * lexp) list *) @@ -769,7 +769,7 @@ let rec lexp_unparse lxp = -> Symbol (loc, "?" ^ (maybename name) ^ "-" ^ string_of_int idx ^ "[" ^ subst_string subst ^ "]")
- | SortLevel (SLz) -> Symbol (U.dummy_location, "##TypeLevel.z") + | SortLevel (SLz) -> Symbol (Source.Location.dummy, "##TypeLevel.z") | SortLevel (SLsucc l) -> Node (Symbol (lexp_location l, "##TypeLevel.succ"), [lexp_unparse l])
===================================== src/log.ml ===================================== @@ -88,7 +88,7 @@ type log_entry = { kind : string option; section : string option; print_action : (unit -> unit) option; - loc : location option; + loc : Source.Location.t option; msg : string; }
@@ -106,11 +106,6 @@ let mkEntry level ?kind ?section ?print_action ?loc msg = let log_push (entry : log_entry) = typer_log := entry::(!typer_log)
-let string_of_location (loc : location) = - (loc.file ^ ":" - ^ string_of_int loc.line ^ ":" - ^ string_of_int loc.column ^ ":") - let maybe_color_string color_opt str = match color_opt with | Some color -> Fmt.color_string color str @@ -119,7 +114,7 @@ let maybe_color_string color_opt str = let string_of_log_entry {level; kind; section; loc; msg; _} = let color = if typer_log_config.color then (level_color level) else None in let parens s = "(" ^ s ^ ")" in - (option_default "" (option_map string_of_location loc) + (option_default "" (option_map Source.Location.to_string loc) ^ maybe_color_string color (option_default (string_of_level level) kind) ^ ":" ^ option_default "" (option_map parens section) ^ " " ^ msg)
===================================== src/opslexp.ml ===================================== @@ -601,7 +601,7 @@ and check'' erased ctx e = | Imm (Float (_, _)) -> DB.type_float | Imm (Integer (_, _)) -> DB.type_int | Imm (String (_, _)) -> DB.type_string - | Imm (Block (_, _, _) | Symbol _ | Node (_, _)) + | Imm (Block (_, _) | Symbol _ | Node (_, _)) -> (error_tc ~loc:(lexp_location e) "Unsupported immediate value!"; DB.type_int) | SortLevel SLz -> DB.type_level @@ -1005,7 +1005,7 @@ and get_type ctx e = | Imm (Float (_, _)) -> DB.type_float | Imm (Integer (_, _)) -> DB.type_int | Imm (String (_, _)) -> DB.type_string - | Imm (Block (_, _, _) | Symbol _ | Node (_, _)) -> DB.type_int + | Imm (Block (_, _) | Symbol _ | Node (_, _)) -> DB.type_int | Builtin (_, t) -> t | SortLevel _ -> DB.type_level | Sort (l, Stype e) -> mkSort (l, Stype (mkSortLevel (mkSLsucc e))) @@ -1226,7 +1226,7 @@ let erase_type lctx lxp = Log.log_fatal ~print_action:(fun () -> IMap.iter (fun i (_, t, _, (l, n)) -> - print_endline ("\t" ^ (Log.string_of_location l) + print_endline ("\t" ^ (Source.Location.to_string l) ^ " ?" ^ (U.option_default "" n) ^ "[" ^ (string_of_int i) ^ "] : " ^ (lexp_string t)) ) mvs) @@ -1256,7 +1256,7 @@ let ctx2tup ctx nctx = | DB.CVfix (_, nctx) as bloc -> get_blocs nctx (bloc :: blocs) | _ -> assert false in let rec mk_lets_and_tup blocs types = - let loc = U.dummy_location in + let loc = Source.Location.dummy in match blocs with | [] -> let cons_name = "cons" in
===================================== src/option.ml ===================================== @@ -40,3 +40,8 @@ let is_some (o : 'a option) : bool = match o with | Some _ -> true | None -> false + +let is_none (o : 'a option) : bool = + match o with + | Some _ -> false + | None -> true
===================================== src/positivity.ml ===================================== @@ -0,0 +1,134 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.ca + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see http://www.gnu.org/licenses/. *) + +(* Positivity is a syntactic property of type which prevent a common source of + contradiction. In a nutshell, it means that a type T doesn't contain an arrow + with T as its domain, or another inductive type with T as a parameter. How + could we use this to create a contradiction? Take this definition for + example. + + type Evil + | make-evil (Evil -> Void); + + If this were allowed we could write this function. + + innocent-function : Evil -> Void; + innocent-function evil = + case evil + | make-evil e => e evil + + Finally, we create a value of type Void. + + what-have-we-done? : Void; + what-have-we-done? = innocent-function (make-evil innocent-function) + + We created an infinite loop. If our function looks innocuous enough, it's + because we hid the loop inside our mischievous make-evil constructor. + Checking inductive types for positivity prevents us from creating such + constructors. *) + +open Lexp +open Util + +(* Computes if the judgement x ∉ fv(τ) holds. *) +let absent index lexp = + let fv, _ = Opslexp.fv lexp in + not (Debruijn.set_mem index fv) + +let rec absent_in_bindings index bindings = + match bindings with + | [] -> true + | (_, _, tau) :: bindings + -> absent index tau && absent_in_bindings (index + 1) bindings + +(* Computes if the judgement x ⊢ e pos holds. *) +let rec positive (index : db_index) (lexp : lexp) : bool = + (* + * x ∉ fv(e) + * ─────────── + * x ⊢ e pos + *) + absent index lexp || positive' index lexp + +and positive' index lexp = + match Lexp.lexp_lexp' lexp with + | Lexp.Arrow (_, _, tau, _, e) + (* + * x ⊢ e pos x ∉ fv(τ) + * ────────────────────── + * x ⊢ (y : τ) → e pos + *) + -> absent index tau && positive' (index + 1) e + + | Lexp.Call (f, args) + (* + * x ∉ fv(e⃗) + * ────────────── + * x ⊢ x e⃗ pos + *) + -> begin + match Lexp.lexp_lexp' (Lexp.nosusp f) with + | Lexp.Var (_, index') when Int.equal index index' + -> List.for_all (fun (_, arg) -> absent index arg) args + | _ + (* If x ∈ fv(f e⃗), but f ≠ x, then x must occur in e⃗. *) + -> false + end + + | Lexp.Inductive (_, _, vs, cs) + (* + * The rules for μ-types and union types are respectively + * + * x ⊢ e pos x ∉ fv(τ) x ⊢ τ₀ pos x ⊢ τ₁ pos + * ────────────────────── ──────────────────────── + * x ⊢ μy:τ.e pos x ⊢ τ₀ ∪ τ₁ pos + * + * Since the two are not separate in Typer, this rule combines both. + *) + -> absent_in_bindings index vs + && let index = index + List.length vs in + Util.SMap.for_all (fun _ c -> positive_in_constructor index c) cs + + | Lexp.Lambda (_, _, _, e) -> positive index e + + | Lexp.Susp (e, s) -> positive index (Lexp.push_susp e s) + + | Lexp.Var _ + (* + * Since we know that x ∈ fv(e), this must be our variable. The same rule + * as the Call applies as a degenerate case with no arguments. + *) + -> true + + | Lexp.Case _ | Lexp.Cons _ | Lexp.Let _ | Lexp.Sort _ | Lexp.SortLevel _ + (* There are no rules that have these synctactic forms as a conclusion. *) + -> false + + | Lexp.Builtin _ | Lexp.Imm _ + -> failwith "must never happen since we already know that x ∈ fv(e)" + + | Lexp.Metavar _ + -> failwith "positivity must be checked after metavariables instanciation" + +and positive_in_constructor index vs = + match vs with + | [] -> true + | (_, _, tau) :: vs + -> positive index tau && positive_in_constructor (index + 1) vs
===================================== src/prelexer.ml ===================================== @@ -25,9 +25,9 @@ open Util let prelexer_error loc = Log.log_error ~section:"PRELEXER" ~loc
type pretoken = - | Pretoken of location * string - | Prestring of location * string - | Preblock of location * pretoken list * location + | Presymbol of Source.Location.t * string + | Prestring of Source.Location.t * string + | Preblock of Source.Location.t * pretoken list
module Pretoken = struct type t = pretoken @@ -35,11 +35,11 @@ module Pretoken = struct (* Equality up to location, i.e. the location is not considered. *) let rec equal (l : t) (r : t) = match l, r with - | Pretoken (_, l_name), Pretoken (_, r_name) + | Presymbol (_, l_name), Presymbol (_, r_name) -> String.equal l_name r_name | Prestring (_, l_text), Prestring (_, r_text) -> String.equal l_text r_text - | Preblock (_, l_inner, _), Preblock (_, r_inner, _) + | Preblock (_, l_inner), Preblock (_, r_inner) -> Listx.equal equal l_inner r_inner | _ -> false end @@ -60,153 +60,157 @@ end (* FIXME: Add syntax for char constants (maybe 'c'). *) (* FIXME: Handle multiline strings. *)
-let inc_cp (cp:charpos) (c:char) = - (* Count char positions in utf-8: don't count the non-leading bytes. *) - if utf8_head_p c then cp+1 else cp - let rec consume_until_newline (source : #Source.t) : unit = - match source#next_char with + match source#next with | None | Some ('\n') -> () | Some _ -> consume_until_newline source
-let rec prelex (source : #Source.t) ln ctx acc (doc : string) - : pretoken list = +(* Splits a Typer source into pretokens, stopping when it is completely + consumed. *) +let prelex (source : #Source.t) : pretoken list = + let rec loop + (ctx : (Source.Point.t * pretoken list) list) + (acc : pretoken list) + (doc : string option) + : pretoken list =
- let nextline = prelex source (ln + 1) in - let rec prelex' ctx (cpos:charpos) acc doc = - let nexttok = prelex' ctx in - match source#peek_char with + match source#peek with | None -> (match ctx with | [] -> List.rev acc - | ((ln, cpos, _) :: _ctx) -> - (prelexer_error {file=source#file_name; line=ln; column=cpos; docstr=""} - "Unmatched opening brace"; List.rev acc)) + | ((brace_start, _) :: _ctx) + -> let location = source#make_location brace_start in + prelexer_error location "Unmatched opening brace"; + List.rev acc)
| Some ('\n') -> source#advance; - nextline ctx acc doc + loop ctx acc doc
| Some (c) when c <= ' ' -> source#advance; - nexttok (cpos+1) acc doc + loop ctx acc doc
(* A comment. *) | Some ('%') -> consume_until_newline source; - nextline ctx acc doc + loop ctx acc doc
(* line's bounds seems ok: String.sub line 1 0 == "" *) | Some ('@') -> source#advance; - let start_offset = source#current_offset in + let doc_start = source#point in consume_until_newline source; - let new_doc = String.trim (source#slice_from_offset start_offset) in - nextline ctx acc (doc ^ "\n" ^ new_doc) + let doc_line, _ = source#slice doc_start in + let doc' = + match doc with + | None -> doc_line + | Some doc -> doc ^ "\n" ^ String.trim doc_line + in + loop ctx acc (Some (doc'))
(* A string. *) | Some ('"') - -> source#advance; - let rec prestring cp chars = - match source#next_char with + -> let string_start = source#point in + source#advance; + let rec prestring chars = + match source#peek with | None | Some ('\n') - -> let location = {file=source#file_name; line=ln; column=cpos; docstr=doc} in + -> source#advance; + let location = source#make_location ?doc string_start in prelexer_error location "Unterminated string"; - nextline ctx (Prestring (location, "") :: acc) "" + loop ctx (Prestring (location, "") :: acc) None
| Some ('"') - -> let location = {file=source#file_name; line=ln; column=cpos; docstr=doc} in - let pretoken = Prestring (location, string_implode (List.rev chars)) in - nexttok (cp + 1) (pretoken :: acc) "" + -> source#advance; + let location = source#make_location ?doc string_start in + let text = string_implode (List.rev chars) in + let pretoken = Prestring (location, text) in + loop ctx (pretoken :: acc) None
| Some ('\') - -> (match source#next_char with + -> (let escape_sequence_start = source#point in + source#advance; + match source#next with | None | Some ('\n') - -> let location = {file=source#file_name; line=ln; column=cp; docstr=doc} in + -> let location = source#make_location escape_sequence_start in prelexer_error location "Unterminated escape sequence"; - nextline ctx (Prestring (location, "") :: acc) "" - | Some ('t') -> prestring (cp + 2) ('\t' :: chars) - | Some ('n') -> prestring (cp + 2) ('\n' :: chars) - | Some ('r') -> prestring (cp + 2) ('\r' :: chars) + loop ctx (Prestring (location, "") :: acc) None + | Some ('t') -> prestring ('\t' :: chars) + | Some ('n') -> prestring ('\n' :: chars) + | Some ('r') -> prestring ('\r' :: chars) | Some ('u') - -> let location = {file=source#file_name; line=ln; column=cp; docstr=doc} in + -> let location = source#make_location escape_sequence_start in prelexer_error location "Unimplemented unicode escape"; - prestring (cp + 2) chars - | Some (c) -> prestring (cp + 2) (c :: chars)) + prestring chars + | Some (c) -> prestring (c :: chars))
- | Some (char) -> prestring (inc_cp cp char) (char :: chars) - in prestring (cpos + 1) [] + | Some (char) + -> source#advance; + prestring (char :: chars) + in prestring []
| Some ('{') -> source#advance; - prelex' ((ln, cpos, acc) :: ctx) (cpos + 1) [] doc + let ctx' = (source#point, acc) :: ctx in + loop ctx' [] doc
| Some ('}') - -> source#advance; + -> let brace_start = source#point in + source#advance; (match ctx with - | ((sln, scpos, sacc) :: ctx) -> - prelex' ctx (cpos+1) - (Preblock ({file=source#file_name; line=sln; column=scpos; docstr=doc}, - List.rev acc, - {file=source#file_name; line=ln; column=(cpos + 1); docstr=doc}) - :: sacc) "" - | _ -> (prelexer_error {file=source#file_name; line=ln; column=cpos; docstr=doc} - "Unmatched closing brace"; - prelex' ctx (cpos + 1) acc doc)) + | ((block_start, sacc) :: ctx) + -> let location = source#make_location ?doc block_start in + let preblock = Preblock (location, List.rev acc) in + loop ctx (preblock :: sacc) None + | _ + -> let location = source#make_location brace_start in + prelexer_error location "Unmatched closing brace"; + loop ctx acc doc)
(* A pretoken. *) - | Some (c) - -> let start_offset = source#current_offset in + | Some _ + -> let pretoken_start = source#point in source#advance; - let rec pretok cp = - match source#peek_char with + let rec pretok () = + match source#peek with | None | Some (' ' | '\t' | '%' | '"' | '{' | '}') - -> let location = {file=source#file_name; line=ln; column=cpos; docstr=doc} in - let text = source#slice_from_offset start_offset in - nexttok cp (Pretoken (location, text) :: acc) "" + -> let text, location = source#slice ?doc pretoken_start in + loop ctx (Presymbol (location, text) :: acc) None
| Some ('\n') - -> let location = {file=source#file_name; line=ln; column=cpos; docstr=doc} in - let text = source#slice_from_offset start_offset in + -> let text, location = source#slice ?doc pretoken_start in source#advance; - nextline ctx (Pretoken (location, text) :: acc) "" + loop ctx (Presymbol (location, text) :: acc) None
| Some ('\') - -> source#advance; - (match source#next_char with - | Some (char) -> pretok (1 + inc_cp cp char) + -> let backslash_start = source#point in + source#advance; + (match source#next with + | Some _ -> pretok () | None - -> let location = {file=source#file_name; line=ln; column=cpos; docstr=doc} in + -> let error_location = source#make_location backslash_start in source#advance; - let text = source#slice_from_offset start_offset in - prelexer_error location ("Unterminated escape sequence in: " ^ text); - nexttok (cp + 1) (Pretoken (location, text) :: acc) "") + let text, location = source#slice ?doc pretoken_start in + prelexer_error + error_location + ("Unterminated escape sequence in: " ^ text); + loop ctx (Presymbol (location, text) :: acc) None)
- | Some (c) + | Some _ -> source#advance; - pretok (inc_cp cp c) - in pretok (inc_cp cpos c) + pretok () + in pretok () in - (* Traditionally, column numbers start at 1 :-( *) - prelex' ctx 1 acc doc - -let prelex (source : #Source.t) : pretoken list = - (* Traditionally, line numbers start at 1 :-( *) - prelex source 1 [] [] "" - -let pretoken_name pretok = - match pretok with - | Pretoken _ -> "Pretoken" - | Prestring _ -> "Prestring" - | Preblock _ -> "Preblock" + loop [] [] None
let rec pretoken_string pretok = - match pretok with - | Preblock(_,pts,_) -> "{" ^ ( - List.fold_left (fun str pts -> str ^ " " ^ (pretoken_string pts)) - "" pts) ^ " }" - | Pretoken(_, str) -> str - | Prestring(_, str) -> """ ^ str ^ """ + match pretok with + | Preblock (_, pts) -> "{" ^ ( + List.fold_left (fun str pts -> str ^ " " ^ (pretoken_string pts)) + "" pts) ^ " }" + | Presymbol (_, name) -> name + | Prestring (_, str) -> """ ^ str ^ """
let pretokens_string pretokens = List.fold_left (fun str pt -> str ^ (pretoken_string pt)) "" pretokens @@ -217,9 +221,9 @@ let pretokens_print p = print_string (pretokens_string p)
(* Prelexer comparison, ignoring source-line-number info, used for tests. *) let rec pretokens_equal p1 p2 = match p1, p2 with - | Pretoken (_, s1), Pretoken (_, s2) -> s1 = s2 + | Presymbol (_, s1), Presymbol (_, s2) -> s1 = s2 | Prestring (_, s1), Prestring (_, s2) -> s1 = s2 - | Preblock (_, ps1, _), Preblock (_, ps2, _) -> + | Preblock (_, ps1), Preblock (_, ps2) -> pretokens_eq_list ps1 ps2 | _ -> false and pretokens_eq_list ps1 ps2 = match ps1, ps2 with
===================================== src/sexp.ml ===================================== @@ -28,19 +28,20 @@ let sexp_error ?print_action loc msg = Log.log_error ~section:"SEXP" ?print_action ~loc msg
type integer = Z.t -type symbol = location * string +type symbol = Source.Location.t * string
-type sexp = (* Syntactic expression, kind of like Lisp. *) - | Block of location * pretoken list * location +(* Syntactic expression, kind of like Lisp. *) +type sexp = + | Block of Source.Location.t * pretoken list | Symbol of symbol - | String of location * string - | Integer of location * integer - | Float of location * float + | String of Source.Location.t * string + | Integer of Source.Location.t * integer + | Float of Source.Location.t * float | Node of sexp * sexp list type token = sexp
let epsilon l = Symbol (l, "") -let dummy_epsilon = epsilon dummy_location +let dummy_epsilon = epsilon Source.Location.dummy
(********************** Sexp tests **********************)
@@ -67,9 +68,9 @@ let emptyString = hString ""
(*************** The Sexp Printer *********************)
-let rec sexp_location (s : sexp) : location = +let rec sexp_location (s : sexp) : Source.Location.t = match s with - | Block (l, _, _) -> l + | Block (l, _) -> l | Symbol (l, _) -> l | String (l, _) -> l | Integer (l, _) -> l @@ -81,11 +82,18 @@ let rec sexp_location (s : sexp) : location = let rec sexp_string ?(print_locations = false) sexp = (if print_locations then - let {file; line; column; _} = sexp_location sexp in - Printf.sprintf "#;("%s" %d %d) " file line column + let open Source.Location in + let location = sexp_location sexp in + Printf.sprintf + "#;("%s" %d %d %d %d) " + location.file + location.start_line + location.start_column + location.end_line + location.end_column else "") ^ match sexp with - | Block(_,pts,_) -> "{" ^ (pretokens_string pts) ^ " }" + | Block (_, pts) -> "{" ^ (pretokens_string pts) ^ " }" | Symbol(_, "") -> "()" (* Epsilon *) | Symbol(_, name) -> name | String(_, str) -> """ ^ str ^ """ @@ -210,7 +218,7 @@ let rec sexp_parse (g : grammar) (rest : sexp list) sexp_parse rest' level op largs (e::rargs)) | e::rest -> sexp_parse rest level op largs (e::rargs) | [] -> (mk_node (match rargs with [] -> op - | _ -> ((dummy_location,"")::op)) + | _ -> ((Source.Location.dummy, "")::op)) largs rargs false, [])
@@ -262,7 +270,7 @@ let sexp_parse_all_to_list grm tokens limit : sexp list =
(* Sexp comparison, ignoring source-line-number info, used for tests. *) let rec sexp_equal s1 s2 = match s1, s2 with - | Block (_, ps1, _), Block (_, ps2, _) -> pretokens_eq_list ps1 ps2 + | Block (_, ps1), Block (_, ps2) -> pretokens_eq_list ps1 ps2 | Symbol (_, s1), Symbol (_, s2) -> s1 = s2 | String (_, s1), String (_, s2) -> s1 = s2 | Integer (_, n1), Integer (_, n2) -> n1 = n2
===================================== src/source.ml ===================================== @@ -18,48 +18,161 @@ * You should have received a copy of the GNU General Public License along * with this program. If not, see http://www.gnu.org/licenses/. *)
-type location = Util.location +module Point = struct + (* offset * line * column *) + type t = int * int * int + + let equal (l, _, _ : t) (r, _, _ : t) : bool = + (* The line and column are metadata, only the offset is necessary for + determining equality. *) + Int.equal l r +end
module Location = struct - type t = location + type t = + { + file : string; + start_line : int; + start_column : int; + end_line : int; + end_column : int; + doc : string option; + } + + let dummy = + { + file = ""; + start_line = 0; + start_column = 0; + end_line = 0; + end_column = 0; + doc = None; + } + + (* Creates a zero-width location around the given point. *) + let of_point + ?(doc : string option) + (file : string) + (_, line, column : Point.t) + : t = + + { + file; + start_line = line; + start_column = column; + end_line = line; + end_column = column; + doc; + } + + let to_string ({file; start_line; start_column; _} : t) : string = + Printf.sprintf "%s:%d:%d" file start_line start_column
let equal (l : t) (r : t) = - let open Util in - let {file = l_file; line = l_line; column = l_column; docstr = l_doc} = l in - let {file = r_file; line = r_line; column = r_column; docstr = r_doc} = r in + let + { + file = l_file; + start_line = l_start_line; + start_column = l_start_column; + end_line = l_end_line; + end_column = l_end_column; + doc = l_doc; + } = l + in + let + { + file = r_file; + start_line = r_start_line; + start_column = r_start_column; + end_line = r_end_line; + end_column = r_end_column; + doc = r_doc; + } = r + in String.equal l_file r_file - && Int.equal l_line r_line - && Int.equal l_column r_column - && String.equal l_doc r_doc + && Int.equal l_start_line r_start_line + && Int.equal l_start_column r_start_column + && Int.equal l_end_line r_end_line + && Int.equal l_end_column r_end_column + && Option.equal String.equal l_doc r_doc end
+(* Traditionally, line numbers start at 1… *) +let first_line_of_file = 1 +(* … and so do column numbers :-( *) +let first_column_of_file = 1 + (* A source object is text paired with a cursor. The text can be lazily loaded as it is accessed byte by byte, but it must be retained for future reference by error messages. *) -class virtual t = object (self) +class virtual t (base_line : int) (base_column : int) (file_name : string) = +object (self) + val mutable line = base_line + val mutable column = base_column + (* A path if the text comes from a file, otherwise a meaningful identifier. *) - method virtual file_name : string + method file_name : string = file_name
(* Return the byte at the cursor, or None if the cursor is at the end of the text. *) - method virtual peek_char : char option + method virtual peek : char option
- (* The current offset of the cursor in the file, in bytes. *) - method virtual current_offset : int + method point : Point.t = + (self#offset, line, column)
- (* Slices the text, from (and including) a starting offset and to (and + (* The current offset of the cursor in the file, in bytes. *) + method virtual private offset : int + + (* Makes a location starting at the given point and ending at the current + cursor position. *) + method make_location + ?(doc : string option) + (_, start_line, start_column : Point.t) + : Location.t = + + let open Location in + { + file = file_name; + start_line; + start_column; + end_line = line; + end_column = column; + doc; + } + + (* Slices the text, from (and including) a starting point and to (and excluding) the curent cursor offset.
Note that the source is required only to buffer the last line read and may raise an Invalid_argument if the slice extends before the start of the line. *) - method virtual slice_from_offset : int -> string + method slice + ?(doc : string option) + (offset, _, _ as point : Point.t) + : string * Location.t =
- (* Moves the cursor forward one byte *) - method virtual advance : unit + (self#slice_impl offset, self#make_location ?doc point) + + method virtual private slice_impl : int -> string
- method next_char : char option = - let c = self#peek_char in + (* Moves the cursor forward one byte *) + method advance : unit = + let is_utf8_head c = Char.code c < 128 || Char.code c >= 192 in + let c = self#peek in + self#advance_impl; + match c with + | Some '\n' + -> line <- line + 1; + column <- 0; + | Some c when is_utf8_head c + -> column <- column + 1 + | _ -> () + + method private virtual advance_impl : unit + + (* Returns the char at the cursor, then advances it forward. *) + method next : char option = + let c = self#peek in self#advance; c end @@ -67,60 +180,62 @@ end let read_buffer_length = 4096
class source_file file_name = object (self) - inherit t + inherit t first_line_of_file first_column_of_file file_name
val in_channel = open_in file_name val mutable end_of_line = false - val mutable line = "" + val mutable source_line = "" val mutable line_offset = 0 val mutable offset = 0
- method private peek_char_unchecked = - if offset < String.length line - then line.[offset] + method private peek_unchecked = + if offset < String.length source_line + then source_line.[offset] else '\n'
- method peek_char = - if offset <= String.length line - then Some self#peek_char_unchecked + method peek = + if offset <= String.length source_line + then Some self#peek_unchecked else try - line_offset <- line_offset + 1 + String.length line; - line <- input_line in_channel; + line_offset <- line_offset + 1 + String.length source_line; + source_line <- input_line in_channel; offset <- 0; - Some self#peek_char_unchecked + Some self#peek_unchecked with | End_of_file -> None
- method advance = + method private advance_impl = offset <- offset + 1
- method current_offset = line_offset + offset + method private offset = line_offset + offset
- method slice_from_offset start_offset = + method private slice_impl start_offset = let relative_start_offset = start_offset - line_offset in - String.sub line relative_start_offset (offset - relative_start_offset) - - method file_name = file_name + String.sub source_line relative_start_offset (offset - relative_start_offset) end
-class source_string source = object - inherit t +class source_string + ?(file : string = "<string>") + ?(line : int = first_line_of_file) + ?(column : int = first_column_of_file) + source + = +object + inherit t line column file
val mutable offset = 0
- method peek_char = + method peek = if offset < String.length source then Some (source.[offset]) else None
- method advance = + method private advance_impl = offset <- offset + 1
- method current_offset = offset + method private offset = offset
- method slice_from_offset start_offset = + method private slice_impl start_offset = String.sub source start_offset (offset - start_offset) - - method file_name = "<string>" end
===================================== src/unification.ml ===================================== @@ -148,11 +148,11 @@ let common_subset ctx s1 s2 = * Identity 0 = #0 · #1 · #2 ... = #0 · (Identity 1) *) | (S.Cons _, S.Identity o2') - -> loop s1 (S.Cons (mkVar ((U.dummy_location, None), 0), + -> loop s1 (S.Cons (mkVar ((Source.Location.dummy, None), 0), S.Identity 1, o2')) o1 o2 o | (S.Identity o1', S.Cons _) - -> loop (S.Cons (mkVar ((U.dummy_location, None), 0), + -> loop (S.Cons (mkVar ((Source.Location.dummy, None), 0), S.Identity 1, o1')) s2 o1 o2 o | (S.Identity o1', S.Identity o2')
===================================== src/util.ml ===================================== @@ -38,15 +38,15 @@ module IMap = UPDATABLE(Map.Make(Int))
type charpos = int type bytepos = int -type location = { file : string; line : int; column : charpos; docstr : string; } -let dummy_location = {file=""; line=0; column=0; docstr=""} +type location = Source.Location.t +let dummy_location = Source.Location.dummy
(*************** DeBruijn indices for variables *********************)
(* Occurrence of a variable's symbol: we use DeBruijn index, and for * debugging purposes, we remember the name that was used in the source * code. *) -type vname = location * string option +type vname = Source.Location.t * string option type db_index = int (* DeBruijn index. *) type db_offset = int (* DeBruijn index offset. *) type db_revindex = int (* DeBruijn index counting from the root. *) @@ -63,12 +63,6 @@ let get_vname_name vname = | Some n -> n | _ -> "" (* FIXME: Replace with dummy_name ? *)
-(* print debug info *) -let loc_string loc = - "Ln " ^ (Fmt.ralign_int loc.line 3) ^ ", cl " ^ (Fmt.ralign_int loc.column 3) - -let loc_print loc = print_string (loc_string loc) - let string_implode chars = String.concat "" (List.map (String.make 1) chars) let string_sub str b e = String.sub str b (e - b)
===================================== tests/dune ===================================== @@ -4,10 +4,12 @@ (names elab_test env_test eval_test + gambit_test inverse_test lexp_test lexer_test macro_test + positivity_test sexp_test unify_test) (deps (alias %{project_root}/btl/typer_stdlib))
===================================== tests/gambit_test.ml ===================================== @@ -0,0 +1,190 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.ca + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR + * A PARTICULAR PURPOSE. See the GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along with + * this program. If not, see http://www.gnu.org/licenses/. *) + +(** Tests for the compilation of Lexps to Gambit Scheme code. + + There is more support code in this file than I would have liked. This is due + to the fact that there is a lot of α-renaming and gensymming so we can't + directly compare s-expressions. Instead, I defined predicates for lists, + strings, known symbols, unknown gensymmed symbols, etc. *) + +open Typerlib + +open Utest_lib + +open Gambit + +let fail_on_exp exp = + Printf.printf "in %s\n" (Scm.string_of_exp exp); + false + +let type_error expected actual = + Printf.printf + "%sExpected %s, but got %s%s\n" + Fmt.red + expected + (Scm.describe actual) + Fmt.reset; + fail_on_exp actual + +let string expected actual = + match actual with + | Scm.String value when String.equal expected value -> true + | Scm.String _ + -> Printf.printf + "%sExpected a string equal to "%s"%s\n" + Fmt.red + expected + Fmt.reset; + fail_on_exp actual + | _ -> type_error "a string" actual + +let sym expected actual = + match actual with + | Scm.Symbol value when String.equal expected value -> true + | Scm.Symbol _ + -> Printf.printf + "%sExpected a symbol equal to |%s|%s\n" + Fmt.red + expected + Fmt.reset; + fail_on_exp actual + | _ -> type_error "a symbol" actual + +let has_prefix prefix value = + String.length prefix < String.length value + && String.equal prefix (String.sub value 0 (String.length prefix)) + +type var = Var of string | UniqueVar of string + +let make_var prefix = ref (Var prefix) + +let gensym var actual = + match actual with + | Scm.Symbol value + -> (match !var with + | UniqueVar prev when String.equal value prev -> true + | UniqueVar prev + -> Printf.printf + "%sExpected a symbol equal to |%s|%s\n" + Fmt.red + prev + Fmt.reset; + fail_on_exp actual + | Var prefix when has_prefix (prefix ^ "%") value + -> var := UniqueVar value; + true + | Var prefix + -> Printf.printf + "%sExpected a symbol starting with |%s|%s\n" + Fmt.red + prefix + Fmt.reset; + fail_on_exp actual) + | _ -> type_error "a symbol" actual + +(* Returns whether the s-expression is list and that that the element at an + index satifies the predicate at the same index. *) +let list (expected : (Scm.t -> bool) list) (actual : Scm.t) : bool = + match actual with + | Scm.List value + -> let rec loop i es xs = + match es, xs with + | e :: es, x :: xs + -> if e x + then loop (i + 1) es xs + else fail_on_exp actual + | _ :: _, [] | [], _ :: _ + -> Printf.printf + "%sExpected a list of %d elements, but got %d elements%s\n" + Fmt.red + (List.length expected) + (List.length value) + Fmt.reset; + fail_on_exp actual + | [], [] -> true + in + loop 0 expected value + | _ -> type_error "a list" actual + +let test_compile name source predicate = + let compile () = + let ectx = Elab.default_ectx in + let lctx = Debruijn.ectx_to_lctx ectx in + let lexps = Elab.lexp_expr_str source ectx in + let elexps = List.map (Opslexp.erase_type lctx) lexps in + let sctx = ScmContext.of_lctx lctx in + let actual = List.map (scheme_of_expr sctx) elexps in + match actual with + | head :: [] + -> if predicate head + then success + else failure + | _ + -> Printf.printf "expected 1 expression, but got %d" (List.length actual); + failure + in + Utest_lib.add_test "GAMBIT" name compile + +let () = + test_compile + "Typer string to Scheme string" + {|"Hello"|} + (string "Hello") + +let () = + let var = make_var "x" in + test_compile + "Typer lambda to Scheme lambda" + {|lambda (x : Int) -> x|} + (list [sym "lambda"; list [gensym var]; gensym var]) + +let () = + test_compile + "Typer data cons of 0 arguments to Scheme vector" + {|datacons (typecons T V) V|} + (list [sym "##vector"; list [sym "quote"; sym "V"]]) + +let () = + let var = make_var "" in + test_compile + "Typer data cons of 1 argument to Scheme function" + {|datacons (typecons T (V Int)) V|} + (list [sym "lambda"; + list [gensym var]; + list [sym "##vector"; + list [sym "quote"; sym "V"]; + gensym var]]) + +let () = + let var_0 = make_var "" in + let var_1 = make_var "" in + test_compile + "Typer data cons of 2 arguments to Scheme function" + {|datacons (typecons T (V Int Int)) V|} + (list [sym "lambda"; + list [gensym var_0]; + list [sym "lambda"; + list [gensym var_1]; + list [sym "##vector"; + list [sym "quote"; sym "V"]; + gensym var_0; + gensym var_1]]]) + +let () = Utest_lib.run_all ()
===================================== tests/lexer_test.ml ===================================== @@ -30,11 +30,10 @@ let test_lex name pretokens expected = locations. *) let rec sexp_equal actual expected = match actual, expected with - | Sexp.Block (actual_start, actual_pretokens, actual_end), - Sexp.Block (expected_start, expected_pretokens, expected_end) - -> Location.equal actual_start expected_start + | Sexp.Block (actual_location, actual_pretokens), + Sexp.Block (expected_location, expected_pretokens) + -> Location.equal actual_location expected_location && Listx.equal Pretoken.equal actual_pretokens expected_pretokens - && Location.equal actual_end expected_end | Sexp.Symbol (actual_location, actual_name), Sexp.Symbol (expected_location, expected_name) -> Location.equal actual_location expected_location @@ -66,37 +65,44 @@ let test_lex name pretokens expected = in add_test "LEXER" name lex
-let l : location = - {file = "test.typer"; line = 1; column = 1; docstr = ""} +let l : Source.Location.t = + { + file = "test.typer"; + start_line = 1; + start_column = 1; + end_line = 1; + end_column = 1; + doc = None; + }
let () = test_lex "Inner operator inside a presymbol" - [Pretoken (l, "a.b")] - [Node (Symbol ({l with column = 2}, "__.__"), - [Symbol ({l with column = 1}, "a"); - Symbol ({l with column = 3}, "b")])] + [Presymbol (l, "a.b")] + [Node (Symbol ({l with start_column = 2; end_column = 3}, "__.__"), + [Symbol ({l with start_column = 1; end_column = 2}, "a"); + Symbol ({l with start_column = 3; end_column = 4}, "b")])]
let () = test_lex "Inner operators at the beginning of a presymbol" - [Pretoken (l, ".b")] - [Node (Symbol ({l with column = 1}, "__.__"), - [epsilon {l with column = 1}; - Symbol ({l with column = 2}, "b")])] + [Presymbol (l, ".b")] + [Node (Symbol ({l with start_column = 1; end_column = 2}, "__.__"), + [epsilon {l with start_column = 1; end_column = 1}; + Symbol ({l with start_column = 2; end_column = 3}, "b")])]
let () = test_lex "Inner operators at the end of a presymbol" - [Pretoken (l, "a.")] - [Node (Symbol ({l with column = 2}, "__.__"), - [Symbol ({l with column = 1}, "a"); - epsilon {l with column = 3}])] + [Presymbol (l, "a.")] + [Node (Symbol ({l with start_column = 2; end_column = 3}, "__.__"), + [Symbol ({l with start_column = 1; end_column = 2}, "a"); + epsilon {l with start_column = 3; end_column = 3}])]
let () = test_lex "An inner operator by itself is a simple symbol" - [Pretoken (l, ".")] - [Symbol ({l with column = 1}, ".")] + [Presymbol (l, ".")] + [Symbol ({l with start_column = 1; end_column = 2}, ".")]
let () = run_all ()
===================================== tests/positivity_test.ml ===================================== @@ -0,0 +1,118 @@ +(* Copyright (C) 2021 Free Software Foundation, Inc. + * + * Author: Simon Génier simon.genier@umontreal.ca + * Keywords: languages, lisp, dependent types. + * + * This file is part of Typer. + * + * Typer is free software; you can redistribute it and/or modify it under the + * terms of the GNU General Public License as published by the Free Software + * Foundation, either version 3 of the License, or (at your option) any later + * version. + * + * Typer is distributed in the hope that it will be useful, but WITHOUT ANY + * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS + * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more + * details. + * + * You should have received a copy of the GNU General Public License along + * with this program. If not, see http://www.gnu.org/licenses/. *) + +open Typerlib +open Utest_lib + +open Lexp +open Positivity +open Util + +exception WrongPolarity of vname + +type polarity = + | Positive + | Negative + +let print_lexp lexp = ut_string 3 (Lexp.lexp_string lexp ^ "\n") + +let assert_polarity polarity lexp vname = + match (polarity, positive 0 lexp) with + | (Positive, false) | (Negative, true) -> raise (WrongPolarity vname) + | _ -> () + +let lexp_decl_str (source : string) : (vname * lexp) list = + let (decls, _) = Elab.lexp_decl_str source Elab.default_ectx in + assert (List.length decls > 0); + let decls = List.flatten decls in + List.map (fun (vname, lexp, _) -> print_lexp lexp; (vname, lexp)) decls + +(** + * Check that all the values declared in the source have the given polarity. + * + * Only declarations are checked, you may introduce variables with any polarity + * in the bindings of let or lambda expressions. + *) +let check_polarity (polarity : polarity) (source : string) : int = + let decls = lexp_decl_str source in + try + List.iter (fun (vname, lexp) -> assert_polarity polarity lexp vname) decls; + success + with + | WrongPolarity _ -> failure + +let add_polarity_test polarity name sample = + add_test "POSITIVITY" name (fun () -> check_polarity polarity sample) + +let add_positivity_test = add_polarity_test Positive + +let add_negativity_test = add_polarity_test Negative + +let () = add_positivity_test + "a variable is positive in itself" + {| + x : Type; + x = x; + |} + +let () = add_positivity_test + "a variable is positive in some other variable" + {| + y : Type; + y = Int; + x : Type; + x = y; + |} + +let () = add_positivity_test + "an arrow is positive in a variable that appears in its right hand side" + {| + x : Type; + x = Int -> x; + |} + +let () = add_negativity_test + "an arrow is negative in a variable that appears in its left hand side" + {| + x : Type; + x = x -> Int; + |} + +let () = add_positivity_test + "an application of a variable is positive if it does not occur in its arguments" + {| + GoodList : Type -> Type; + GoodList = typecons + (GoodList (a : Type)) + (good_nil) + (good_cons (GoodList a)); + |} + +let () = add_negativity_test + "an application of a variable is negative if it occurs in its arguments" + {| + EvilList : Type -> Type; + EvilList = typecons + (EvilList (a : Type)) + (evil_nil) + (evil_cons (EvilList (EvilList a))); + |} + +let () = run_all ()
===================================== tests/unify_test.ml ===================================== @@ -91,7 +91,7 @@ let _ = {| type Nat | Z | S (Nat); |} ectx in - let dloc = U.dummy_location in + let dloc = Source.Location.dummy in let nat = mkVar ((dloc, Some "Nat"), 2) in let shift l i = mkSusp l (S.shift i) in let ectx, _ =
===================================== typer.ml ===================================== @@ -21,6 +21,9 @@
open Typerlib
+open Backend +open Debruijn + let welcome_msg = " Typer 0.0.0 - Interpreter - (c) 2016-2021
@@ -29,6 +32,7 @@ let welcome_msg = "
let arg_batch = ref false +let arg_backend_name = ref "interpreter"
let arg_files = ref [] let add_input_file file = @@ -46,6 +50,10 @@ let arg_defs = ("-Vfull-lctx", Arg.Set Debruijn.log_full_lctx, "Print the full lexp context on error."); + + ("--backend", + Arg.Symbol (["interpreter"; "gambit"], fun name -> arg_backend_name := name), + "Select the backend"); ]
let main () = @@ -53,7 +61,12 @@ let main () = Arg.parse arg_defs add_input_file usage;
let ectx = Elab.default_ectx in - let backend = new Eval.ast_interpreter (Debruijn.ectx_to_lctx ectx) in + let backend = + let lctx = ectx_to_lctx ectx in + match !arg_backend_name with + | "gambit" -> (new Gambit.gambit_compiler lctx stdout :> backend) + | _ -> (new Eval.ast_interpreter lctx :> backend) + in let interactive = backend#interactive in let file_names = List.rev !arg_files in let is_interactive = not !arg_batch && Option.is_some interactive in
View it on GitLab: https://gitlab.com/monnier/typer/-/compare/5bb2dddd572f24dcd4610f70cf58bdcd7...