Merge pull request #125 from engboris/syntax-macros

Refactoring (use PPX) and separate files

Author: engboris

README.md

@@ -75,10 +75,12 @@ automaton accepting words ending with 00
   #(if read 1 on q0 then q0)
   #(if read 0 on q1 then q2)})
 
-<show kill exec { @#e #a1 }>
-<show kill exec { @#000 #a1 }>
-<show kill exec { @#010 #a1 }>
-<show kill exec { @#110 #a1 }>
+(:= kill (-a _ _))
+
+<show exec { @(exec { @#e #a1 }) #kill }>
+<show exec { @(exec { @#000 #a1 }) #kill }>
+<show exec { @(exec { @#010 #a1 }) #kill }>
+<show exec { @(exec { @#110 #a1 }) #kill }>
 ```
 
 More examples can be found in `examples/`.

dune-project

@@ -19,7 +19,7 @@
  (name stellogen)
  (synopsis "Stellogen is a minimalistic and logic-agnostic programming
 language based on term unification.")
- (depends base menhir (alcotest :with-test) sedlex)
+ (depends base menhir (alcotest :with-test) sedlex ppx_deriving)
  (tags
   ("transcendental syntax" "logic programming" "constraint programming" "resolution logic" "unification" "self-assembly")))
 

examples/automata.sg

@@ -22,13 +22,13 @@
 (:= 110 (+i [1 1 0]))
 (:: 110 binary)
 
-'''
-automaton accepting words ending with 00
-'''
 (:= (initial Q) [(-i W) (+a W Q)])
 (:= (accept Q) [(-a [] Q) accept])
 (:= (if read C1 on Q1 then Q2) [(-a [C1|W] Q1) (+a W Q2)])
 
+'''
+automaton accepting words ending with 00
+'''
 (:= a1 {
   #(initial q0)
   #(accept q2)
@@ -37,7 +37,9 @@ automaton accepting words ending with 00
   #(if read 1 on q0 then q0)
   #(if read 0 on q1 then q2)})
 
-<show kill exec { @#e #a1 }>
-<show kill exec { @#000 #a1 }>
-<show kill exec { @#010 #a1 }>
-<show kill exec { @#110 #a1 }>
+(:= kill (-a _ _))
+
+<show exec { @(exec { @#e #a1 }) #kill }>
+<show exec { @(exec { @#000 #a1 }) #kill }>
+<show exec { @(exec { @#010 #a1 }) #kill }>
+<show exec { @(exec { @#110 #a1 }) #kill }>

examples/binary4.sg

@@ -1,48 +1,38 @@
-'''
-(spec u4 [(-b 1 _) (-b 2 _) (-b 3 _) (-b 4 _) ok])
+(spec u4 [(-b _ 1 _) (-b _ 2 _) (-b _ 3 _) (-b _ 4 _) ok])
 
-(new-declaration (:: tested test)
-  (:= test @(exec (process #test #test{b=>+b})))
-  (== test ok))
+(new-declaration (:: Tested Test)
+  (== @(exec (process #Test #Tested)) ok))
 
-(:= b1 [ [(b 1 1)] [(b 2 0)] [(b 3 0)] [(b 4 1)]])
-(:: b1 u4)
+(:= (make_bin Name X1 X2 X3 X4)
+  { [(+b Name 1 X1)] [(+b Name 2 X2)] [(+b Name 3 X3)] [(+b Name 4 X4)] })
 
-(:= b2 [ [(b 1 0)] [(b 2 0)] [(b 3 1)] [(b 4 1)]])
+(:= b1 #(make_bin b1 0 0 0 1))
 (:: b1 u4)
 
-(:= and [
-  [(-b1 arg 0) (-b2 arg X) (b arg 0)]
-  [(-b1 arg 1) (-b2 arg X) (b arg X)]])
-
-(:= or [
-  [(-b1 arg 0) (-b2 arg X) (b arg X)]
-  [(-b1 arg 1) (-b2 arg X) (b arg 1)]])
-
-(:= xor [
-  [(-b1 arg 1) (-b2 arg 0) (b arg 1)]
-  [(-b1 arg 0) (-b2 arg 1) (b arg 1)]
-  [(-b1 arg 0) (-b2 arg 0) (b arg 0)]
-  [(-b1 arg 1) (-b2 arg 1) (b arg 0)]])
-
-'logical AND
-<show exec (process
-  #b1{b=>+b1}
-  #and{arg=>1} #and{arg=>2} #and{arg=>3} #and{arg=>4}
-  #b2{b=>+b2}
-  kill)>
-
-'logical OR
-<show exec (process
-  #b1{b=>+b1}
-  #or{arg=>1} #or{arg=>2} #or{arg=>3} #or{arg=>4}
-  #b2{b=>+b2}
-  kill)>
-
-'logical XOR
-<show exec (process
-  #b1{b=>+b1}
-  #xor{arg=>1} #xor{arg=>2} #xor{arg=>3} #xor{arg=>4}
-  #b2{b=>+b2}
-  kill)>
-  '''
+(:= b2 #(make_bin b2 0 0 1 1))
+(:: b2 u4)
+
+(show #b1)
+(show #b2)
+
+(:= (if A = X and B = Y then R = Z) [(-b A I X) (-b B I Y) (+b R I Z)])
+
+'''
+'FIXME
+
+(:= (and AA BB RR) {
+  #(if AA = 0 and BB = XX then RR = 0)
+  #(if AA = 1 and BB = XX then RR = XX) })
+(show #(and b1 b2 r1))
+(show (process #b1 #(and b1 b2 r1) #b2))
+
+(:= (or A B R) {
+  [(-b A I 0) (-b B I X) (+b R I X)]
+  [(-b A I 1) (-b B I X) (+b R I 1)]})
+
+(:= (xor A B R) {
+  [(-b A I 1) (-b B I 0) (+b R I 1)]
+  [(-b A I 0) (-b B I 1) (+b R I 1)]
+  [(-b A I 0) (-b B I 0) (+b R I 0)]
+  [(-b A I 1) (-b B I 1) (+b R I 0)]})
+'''

examples/circuits.sg

@@ -36,4 +36,3 @@ FIXME
   [(-c4 R) R]
   'apply semantics
     #semantics)>
-  '&kill

examples/npda.sg

@@ -35,7 +35,9 @@
   #(if read 0 with 0 on q1 then q1)
   #(if read 1 with 1 on q1 then q1)})
 
-<show kill exec { @#e #a1 }>
-<show kill exec { @#0000 #a1 }>
-<show kill exec { @#0110 #a1 }>
-<show kill exec { @#1110 #a1 }>
+(:= kill (-a _ _ _))
+
+<show exec { @(exec { @#e #a1 }) #kill }>
+<show exec { @(exec { @#0000 #a1 }) #kill }>
+<show exec { @(exec { @#0110 #a1 }) #kill }>
+<show exec { @(exec { @#1110 #a1 }) #kill }>

examples/turing.sg

@@ -29,12 +29,12 @@
   [(-m q3 L e R) (+m qr L e R)]
   [(-m qr L C R) reject]})
 
-<show kill exec { @(+i [a e e]) #mt}>
-<show kill exec { @(+i [b e e]) #mt}>
-<show kill exec { @(+i [a b b e e]) #mt}>
+<show exec { @(+i [a e]) #mt}>
+<show exec { @(+i [b e]) #mt}>
+<show exec { @(+i [a b b e]) #mt}>
 
-<show kill exec { @(+i [e e]) #mt}>
-<show kill exec { @(+i [a b e e]) #mt}>
-<show kill exec { @(+i [a a b b e e]) #mt}>
-<show kill exec { @(+i [a b b a e e]) #mt}>
-<show kill exec { @(+i [a b a b e e]) #mt}>
+<show exec { @(+i [e]) #mt}>
+<show exec { @(+i [a b e]) #mt}>
+<show exec { @(+i [a a b b e]) #mt}>
+<show exec { @(+i [a b b a e]) #mt}>
+<show exec { @(+i [a b a b e]) #mt}>

nvim/syntax/stellogen.vim

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

src/dune

@@ -2,7 +2,7 @@
  (name stellogen)
  (libraries base menhirLib)
  (preprocess
-  (pps sedlex.ppx)))
+  (pps sedlex.ppx ppx_deriving.show ppx_deriving.ord ppx_deriving.eq)))
 
 (env
  (dev

src/expr.ml

@@ -23,6 +23,7 @@ type expr =
   | Symbol of string
   | Var of ident
   | List of expr list
+[@@derive eq]
 
 let primitive = String.append "%"
 
@@ -73,14 +74,6 @@ 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
-  | List es1, List es2 -> begin
-    try List.for_all2_exn es1 es2 ~f:equal_expr with _ -> false
-  end
-  | _ -> false
-
 let rec replace_id (xfrom : ident) xto e =
   match e with
   | Var x when equal_string x xfrom -> xto
@@ -151,30 +144,31 @@ let rec raylist_of_expr (e : expr) : ray list =
     ray_of_expr h :: raylist_of_expr t
   | e -> failwith ("error: unhandled star " ^ to_string e)
 
-let rec star_of_expr : expr -> marked_star = function
+let rec star_of_expr : expr -> Marked.star = function
   | List [ Symbol k; s ] when equal_string k focus_op ->
-    star_of_expr s |> Lsc_ast.remove_mark |> Lsc_ast.mark
+    star_of_expr s |> Marked.remove |> Marked.make_state
   | List [ Symbol k; s; List ps ] when equal_string k params_op ->
-    Unmarked { content = raylist_of_expr s; bans = bans_of_expr ps }
-  | e -> Unmarked { content = raylist_of_expr e; bans = [] }
+    Action { content = raylist_of_expr s; bans = bans_of_expr ps }
+  | e -> Action { content = raylist_of_expr e; bans = [] }
 
-let rec constellation_of_expr : expr -> marked_constellation = function
-  | Symbol k when equal_string k nil_op -> []
-  | Symbol s -> [ Unmarked { content = [ var (s, None) ]; bans = [] } ]
-  | Var x -> [ Unmarked { content = [ var (x, None) ]; bans = [] } ]
+let rec constellation_of_expr : expr -> Marked.constellation = function
+  | Symbol s -> [ Action { content = [ var (s, None) ]; bans = [] } ]
+  | Var x -> [ Action { content = [ var (x, None) ]; bans = [] } ]
   | List [ Symbol s; h; t ] when equal_string s cons_op ->
     star_of_expr h :: constellation_of_expr t
-  | List g -> [ Unmarked { content = [ ray_of_expr (List g) ]; bans = [] } ]
+  | List g -> [ Action { content = [ ray_of_expr (List g) ]; bans = [] } ]
 
 (* ---------------------------------------
    Stellogen expr of Expr
    --------------------------------------- *)
 
 let rec sgen_expr_of_expr (e : expr) : sgen_expr =
   match e with
+  | Symbol k when equal_string k nil_op ->
+    Raw [ Action { content = []; bans = [] } ]
   (* ray *)
   | Var _ | Symbol _ ->
-    Raw [ Unmarked { content = [ ray_of_expr e ]; bans = [] } ]
+    Raw [ Action { content = [ ray_of_expr e ]; bans = [] } ]
   (* star *)
   | List (Symbol s :: _) when equal_string s params_op -> Raw [ star_of_expr e ]
   | List (Symbol s :: _) when equal_string s cons_op -> Raw [ star_of_expr e ]
@@ -188,10 +182,6 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr =
     Group (List.map ~f:sgen_expr_of_expr gs)
   (* process *)
   | List (Symbol "process" :: gs) -> Process (List.map ~f:sgen_expr_of_expr gs)
-  (* kill *)
-  | List [ Symbol "kill"; g ] -> Kill (sgen_expr_of_expr g)
-  (* clean *)
-  | List [ Symbol "clean"; g ] -> Clean (sgen_expr_of_expr g)
   (* exec *)
   | List [ Symbol "exec"; g ] -> Exec (false, sgen_expr_of_expr g)
   (* linear exec *)