Jonathan Graveline pushed to branch graveline at Stefan / Typer

Commits: b3519661 by Jonathan Graveline at 2018-08-02T19:38:52Z macro `case` should now work on tuple

use `sexp_name` in `Sexp_debug_print`

change in `is_binary_op` (I think it was a bug)

tuple constructor now has a `gensym` name

- - - - -

6 changed files:

- btl/case.typer - btl/pervasive.typer - btl/plain-let.typer - btl/tuple.typer - src/eval.ml - src/lexp.ml

Changes:

===================================== btl/case.typer ===================================== @@ -36,13 +36,61 @@ gen-vars vars = io-list (List_map (lambda _ -> gensym ()) vars);

+tuple-ctor : List Sexp -> Sexp; +tuple-ctor args = let + + ctor : Sexp; + ctor = Sexp_symbol "cons"; + +in Sexp_node (Sexp_symbol "##datacons") + (cons (Sexp_symbol "?") + (cons ctor + nil)); + +%% +%% Expand tuple expression `(expr1, expr2, ...)` with a constructor +%% +%% become +%% `cons expr1 expr2 ... ` +%% + +expand-tuple-ctor : Sexp -> Sexp; +expand-tuple-ctor sexp = let + + err = (lambda _ -> Sexp_error); + +in Sexp_dispatch sexp + (lambda s ss -> + if (Sexp_eq s (Sexp_symbol "_,_")) then + (Sexp_node (tuple-ctor ss) ss) + else + (Sexp_node s ss)) + (lambda _ -> sexp) + err err err err; + +%% +%% Is tuple +%% + +is-tuple : Sexp -> Bool; +is-tuple sexp = let + + sfalse = (lambda _ -> false); + +in Sexp_dispatch sexp + (lambda s _ -> Sexp_eq s (tuple-ctor nil)) + sfalse sfalse sfalse sfalse sfalse; + %% -%% Get matched expression (e.g. case (var1,var2,...) | ...) +%% Get matched expression (e.g. case var1 var2 ... | ...) %% -%% Expression are separated by "," so it is useful for -%% case (expr1,expr2,...) ... +%% Expression are separated by " " (space) so it is useful for +%% case expr1 expr2 ... | ... %% but also for -%% case ... | (expr3,expr4,...) => ... +%% case ... | expr3 expr4 ... => ... +%% +%% (This function is now doing nothing since there's only one +%% variable at any time: one expression or a tuple of expressions) %%

get-tup-exprs : Sexp -> List Sexp; @@ -51,19 +99,15 @@ get-tup-exprs sexp = let err = (lambda _ -> cons Sexp_error nil);

get-tup-exprs-helper : Sexp -> List Sexp -> List Sexp; - get-tup-exprs-helper s ss = case (Sexp_eq (Sexp_symbol "_,_") s) - | true => (ss) % tuple + get-tup-exprs-helper s ss = case (Sexp_eq (Sexp_symbol "_,_") s) + | true => cons (Sexp_node s ss) nil % tuple %% constructor or function called (only 1 pattern) - | false => (cons (Sexp_node s ss) nil); + | false => cons (Sexp_node s ss) nil;

in Sexp_dispatch sexp get-tup-exprs-helper - (lambda s -> (cons (Sexp_symbol s) nil)) - err err err - (lambda ss -> cons ss nil); % do nothing to Block - -%% -return = IO_return; + (lambda s -> cons (Sexp_symbol s) nil) + err err err err;

%% %% Some alias to clarify type of functions @@ -89,17 +133,25 @@ is-dflt v = Sexp_eq dflt-var v; %% with all patterns and the user code for each branches %%

-get-branches : List Sexp -> List (Pair Pats Code); -get-branches sexps = let +get-branches : List Sexp -> List Sexp -> List (Pair Pats Code); +get-branches vars sexps = let

perr = (lambda _ -> pair (cons Pat_error nil) Code_error);

to-case : Sexp -> Pair Pats Code; - to-case sexp = Sexp_dispatch sexp + to-case sexp = let + + tup-exprs : Sexp -> List Sexp; + tup-exprs sexp = if (Int_eq (List_length vars) 1) then + (cons (expand-tuple-ctor sexp) nil) + else + (List_map expand-tuple-ctor (get-tup-exprs sexp)); + + in Sexp_dispatch sexp

(lambda s ss -> case (Sexp_eq (Sexp_symbol "_=>_") s) % expecting a Sexp_node as second argument to _=>_ - | true => pair (get-tup-exprs (List_nth 0 ss Pat_error)) (List_nth 1 ss Code_error) + | true => pair (tup-exprs (List_nth 0 ss Pat_error)) (List_nth 1 ss Code_error) | false => pair (cons Pat_error nil) Code_error)

perr perr perr perr perr; @@ -120,6 +172,12 @@ renamed-pat : Sexp -> List Sexp -> IO Sexp; renamed-pat pat names = let

serr = lambda _ -> Sexp_error; + + tup : Bool; + tup = is-tuple pat; + + tuple-nth : Int -> Sexp; + tuple-nth n = Sexp_symbol (String_concat "%" (Int->String n));

mf : Sexp -> Int -> Sexp; mf v i = Sexp_dispatch v @@ -127,25 +185,36 @@ renamed-pat pat names = let if (Sexp_eq sym (Sexp_symbol "_:=_")) then (Sexp_node sym (cons (List_nth 0 ss Sexp_error) (cons (List_nth i names Sexp_error) nil))) + else if tup then + %% tuples argument are all implicit so we must take special care of those + (Sexp_node (Sexp_symbol "_:=_") + (cons (tuple-nth i) (cons (List_nth i names Sexp_error) nil))) + else + (List_nth i names Sexp_error)) + (lambda _ -> if tup then + (Sexp_node (Sexp_symbol "_:=_") + (cons (tuple-nth i) (cons (List_nth i names Sexp_error) nil))) else (List_nth i names Sexp_error)) - (lambda _ -> List_nth i names Sexp_error) serr serr serr serr;

