Jonathan Graveline pushed to branch graveline at Stefan / Typer

Commits: b46c9421 by Jonathan Graveline at 2018-06-13T19:55:28Z Upload case.typer - - - - -

1 changed file:

- + samples/case.typer

Changes:

===================================== samples/case.typer ===================================== --- /dev/null +++ b/samples/case.typer @@ -0,0 +1,375 @@ +%%% +%%% Macro : case ... | ... +%%% +%%% (pattern matching) +%%% + +%% +%% Match every variable in each pattern. +%% +%% var_test is (var_test ctor) +%% +%% Push current var n_times for sub test +%% push_var is (push_var n_times) +%% +%% sub_test introduce a variable for testing sub pattern +%% sub_test is (sub_test sup_var ctor) +%% + +type VarTest + | var_test Sexp + | push_var Int + | sub_test Sexp Sexp; + +type Pattern + | branch (List VarTest) Sexp + | dflt_branch Sexp; + +%% +%% Get matched variable (e.g. case (var1,var2,...) | ...) +%% + +get_vars : Sexp -> List Sexp; +get_vars sexp = let + + err = (lambda _ -> cons Sexp_error nil); + + get_vars_helper : List Sexp -> List Sexp; + get_vars_helper sexps = case sexps + | (cons s ss) => (case (Sexp_eq (Sexp_symbol "_,_") s) + | true => (ss) % tuple + % constructor or function called (only 1 pattern) + | false => (cons (Sexp_node s ss) nil)) + | nil => (cons (Sexp_symbol "_") nil); + +in Sexp_dispatch sexp + (lambda s ss -> (get_vars_helper (cons s ss))) + (lambda s -> (cons (Sexp_symbol s) nil)) + err err err + (lambda ss -> cons ss nil); % do nothing to Block + +mapi : (Sexp -> Int -> Sexp) -> Int -> List Sexp -> List Sexp; +mapi f i xs = case xs + | nil => nil + | cons x xs => cons (f x i) (mapi f (i + 1) xs); + +get_num_vars : List Sexp -> String -> List Sexp; +get_num_vars vars s = mapi + (lambda _ i -> Sexp_symbol (String_concat s (Int->String i))) + 0 vars; + +%% +%% Get pattern to match +%% + +get_cases : List Sexp -> List Pattern; +get_cases sexps = let + + to_case : Sexp -> Pattern; + to_case sexp = Sexp_dispatch sexp + + (lambda s ss -> case (Sexp_eq (Sexp_symbol "_=>_") s) + % expecting a Sexp_node as second argument to _=>_ + | true => (branch + (List_map (lambda ctor -> var_test ctor) (get_vars (List_nth 0 ss Sexp_error))) + (List_nth 1 ss Sexp_error)) + | false => (dflt_branch (Sexp_node s ss))) + + (lambda s -> dflt_branch (Sexp_symbol s)) + (lambda s -> dflt_branch (Sexp_string s)) + (lambda i -> dflt_branch (Sexp_integer i)) + (lambda f -> dflt_branch (Sexp_float f)) + + (lambda ss -> dflt_branch ss); + + helper : List Sexp -> List Pattern; + helper sexps = List_map (lambda s -> (to_case s)) sexps; + +in helper sexps; + +%% +%% Rename nth constructor inside ctor to "s" +%% (I will need gensym here or from the calling function) +%% + +rename_nth : Int -> Sexp -> Sexp; +rename_nth n ctor = let + + mapiif : (Sexp -> Int -> Sexp) -> (Sexp -> Bool) -> Int -> List Sexp -> List Sexp; + mapiif f b i xs = case xs + | nil => nil + | cons x xs => if_then_else_ (b x) + (cons (f x i) (mapiif f b (i + 1) xs)) + (cons x (mapiif f b i xs)); + + % cons (f x i) (mapiif f b (if_then_else_ (b x) i (i + 1)) xs); + + err = (lambda _ -> Sexp_symbol "<not a ctor (0)>"); + + %% + %% Is argument a variable or a ctor + %% + + is_ctor : Sexp -> Bool; + is_ctor v = Sexp_dispatch v + (lambda _ _ -> true) (lambda _ -> false) + (lambda _ -> false) (lambda _ -> false) + (lambda _ -> false) (lambda _ -> false); + + %% + %% Check for ctor within englobing ctor and rename variable + %% + + sub_ctor : Sexp -> Int -> Sexp; + sub_ctor ctor i = Sexp_dispatch ctor + (lambda s ss -> if_then_else_ (Int_eq i n) + (Sexp_symbol "s") + (Sexp_symbol "_")) + (lambda s -> Sexp_symbol s) + err err err err ; + +in Sexp_dispatch ctor + (lambda s ss -> Sexp_node s + (mapiif sub_ctor is_ctor 0 ss)) + (lambda s -> Sexp_symbol s) + err err err err ; + +%% +%% Expand sub pattern into sub_test +%% + +expand_cases : List Pattern -> List Pattern; +expand_cases pats = let + + foldi : (Sexp -> Int -> List VarTest -> List VarTest) -> Int -> List VarTest -> List Sexp -> List VarTest; + foldi f i o xs = case xs + | nil => o + | cons x xs => foldi f (i + 1) (f x i o) xs; + + get_sub_pattern : Sexp -> List Sexp; + get_sub_pattern ctor = let + + err = (lambda _ -> Sexp_error); + + check_keyword : Sexp -> Sexp; + check_keyword ctor = Sexp_dispatch ctor + (lambda s ss -> if_then_else_ (Sexp_eq s (Sexp_symbol "ctor")) + (Sexp_node (List_nth 0 ss Sexp_error) (List_tail ss)) + (Sexp_node s ss)) + (lambda s -> Sexp_symbol s) + err err err err; + + no_pattern : List Sexp -> ? -> List Sexp; + no_pattern pats = (lambda _ -> pats); + + helper : List Sexp -> List Sexp; + helper vars = List_foldl (lambda pats var -> + Sexp_dispatch var + (lambda s ss -> cons (check_keyword (Sexp_node s ss)) pats) + (no_pattern pats) (no_pattern pats) (no_pattern pats) (no_pattern pats) (no_pattern pats) + ) nil vars; + + in Sexp_dispatch ctor + (lambda s ss -> helper ss) + (no_pattern nil) (no_pattern nil) (no_pattern nil) (no_pattern nil) (no_pattern nil); + + expand_one : List VarTest -> VarTest -> List VarTest; + expand_one all test = case test + | push_var n => (List_concat all (cons (push_var n) nil)) + | _ => (let + + expand : VarTest -> List VarTest; + expand test = let + + t : Sexp; + t = case test + | (var_test t) => t + | (sub_test _ t) => t + | _ => Sexp_error; + + renamed : Int -> VarTest; + renamed i = case test + | (var_test t) => (var_test (rename_nth i t)) + | (sub_test v t) => (sub_test v (rename_nth i t)) + | _ => (var_test Sexp_error); + + sub_pattern : List Sexp; + sub_pattern = List_reverse (get_sub_pattern t) nil; + + nb_pattern : Int; + nb_pattern = List_length sub_pattern; + + sub_case : List VarTest; + sub_case = (cons (push_var nb_pattern) + (foldi + (lambda c i o -> + (List_concat o + (cons (renamed i) (cons (sub_test (Sexp_symbol "s") c) nil)))) + 0 nil sub_pattern)); + + in if_then_else_ (Int_eq nb_pattern 0) + (List_concat all (cons test nil)) + (List_concat all sub_case) + + in expand test); % (List_concat all (cons test nil)); + + expand_all : Pattern -> Pattern; + expand_all p = case p + | (dflt_branch _) => p + | (branch cs f) => (let + + ctors : List VarTest; + ctors = (List_foldl expand_one nil cs); + + in if_then_else_ (Int_eq (List_length cs) (List_length ctors)) + (branch ctors f) + (expand_all (branch ctors f))); + +in List_map expand_all pats; + +pattern_to_sexp : List Sexp -> List Pattern -> Sexp; +pattern_to_sexp vars pats = let + + vars_wrap : List Sexp -> Sexp -> List Sexp -> Sexp; + vars_wrap numvs succ vs = Sexp_node (List_foldl + (lambda o v -> (quote (lambda_->_ (uquote v) (uquote o)))) + succ vs) ( numvs ); + + to_case : Sexp -> Sexp -> Sexp -> Option Sexp -> Sexp; + to_case var ctor succ fail = case fail + | some fail => (quote (##case_ (_|_ (uquote var) + (_=>_ (uquote ctor) (uquote succ)) + (_=>_ _ (uquote fail))))) + | none => (quote (##case_ (_|_ (uquote var) + (_=>_ (uquote ctor) (uquote succ))))); + + push : Int -> List Sexp -> List Sexp; + push n vars = if_then_else_ (Int_<= n 1) + (vars) + (case vars + | (cons v _) => push (n - 1) (cons v vars) + | nil => nil); + + chain_ctors_fail : List Sexp -> List VarTest -> Sexp -> Sexp -> Sexp; + chain_ctors_fail vars tests succ fail = case vars + | (cons v vv) => (case tests + | (cons t tt) => (case t + | (var_test t) => if_then_else_ (Sexp_eq t (Sexp_symbol "_")) + (to_case v t (chain_ctors_fail vv tt succ fail) none) + (to_case v t (chain_ctors_fail vv tt succ fail) (some fail)) + | (sub_test v t) => if_then_else_ (Sexp_eq t (Sexp_symbol "_")) + (to_case v t (chain_ctors_fail vars tt succ fail) none) + (to_case v t (chain_ctors_fail vars tt succ fail) (some fail)) + | (push_var n) => (chain_ctors_fail (push n vars) tt succ fail)) + | nil => Sexp_error) + | nil => (case tests + | (cons t tt) => (case t + | (var_test _) => Sexp_error + | (sub_test v t) => if_then_else_ (Sexp_eq t (Sexp_symbol "_")) + (to_case v t (chain_ctors_fail vars tt succ fail) none) + (to_case v t (chain_ctors_fail vars tt succ fail) (some fail)) + | (push_var n) => (chain_ctors_fail (push n vars) tt succ fail)) + | nil => succ); + + chain_ctors_nofail : List Sexp -> List VarTest -> Sexp -> Sexp; + chain_ctors_nofail vars tests succ = case vars + | (cons v vv) => (case tests + | (cons t tt) => (case t + | (var_test t) => + (to_case v t (chain_ctors_nofail vv tt succ) none) + | (sub_test v t) => + (to_case v t (chain_ctors_nofail vars tt succ) none) + | (push_var n) => (chain_ctors_nofail (push n vars) tt succ)) + | nil => Sexp_error) + | nil => (case tests + | (cons t tt) => (case t + | (var_test _) => Sexp_error + | (sub_test v t) => + (to_case v t (chain_ctors_nofail vars tt succ) none) + | (push_var n) => (chain_ctors_nofail (push n vars) tt succ)) + | nil => succ); + + one_to_sexp : List Sexp -> Pattern -> Sexp -> Sexp; + one_to_sexp vars pat fail = case pat + | (dflt_branch f) => f + | (branch tests f) => (chain_ctors_fail vars tests f fail); + + last_to_sexp : List Sexp -> Pattern -> Sexp; + last_to_sexp vars pat = case pat + | (dflt_branch f) => f + | (branch tests f) => (chain_ctors_nofail vars tests f); + + test_fun : List Sexp -> Pattern -> Sexp -> Sexp; + test_fun vars pat fail = (quote (lambda (_ : Unit) -> + (uquote (one_to_sexp vars pat (quote ((uquote fail) ())))))); + + last_test_fun : List Sexp -> Pattern -> Sexp; + last_test_fun vars pat = (quote (lambda (_ : Unit) -> + (uquote (last_to_sexp vars pat)))); + + helper : List Sexp -> List Pattern -> Sexp; + helper vars pats = case pats + | (cons p pats) => (case pats + | (cons _ _) => (quote (let + (uquote (Sexp_symbol " fail sym ")) + = (uquote (helper vars pats)); + in (uquote (test_fun vars p (Sexp_symbol " fail sym "))))) + | nil => (last_test_fun vars p)) + | nil => Sexp_error; + +in (quote ((uquote (helper vars pats)) ())); + +%% +%% The macro we want. +%% + +case_ = macro (lambda args -> let + + foldi : (Sexp -> Int -> Sexp -> Sexp) -> Int -> Sexp -> List Sexp -> Sexp; + foldi f i o xs = case xs + | nil => o + | cons x xs => foldi f (i + 1) (f x i o) xs; + + case0_ : List Sexp -> Sexp; + case0_ args = let + + vars : List Sexp; + vars = case args + | (cons s ss) => get_vars s + | nil => nil; + + pats : List Pattern; + pats = case args + | (cons s ss) => get_cases ss + | nil => nil; + + num_vars : List Sexp; + num_vars = get_num_vars vars " sym no "; + + vars_wrap : Sexp -> Sexp; + vars_wrap fun = (Sexp_node (foldi + (lambda v i fun -> (quote (lambda_->_ + ((uquote (List_nth i num_vars Sexp_error)) : (decltype (uquote v))) + (uquote fun)))) + 0 fun ( vars ) + ) (List_reverse vars nil)); + + in vars_wrap (pattern_to_sexp num_vars (expand_cases pats)); + + % Only the Sexp after "_|_" are interesting + + case1_ : List Sexp -> Sexp; + case1_ args = case args + | (cons s ss) => if_then_else_ (Sexp_eq (Sexp_symbol "_|_") s) + (case0_ ss) + (Sexp_error) + | nil => Sexp_error; + + err = (lambda _ -> Sexp_error); + +% Expecting only one Sexp_node containing a case with arguments + +in (Sexp_dispatch (List_nth 0 args Sexp_error) + (lambda s ss -> (case1_ (cons s ss))) + err err err err err) +);

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