Add declaration definition (macro)

Author: engboris

bin/sgen.ml

@@ -9,13 +9,13 @@ let parse_and_eval input_file =
   in
   Sedlexing.set_position lexbuf (start_pos input_file);
   let expr = Sgen_parsing.parse_with_error lexbuf in
-  let expanded = List.map ~f:Expr.expand_macro expr in
+  let preprocessed = Expr.preprocess expr in
   Stdlib.print_string
-    (List.map ~f:Expr.to_string expanded |> String.concat ~sep:"\n");
+    (List.map ~f:Expr.to_string preprocessed |> String.concat ~sep:"\n");
   Stdlib.print_newline ();
   Stdlib.print_string "----------------";
   Stdlib.flush Stdlib.stdout;
-  let p = Expr.program_of_expr expanded in
+  let p = Expr.program_of_expr preprocessed in
   Stdlib.print_string "\n";
   let _ = Stellogen.Sgen_eval.eval_program p in
   ()

examples/syntax.sg

@@ -10,7 +10,7 @@
   [-a b]])
 
 'full focus
-(show @[ [a] [b] [c] ])
+(:= f @[ [a] [b] [c] ])
 
 'identifier
 (:= x #a)
@@ -19,7 +19,7 @@
 (:= x (union #a #b))
 
 'string literals
-(:= s ["hello world"])
+(:= s "hello world")
 
 'cons
 ' [0 1 e] == %cons(0 (%cons 1 %nil))
@@ -32,11 +32,11 @@
 'execution
 (:= x [(+f X) X])
 (:= y (-f a))
-(:= ex (exec (union #x #y)))    'non-linear
-(:= ex (linexec (union #x #y))) 'linear
+(:= ex (linexec (union @#x #y))) 'linear
+(:= ex (exec (union @#x #y)))    'non-linear
 
 'show constellation
-<show exec (union @#x #y)>
+(show #ex)
 (show [ [a] [b] [c] ])
 (show #s)
 
@@ -103,14 +103,16 @@
 (== x 0)
 '(== x 1)
 
-'manual type checking
-(:= 0 (+nat 0))
-(:= test @(exec (union @#0 #nat)))
-(== test ok)
-
+'type checking
 (:= 2 <+nat s s 0>)
-(:= test @(exec (union @#0 #nat)))
+(:= test @(exec (union @#2 #nat)))
 (== test ok)
 
 'import file
 '(use "examples/automata.sg")
+
+'declaration definition
+(new-declaration (:: tested test)
+  (:= test @(exec (union @#tested #test)))
+  (== test ok))
+(:: 2 nat)

nvim/syntax/stellogen.vim

@@ -1,6 +1,6 @@
 syn clear
 
-syn keyword sgKeyword kill clean eval show use exec spec linexec trace process run union
+syn keyword sgKeyword define syntax kill clean eval show use exec spec linexec trace process run union
 syn match sgComment "\s*'[^'].*$"
 syn match sgId "#\%(\l\|\d\)\w*"
 syn region sgComment start="'''" end="'''" contains=NONE

src/expr.ml

@@ -72,6 +72,43 @@ let rec expand_macro : Raw.t -> expr = function
     List.fold_left t ~init:(expand_macro h) ~f:(fun acc e ->
       List [ expand_macro e; acc ] )
 
+let rec equal_expr x y =
+  match (x, y) with
+  | Var x1, Var x2 | Symbol x1, Symbol x2 -> equal_string x1 x2
+  | Unquote e1, Unquote e2 -> equal_expr e1 e2
+  | List es1, List es2 -> begin
+    try List.for_all2_exn es1 es2 ~f:equal_expr with _ -> false
+  end
+  | _ -> false
+
+let rec replace_id xfrom xto = function
+  | Symbol s -> Symbol s
+  | Var x -> Var x
+  | Unquote e when equal_expr e xfrom -> xto
+  | Unquote e -> Unquote e
+  | List es -> List (List.map ~f:(replace_id xfrom xto) es)
+
+let unfold_decl_def (env : (string * (expr list * expr list)) list) es :
+  expr list =
+  List.fold_left es ~init:(env, []) ~f:(fun (env, acc) -> function
+    | List (Symbol "new-declaration" :: List (Symbol k :: args) :: content) ->
+      ((k, (args, content)) :: env, acc)
+    | List (Symbol k :: args)
+      when List.Assoc.find ~equal:equal_string env k |> Option.is_some ->
+      let syntax_args, content =
+        List.Assoc.find_exn ~equal:equal_string env k
+      in
+      if List.length syntax_args <> List.length args then
+        failwith ("Error: not enough args given in macro call " ^ k)
+      else
+        let replace_ids e =
+          List.fold_left (List.zip_exn syntax_args args) ~init:e
+            ~f:(fun acc (xfrom, xto) -> replace_id xfrom (Unquote xto) acc )
+        in
+        (env, (List.map ~f:replace_ids content |> List.rev) @ acc)
+    | e -> (env, e :: acc) )
+  |> snd |> List.rev
+
 (* ---------------------------------------
    Constellation of Expr
    --------------------------------------- *)
@@ -155,57 +192,45 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr =
   | List [ Symbol k; g ] when equal_string k focus_op ->
     Focus (sgen_expr_of_expr g)
   (* union *)
-  | List (Symbol k :: gs) when equal_string k "union" ->
-    Union (List.map ~f:sgen_expr_of_expr gs)
+  | List (Symbol "union" :: gs) -> Union (List.map ~f:sgen_expr_of_expr gs)
   (* process *)
-  | List (Symbol k :: gs) when equal_string k "process" ->
-    Process (List.map ~f:sgen_expr_of_expr gs)
+  | List (Symbol "process" :: gs) -> Process (List.map ~f:sgen_expr_of_expr gs)
   (* kill *)
-  | List [ Symbol k; g ] when equal_string k "kill" ->
-    Kill (sgen_expr_of_expr g)
+  | List [ Symbol "kill"; g ] -> Kill (sgen_expr_of_expr g)
   (* clean *)
-  | List [ Symbol k; g ] when equal_string k "clean" ->
-    Clean (sgen_expr_of_expr g)
+  | List [ Symbol "clean"; g ] -> Clean (sgen_expr_of_expr g)
   (* exec *)
-  | List [ Symbol k; g ] when equal_string k "exec" ->
-    Exec (false, sgen_expr_of_expr g)
+  | List [ Symbol "exec"; g ] -> Exec (false, sgen_expr_of_expr g)
   (* linear exec *)
-  | List [ Symbol k; g ] when equal_string k "linexec" ->
-    Exec (true, sgen_expr_of_expr g)
+  | List [ Symbol "linexec"; g ] -> Exec (true, sgen_expr_of_expr g)
   (* eval *)
-  | List [ Symbol k; g ] when equal_string k "eval" ->
-    Eval (sgen_expr_of_expr g)
+  | List [ Symbol "eval"; g ] -> Eval (sgen_expr_of_expr g)
   (* KEEP LAST -- raw constellation *)
   | List g -> Raw (constellation_of_expr (List g))
 
 (* ---------------------------------------
    Stellogen program of Expr
    --------------------------------------- *)
 
-(* let typedecl_of_expr : expr -> type_declaration = function
-  | Symbol k when equal_string k nil_op -> []
-  | List [ Symbol k; h; t ] when equal_string k cons_op ->
-*)
-
 let decl_of_expr : expr -> declaration = function
   (* definition := *)
   | List [ Symbol k; x; g ] when equal_string k def_op ->
     Def (ray_of_expr x, sgen_expr_of_expr g)
-  | List [ Symbol k; x; g ] when equal_string k "spec" ->
-    Def (ray_of_expr x, sgen_expr_of_expr g)
+  | List [ Symbol "spec"; x; g ] -> Def (ray_of_expr x, sgen_expr_of_expr g)
+  | List [ Symbol "exec"; x; g ] -> Def (ray_of_expr x, sgen_expr_of_expr g)
   (* show *)
-  | List [ Symbol k; g ] when equal_string k "show" ->
-    Show (sgen_expr_of_expr g)
+  | List [ Symbol "show"; g ] -> Show (sgen_expr_of_expr g)
   (* trace *)
-  | List [ Symbol k; g ] when equal_string k "trace" ->
-    Trace (sgen_expr_of_expr g)
+  | List [ Symbol "trace"; g ] -> Trace (sgen_expr_of_expr g)
   (* expect *)
   | List [ Symbol k; x; g ] when equal_string k expect_op ->
     Expect (ray_of_expr x, sgen_expr_of_expr g, const "default")
   | List [ Symbol k; x; g; m ] when equal_string k expect_op ->
     Expect (ray_of_expr x, sgen_expr_of_expr g, ray_of_expr m)
   (* use *)
   | List [ Symbol k; r ] when equal_string k "use" -> Use (ray_of_expr r)
-  | _ -> failwith "error: invalid declaration"
+  | e -> failwith ("error: invalid declaration ^ " ^ to_string e)
 
 let program_of_expr = List.map ~f:decl_of_expr
+
+let preprocess e = e |> List.map ~f:expand_macro |> unfold_decl_def []

src/sgen_eval.ml

@@ -9,6 +9,36 @@ let add_obj env x e = List.Assoc.add ~equal:equal_ray env.objs x e
 
 let get_obj env x = List.Assoc.find ~equal:equal_ray env.objs x
 
+let rec replace_id (xfrom : ident) (xto : sgen_expr) e :
+  (sgen_expr, err) Result.t =
+  match e with
+  | Id x when equal_ray x xfrom -> Ok xto
+  | Exec (b, e) ->
+    let* g = replace_id xfrom xto e in
+    Exec (b, g) |> Result.return
+  | Kill e ->
+    let* g = replace_id xfrom xto e in
+    Kill g |> Result.return
+  | Clean e ->
+    let* g = replace_id xfrom xto e in
+    Clean g |> Result.return
+  | Union es ->
+    let* gs = List.map ~f:(replace_id xfrom xto) es |> Result.all in
+    Union gs |> Result.return
+  | Focus e ->
+    let* g = replace_id xfrom xto e in
+    Focus g |> Result.return
+  | Subst (e, subst) ->
+    let* g = replace_id xfrom xto e in
+    Subst (g, subst) |> Result.return
+  | Process gs ->
+    let* procs = List.map ~f:(replace_id xfrom xto) gs |> Result.all in
+    Process procs |> Result.return
+  | Eval e ->
+    let* g = replace_id xfrom xto e in
+    Eval g |> Result.return
+  | Raw _ | Id _ -> e |> Result.return
+
 let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function
   | Raw g -> Raw (f g) |> Result.return
   | Id x -> begin
@@ -54,36 +84,6 @@ let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function
     let* map_e = map_sgen_expr env ~f e in
     Eval map_e |> Result.return
 
-let rec replace_id env (_from : ident) (_to : sgen_expr) e :
-  (sgen_expr, err) Result.t =
-  match e with
-  | Id x when equal_ray x _from -> Ok _to
-  | Exec (b, e) ->
-    let* g = replace_id env _from _to e in
-    Exec (b, g) |> Result.return
-  | Kill e ->
-    let* g = replace_id env _from _to e in
-    Kill g |> Result.return
-  | Clean e ->
-    let* g = replace_id env _from _to e in
-    Clean g |> Result.return
-  | Union es ->
-    let* gs = List.map ~f:(replace_id env _from _to) es |> Result.all in
-    Union gs |> Result.return
-  | Focus e ->
-    let* g = replace_id env _from _to e in
-    Focus g |> Result.return
-  | Subst (e, subst) ->
-    let* g = replace_id env _from _to e in
-    Subst (g, subst) |> Result.return
-  | Process gs ->
-    let* procs = List.map ~f:(replace_id env _from _to) gs |> Result.all in
-    Process procs |> Result.return
-  | Eval e ->
-    let* g = replace_id env _from _to e in
-    Eval g |> Result.return
-  | Raw _ | Id _ -> e |> Result.return
-
 let subst_vars env _from _to =
   map_sgen_expr env ~f:(subst_all_vars [ (_from, _to) ])
 
@@ -172,7 +172,7 @@ let rec eval_sgen_expr (env : env) :
     let* subst = subst_funcs env pf1 pf2 e in
     eval_sgen_expr env subst
   | Subst (e, SGal (x, _to)) ->
-    let* fill = replace_id env x _to e in
+    let* fill = replace_id x _to e in
     eval_sgen_expr env fill
   | Eval e -> (
     let* eval_e = eval_sgen_expr env e in
@@ -240,8 +240,8 @@ let rec eval_decl env : declaration -> (env, err) Result.t = function
     in
     Sedlexing.set_position lexbuf (start_pos formatted_filename);
     let expr = Sgen_parsing.parse_with_error lexbuf in
-    let expanded = List.map ~f:Expr.expand_macro expr in
-    let p = Expr.program_of_expr expanded in
+    let preprocessed = Expr.preprocess expr in
+    let p = Expr.program_of_expr preprocessed in
     let* env = eval_program p in
     Ok env