-in return (Sexp_dispatch pat - (lambda s ss -> Sexp_node s (List_mapi mf ss)) - (lambda s -> Sexp_symbol s) - serr serr serr serr); +in do { + pat <- IO_return pat; + IO_return (Sexp_dispatch pat + (lambda s ss -> Sexp_node s (List_mapi mf ss)) + (lambda s -> Sexp_symbol s) + serr serr serr serr); +};

%% -%% Takes an Sexp as argument and return `IO true` if it is a pattern +%% Takes an Sexp as argument and IO_return `IO true` if it is a pattern %% (i.e. a constructor with or without argument) %%

is-pat : Pat -> IO Bool; is-pat pat = let

- err = lambda _ -> return false; + err = lambda _ -> IO_return false;

serr = lambda _ -> "< error >";

@@ -158,16 +227,18 @@ is-pat pat = let in Sexp_dispatch pat (lambda sym _ -> do { env <- Elab_getenv (); - return (Elab_isconstructor (sym-str sym) env); + ctor <- IO_return (Elab_isconstructor (sym-str sym) env); + tupl <- IO_return (Sexp_eq sym (Sexp_symbol "_,_")); + IO_return (or ctor tupl); }) (lambda sym -> do { env <- Elab_getenv (); - return (Elab_isconstructor sym env); + IO_return (Elab_isconstructor sym env); }) err err err err;

%% -%% Takes two pattern and return `IO true` if the two pattern +%% Takes two pattern and IO_return `IO true` if the two pattern %% has the same constructor %%

@@ -187,40 +258,40 @@ in Sexp_eq (ctor-of p0) (ctor-of p1); %% %% Get variable introduced by a constructor %% -%% Takes a pattern as argument and return each arguments +%% Takes a pattern as argument and IO_return each arguments %% of the constructor which is a variable (as opposed to a sub pattern) %%

introduced-vars : Pat -> IO (List Var); introduced-vars pat = let

- serr = lambda _ -> return nil; + serr = lambda _ -> IO_return nil;

