Simon Génier pushed to branch sexp-case at Stefan / Typer

Commits: ab7984ee by Simon Génier at 2020-12-11T22:31:44-05:00 Use sexp-case in a few places.

- - - - -

2 changed files:

- btl/pervasive.typer - btl/sexp-case.typer

Changes:

===================================== btl/pervasive.typer ===================================== @@ -172,26 +172,23 @@ __.__ = %%%% Sexp-Case macro

define-operator "sexp-case" () 43; -sexp-case_ = - let lib = load "btl/sexp-case.typer" - in macro lib.sexp-case-impl; +sexp-case-lib = load "btl/sexp-case.typer"; +sexp-case_ = macro (lambda (sexps : List Sexp) -> IO_return (sexp-case-lib.sexp-case-impl sexps));

%%%% A more flexible `lambda`

%% Sexp_to_list : Sexp -> List Sexp -> List Sexp; Sexp_to_list s = lambda exceptions -> - let singleton (_ : ?) = cons s nil in %FIXME: Get rid of ": ?"! - Sexp_dispatch - s - (node := lambda head -> lambda tail - -> case List_find (Sexp_eq head) exceptions - | some _ => singleton () + sexp-case s + | node head tail + => (case List_find (Sexp_eq head) exceptions + | some _ => cons s nil | none => cons head tail) - (symbol := lambda s - -> case String_eq "" s + | symbol name + => (case String_eq "" name | true => nil - | false => singleton ()) - singleton singleton singleton singleton; + | false => cons s nil) + | _ => cons s nil;

multiarg_lambda = %% This macro lets `lambda_->_` (and siblings) accept multiple arguments. @@ -321,52 +318,37 @@ type-impl = lambda (x : List Sexp) -> %% Type name --^ ^------^ constructors

%% Return a list contained inside a node sexp. - let knil = K nil; - kerr = K Sexp_error; - - get-list : Sexp -> List Sexp; - get-list node = Sexp_dispatch node - (lambda op lst -> lst) % Nodes - knil % Symbol - knil % String - knil % Integer - knil % Float - knil; % List of Sexp + let get-list : Sexp -> List Sexp; + get-list node = + sexp-case node + | node _ lst => lst + | _ => (nil : List Sexp);

%% Get a name (symbol) from a sexp %% - (name t) -> name %% - name -> name get-name : Sexp -> Sexp; get-name sxp = - Sexp_dispatch sxp - (lambda op _ -> get-name op) % Nodes - (lambda _ -> sxp) % Symbol - kerr % String - kerr % Integer - kerr % Float - kerr; % List of Sexp + sexp-case sxp + | node op _ => get-name op + | symbol _ => sxp + | _ => Sexp_error;

get-args : Sexp -> List Sexp; get-args sxp = - Sexp_dispatch sxp - (lambda _ args -> args) % Nodes - (lambda _ -> (nil : List Sexp)) % Symbol - (lambda _ -> (nil : List Sexp)) % String - (lambda _ -> (nil : List Sexp)) % Integer - (lambda _ -> (nil : List Sexp)) % Float - (lambda _ -> (nil : List Sexp)); % List of Sexp + sexp-case sxp + | node _ args => args + | _ => (nil : List Sexp);

get-type : Sexp -> Sexp; get-type sxp = - Sexp_dispatch sxp - (lambda s ss -> case (Sexp_eq s (Sexp_symbol "_:_")) - | true => List_nth 1 ss Sexp_error - | false => sxp) - (lambda _ -> sxp) - (lambda _ -> Sexp_error) - (lambda _ -> Sexp_error) - (lambda _ -> Sexp_error) - (lambda _ -> Sexp_error); + sexp-case sxp + | node s ss + => (case Sexp_eq s (Sexp_symbol "_:_") + | true => List_nth 1 ss Sexp_error + | false => sxp) + | symbol _ => sxp + | _ => Sexp_error;

get-head = List_head Sexp_error;

@@ -699,14 +681,9 @@ Test_file = macro (lambda args -> let (cons (Sexp_symbol "unit") nil);

%% Expecting a String and nothing else -in IO_return (Sexp_dispatch (List_nth 0 args Sexp_error) - (lambda _ _ -> ret) - (lambda _ -> ret) - %% `load` is a special form and takes a Sexp rather than a real `String` - (lambda s -> quote (let lib = load (uquote (Sexp_string s)); in lib.exec-test)) - (lambda _ -> ret) - (lambda _ -> ret) - (lambda _ -> ret)) +in IO_return (sexp-case List_nth 0 args Sexp_error + | string s => quote (let lib = load (uquote (Sexp_string s)); in lib.exec-test) + | _ => ret) );

%%% pervasive.typer ends here.

===================================== btl/sexp-case.typer ===================================== @@ -155,7 +155,7 @@ sexp<-sexp-case-acc = lambda target -> lambda acc -> %% | node (symbol "_=>_") (cons pattern (cons expr nil)) => ?e-double-arrow %% | _ => ?e-else %% -sexp-case-impl : List Sexp -> IO Sexp; +sexp-case-impl : List Sexp -> Sexp; sexp-case-impl = lambda args -> let not-bottom : Sexp; @@ -389,10 +389,10 @@ sexp-case-impl = lambda args -> expand-sexp-case : Sexp -> List Sexp -> Sexp; expand-sexp-case = lambda head -> lambda tail -> case Sexp_eq head not-bottom - | false => Sexp_error + | false => Sexp_symbol "todo" | true => case tail - | nil => Sexp_error + | nil => Sexp_symbol "todo" | cons target arms => case parse-arms arms | (err (α := SexpCaseAcc) (β := String)) message => @@ -402,19 +402,18 @@ sexp-case-impl = lambda args -> sexp<-sexp-case-acc target acc ; in - IO_return - case args - | nil => Sexp_error - | cons head tail => - case tail - | nil => - Sexp_dispatch - head - expand-sexp-case - (lambda _ -> Sexp_symbol "invalid case expression: symbol") - (lambda _ -> Sexp_symbol "invalid case expression: string") - (lambda _ -> Sexp_symbol "invalid case expression: int") - (lambda _ -> Sexp_symbol "invalid case expression: float") - (lambda _ -> Sexp_symbol "invalid case expression: block") - | cons _ _ => Sexp_error + case args + | nil => Sexp_symbol "todo" + | cons head tail => + case tail + | nil => + Sexp_dispatch + head + expand-sexp-case + (lambda _ -> Sexp_symbol "invalid case expression: symbol") + (lambda _ -> Sexp_symbol "invalid case expression: string") + (lambda _ -> Sexp_symbol "invalid case expression: int") + (lambda _ -> Sexp_symbol "invalid case expression: float") + (lambda _ -> Sexp_symbol "invalid case expression: block") + | cons _ _ => Sexp_symbol "todo" ;

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