ff : IO (List Sexp) -> Sexp -> IO (List Sexp); ff o v = Sexp_dispatch v (lambda s ss -> do { o <- o; % bind if (Sexp_eq s (Sexp_symbol "_:=_")) then - (return (List_concat o (cons (List_nth 1 ss Var_error) nil))) + (IO_return (List_concat o (cons (List_nth 1 ss Var_error) nil))) else - (return (List_concat o (cons dflt-var nil))); + (IO_return (List_concat o (cons dflt-var nil))); }) (lambda s -> do { o <- o; % bind - sym <- return (Sexp_symbol s); + sym <- IO_return (Sexp_symbol s); b <- is-pat sym; if (b) then - (return (List_concat o (cons dflt-var nil))) + (IO_return (List_concat o (cons dflt-var nil))) else - (return (List_concat o (cons sym nil))); + (IO_return (List_concat o (cons sym nil))); }) serr serr serr serr;

in Sexp_dispatch pat - (lambda _ ss -> List_foldl ff (return nil) ss) - (lambda _ -> return nil) % constructor as a unique symbol (as `true`) - (lambda _ -> return nil) (lambda _ -> return nil) % error - (lambda _ -> return nil) (lambda _ -> return nil); % error + (lambda _ ss -> List_foldl ff (IO_return nil) ss) + (lambda _ -> IO_return nil) % constructor as a unique symbol (as `true`) + (lambda _ -> IO_return nil) (lambda _ -> IO_return nil) % error + (lambda _ -> IO_return nil) (lambda _ -> IO_return nil); % error

%% %% Wrap the third argument (`fun`) with a `let` definition for each variables @@ -237,7 +308,7 @@ wrap-vars ivars rvars fun = List_fold2 (lambda fun v0 v1 -> fun ivars rvars;

%% -%% Take a List of branches and return a List of the first pattern in each branches +%% Take a List of branches and IO_return a List of the first pattern in each branches %% (I must keep the order from input to ouput) %%

@@ -252,14 +323,14 @@ in List_map mf ps;

%% %% Takes a pattern as argument and -%% return a List of sub pattern for that branch +%% IO_return a List of sub pattern for that branch %% the List contain dflt-var if it has a variable which is not a pattern %%

pattern-sub-pats : Pat -> IO (List Pat); pattern-sub-pats pat = let

- err = lambda _ -> return nil; + err = lambda _ -> IO_return nil;

%% %% dflt-var mean there's no sub pattern @@ -273,26 +344,26 @@ pattern-sub-pats pat = let map-arg arg = do { b <- is-pat arg; if (b) then - (return arg) + (IO_return (expand-tuple-ctor arg)) else - (return dflt-var); + (IO_return dflt-var); };

in Sexp_dispatch pat (lambda ctor args -> do { r <- io-list (List_map map-arg args); - return r; + IO_return r; }) (lambda sym -> do { %% constructor has no argument %% so there can't be any sub pattern - return nil; + IO_return nil; }) err err err err;

%% %% Takes a List of similar pattern (i.e. a pattern of same constructor) -%% return a List of gensym variable if there's is a sub pattern +%% IO_return a List of gensym variable if there's is a sub pattern %% and a default variable when there's no sub pattern %%

@@ -313,7 +384,7 @@ pattern-sub-pats-vars rvars branches = let subs : IO (List Pat); subs = do { r <- pattern-sub-pats pat; - return r; + IO_return r; };

in do { @@ -321,19 +392,19 @@ pattern-sub-pats-vars rvars branches = let subs <- subs;

if (List_empty subs) then - (return psubs) + (IO_return psubs) else - (return (List_mapi (lambda c n -> let + (IO_return (List_mapi (lambda c n -> let new-sym = List_nth n rvars Var_error; prev-sym = List_nth n psubs dflt-var; in if (is-dflt c) then (prev-sym) else (new-sym) ) subs)); };

-in List_foldl ff (return nil) pats; +in List_foldl ff (IO_return nil) pats;

%% -%% return a List of old/new variables names +%% IO_return a List of old/new variables names %% %% new variable should be identical for each branches %% but old variable (from user code) are arbitrary @@ -352,8 +423,8 @@ pattern-term pat rvars = let

in do { ivars <- introduced-vars pat; - rvv <- return (List_fold2 ff nil ivars rvars); - return rvv; + rvv <- IO_return (List_fold2 ff nil ivars rvars); + IO_return rvv; };

%% @@ -367,7 +438,7 @@ in do { part-type = Pair (Triplet Pat (List Var) (List (Pair Pat (List (Pair Var Var))))) (List (Pair Pats Code));

%% -%% return a pair of renamed and partitioned pattern +%% IO_return a pair of renamed and partitioned pattern %% (i.e. a Pair of renamed pattern, introduced variables, old pattern and tail of branches) %% (Yeah, I need old pattern to get sub pattern at some point) %% @@ -439,25 +510,25 @@ partition-branches branches = let ff rvars o p = do { o <- o; p <- pattern-term p rvars; - return (List_concat o (cons p nil)); + IO_return (List_concat o (cons p nil)); };

mf : pre-part-type -> IO part-type; mf p = case p | pair pp tt => do { - pat <- return (List_nth 0 pp Pat_error); + pat <- IO_return (List_nth 0 pp Pat_error); ivars <- introduced-vars pat; rvars <- gen-vars ivars; rpat <- renamed-pat pat rvars; - vars <- List_foldl (ff rvars) (return nil) pp; - return (pair (triplet rpat rvars (List_merge pp vars)) tt); + vars <- List_foldl (ff rvars) (IO_return nil) pp; + IO_return (pair (triplet rpat rvars (List_merge pp vars)) tt); };

in io-list (List_map mf pre-parts);

in do { parts <- parts; - return parts; + IO_return parts; };

%% @@ -553,7 +624,7 @@ compile-case subjects branches = let parts : IO (List part-type); parts = do { ps <- partition-branches branches; - return (merge-dflt ps none); + IO_return (merge-dflt ps none); };

translate-sub-pats : List Var -> List (Pair Pat (List (Pair Var Var))) -> List (Pair Pats Code) @@ -578,14 +649,14 @@ compile-case subjects branches = let sub-pats <- sub-pats; sub-pats-vars <- sub-pats-vars;

- sub-pats <- return (List_fold2 (lambda o pat var -> + sub-pats <- IO_return (List_fold2 (lambda o pat var -> if (is-dflt var) then (o) else (List_concat o (cons pat nil)) ) nil sub-pats sub-pats-vars);

- return (case branch | pair pats code => + IO_return (case branch | pair pats code => pair (List_concat sub-pats pats) (wrap-vars (List_map-snd vars) (List_map-fst vars) code)); }; @@ -593,24 +664,24 @@ compile-case subjects branches = let new-branches : IO (List (Pair Pats Code)); new-branches = do { nbranches <- io-list (List_map2 mf pats-vars branches); - return (adjust-len nbranches); + IO_return (adjust-len nbranches); };

new-subjects : IO (List Var); new-subjects = do { sub-pats-vars <- sub-pats-vars; - r <- return (List_concat sub-pats-vars (List_tail subjects)); + r <- IO_return (List_concat sub-pats-vars (List_tail subjects));

%% As for constructor we remove variable if it is always a default %% variable without any corresponding sub pattern

- r <- return (List_foldl (lambda o v -> + r <- IO_return (List_foldl (lambda o v -> if (is-dflt v) then (o) else (List_concat o (cons v nil)) ) nil r); - return r; + IO_return r; };

code-or-recurse : List Var -> List (Pair Pats Code) -> IO Code; @@ -618,14 +689,14 @@ compile-case subjects branches = let | cons _ _ => compile-case subjects branches | nil => (case branches | cons branch _ => (case branch - | pair _ code => return code) - | nil => return Code_error); + | pair _ code => IO_return code) + | nil => IO_return Code_error);

in do { new-subjects <- new-subjects; new-branches <- new-branches; code <- code-or-recurse new-subjects new-branches; - return code; + IO_return code; };

in recursion pats-vars branches; @@ -635,13 +706,13 @@ compile-case subjects branches = let | pair patterns branches => (case patterns | triplet pat rvars pats-vars => do { sub-cases <- translate-sub-pats rvars pats-vars branches; - return (quote (_=>_ (uquote pat) (uquote sub-cases))); + IO_return (quote (_=>_ (uquote pat) (uquote sub-cases))); });

translate : List part-type -> IO Code; translate parts = do { branches <- io-list (List_map translate-part parts); - return (Sexp_node (Sexp_symbol "##case_") (cons ( + IO_return (Sexp_node (Sexp_symbol "##case_") (cons ( Sexp_node (Sexp_symbol "_|_") (cons subject branches) ) nil)); }; @@ -649,7 +720,7 @@ compile-case subjects branches = let in do { parts <- parts; r <- translate parts; - return r; + IO_return r; };

%%% @@ -669,7 +740,7 @@ rec-case args = let

ctors : List (Pair Pats Code); ctors = case args - | (cons s ss) => get-branches ss + | (cons s ss) => get-branches vars ss | nil => nil;

num-vars : IO (List Sexp); @@ -679,14 +750,14 @@ rec-case args = let

in do { vars <- vars; - return vars; + IO_return vars; };

in do { num-vars <- num-vars; f <- compile-case num-vars ctors; - r <- return (wrap-vars vars num-vars f); - return r; + r <- IO_return (wrap-vars vars num-vars f); + IO_return r; };

%% Only the Sexp after "_|_" are interesting @@ -705,4 +776,4 @@ rec-case args = let in (Sexp_dispatch (List_nth 0 args Sexp_error) case1 err err err err err);

-case_ = macro rec-case; +case-macro = macro rec-case;

===================================== btl/pervasive.typer ===================================== @@ -541,9 +541,23 @@ list = load_ "btl/list.typer";

do = let lib = load_ "btl/do.typer" in lib.do;

+%% various macro for tuple +%% used by `case_` + +tuple-lib = load_ "btl/tuple.typer"; + +%% get nth element +tuple-nth = tuple-lib.tuple-nth; + +%% affectation (e.g. `(x,y,z) <- tup`) +_<-_ = tuple-lib.assign-tuple; + +%% creation (e.g. `tup = (x,y,z)`) +_,_ = tuple-lib.make-tuple; + %% macro `case` for a little more complex pattern matching

-case_ = let lib = load_ "btl/case.typer" in lib.case_; +case_ = let lib = load_ "btl/case.typer" in lib.case-macro;

%%%% plain-let

@@ -552,6 +566,6 @@ case_ = let lib = load_ "btl/case.typer" in lib.case_; define-operator "plain-let" () 3; %% define-operator "in" 3 67;

-plain-let_in_ = let lib = load_ "btl/plain-let.typer" in lib.plain-let_in_; +plain-let_in_ = let lib = load_ "btl/plain-let.typer" in lib.plain-let-macro;

%%% pervasive.typer ends here.

===================================== btl/plain-let.typer ===================================== @@ -116,7 +116,7 @@ in do { IO_return (gen-code sym-def var-sym body); };

-plain-let_in_ = macro (lambda args -> do { +plain-let-macro = macro (lambda args -> do { r <- impl args; IO_return r; });

===================================== btl/tuple.typer ===================================== @@ -73,9 +73,9 @@ gen-deduce vars = List_map %%% Access one tuple's element %%%

-%% tuple_nth : (tup-type : Type) ≡> (elem-type : Type) ≡> tup-type -> Int -> elem-type; +%% tuple-nth : (tup-type : Type) ≡> (elem-type : Type) ≡> tup-type -> Int -> elem-type;

-tuple_nth = macro (lambda args -> let +tuple-nth = macro (lambda args -> let

nerr = lambda _ -> (Int->Integer (-1));

@@ -99,7 +99,7 @@ in IO_return (Sexp_node (Sexp_symbol "__.__") (cons tup (cons elem-sym nil))) %%% Affectation, unwraping tuple %%%

-_<-_ = macro (lambda args -> let +assign-tuple = macro (lambda args -> let

xserr = lambda _ -> (nil : List Sexp);

@@ -114,39 +114,60 @@ _<-_ = macro (lambda args -> let

mf : Sexp -> Sexp -> Int -> Sexp; mf t arg i = Sexp_node (Sexp_symbol "_=_") - (cons arg (cons (Sexp_node (Sexp_symbol "tuple_nth") + (cons arg (cons (Sexp_node (Sexp_symbol "tuple-nth") (cons t (cons (Sexp_integer (Int->Integer i)) nil))) nil));

-in IO_return (Sexp_node (Sexp_symbol "_;_") (List_mapi +in do { + IO_return (Sexp_node (Sexp_symbol "_;_") (List_mapi (mf (List_nth 1 args Sexp_error)) - (get-tup-elem (List_nth 0 args Sexp_error)))) -); + (get-tup-elem (List_nth 0 args Sexp_error)))); +}); + +%% +%% Wrap the third argument (`fun`) with a `let` definition for each variables +%% Names are taken from `rvars` and definition are taken from `ivars` +%%

-make-tuple : List Sexp -> IO Sexp; -make-tuple values = let +wrap-vars : List Sexp -> List Sexp -> Sexp -> Sexp; +wrap-vars ivars rvars fun = List_fold2 (lambda fun v0 v1 -> + %% + %% I prefer `let` definition because a lambda function would need a type + %% (quote ((lambda (uquote v0) -> (uquote fun)) (uquote v1)))) + %% + (quote (let (uquote v1) = (uquote v0) in (uquote fun)))) + fun ivars rvars; + +make-tuple-impl : List Sexp -> IO Sexp; +make-tuple-impl values = let

mf1 : Sexp -> Sexp -> Sexp; mf1 name value = Sexp_node (Sexp_symbol "_::_") (cons name (cons value nil));

- mf2 : Sexp -> Sexp; - mf2 value = Sexp_node (Sexp_symbol "_:=_") (cons (Sexp_symbol "_") (cons value nil)); + mf2 : Sexp -> Sexp -> Sexp; + mf2 value nth = Sexp_node (Sexp_symbol "_:=_") (cons nth (cons value nil));

in do { + %% rval <- gen-vars values; + %% args <- gen-vars rval; args <- gen-vars values; names <- IO_return (gen-tuple-names values); + ctor <- gensym (); fun <- IO_return (Sexp_node (Sexp_symbol "lambda_->_") (cons (Sexp_node (List_nth 0 args Sexp_error) (List_tail args)) (cons - (Sexp_node (Sexp_symbol "typecons") (cons (Sexp_symbol "_") + (Sexp_node (Sexp_symbol "typecons") (cons (ctor) (cons (Sexp_node (Sexp_symbol "cons") (List_map2 mf1 names args)) nil))) nil)) ); call-fun <- IO_return (Sexp_node fun (gen-deduce values)); tuple <- IO_return (Sexp_node (Sexp_symbol "##datacons") (cons call-fun (cons (Sexp_symbol "cons") nil))); - affect <- IO_return (Sexp_node tuple (List_map mf2 values)); + affect <- IO_return (Sexp_node tuple (List_map2 mf2 values names)); + %% IO_return (wrap-vars values rval affect); IO_return affect; };

-_,_ = macro (lambda args -> - make-tuple args -); +make-tuple = macro (lambda args -> do { + r <- make-tuple-impl args; + r <- IO_return r; + IO_return r; +});

===================================== src/eval.ml ===================================== @@ -334,14 +334,7 @@ let sexp_eq loc depth args_val = match args_val with | _ -> error loc "Sexp.= expects 2 sexps"

let sexp_debug_print loc depth args_val = match args_val with - | [Vsexp (s1)] -> (let tstr = (match s1 with - | Block _ -> "Block" - | Symbol _ -> "Symbol" - | String _ -> "String" - | Integer _ -> "Integer" - | Float _ -> "Float" - | Node _ -> "Node" - ) + | [Vsexp (s1)] -> (let tstr = sexp_name s1 in (print_string ("\n\t"^tstr^" : ["^(sexp_string s1)^"]\n\n") ; Vcommand (fun () -> Vsexp (s1)))) | _ -> error loc "Sexp.debug_print expects 1 sexps"

===================================== src/lexp.ml ===================================== @@ -637,9 +637,10 @@ let pp_newline buffer ctx = reset_col_size ctx

let is_binary_op str = + let len = String.length str in let c1 = String.get str 0 in - let cn = String.get str ((String.length str) - 1) in - if (c1 = '_') && (cn = '_') then true else false + let cn = String.get str (len - 1) in + if (c1 = '_') && (cn = '_') && (len > 2) then true else false

let get_binary_op_name name = assert (((String.length name) - 2) >= 1);

View it on GitLab: https://gitlab.com/monnier/typer/commit/b35196610ca52c9dae3f93f78e4754b4d613...