From e1910515facf70c75d9a790664f4a9abf4da248c Mon Sep 17 00:00:00 2001 From: engboris Date: Thu, 29 May 2025 01:03:02 +0200 Subject: [PATCH 01/45] Remove experimental parts of guide --- guide/en/src/automata/nfsa.md | 1 - guide/en/src/automata/pda.md | 1 - guide/en/src/automata/transducers.md | 1 - guide/en/src/automata/turing.md | 1 - guide/en/src/lambda/lintypes.md | 1 - guide/en/src/lambda/stlc.md | 1 - guide/en/src/lambda/untypedlin.md | 1 - guide/en/src/objects/interfaces.md | 17 ----------------- guide/en/src/stellogen/effects.md | 24 ------------------------ guide/fr/src/automata/nfsa.md | 1 - guide/fr/src/automata/pda.md | 1 - guide/fr/src/automata/transducers.md | 1 - guide/fr/src/automata/turing.md | 1 - guide/fr/src/lambda/lintypes.md | 1 - guide/fr/src/lambda/stlc.md | 1 - guide/fr/src/lambda/untypedlin.md | 1 - guide/fr/src/objects/interfaces.md | 17 ----------------- guide/fr/src/stellogen/effects.md | 24 ------------------------ 18 files changed, 96 deletions(-) delete mode 100644 guide/en/src/automata/nfsa.md delete mode 100644 guide/en/src/automata/pda.md delete mode 100644 guide/en/src/automata/transducers.md delete mode 100644 guide/en/src/automata/turing.md delete mode 100644 guide/en/src/lambda/lintypes.md delete mode 100644 guide/en/src/lambda/stlc.md delete mode 100644 guide/en/src/lambda/untypedlin.md delete mode 100644 guide/en/src/objects/interfaces.md delete mode 100644 guide/en/src/stellogen/effects.md delete mode 100644 guide/fr/src/automata/nfsa.md delete mode 100644 guide/fr/src/automata/pda.md delete mode 100644 guide/fr/src/automata/transducers.md delete mode 100644 guide/fr/src/automata/turing.md delete mode 100644 guide/fr/src/lambda/lintypes.md delete mode 100644 guide/fr/src/lambda/stlc.md delete mode 100644 guide/fr/src/lambda/untypedlin.md delete mode 100644 guide/fr/src/objects/interfaces.md delete mode 100644 guide/fr/src/stellogen/effects.md diff --git a/guide/en/src/automata/nfsa.md b/guide/en/src/automata/nfsa.md deleted file mode 100644 index 8fc4165..0000000 --- a/guide/en/src/automata/nfsa.md +++ /dev/null @@ -1 +0,0 @@ -# Automate finis diff --git a/guide/en/src/automata/pda.md b/guide/en/src/automata/pda.md deleted file mode 100644 index f6552fa..0000000 --- a/guide/en/src/automata/pda.md +++ /dev/null @@ -1 +0,0 @@ -# Automates à pile diff --git a/guide/en/src/automata/transducers.md b/guide/en/src/automata/transducers.md deleted file mode 100644 index 34f1efa..0000000 --- a/guide/en/src/automata/transducers.md +++ /dev/null @@ -1 +0,0 @@ -# Transducteurs diff --git a/guide/en/src/automata/turing.md b/guide/en/src/automata/turing.md deleted file mode 100644 index 8193e64..0000000 --- a/guide/en/src/automata/turing.md +++ /dev/null @@ -1 +0,0 @@ -# Machines de Turing (TODO) diff --git a/guide/en/src/lambda/lintypes.md b/guide/en/src/lambda/lintypes.md deleted file mode 100644 index 5ca230e..0000000 --- a/guide/en/src/lambda/lintypes.md +++ /dev/null @@ -1 +0,0 @@ -# Types linéaires (TODO) diff --git a/guide/en/src/lambda/stlc.md b/guide/en/src/lambda/stlc.md deleted file mode 100644 index cff6df6..0000000 --- a/guide/en/src/lambda/stlc.md +++ /dev/null @@ -1 +0,0 @@ -# Lambda-calcul simplement typé (TODO) diff --git a/guide/en/src/lambda/untypedlin.md b/guide/en/src/lambda/untypedlin.md deleted file mode 100644 index a16604a..0000000 --- a/guide/en/src/lambda/untypedlin.md +++ /dev/null @@ -1 +0,0 @@ -# Lambda-calcul linéaire non typé (TODO) diff --git a/guide/en/src/objects/interfaces.md b/guide/en/src/objects/interfaces.md deleted file mode 100644 index 2dc9a6d..0000000 --- a/guide/en/src/objects/interfaces.md +++ /dev/null @@ -1,17 +0,0 @@ -# Interfaces - -It is possible to check whether a galaxy is constructed in a certain way -with fields of some specific name and type: - -``` -interface nat_pair - n :: nat. - m :: nat. -end - -g_pair :: nat_pair. -g_pair = galaxy - n = +nat(0). - m = +nat(0). -end -``` diff --git a/guide/en/src/stellogen/effects.md b/guide/en/src/stellogen/effects.md deleted file mode 100644 index eb4cced..0000000 --- a/guide/en/src/stellogen/effects.md +++ /dev/null @@ -1,24 +0,0 @@ -# Reactive effects - -Stellogen uses "reactive effects" which are activated during the -interaction between two rays using special head symbols. - -## Print - -For printing, an interaction between two rays `%print` is needed. -The interaction generates a substitution defining the ray to be displayed: - -``` -+%print(X); -%print("hello world\n"). -``` - -This command displays `hello world` then an end of line symbol. - -## Running a constellation - -When constellations produce an effect, a `run` command is available -to execute them: - -``` -run +%print(X); -%print("hello world\n"). -``` diff --git a/guide/fr/src/automata/nfsa.md b/guide/fr/src/automata/nfsa.md deleted file mode 100644 index 8fc4165..0000000 --- a/guide/fr/src/automata/nfsa.md +++ /dev/null @@ -1 +0,0 @@ -# Automate finis diff --git a/guide/fr/src/automata/pda.md b/guide/fr/src/automata/pda.md deleted file mode 100644 index f6552fa..0000000 --- a/guide/fr/src/automata/pda.md +++ /dev/null @@ -1 +0,0 @@ -# Automates à pile diff --git a/guide/fr/src/automata/transducers.md b/guide/fr/src/automata/transducers.md deleted file mode 100644 index 34f1efa..0000000 --- a/guide/fr/src/automata/transducers.md +++ /dev/null @@ -1 +0,0 @@ -# Transducteurs diff --git a/guide/fr/src/automata/turing.md b/guide/fr/src/automata/turing.md deleted file mode 100644 index 8193e64..0000000 --- a/guide/fr/src/automata/turing.md +++ /dev/null @@ -1 +0,0 @@ -# Machines de Turing (TODO) diff --git a/guide/fr/src/lambda/lintypes.md b/guide/fr/src/lambda/lintypes.md deleted file mode 100644 index 5ca230e..0000000 --- a/guide/fr/src/lambda/lintypes.md +++ /dev/null @@ -1 +0,0 @@ -# Types linéaires (TODO) diff --git a/guide/fr/src/lambda/stlc.md b/guide/fr/src/lambda/stlc.md deleted file mode 100644 index cff6df6..0000000 --- a/guide/fr/src/lambda/stlc.md +++ /dev/null @@ -1 +0,0 @@ -# Lambda-calcul simplement typé (TODO) diff --git a/guide/fr/src/lambda/untypedlin.md b/guide/fr/src/lambda/untypedlin.md deleted file mode 100644 index a16604a..0000000 --- a/guide/fr/src/lambda/untypedlin.md +++ /dev/null @@ -1 +0,0 @@ -# Lambda-calcul linéaire non typé (TODO) diff --git a/guide/fr/src/objects/interfaces.md b/guide/fr/src/objects/interfaces.md deleted file mode 100644 index d19fe69..0000000 --- a/guide/fr/src/objects/interfaces.md +++ /dev/null @@ -1,17 +0,0 @@ -# Interfaces - -Il est possible de vérifier si une galaxie est formé d'une certaine -manière avec des champs possédant un certain nom et étant d'un certain type : - -``` -interface nat_pair - n :: nat. - m :: nat. -end - -g_pair :: nat_pair. -g_pair = galaxy - n = +nat(0). - m = +nat(0). -end -``` diff --git a/guide/fr/src/stellogen/effects.md b/guide/fr/src/stellogen/effects.md deleted file mode 100644 index b78678b..0000000 --- a/guide/fr/src/stellogen/effects.md +++ /dev/null @@ -1,24 +0,0 @@ -# Effets réactifs - -Stellogen utilise des "effets réactifs" qui sont déclenchés lors de -l'interaction entre des rayons utilisant des symboles de têtes spéciaux. - -## Print - -Pour l'affichage, il faut une interaction entre deux rayons `%print`. -L'interaction génère une substitution définissant le rayon à afficher : - -``` -+%print(X); -%print("hello world\n"). -``` - -La commande ci-dessus affiche `hello world` puis un saut à la ligne. - -## Lancement de constellation - -Lorsque les constellations produisent des effets, une commande `run` -est disponible pour les exécuter : - -``` -run +%print(X); -%print("hello world\n"). -``` From 63b9a65533d8523db157903a75403ba1a188f9ac Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 30 May 2025 19:33:26 +0200 Subject: [PATCH 02/45] Use S-expr for LSC --- src/common/common_parser.mly | 2 +- src/lsc/lsc_lexer.ml | 13 ++++--- src/lsc/lsc_parser.mly | 70 +++++++++++++++-------------------- src/stellogen/sgen_lexer.ml | 2 - src/stellogen/sgen_parser.mly | 3 ++ test/lsc/basic.stellar | 3 +- test/lsc/prolog.stellar | 6 +-- 7 files changed, 47 insertions(+), 52 deletions(-) diff --git a/src/common/common_parser.mly b/src/common/common_parser.mly index f717b5c..5e667ed 100644 --- a/src/common/common_parser.mly +++ b/src/common/common_parser.mly @@ -1,11 +1,11 @@ %token PRINT %token EOF %token AT -%token DOT %token EOL %token AMP %token LBRACK RBRACK %token LBRACE RBRACE +%token LANGLE RANGLE %token LPAR RPAR %% diff --git a/src/lsc/lsc_lexer.ml b/src/lsc/lsc_lexer.ml index f443bfc..b9dfc48 100644 --- a/src/lsc/lsc_lexer.ml +++ b/src/lsc/lsc_lexer.ml @@ -65,24 +65,27 @@ and comments lexbuf = and read lexbuf = match%sedlex lexbuf with + | "star" -> STAR + | "const" -> CONST + | "bans" -> BANS | is_var_start, Star is_var_rest -> VAR (Utf8.lexeme lexbuf) | is_func_start, Star is_func_rest -> SYM (Utf8.lexeme lexbuf) | '\'' -> comment lexbuf | "'''" -> comments lexbuf | '_' -> PLACEHOLDER - | '.' -> DOT - | '|' -> BAR | '[' -> LBRACK | ']' -> RBRACK | '(' -> LPAR | ')' -> RPAR - | ',' -> COMMA + | '<' -> LANGLE + | '>' -> RANGLE + | '/' -> SLASH + | "!=" -> NEQ + | "!@" -> INCOMP | '@' -> AT | '&' -> AMP | '+' -> PLUS | '-' -> MINUS - | ':' -> CONS - | ';' -> SEMICOLON | '"' -> read_string (Buffer.create 128) lexbuf | space | newline -> read lexbuf | eof -> EOF diff --git a/src/lsc/lsc_parser.mly b/src/lsc/lsc_parser.mly index e6b4e93..a5cdecf 100644 --- a/src/lsc/lsc_parser.mly +++ b/src/lsc/lsc_parser.mly @@ -4,72 +4,62 @@ open Lsc_ast %token VAR %token SYM -%token BAR -%token NEQ -%token COMMA +%token STAR CONST +%token BANS +%token SLASH +%token NEQ INCOMP %token PLUS MINUS -%token CONS -%token SEMICOLON %token PLACEHOLDER -%right CONS - %start constellation_file %start marked_constellation %% let constellation_file := - | DOT?; EOL*; EOF; { [] } - | ~=marked_constellation; EOL*; DOT?; EOL*; EOF; <> + | EOF; { [] } + | ~=marked_constellation; EOF; <> let marked_constellation := - | ~=separated_nonempty_list(pair(SEMICOLON, EOL*), star); - EOL*; SEMICOLON?; <> + | ~=star+; <> let star := - | ~=bracks_opt(star_content); - | ~=bracks_opt(AT; EOL*; star_content); + | ~=pars(STAR; star_content); + | ~=pars(AT; STAR; star_content); let star_content := - | LBRACK; EOL*; RBRACK; - { {content=[]; bans=[]} } - | l=separated_nonempty_list(pair(COMMA?, EOL*), ray); bs=bans?; - { {content=l; bans=Option.to_list bs |> List.concat } } + | l=ray*; bs=pars(bans)?; + { { content=l; bans=Option.to_list bs |> List.concat } } %public let bans := - | EOL*; BAR; EOL*; ~=separated_nonempty_list(COMMA?, ban); EOL*; <> + | BANS; ~=ban+; <> let ban := - | r1=ray; NEQ; r2=ray; EOL*; { Ineq (r1, r2) } - | r1=ray; CONS; r2=ray; { Incomp (r1, r2) } + | NEQ; r1=ray; r2=ray; { Ineq (r1, r2) } + | INCOMP; r1=ray; r2=ray; { Incomp (r1, r2) } %public let symbol := - | p=polarity; AMP; f = SYM; { noisy (p, f) } - | p=polarity; AMP; PRINT; { noisy (p, "print") } - | p=polarity; f = SYM; { muted (p, f) } - | f=SYM; { muted (Null, f) } + | p=polarity; AMP; f=SYM; { noisy (p, f) } + | p=polarity; AMP; PRINT; { noisy (p, "print") } + | p=polarity; f=SYM; { muted (p, f) } + | f=SYM; { muted (Null, f) } let polarity := | PLUS; { Pos } | MINUS; { Neg } %public let ray := - | PLACEHOLDER; { to_var ("_"^(fresh_placeholder ())) } - | ~=VAR; - | pf=symbol; ts=args?; { to_func (pf, Option.to_list ts |> List.concat) } + | PLACEHOLDER; { to_var ("_"^(fresh_placeholder ())) } + | ~=VAR; + | pf=symbol; { to_func (pf, []) } + | LPAR; pf=symbol; ts=ray_internal+; RPAR; { to_func (pf, ts) } let ray_internal := - | ~=ray; <> - | ~=cons_expr; <> - -let args := - | ~=pars(separated_nonempty_list(COMMA?, ray_internal)); <> - -let cons_expr := - | r1=ray_internal; CONS; r2=ray_internal; - { to_func (muted (Null, ":"), [r1; r2]) } - | LPAR; r1=ray_internal; CONS; r2=ray_internal; RPAR; - { to_func (muted (Null, ":"), [r1; r2]) } - | e=pars(cons_expr); CONS; r=ray_internal; - { to_func (muted (Null, ":"), [e; r]) } + | ~=ray; <> + | LBRACK; AMP; pf=symbol; rs=ray_internal+; RBRACK; + { Base.List.reduce_exn rs ~f:(fun r1 r2 -> to_func (pf, [r2; r1]) ) } + | LBRACK; rs=ray_internal+; RBRACK; + { Base.List.reduce_exn rs ~f:(fun r1 r2 -> + to_func (muted (Null, "cons"), [r2; r1]) ) } + | LANGLE; pfs=symbol+; SLASH; r=ray; RANGLE; + { Base.List.fold_left pfs ~init:r ~f:(fun acc pf -> to_func (pf, [acc]) ) } diff --git a/src/stellogen/sgen_lexer.ml b/src/stellogen/sgen_lexer.ml index cc5a794..43950e6 100644 --- a/src/stellogen/sgen_lexer.ml +++ b/src/stellogen/sgen_lexer.ml @@ -32,14 +32,12 @@ let rec read lexbuf = | "&" -> AMP | '"' -> read_string (Buffer.create 255) lexbuf (* Stellar resolution *) - | '|' -> BAR | "!=" -> NEQ | '_' -> PLACEHOLDER | '[' -> LBRACK | ']' -> RBRACK | '(' -> LPAR | ')' -> RPAR - | ',' -> COMMA | '@' -> AT | '+' -> PLUS | '-' -> MINUS diff --git a/src/stellogen/sgen_parser.mly b/src/stellogen/sgen_parser.mly index c3a1430..a580c56 100644 --- a/src/stellogen/sgen_parser.mly +++ b/src/stellogen/sgen_parser.mly @@ -8,6 +8,9 @@ open Sgen_ast %token RUN %token SPEC %token TRACE +%token CONS +%token SEMICOLON +%token DOT %token SHARP %token KILL CLEAN %token EXEC LINEXEC diff --git a/test/lsc/basic.stellar b/test/lsc/basic.stellar index 281fa6d..f843ff6 100644 --- a/test/lsc/basic.stellar +++ b/test/lsc/basic.stellar @@ -1 +1,2 @@ --f(a); @+f(X) X. +(star (-f a)) +(@star (+f X) X) diff --git a/test/lsc/prolog.stellar b/test/lsc/prolog.stellar index 64af300..50dd7c7 100644 --- a/test/lsc/prolog.stellar +++ b/test/lsc/prolog.stellar @@ -1,3 +1,3 @@ -[+add(0 Y Y)]; -[-add(X Y Z) +add(s(X) Y s(Z))]; -[@-add(s(s(0)) s(s(0)) R) R]. +(star (+add 0 Y Y)) +(star (-add X Y Z) (+add (s X) Y (s Z))) +(@star (-add R) R) From b6ecc9383bcce204e4c32d897a0d3bdcf59d223b Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 30 May 2025 23:35:27 +0200 Subject: [PATCH 03/45] Use S-expr in Stellogen --- examples/nat.sg | 77 +++++++++-------- src/common/common_parser.mly | 2 + src/lsc/lsc_lexer.ml | 1 - src/lsc/lsc_parser.mly | 19 ++--- src/stellogen/sgen_lexer.ml | 30 +++---- src/stellogen/sgen_parser.mly | 152 +++++++++++++++------------------- 6 files changed, 133 insertions(+), 148 deletions(-) diff --git a/examples/nat.sg b/examples/nat.sg index 470a0c5..d44ccf2 100644 --- a/examples/nat.sg +++ b/examples/nat.sg @@ -1,35 +1,42 @@ -spec nat = -nat(0) ok; -nat(s(N)) +nat(N). - -checker = galaxy - interaction = @#tested #test. - expect = ok. -end - -fchecker = galaxy - interaction = @#tested #test. - expect = arg out. -end - -spec "nat -> nat" = - +nat(X) arg; - -nat(X) out. - -0 :: nat [checker]. -0 = +nat(0). - -1 :: nat [checker]. -1 = +nat(s(0)). - -2 :: nat [checker]. -2 = +nat(s(s(0))). - -add1 :: "nat -> nat" [fchecker]. -add1 = -nat(X) +nat(s(X)). - -is_empty = - -nat(0) res(1); - -nat(s(_)) res(0). - -show-exec #add1 #2. -show-exec #is_empty @#0. -show-exec #is_empty @#1. +(spec nat + (const + (star (-nat 0) ok) + (star (-nat (s N)) (+nat N)))) + +(def fchecker + (galaxy + (interaction (union @#tested #test)) + (expect (const (star arg out))))) + +(spec (arrow nat nat) + (const + (star (+nat X) arg) + (star (-nat X) out))) + +(:: 0 nat) +(def 0 + (const (star (+nat 0)))) + +(:: 1 nat) +(def 1 + (const + (star <+nat s /0>))) + +(:: 2 nat) +(def 2 + (const + (star <+nat s s /0>))) + +(:: add1 ((arrow nat nat) fchecker)) +(def add1 + (const + (star (-nat X) <+nat s /X>))) + +(def is_empty + (const + (star <-nat /0> ) + (star <-nat s /_> ))) + +(show-exec (union #add1 #2)) +(show-exec (union #is_empty @#0)) +(show-exec (union #is_empty @#1)) diff --git a/src/common/common_parser.mly b/src/common/common_parser.mly index 5e667ed..ee1382b 100644 --- a/src/common/common_parser.mly +++ b/src/common/common_parser.mly @@ -3,6 +3,8 @@ %token AT %token EOL %token AMP +%token STAR +%token SLASH %token LBRACK RBRACK %token LBRACE RBRACE %token LANGLE RANGLE diff --git a/src/lsc/lsc_lexer.ml b/src/lsc/lsc_lexer.ml index b9dfc48..2afa421 100644 --- a/src/lsc/lsc_lexer.ml +++ b/src/lsc/lsc_lexer.ml @@ -66,7 +66,6 @@ and comments lexbuf = and read lexbuf = match%sedlex lexbuf with | "star" -> STAR - | "const" -> CONST | "bans" -> BANS | is_var_start, Star is_var_rest -> VAR (Utf8.lexeme lexbuf) | is_func_start, Star is_func_rest -> SYM (Utf8.lexeme lexbuf) diff --git a/src/lsc/lsc_parser.mly b/src/lsc/lsc_parser.mly index a5cdecf..471c541 100644 --- a/src/lsc/lsc_parser.mly +++ b/src/lsc/lsc_parser.mly @@ -4,9 +4,7 @@ open Lsc_ast %token VAR %token SYM -%token STAR CONST %token BANS -%token SLASH %token NEQ INCOMP %token PLUS MINUS %token PLACEHOLDER @@ -16,9 +14,7 @@ open Lsc_ast %% -let constellation_file := - | EOF; { [] } - | ~=marked_constellation; EOF; <> +let constellation_file := mcs=marked_constellation; EOF; { mcs } let marked_constellation := | ~=star+; <> @@ -52,14 +48,15 @@ let polarity := | PLACEHOLDER; { to_var ("_"^(fresh_placeholder ())) } | ~=VAR; | pf=symbol; { to_func (pf, []) } - | LPAR; pf=symbol; ts=ray_internal+; RPAR; { to_func (pf, ts) } + | LPAR; pf=symbol; ts=ray+; RPAR; { to_func (pf, ts) } + | ~=blocks; <> -let ray_internal := - | ~=ray; <> - | LBRACK; AMP; pf=symbol; rs=ray_internal+; RBRACK; +let blocks := + | LBRACK; AMP; pf=symbol; rs=ray+; RBRACK; { Base.List.reduce_exn rs ~f:(fun r1 r2 -> to_func (pf, [r2; r1]) ) } - | LBRACK; rs=ray_internal+; RBRACK; + | LBRACK; rs=ray+; RBRACK; { Base.List.reduce_exn rs ~f:(fun r1 r2 -> to_func (muted (Null, "cons"), [r2; r1]) ) } | LANGLE; pfs=symbol+; SLASH; r=ray; RANGLE; - { Base.List.fold_left pfs ~init:r ~f:(fun acc pf -> to_func (pf, [acc]) ) } + { Base.List.fold_right pfs ~init:r ~f:(fun pf base -> + to_func (pf, [base]) ) } diff --git a/src/stellogen/sgen_lexer.ml b/src/stellogen/sgen_lexer.ml index 43950e6..0847b93 100644 --- a/src/stellogen/sgen_lexer.ml +++ b/src/stellogen/sgen_lexer.ml @@ -2,21 +2,20 @@ open Sgen_parser exception SyntaxError of string -let update_pos_newline lexbuf = - Sedlexing.new_line lexbuf; - EOL +let update_pos_newline lexbuf = Sedlexing.new_line lexbuf let rec read lexbuf = match%sedlex lexbuf with (* Stellogen *) - | '{' -> LBRACE - | '}' -> RBRACE - | "end" -> END | "exec" -> EXEC | "run" -> RUN - | "interface" -> INTERFACE + | "const" -> CONST + | "union" -> UNION + | "get" -> GET + (* | "interface" -> INTERFACE *) | "show" -> SHOW | "spec" -> SPEC + | "def" -> DEF | "kill" -> KILL | "clean" -> CLEAN | "use" -> USE @@ -24,26 +23,26 @@ let rec read lexbuf = | "linear-exec" -> LINEXEC | "show-exec" -> SHOWEXEC | "galaxy" -> GALAXY - | "process" -> PROCESS - | "->" -> RARROW - | "=>" -> DRARROW - | "." -> DOT + (* | "process" -> PROCESS *) | "#" -> SHARP | "&" -> AMP + | ':' -> CONS | '"' -> read_string (Buffer.create 255) lexbuf (* Stellar resolution *) | "!=" -> NEQ + | "star" -> STAR | '_' -> PLACEHOLDER | '[' -> LBRACK | ']' -> RBRACK + | '<' -> LANGLE + | '>' -> RANGLE | '(' -> LPAR | ')' -> RPAR | '@' -> AT + | '/' -> SLASH | '+' -> PLUS | '-' -> MINUS | '=' -> EQ - | ':' -> CONS - | ';' -> SEMICOLON (* Identifiers *) | Plus 'A' .. 'Z', Star ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') -> VAR (Sedlexing.Utf8.lexeme lexbuf) @@ -52,7 +51,9 @@ let rec read lexbuf = SYM (Sedlexing.Utf8.lexeme lexbuf) (* Whitespace *) | Plus (' ' | '\t') -> read lexbuf - | '\r' | '\n' | "\r\n" -> update_pos_newline lexbuf + | '\r' | '\n' | "\r\n" -> + update_pos_newline lexbuf; + read lexbuf (* Comments *) | '\'' -> comment lexbuf | "'''" -> comments lexbuf @@ -94,7 +95,6 @@ and read_string buf lexbuf = and comment lexbuf = match%sedlex lexbuf with - | '\r' | '\n' | "\r\n" -> EOL | eof -> EOF | _ -> ignore (Sedlexing.next lexbuf); diff --git a/src/stellogen/sgen_parser.mly b/src/stellogen/sgen_parser.mly index a580c56..c9eb9f6 100644 --- a/src/stellogen/sgen_parser.mly +++ b/src/stellogen/sgen_parser.mly @@ -3,112 +3,94 @@ open Sgen_ast %} %token SHOW SHOWEXEC -%token INTERFACE +(* %token INTERFACE *) %token USE %token RUN +%token CONS %token SPEC +%token CONST +%token GET +%token DEF %token TRACE -%token CONS -%token SEMICOLON -%token DOT +%token UNION %token SHARP %token KILL CLEAN %token EXEC LINEXEC -%token PROCESS +(* %token PROCESS *) %token GALAXY -%token RARROW DRARROW %token EQ -%token END %start program %start declaration %% -let program := - | EOL*; EOF; { [] } - | EOL*; d=declaration; EOL+; p=program; { d::p } - | EOL*; d=declaration; EOF; { [d] } - +let program := ~=pars(declaration)*; EOF; <> let ident := ~=ray; <> let declaration := - | SPEC; ~=ident; EOL*; EQ; EOL*; ~=galaxy_expr; - | ~=ident; EOL*; EQ; EOL*; ~=galaxy_expr; - | SHOW; EOL*; ~=galaxy_expr; - | SHOWEXEC; EOL*; ~=galaxy_expr; - | TRACE; EOL*; ~=galaxy_expr; - | RUN; EOL*; ~=galaxy_expr; - | ~=type_declaration; - | USE; ~=separated_list(RARROW, ident); DOT; - | INTERFACE; EOL*; x=ident; EOL*; i=interface_item*; END; INTERFACE?; - { Def (x, Raw (Interface i)) } + | SPEC; ~=ident; ~=galaxy_expr; + | DEF; ~=ident; ~=galaxy_expr; + | SHOW; ~=galaxy_expr; + | SHOWEXEC; ~=galaxy_expr; + | TRACE; ~=galaxy_expr; + | RUN; ~=galaxy_expr; + | ~=type_declaration; + | USE; ~=ident+; + (* | INTERFACE; EOL*; x=ident; EOL*; i=interface_item*; END; INTERFACE?; + { Def (x, Raw (Interface i)) } *) let type_declaration := - | x=ident; CONS; CONS; ts=separated_list(SEMICOLON, type_expr); EOL*; DOT; - { TDef (x, ts) } - | x=ident; CONS; EQ; CONS; EOL*; g=galaxy_expr; - { TExp (x, g) } + | CONS; CONS; x=ident; ts=type_expr+; { TDef (x, ts) } + | EQ; EQ; x=ident; g=galaxy_expr; { TExp (x, g) } -let type_expr := ~=ident; ~=bracks(ident)?; EOL*; <> +let type_expr := + | t=ident; { (t, None) } + | LPAR; t=ident; ck=ident; RPAR; { (t, Some ck) } let galaxy_expr := - | ~=galaxy_content; EOL*; DOT; <> - | ~=process; <> - | ~=undelimited_raw_galaxy; - -let interface_item := ~=type_declaration; EOL*; <> + | ~=galaxy_content; <> + (*| ~=pars(process); <> *) -let undelimited_raw_galaxy := - | ~=marked_constellation; EOL*; DOT; - | GALAXY; EOL*; ~=galaxy_item*; EOL*; END; GALAXY?; +(* let interface_item := ~=pars(type_declaration); <> *) -let delimited_raw_galaxy := - | braces(EOL*); { Const [] } - | ~=pars(marked_constellation); - | ~=braces(marked_constellation); +let raw_galaxy := + | CONST; { Const [] } + | CONST; ~=marked_constellation; + | GALAXY; ~=pars(galaxy_item)*; let prefixed_id := SHARP; ~=ident; let galaxy_content := - | ~=pars(galaxy_content); <> - | ~=delimited_raw_galaxy; - | g=galaxy_content; h=galaxy_content; { Union (g, h) } - | ~=galaxy_access; <> - | AT; ~=focussed_galaxy_content; - | ~=galaxy_content; ~=bracks(substitution); - | ~=galaxy_block; <> - | ~=prefixed_id; <> - -let focussed_galaxy_content := - | ~=pars(galaxy_content); <> - | ~=galaxy_access; <> - | ~=delimited_raw_galaxy; - | ~=galaxy_block; <> - | ~=prefixed_id; <> + | ~=pars(raw_galaxy); + | ~=galaxy_access; <> + | AT; ~=focussed_galaxy_content; + (*| ~=galaxy_content; ~=bracks(substitution); *) + | ~=pars(galaxy_block); <> + | ~=prefixed_id; <> + | LPAR; UNION; g1=galaxy_content; g2=galaxy_content; RPAR; + { Union (g1, g2) } let galaxy_block := - | EXEC; EOL*; ~=galaxy_content; EOL*; END; EXEC?; - - | LINEXEC; EOL*; ~=galaxy_content; EOL*; END; LINEXEC?; - - | KILL; EOL*; ~=galaxy_content; EOL*; END; KILL?; - - | CLEAN; EOL*; ~=galaxy_content; EOL*; END; CLEAN?; - - | EXEC; EOL*; mcs=marked_constellation; EOL*; END; EXEC?; - { Exec (Raw (Const mcs)) } - | LINEXEC; EOL*; mcs=marked_constellation; EOL*; END; LINEXEC?; - { LinExec (Raw (Const mcs)) } - | KILL; EOL*; mcs=marked_constellation; EOL*; END; KILL?; - { Kill (Raw (Const mcs)) } - | CLEAN; EOL*; mcs=marked_constellation; EOL*; END; CLEAN?; - { Clean (Raw (Const mcs)) } + | EXEC; ~=galaxy_content; + | LINEXEC; ~=galaxy_content; + | KILL; ~=galaxy_content; + | CLEAN; ~=galaxy_content; + | EXEC; g=raw_galaxy; { Exec (Raw g) } + | LINEXEC; g=raw_galaxy; { LinExec (Raw g) } + | KILL; g=raw_galaxy; { Kill (Raw g) } + | CLEAN; g=raw_galaxy; { Clean (Raw g) } + +let focussed_galaxy_content := + | ~=galaxy_content; <> + | ~=pars(galaxy_access); <> + (* | ~=pars(galaxy_block); <> *) let galaxy_access := - | SHARP; x=ident; RARROW; y=ident; { Access (Id x, y) } - | ~=galaxy_access; RARROW; y=ident; + | GET; x=ident; y=ident; { Access (Id x, y) } + | GET; ~=galaxy_access; y=ident; +(* let substitution := | DRARROW; ~=symbol; | ~=symbol; DRARROW; @@ -117,23 +99,21 @@ let substitution := | SHARP; ~=ident; DRARROW; ~=galaxy_expr; | SHARP; x=ident; DRARROW; h=marked_constellation; { SGal (x, Raw (Const h)) } +*) let galaxy_item := - | ~=ident; EQ; EOL*; ~=galaxy_content; DOT; EOL*; - - | x=ident; EQ; EOL*; mcs=marked_constellation; EOL*; DOT; EOL*; - { GLabelDef (x, Raw (Const mcs)) } - | x=ident; EQ; EOL*; g=undelimited_raw_galaxy; EOL*; DOT; EOL*; - { GLabelDef (x, Raw g) } - | ~=ident; EQ; EOL*; ~=process; EOL*; - | ~=type_declaration; EOL*; + | ~=ident; ~=galaxy_content; + (*| ~=ident; ~=pars(process); *) + | ~=type_declaration; +(* let process := - | PROCESS; EOL*; END; PROCESS?; { Process [] } - | PROCESS; EOL*; ~=process_item+; END; PROCESS?; + | PROCESS; { Process [] } + | PROCESS; ~=process_item+; let process_item := - | ~=galaxy_content; DOT; EOL*; <> - | ~=undelimited_raw_galaxy; EOL*; - | AMP; KILL; DOT; EOL*; { Id (const "kill") } - | AMP; CLEAN; DOT; EOL*; { Id (const "clean") } + | ~=galaxy_content; <> + | ~=pars(raw_galaxy); + | pars(AMP; KILL); { Id (const "kill") } + | pars(AMP; CLEAN); { Id (const "clean") } +*) From d3d15b8ec30d34f68dc1333a8757ff57813381ee Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 30 May 2025 23:40:45 +0200 Subject: [PATCH 04/45] Fix examples/nat.sg --- examples/nat.sg | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/examples/nat.sg b/examples/nat.sg index d44ccf2..a22ebd4 100644 --- a/examples/nat.sg +++ b/examples/nat.sg @@ -20,7 +20,7 @@ (:: 1 nat) (def 1 (const - (star <+nat s /0>))) + (star (+nat (s 0))))) (:: 2 nat) (def 2 @@ -30,13 +30,13 @@ (:: add1 ((arrow nat nat) fchecker)) (def add1 (const - (star (-nat X) <+nat s /X>))) + (star (-nat X) (+nat (s X))))) (def is_empty (const - (star <-nat /0> ) - (star <-nat s /_> ))) + (star (-nat 0) (res 1)) + (star (-nat (s _)) (res 0)))) -(show-exec (union #add1 #2)) +(show-exec (union @#add1 #2)) (show-exec (union #is_empty @#0)) (show-exec (union #is_empty @#1)) From 4b22e83d6099b57dcf6e20d43704c8c8d696763f Mon Sep 17 00:00:00 2001 From: engboris Date: Sat, 31 May 2025 00:01:42 +0200 Subject: [PATCH 05/45] Update nvim configs --- nvim/ftdetect/stellogen.vim | 1 + nvim/syntax/stellogen.vim | 15 +++++---------- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/nvim/ftdetect/stellogen.vim b/nvim/ftdetect/stellogen.vim index 91ef933..89fa3f5 100644 --- a/nvim/ftdetect/stellogen.vim +++ b/nvim/ftdetect/stellogen.vim @@ -1 +1,2 @@ autocmd BufNewFile,BufRead *.sg setfiletype stellogen +autocmd FileType stellogen setlocal shiftwidth=2 softtabstop=2 expandtab diff --git a/nvim/syntax/stellogen.vim b/nvim/syntax/stellogen.vim index 8f7c99f..9184566 100644 --- a/nvim/syntax/stellogen.vim +++ b/nvim/syntax/stellogen.vim @@ -1,24 +1,19 @@ syn clear -syn keyword sgKeyword show use exec spec linear trace process end galaxy run interface +syn keyword sgKeyword def const star show use exec spec linear trace process end galaxy run interface union syn match sgComment "\s*'[^'].*$" syn match sgId "#\%(\l\|\d\)\w*" -syn match sgIdDef "\zs\%(\l\|\d\)\w*\ze\s*=" -syn match sgIdType "\zs\%(\l\|\d\)\w*\ze\s*::" -syn match sgType "^\w*\s*::\s*\zs\%(\l\|\d\)\w*\ze" syn region sgComment start="'''" end="'''" contains=NONE syn region sgString start=/\v"/ skip=/\v\\./ end=/\v"/ -syn match sgSeparator "[;\.\{\}\:\[\]|]" -syn match sgOperator "[=@]" -syn match sgOperator "=>" +syn match sgSeparator "[\<\>\{\}\[\]|]" +syn match sgOperator "@" +syn match sgOperator "::" +syn match sgOperator "==" syn match sgOperator "!=" hi link sgKeyword Keyword hi link sgId Identifier -hi link sgIdDef Identifier -hi link sgIdType Identifier hi link sgComment Comment hi link sgOperator Operator hi link sgSeparator Special hi link sgString String -hi link sgType Type From 4ff4fac16003114f54589fbda4fd12718ae2fa09 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 1 Jun 2025 17:52:37 +0200 Subject: [PATCH 06/45] Update all example files to use s-expr --- examples/automata.sg | 66 ++++++----- examples/binary4.sg | 95 +++++++++------- examples/circuits.sg | 54 ++++----- examples/lambda.sg | 58 +++++++--- examples/linear_lambda.sg | 88 +++++++++------ examples/mall.sg | 41 +++++-- examples/mll.sg | 122 +++++++++++--------- examples/nat.sg | 2 +- examples/npda.sg | 70 +++++++----- examples/prolog.sg | 46 ++++---- examples/stack.sg | 23 ++-- examples/sumtypes.sg | 45 ++++---- examples/syntax.sg | 156 ++++++++++++++------------ examples/turing.sg | 96 +++++++++------- exercises/00-unification.sg | 51 ++++++--- exercises/01-paths.sg | 32 ++++-- exercises/02-registers.sg | 27 +++-- exercises/03-boolean.sg | 84 ++++++++++++++ exercises/04-boolean.sg | 62 ---------- exercises/solutions/00-unification.sg | 51 ++++++--- exercises/solutions/01-paths.sg | 35 ++++-- exercises/solutions/02-registers.sg | 36 +++--- exercises/solutions/03-boolean.sg | 95 ++++++++++++++++ exercises/solutions/04-boolean.sg | 63 ----------- nvim/syntax/stellogen.vim | 2 +- src/lsc/lsc_parser.mly | 15 ++- src/lsc/unification.ml | 9 +- src/stellogen/sgen_lexer.ml | 7 +- src/stellogen/sgen_parser.mly | 40 +++---- test/behavior/automata.sg | 90 +++++++-------- test/behavior/galaxy.sg | 34 +++--- test/behavior/linear.sg | 27 +++-- test/behavior/prolog.sg | 43 ++++--- test/syntax/blocks.sg | 8 -- test/syntax/definitions.sg | 99 ---------------- test/syntax/galaxy.sg | 37 ------ 36 files changed, 1037 insertions(+), 872 deletions(-) create mode 100644 exercises/03-boolean.sg delete mode 100644 exercises/04-boolean.sg create mode 100644 exercises/solutions/03-boolean.sg delete mode 100644 exercises/solutions/04-boolean.sg delete mode 100644 test/syntax/blocks.sg delete mode 100644 test/syntax/definitions.sg delete mode 100644 test/syntax/galaxy.sg diff --git a/examples/automata.sg b/examples/automata.sg index c001932..bd96bcb 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -1,37 +1,49 @@ -spec binary = - -i(e) ok; - -i(0:X) +i(X); - -i(1:X) +i(X). +(spec binary + (const + (star (-i e) ok) + (star (-i [0 X]) (+i X)) + (star (-i [1 X]) (+i X)))) 'input words -e :: binary. -e = +i(e). +(:: e binary) +(def e + (const (star (+i e)))) -000 :: binary. -000 = +i(0:0:0:e). +(:: 000 binary) +(def 000 + (const (star (+i [0 0 0 e])))) -010 :: binary. -010 = +i(0:1:0:e). +(:: 010 binary) +(def 010 + (const (star (+i [0 1 0 e])))) -110 :: binary. -110 = +i(1:1:0:e). +(:: 110 binary) +(def 110 + (const (star (+i [1 1 0 e])))) ''' automaton accepting words ending with 00 ''' -a1 = galaxy - initial = - -i(W) +a(W q0). - final = - -a(e q2) accept. - transitions = - -a(0:W q0) +a(W q0); - -a(0:W q0) +a(W q1); - -a(1:W q0) +a(W q0); - -a(0:W q1) +a(W q2). -end +(def a1 + (galaxy + (initial + (const + (star (-i W) (+a W q0)))) + (final + (const + (star (-a e q2) accept))) + (transitions + (const + (star (-a [0 W] q0) (+a W q0)) + (star (-a [0 W] q0) (+a W q1)) + (star (-a [1 W] q0) (+a W q0)) + (star (-a [0 W] q1) (+a W q2)))))) -show process #e. #a1. &kill. end -show process #000. #a1. &kill. end -show process #010. #a1. &kill. end -show process #110. #a1. &kill. end +(show (kill (exec + (union @#e #a1)))) +(show (kill (exec + (union @#000 #a1)))) +(show (kill (exec + (union @#010 #a1)))) +(show (kill (exec + (union @#110 #a1)))) diff --git a/examples/binary4.sg b/examples/binary4.sg index f921b50..b29e1b5 100644 --- a/examples/binary4.sg +++ b/examples/binary4.sg @@ -1,54 +1,65 @@ -spec u4 = -b(1 _) -b(2 _) -b(3 _) -b(4 _) ok. +(spec u4 + (const + (star (-b 1 _) (-b 2 _) (-b 3 _) (-b 4 _) ok))) -checker = galaxy - interaction = - process - #test. - #tested[b=>+b]. - end - expect = ok. -end +(def checker + (galaxy + (interaction + (process + #test + #tested[b=>+b])) + (expect (const (star ok))))) -b1 :: u4 [checker]. -b1 = b(1 1); b(2 0); b(3 0); b(4 1). +(:: b1 (u4 / checker)) +(def b1 + (const + (star (b 1 1)) + (star (b 2 0)) + (star (b 3 0)) + (star (b 4 1)))) -b1 :: u4 [checker]. -b2 = b(1 0); b(2 0); b(3 1); b(4 1). +(:: b1 (u4 / checker)) +(def b2 + (const + (star (b 1 0)) + (star (b 2 0)) + (star (b 3 1)) + (star (b 4 1)))) -and = - -b1(arg 0) -b2(arg X) b(arg 0); - -b1(arg 1) -b2(arg X) b(arg X). +(def and + (const + (star (-b1 arg 0) (-b2 arg X) (b arg 0)) + (star (-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). +(def or + (const + (star (-b1 arg 0) (-b2 arg X) (b arg X)) + (star (-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). +(def xor + (const + (star (-b1 arg 1) (-b2 arg 0) (b arg 1)) + (star (-b1 arg 0) (-b2 arg 1) (b arg 1)) + (star (-b1 arg 0) (-b2 arg 0) (b arg 0)) + (star (-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. -end +(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. -end +(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. -end +(show-exec (process + #b1[b=>+b1] + #xor[arg=>1] #xor[arg=>2] #xor[arg=>3] #xor[arg=>4] + #b2[b=>+b2] + &kill)) diff --git a/examples/circuits.sg b/examples/circuits.sg index 0ba4c45..01dc4a3 100644 --- a/examples/circuits.sg +++ b/examples/circuits.sg @@ -1,41 +1,43 @@ ''' FIXME ''' +(def semantics + (const + (star (+1 1)) + (star (+0 0)) + (star (+s X X X)) + (star (+not 1 0)) (star (+not 0 1)) + (star (+and 1 X X)) (star (+and 0 X 0)))) -semantics = - +1(1); - +0(0); - +s(X X X); - +not(1 0); +not(0 1); - +and(1 X X); +and(0 X 0). - -show-exec process +(show-exec (process 'inputs - -1(X) +c0(X). + (const (star (-1 X) (+c0 X))) 'layer 1 - -c0(X) -s(X Y Z) +c1(Y) +c2(Z). + (const (star (-c0 X) (-s X Y Z) (+c1 Y) (+c2 Z))) 'layer 2 - -c1(X) -not(X R) +c3(R). + (const (star (-c1 X) (-not X R) (+c3 R))) 'layer 3 - -c2(X) -c3(Y) -and(X Y R) +c4(R). + (const (star (-c2 X) (-c3 Y) (-and X Y R) (+c4 R))) 'output - -c4(R) R. - #semantics. - '&kill. -end + (const (star (-c4 R) R)) + #semantics)) + '&kill -show-exec process +(show-exec (process 'inputs - -0(X) +c0(X); - -0(X) +c1(X). + (const + (star (-0 X) (+c0 X)) + (star (-0 X) (+c1 X))) 'layer 1 - -c0(X) -not(X R) +c2(R); - -c1(X) -not(X R) +c3(R). + (const + (star (-c0 X) (-not X R) (+c2 R)) + (star (-c1 X) (-not X R) (+c3 R))) 'layer 2 - -c2(X) -c3(Y) -and(X Y R) +c4(R). + (const + (star (-c2 X) (-c3 Y) (-and X Y R) (+c4 R))) 'output - -c4(R) R. + (const + (star (-c4 R) R)) 'apply semantics - #semantics. - '&kill. -end + #semantics)) + '&kill diff --git a/examples/lambda.sg b/examples/lambda.sg index 70f2d4f..5453485 100644 --- a/examples/lambda.sg +++ b/examples/lambda.sg @@ -1,18 +1,40 @@ -''' id id ''' -id = +id(exp(l:X d)) +id(r:X). -id_arg = ida(exp(l:X Y)) +arg(exp(l:r:X Y)). -linker = -id(X) -arg(X); @+arg(r:X) out(X). -show-exec id id_arg linker. - -''' id x ''' -var_x = x(exp(X Y)) +arg(exp(l:X Y)). -linker = -id(X) -arg(X); @+arg(r:X) out(X). -show-exec id var_x linker. - -''' lproj x ''' -lproj = - +lproj(l:X); 'weakening - lproj(exp(r:l:X d)) +lproj(r:r:X). - -linker = -lproj(X) -arg(X); @+arg(r:X) out(X). -show-exec lproj var_x linker. +' id id +(def id + (const + (star (+id (exp [l X] d)) (+id [r X])))) + +(def id_arg + (const + (star (ida (exp [l X] Y)) (+arg (exp [l r X] Y))))) + +(def linker + (const + (star (-id X) (-arg X)) + (@star (+arg [r X]) (out X)))) + +(show-exec (union (union #id #id_arg) #linker)) + +' id x +(def var_x + (const + (star (x (exp X Y)) (+arg (exp [l X] Y))))) + +(def linker + (const + (star (-id X) (-arg X)) + (@star (+arg [r X]) (out X)))) + +(show-exec (union (union #id #var_x) #linker)) + +' lproj x +(def lproj + (const + (star (+lproj [l X])) 'weakening + (star (lproj (exp [r l X] d)) (+lproj [r r X])))) + +(def linker + (const + (star (-lproj X) (-arg X)) + (@star (+arg [r X]) (out X)))) + +(show-exec (union (union #lproj #var_x) #linker)) diff --git a/examples/linear_lambda.sg b/examples/linear_lambda.sg index f42bf26..f2a6a69 100644 --- a/examples/linear_lambda.sg +++ b/examples/linear_lambda.sg @@ -1,32 +1,56 @@ -''' identity function (\x -> x) ''' -id = +id(l:X) +id(r:X). - -''' id id ''' -id_arg = ida(l:X) +arg(l:r:X). -linker = -id(X) -arg(X); @+arg(r:X) out(X). -show-exec #id #id_arg #linker. - -''' id x ''' -x_arg = x(X) +arg(l:X). -linker = -id(X) -arg(X); @+arg(r:X) out(X). -show-exec #id #x_arg #linker. - -''' linear types ''' -spec "a -o a" = galaxy - test1 = - -x(X) +parxy(X); -y(X); - @-parxy(X) ok. - test2 = - -x(X); -y(X) +parxy(X); - @-parxy(X) ok. -end - -adapter = -id(l:X) +x(X); -id(r:X) +y(X). - -checker = galaxy - interaction = #tested #test. - expect = ok. -end - -vehicle :: "a -o a" [checker]. -vehicle = #id #adapter. +' identity function (\x -> x) +(def id + (const + (star (+id [l X]) (+id [r X])))) + +' id id +(def id_arg + (const + (star (ida [l X]) (+arg [l r X])))) + +(def linker + (const + (star (-id X) (-arg X)) + (@star (+arg [r X]) (out X)))) + +(show-exec (union (union #id #id_arg) #linker)) + +' id x +(def x_arg + (const + (star (x X) (+arg [l X])))) + +(def linker + (const + (star (-id X) (-arg X)) + (@star (+arg [r X]) (out X)))) + +(show-exec (union (union #id #x_arg) #linker)) + +' linear types +(spec (larrow a a) + (galaxy + (test1 + (const + (star (-x X) (+parxy X)) + (star (-y X)) + (@star (-parxy X) ok))) + (test2 + (const + (star (-x X)) + (star (-y X) (+parxy X)) + (@star (-parxy X) ok))))) + +(def adapter + (const + (star (-id [l X]) (+x X)) + (star (-id [r X]) (+y X)))) + +(def checker + (galaxy + (interaction (union #tested #test)) + (expect (const (star ok))))) + +(:: vehicle ((larrow a a) / checker)) +(def vehicle + (union #id #adapter)) diff --git a/examples/mall.sg b/examples/mall.sg index 1880fc6..625106e 100644 --- a/examples/mall.sg +++ b/examples/mall.sg @@ -1,12 +1,29 @@ -left = +5(l:l:X) +5(l:r:X) | c:a. -right = +5(r:l:X) +5(r:r:X) | c:b. - -with = #left #right. -plus = +3(l:l:X) c(X); +3(l:r:X) d(X). -cut = -5(X) -3(X). - -show-exec process - #with. - #plus #cut. - &kill. -end +''' +(def left + (const (star + (+5 [l l X]) (+5 [l r X]) + (!@ c a))))) + ''' + +''' +(def right + (const + (star (+5 [r l X]) (+5 [r r X) + (bans (!@ c b))))) + +(def with + (union #left #right)) + +(def plus + (const + (star (+3 [l l X]) (c X)) + (star (+3 [l r X]) (d X)))) + +(def cut + (const (star (-5 X) (-3 X)))) + +(show-exec (process + #with + (union #plus #cut) + &kill)) +''' diff --git a/examples/mll.sg b/examples/mll.sg index 3bd6fb4..71fd5af 100644 --- a/examples/mll.sg +++ b/examples/mll.sg @@ -1,61 +1,75 @@ -'''test of linear identity''' -spec "a -o a" = galaxy - testrl = - -1(X) -2(X) +c5(X); - -3(X); -4(X) +c6(X); - -c5(X) +7(X); -c6(X); - @-7(X) ok. - testrr = - -1(X) -2(X) +c5(X); - -3(X); -4(X) +c6(X); - -c5(X); +7(X) -c6(X); - @-7(X) ok. - testll = - -1(X) -2(X) +c5(X); - -4(X); -3(X) +c6(X); - -c5(X) +7(X); -c6(X); - @-7(X) ok. - testlr = - -1(X) -2(X) +c5(X); - -4(X); -3(X) +c6(X); - -c5(X); +7(X) -c6(X); - @-7(X) ok. -end +' test of linear identity +(spec (larrow a a) + (galaxy + (testrl + (const + (star (-1 X) (-2 X) (+c5 X)) + (star (-3 X)) (star (-4 X) (+c6 X)) + (star (-c5 X) (+7 X)) (star (-c6 X)) + (@star (-7 X) ok))) + (testrr + (const + (star (-1 X) (-2 X) (+c5 X)) + (star (-3 X)) (star (-4 X) (+c6 X)) + (star (-c5 X)) (star (+7 X) (-c6 X)) + (@star (-7 X) ok))) + (testll + (const + (star (-1 X) (-2 X) (+c5 X)) + (star (-4 X)) (star (-3 X) (+c6 X)) + (star (-c5 X) (+7 X)) (star (-c6 X)) + (@star (-7 X) ok))) + (testlr + (const + (star (-1 X) (-2 X) (+c5 X)) + (star (-4 X)) (star (-3 X) (+c6 X)) + (star (-c5 X)) (star (+7 X) (-c6 X)) + (@star (-7 X) ok))))) -checker = galaxy - interaction = #tested #test. - expect = ok. -end +(def checker + (galaxy + (interaction (union #tested #test)) + (expect (const (star ok))))) -id :: "a -o a" [checker]. -id = - -5(l:X) +1(X); - -5(r:X) +2(X); - -6(l:X) +3(X); - -6(r:X) +4(X); - +5(l:X) +6(l:X); - +5(r:X) +6(r:X). +(:: id ((larrow a a) / checker)) +(def id + (const + (star (-5 [l X]) (+1 X)) + (star (-5 [r X]) (+2 X)) + (star (-6 [l X]) (+3 X)) + (star (-6 [r X]) (+4 X)) + (star (+5 [l X]) (+6 [l X])) + (star (+5 [r X]) (+6 [r X])))) -'''cut-elimination''' -ps1 = galaxy - vehicle = +7(l:X) +7(r:X); 3(X) +8(l:X); @+8(r:X) 6(X). - cuts = -7(X) -8(X). -end +'cut-elimination +(def ps1 + (galaxy + (vehicle + (const + (star (+7 [l X]) (+7 [r X])) + (star (3 X) (+8 [l X])) + (@star (+8 [r X]) (6 X)))) + (cuts + (const + (star (-7 X) (-8 X)))))) -show-exec #ps1->vehicle #ps1->cuts. +(show-exec (union (get ps1 vehicle) (get ps1 cuts))) -spec "a * b" = - -1(g:X) -2(g:X) +3(g:X); - @-3(g:X) ok. +(spec (tens a b) + (const + (star (-1 [g X]) (-2 [g X]) (+3 [g X])) + (@star (-3 [g X]) ok))) -linear = galaxy - interaction = linear-exec #tested #test end. - expect = ok. -end +(def linear + (galaxy + (interaction + (linear-exec (union #tested #test))) + (expect (const (star ok))))) -'does not typecheck -'vehicle :: "a * a" [linear]. -vehicle = - +3(l:X) +3(r:X); - -3(l:X) +1(g:X); - -3(r:X) +2(g:X). +' does not typecheck +' (:: vehicle ((tens a a) linear)) +(def vehicle + (const + (star (+3 [l X]) (+3 [r X])) + (star (-3 [l X]) (+1 [g X])) + (star (-3 [r X]) (+2 [g X])))) diff --git a/examples/nat.sg b/examples/nat.sg index a22ebd4..1219542 100644 --- a/examples/nat.sg +++ b/examples/nat.sg @@ -27,7 +27,7 @@ (const (star <+nat s s /0>))) -(:: add1 ((arrow nat nat) fchecker)) +(:: add1 ((arrow nat nat) / fchecker)) (def add1 (const (star (-nat X) (+nat (s X))))) diff --git a/examples/npda.sg b/examples/npda.sg index e3f90ce..458e5f5 100644 --- a/examples/npda.sg +++ b/examples/npda.sg @@ -1,36 +1,48 @@ -spec binary = - -i(e) ok; - -i(0:X) +i(X); - -i(1:X) +i(X). +(spec binary + (const + (star (-i e) ok) + (star (-i [0 X]) (+i X)) + (star (-i [1 X]) (+i X)))) 'input words -e :: binary. -e = +i(e). +(:: e binary) +(def e + (const (star (+i e)))) -0000 :: binary. -0000 = +i(0:0:0:0:e). +(:: 0000 binary) +(def 0000 + (const (star (+i [0 0 0 0 e])))) -0110 :: binary. -0110 = +i(0:1:1:0:e). +(:: 0110 binary) +(def 0110 + (const (star (+i [0 1 1 0 e])))) -1110 :: binary. -1110 = +i(1:1:1:0:e). +(:: 1110 binary) +(def 1110 + (const (star (+i [1 1 1 0 e])))) -a1 = galaxy - initial = - -i(W) +a(W e q0). - final = - -a(e e q0) accept; - -a(e e q1) accept. - transitions = - -a(0:W S q0) +a(W 0:S q0); - -a(1:W S q0) +a(W 1:S q0); - -a(W S q0) +a(W S q1); - -a(0:W 0:S q1) +a(W S q1); - -a(1:W 1:S q1) +a(W S q1). -end +(def a1 + (galaxy + (initial + (const + (star (-i W) (+a W e q0)))) + (final + (const + (star (-a e e q0) accept) + (star (-a e e q1) accept))) + (transitions + (const + (star (-a [0 W] S q0) (+a W [0 S] q0)) + (star (-a [1 W] S q0) (+a W [1 S] q0)) + (star (-a W S q0) (+a W S q1)) + (star (-a [0 W] [0 S] q1) (+a W S q1)) + (star (-a [1 W] [1 S] q1) (+a W S q1)))))) -show process #e. #a1. &kill. end -show process #0000. #a1. &kill. end -show process #0110. #a1. &kill. end -show process #1110. #a1. &kill. end +(show (kill (exec + (union @#e #a1)))) +(show (kill (exec + (union @#0000 #a1)))) +(show (kill (exec + (union @#0110 #a1)))) +(show (kill (exec + (union @#1110 #a1)))) diff --git a/examples/prolog.sg b/examples/prolog.sg index 57ec01f..0ccea06 100644 --- a/examples/prolog.sg +++ b/examples/prolog.sg @@ -1,29 +1,35 @@ ' unary addition -add = - +add(0 Y Y); - -add(X Y Z) +add(s(X) Y s(Z)). +(def add + (const + (star (+add 0 Y Y)) + (star (-add X Y Z) (+add (s X) Y (s Z))))) ' 2 + 2 = R -query = -add(s(s(0)) s(s(0)) R) R. +(def query + (const + (star (-add R) R))) -show-exec #add @#query. +(show-exec (union #add @#query)) -graph = - +from(1) +to(2); - +from(1) +to(3); - +from(3) +to(2); - +from(3) +to(4). - '+from(4) +to(3); +(def graph + (const + (star (+from 1) (+to 2)) + (star (+from 1) (+to 3)) + (star (+from 3) (+to 2)) + (star (+from 3) (+to 4)))) + '(star (+from 4) (+to 3)) -composition = -to(X) -from(X). +(def composition + (const + (star (-to X) (-from X)))) ' is there a path between 1 and 4? -query = - @-from(1); - -to(4) ok. +(def query + (const + (@star (-from 1)) + (star (-to 4) ok))) -show-exec process - #query. - #graph #composition. - &kill. -end +(show-exec (process + #query + (union #graph #composition) + &kill)) diff --git a/examples/stack.sg b/examples/stack.sg index c68f177..957d79f 100644 --- a/examples/stack.sg +++ b/examples/stack.sg @@ -1,20 +1,21 @@ -show-exec process - +stack0(e). +(show-exec (process + (const (star (+stack0 e))) 'push 1 then 0 - -stack0(X) +stack1(1:X). - -stack1(X) +stack2(0:X). + (const + (star (-stack0 X) (+stack1 [1 X])) + (star (-stack1 X) (+stack2 [0 X]))) 'pop & save - -stack2(C:X) +stack3(X) +save(C). + (const (star (-stack2 [C X]) (+stack3 X) (+save C))) 'conditional duplication - -stack3(0:X) +stack4(0:0:X); - -stack3(1:X) +stack4(1:1:X). + (const + (star (-stack3 [0 X]) (+stack4 [0 0 X])) + (star (-stack3 [1 X]) (+stack4 [1 1 X]))) 'freeze information - -stack4(X) stack(X). + (const (star (-stack4 X) (stack X))) - -save(C) save(C). + (const (star (-save C) (save C))) 'kill remaining polarized stars - &kill. -end + &kill)) diff --git a/examples/sumtypes.sg b/examples/sumtypes.sg index fb2f42a..9ea1e24 100644 --- a/examples/sumtypes.sg +++ b/examples/sumtypes.sg @@ -1,27 +1,32 @@ -checker = galaxy - interaction = @#tested #test. - expect = ok. -end +(def checker + (galaxy + (interaction (union @#tested #test)) + (expect (const (star ok))))) -spec direction = - -north ok; - -south ok; - -west ok; - -east ok. +(spec direction + (const + (star -north ok) + (star -south ok) + (star -west ok) + (star -east ok))) -n :: direction [checker]. -n = +north. +(:: n (direction / checker)) +(def n + (const (star +north))) -spec result = - -ok(X) ok; - -error(X) ok. +(spec result + (const + (star (-ok X) ok) + (star (-error X) ok))) -x :: result [checker]. -x = +ok(a). +(:: x (result / checker)) +(def x + (const (star (+ok a)))) 'pattern matching -get_ok = - -ok(X) X; - -error(X) +error(X). +(def get_ok + (const + (star (-ok X) X) + (star (-error X) (+error X)))) -show-exec #get_ok @#x. +(show-exec (union #get_ok @#x)) diff --git a/examples/syntax.sg b/examples/syntax.sg index 7cec8d2..c56a09b 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -1,113 +1,127 @@ 'static definition of constellation -x = +a; -a b. -y = #x. -z = -f(X). +(def x + (const + (star +a) + (star -a b))) + +(def y #x) +(def z + (const (star (-f X)))) 'string literals -w = "hello world". +(def w + (const (star "hello world"))) 'cons -w = +w(0:1:0:1:e). +(def w + (const (star (+w [0 1 0 1 e])))) 'full focus -show-exec @#w #w. +(show-exec (union @#w #w)) 'show (literal) contellations -show a; b; c. +(show (const + (star a) (star b) (star c))) 'print result of execution -show-exec a; b; c. -show exec a; b; c end. +(show-exec (const + (star a) (star b) (star c))) + +(show (exec (const + (star a) (star b) (star c)))) 'inequality constraints -ineq = +f(a); +f(b); @-f(X) -f(Y) r(X Y) | X!=Y. +'ineq = +f(a); +f(b); @-f(X) -f(Y) r(X Y) | X!=Y. 'interactive debugging of execution -'trace ineq. +'(trace ineq) 'dynamic definition of constellation -c = process - +n0(0). 'base constellation - -n0(X) +n1(s(X)). 'interacts with previous - -n1(X) +n2(s(X)). 'interacts with previous -end +(def c (process + (const (star (+n0 0))) 'base constellation + (const (star (-n0 X) (+n1 (s X)))) 'interacts with previous + (const (star (-n1 X) (+n2 (s X)))))) 'interacts with previous 'galaxy definition -g = galaxy - test1 = +f(a) ok. - test2 = +f(b) ok. -end -show #g. +(def g (galaxy + (test1 (const (star (+f a) ok))) + (test2 (const (star (+f b) ok))))) + +(show #g) 'reactive effects -run +&print(X); -&print("hello world\n"). +(run (const + (star (+&print X)) + (star (-&print "hello world\n")))) 'access to field of a galaxy -show #g->test1. -show #g->test2. +(show (get g test1)) +(show (get g test2)) 'extend rays with a head function symbol -show-exec (+f(X); f(X))[=>+a]. -show-exec (+f(X); f(X))[=>a]. +(show-exec (const (star (+f X)) (star (f X)))[=>+a]) +(show-exec (const (star (+f X)) (star (f X)))[=>a]) 'remove head function symbol from a ray -show-exec (+f(X); f(X))[+f=>]. +(show-exec (const (star (+f X)) (star (f X)))[+f=>]) 'substitutions -show-exec (+f(X))[X=>+a(X)]. -show-exec (+f(X))[+f=>+g]. -show-exec (#1 #2)[#1=>+f(X) X][#2=>-f(a)]. +(show-exec + (const (star (+f X)))[X=>(+a X)]) +(show-exec (const (star (+f X)))[+f=>+g]) +(show-exec (union #1 #2) + [#1=>(const (star (+f X) X))] + [#2=>(const (star (-f a)))]) 'checkers & typechecking -checker = galaxy - interaction = (@#tested) #test. - expect = ok. -end +(def checker (galaxy + (interaction (union @#tested #test)) + (expect (const (star ok))))) -spec nat = galaxy - test = - -nat(0) ok; - -nat(s(N)) +nat(N). -end +(spec nat + (galaxy + (test + (const + (star (-nat 0) ok) + (star (-nat (s N)) (+nat N)))))) -0 :: nat [checker]. -0 = +nat(0). +(:: 0 (nat /checker)) +(def 0 + (const (star (+nat 0)))) -1 :: nat [checker]. -1 = +nat(s(0)). +(:: 1 (nat / checker)) +(def 1 + (const (star (+nat (s 0))))) 'plural typing -nat2 = -nat(X) ok. -2 :: nat. -2 :: nat2. -2 = +nat(s(s(0))). -3 :: nat; nat2. -3 = +nat(s(s(s(0)))). -4 :: nat [checker]; nat2 [checker]. -4 = +nat(s(s(s(s(0))))). +(def nat2 + (const (star (-nat X) ok))) + +(:: 2 nat) +(:: 2 nat2) +(def 2 + (const (star (+nat )))) + +(:: 3 nat nat2) +(def 3 + (const (star (+nat )))) + +(:: 4 (nat / checker) (nat2 / checker)) +(def 4 + (const (star (+nat )))) 'galaxy with type declarations -show galaxy - n1 :: nat. - n1 = +nat(0). - n2 :: nat. - n2 = +nat(s(s(0))). -end - -interface nat_pair - n :: nat. - m :: nat. -end - -g_pair :: nat_pair. -g_pair = galaxy - n = +nat(0). - m = +nat(0). -end +(show (galaxy + (:: n1 nat) + (n1 (const (star (+nat 0)))) + (:: n2 nat) + (n2 (const (star (+nat )))))) 'import file -'use examples->automata. +'(use examples automata) 'complex identifiers -f(a b) = function(a b). -show #f(a b). +(def (f a b) + (const + (star (function a b)))) +(show #(f a b)) diff --git a/examples/turing.sg b/examples/turing.sg index 26f405f..44a4eef 100644 --- a/examples/turing.sg +++ b/examples/turing.sg @@ -1,42 +1,56 @@ -''' -Turing machine accepting words with as many 'a' as 'b' -''' -mt = galaxy - initial = - -i(C:W) +m(q0 e:e C W); - -i(e) +m(q0 e e e). - accept = - -m(q0 L e R) +m(qa L e R); - -m(qa L e R) accept. - initial_skip = - -m(q0 L sep C:R) +m(q0 sep:L C R). - mark = - -m(q0 L a C:R) +m(q2 sep:L C R); - -m(q0 L b C:R) +m(q3 sep:L C R). - skip = - -m(q2 L a C:R) +m(q2 a:L C R); - -m(q2 L sep C:R) +m(q2 sep:L C R); - -m(q3 L b C:R) +m(q3 b:L C R); - -m(q3 L sep C:R) +m(q3 sep:L C R). - join = - -m(q2 C:L b R) +m(q1 L C sep:R); - -m(q3 C:L a R) +m(q1 L C sep:R). - return = - -m(q1 C:L a R) +m(q1 L C a:R); - -m(q1 C:L b R) +m(q1 L C b:R); - -m(q1 C:L sep R) +m(q1 L C sep:R); - -m(q1 L e C:R) +m(q0 e:L C R). - reject = - -m(q2 L e R) +m(qr L e R); - -m(q3 L e R) +m(qr L e R); - -m(qr L C R) reject. -end +' Turing machine accepting words with as many 'a' as 'b' +(def mt + (galaxy + (initial + (const + (star (-i [C W]) (+m q0 [e e] C W)) + (star (-i e) (+m q0 e e e)))) + (accept + (const + (star (-m q0 L e R) (+m qa L e R)) + (star (-m qa L e R) accept))) + (initial_skip + (const + (star (-m q0 L sep [C R]) (+m q0 [sep L] C R)))) + (mark + (const + (star (-m q0 L a [C R]) (+m q2 [sep L] C R)) + (star (-m q0 L b [C R]) (+m q3 [sep L] C R)))) + (skip + (const + (star (-m q2 L a [C R]) (+m q2 [a L] C R)) + (star (-m q2 L sep [C R]) (+m q2 [sep L] C R)) + (star (-m q3 L b [C R]) (+m q3 [b L] C R)) + (star (-m q3 L sep [C R]) (+m q3 [sep L] C R)))) + (join + (const + (star (-m q2 [C L] b R) (+m q1 L C [sep R])) + (star (-m q3 [C L] a R) (+m q1 L C [sep R])))) + (return + (const + (star (-m q1 [C L] a R) (+m q1 L C [a R])) + (star (-m q1 [C L] b R) (+m q1 L C [b R])) + (star (-m q1 [C L] sep R) (+m q1 L C [sep R])) + (star (-m q1 L e [C R]) (+m q0 [e L] C R)))) + (reject + (const + (star (-m q2 L e R) (+m qr L e R)) + (star (-m q3 L e R) (+m qr L e R)) + (star (-m qr L C R) reject))))) -show process +i(a:e:e). #mt. &kill. end -show process +i(b:e:e). #mt. &kill. end -show process +i(a:b:b:e:e). #mt. &kill. end -show process +i(e:e). #mt. &kill. end -show process +i(a:b:e:e). #mt. &kill. end -show process +i(a:a:b:b:e:e). #mt. &kill. end -show process +i(a:b:b:a:e:e). #mt. &kill. end -show process +i(a:b:a:b:e:e). #mt. &kill. end +(show (kill (exec + (union @(const (star (+i [a e e]))) #mt)))) +(show (kill (exec + (union @(const (star (+i [b e e]))) #mt)))) +(show (kill (exec + (union @(const (star (+i [a b b e e]))) #mt)))) +(show (kill (exec + (union @(const (star (+i [e e]))) #mt)))) +(show (kill (exec + (union @(const (star (+i [a b e e]))) #mt)))) +(show (kill (exec + (union @(const (star (+i [a a b b e e]))) #mt)))) +(show (kill (exec + (union @(const (star (+i [a b b a e e]))) #mt)))) +(show (kill (exec + (union @(const (star (+i [a b a b e e]))) #mt)))) diff --git a/exercises/00-unification.sg b/exercises/00-unification.sg index 8cd02a8..a01c09c 100644 --- a/exercises/00-unification.sg +++ b/exercises/00-unification.sg @@ -1,22 +1,45 @@ 'fill the #your_answer holes with the correct result of execution -x1 :=: #your_answer. -x1 = @+f(X) X; -f(a). +(== x1 #your_answer) +(def x1 + (const + (@star (+f X) X) + (star (-f a)))) -x2 :=: #your_answer. -x2 = @+f(X); -f(Y) a. +(== x2 #your_answer) +(def x2 + (const + (@star (+f X)) + (star (-f Y) a))) -x3 :=: #your_answer. -x3 = @+f(X) X; -f(a); -f(b). +(== x3 #your_answer) +(def x3 + (const + (@star (+f X) X) + (star (-f a)) + (star (-f b)))) -x4 :=: #your_answer. -x4 = @+1 -2; -2 +3. +(== x4 #your_answer) +(def x4 + (const + (@star +1 -2) + (star -2 +3))) -x5 :=: #your_answer. -x5 = @-1 +2; -2 +1. +(== x5 #your_answer) +(def x5 + (const + (@star -1 +2) + (star -2 +1))) -x6 :=: #your_answer. -x6 = @-1 +2; -2 +1. +(== x6 #your_answer) +(def x6 + (const + (@star -1 +2) + (star -2 +1))) -x7 :=: #your_answer. -x7 = @-f(X) X; +f(+g(a)); -g(X) X. +(== x7 #your_answer) +(def x7 + (const + (@star (-f X) X) + (star (+f (+g a))) + (star (-g X) X))) diff --git a/exercises/01-paths.sg b/exercises/01-paths.sg index 1a24a4b..9733e27 100644 --- a/exercises/01-paths.sg +++ b/exercises/01-paths.sg @@ -1,14 +1,32 @@ 'fill the 'your_answer' holes to replace #1 in the constellations 'below such that the result of execution is { ok } -x :=: { ok }. +(== x1 (const (star ok))) +(def x1 + (union (const (@star -1 ok)) #1) + [#1=>#your_answer]) -x = ((-1 ok) #1)[#1=>your_answer]. +(== x2 (const (star ok))) +(def x2 + (union (const (@star -1) (star +2)) #1) + [#1=>#your_answer]) -x = ((-1; +2) #1)[#1=>your_answer]. +(== x3 (const (star ok))) +(def x3 + (union (const (@star -1 ok) (star -2 +3)) #1) + [#1=>#your_answer]) -x = ((-1 ok; -2 +3) #1)[#1=>your_answer]. +(== x4 (const (star ok))) +(def x4 + (union (const (@star (-f (+g X)) ok)) #1) + [#1=>#your_answer]) -x = ((-f(+g(X)) ok) #1)[#1=>your_answer]. - -x = ((+f(a) +f(b); +g(a); @+g(b) ok) #1)[#1=>your_answer]. +(== x5 (const (star ok))) +(def x5 + (union + (const + (star (+f a) (+f b)) + (star (+g a)) + (@star (+g b) ok)) + #1) + [#1=>#your_answer]) diff --git a/exercises/02-registers.sg b/exercises/02-registers.sg index 887a445..17514e7 100644 --- a/exercises/02-registers.sg +++ b/exercises/02-registers.sg @@ -1,29 +1,28 @@ -show-exec process +(show-exec (process 'represents a register with value 0 - +r0(0). + (const (star (+r0 0))) 'update the value to 1 - #your_answer. - #your_answer. + #your_answer + #your_answer 'duplicate the register into two registers r1 and r2 - #your_answer. + #your_answer 'update r1 to 0 - #your_answer. - #your_answer. + #your_answer + #your_answer 'swap the value of r1 and r2 - #your_answer. - #your_answer. + #your_answer + #your_answer 'duplicate r1 and add a copy identifier as first argument - #your_answer. + #your_answer 'update the two copies to 5 at once - #your_answer. - #your_answer. + #your_answer + #your_answer 'duplicate each copy of r1 again with the same method - #your_answer. -end + #your_answer)) diff --git a/exercises/03-boolean.sg b/exercises/03-boolean.sg new file mode 100644 index 0000000..d4eff41 --- /dev/null +++ b/exercises/03-boolean.sg @@ -0,0 +1,84 @@ +'fill the #your_answer hole by following the specifications + +(def checker + (galaxy + (interaction (union #tested #test)) + (expect (const (star ok))))) + +(def not_spec + (galaxy + (test0 (const (@star (-not 0 1) ok))) + (test1 (const (@star (-not 1 0) ok))))) + +(:: not (not_spec / checker)) +(def not + #your_asnwer) + +'how to print the truth table of NOT ? +(== table_not (const + (star (table_not 0 1)) + (star (table_not 1 0)))) +(def table_not + (union + #not + #your_answer)) + +(def and_spec + (galaxy + (test00 (const (@star (-and 0 0 0) ok))) + (test01 (const (@star (-and 0 1 0) ok))) + (test10 (const (@star (-and 1 0 0) ok))) + (test11 (const (@star (-and 1 1 1) ok))))) + +(:: and (and_spec / checker)) +(def and + #your_answer) + +'find a second way to compute AND +(:: and (and_spec / checker)) +(def and2 + #your_answer) + +(def or_spec + (galaxy + (test00 (const (@star (-or 0 0 0) ok))) + (test01 (const (@star (-or 0 1 1) ok))) + (test10 (const (@star (-or 1 0 1) ok))) + (test11 (const (@star (-or 1 1 1) ok))))) + +(:: or (or_spec / checker)) +(def or + #your_asnwer) + +'find a second way to compute OR +(:: or2 (or_spec / checker)) +(def or2 + #your_answer) + +(def impl_spec + (galaxy + (test00 (const (@star (-impl 0 0 1) ok))) + (test01 (const (@star (-impl 0 1 1) ok))) + (test10 (const (@star (-impl 1 0 0) ok))) + (test11 (const (@star (-impl 1 1 1) ok))))) + +(:: impl (impl_spec / checker)) +(def impl + (exec (union (union #not #or) + #your_answer))) + +'find a second way to compute IMPLICATION +(:: impl2 (impl_spec / checker)) +(def impl2 + (exec (union (union #not #or) + #your_answer))) + +'implement the excluded middle X \/ ~X +(== ex (const (star (+ex 1 1)) (star (+ex 0 1)))) +(def ex + (union (union #not #or) + #your_answer)) + +'how to show the values of X, Y and Z for which X /\ ~(Y /\ Z) is true? +(show-exec + #your_answer) diff --git a/exercises/04-boolean.sg b/exercises/04-boolean.sg deleted file mode 100644 index 4c648d9..0000000 --- a/exercises/04-boolean.sg +++ /dev/null @@ -1,62 +0,0 @@ -'fill the #your_answer hole by following the specifications - -not_spec = galaxy - test0 = @-not(0 1) ok. - test1 = @-not(1 0) ok. -end - -not :: not_spec. -not = #your_answer. - -'how to print the truth table of NOT ? -table_not :=: { table_not(1 0); table_not(0 1) }. -table_not = not #your_answer. - -and_spec = galaxy - test00 = @-and(0 0 0) ok. - test01 = @-and(0 1 0) ok. - test10 = @-and(1 0 0) ok. - test11 = @-and(1 1 1) ok. -end - -and :: and_spec. -and = #your_answer. - -'find a second way to compute AND -and2 :: and_spec. -and2 = #your_answer. - -or_spec = galaxy - test00 = @-or(0 0 0) ok. - test01 = @-or(0 1 1) ok. - test10 = @-or(1 0 1) ok. - test11 = @-or(1 1 1) ok. -end - -or :: or_spec. -or = #your_answer. - -'find a second way to compute OR -or2 :: or_spec. -or2 = #your_answer. - -impl_spec = galaxy - test00 = @-impl(0 0 1) ok. - test01 = @-impl(0 1 1) ok. - test10 = @-impl(1 0 0) ok. - test11 = @-impl(1 1 1) ok. -end - -impl :: impl_spec. -impl = not or #your_answer. - -'find a second way to compute IMPLICATION -impl2 :: impl_spec. -impl2 = not or #your_answer. - -'implement the excluded middle X \/ ~X -ex :=: { +ex(1 1); +ex(0 1) }. -ex = not or #your_answer. - -'how to show the values of X, Y and Z for which X /\ ~(Y /\ Z) is true? -show-exec #your_answer. diff --git a/exercises/solutions/00-unification.sg b/exercises/solutions/00-unification.sg index cd7f321..fb02796 100644 --- a/exercises/solutions/00-unification.sg +++ b/exercises/solutions/00-unification.sg @@ -1,22 +1,45 @@ 'fill the #your_answer holes with the correct result of execution -x1 :=: a. -x1 = @+f(X) X; -f(a). +(== x1 (const (star a))) +(def x1 + (const + (@star (+f X) X) + (star (-f a)))) -x2 :=: a. -x2 = @+f(X); -f(Y) a. +(== x2 (const (star a))) +(def x2 + (const + (@star (+f X)) + (star (-f Y) a))) -x3 :=: b; a. -x3 = @+f(X) X; -f(a); -f(b). +(== x3 (const (star b) (star a))) +(def x3 + (const + (@star (+f X) X) + (star (-f a)) + (star (-f b)))) -x4 :=: +1 -2. -x4 = @+1 -2; -2 +3. +(== x4 (const (star +1 -2))) +(def x4 + (const + (@star +1 -2) + (star -2 +3))) -x5 :=: -2 +1. -x5 = @-1 +2; -2 +1. +(== x5 (const (star -2 +1))) +(def x5 + (const + (@star -1 +2) + (star -2 +1))) -x6 :=: -2 +1. -x6 = @-1 +2; -2 +1. +(== x6 (const (star -2 +1))) +(def x6 + (const + (@star -1 +2) + (star -2 +1))) -x7 :=: a. -x7 = @-f(X) X; +f(+g(a)); -g(X) X. +(== x7 (const (star a))) +(def x7 + (const + (@star (-f X) X) + (star (+f (+g a))) + (star (-g X) X))) diff --git a/exercises/solutions/01-paths.sg b/exercises/solutions/01-paths.sg index 84232af..8cd23a4 100644 --- a/exercises/solutions/01-paths.sg +++ b/exercises/solutions/01-paths.sg @@ -1,17 +1,32 @@ 'fill the 'your_answer' holes to replace #1 in the constellations 'below such that the result of execution is { ok } -x1 :=: ok. -x1 = (@(-1 ok) #1)[#1=>+1]. +(== x1 (const (star ok))) +(def x1 + (union (const (@star -1 ok)) #1) + [#1=>(const (star +1))]) -x2 :=: ok. -x2 = ((@-1; +2) #1)[#1=>+1 -2 ok]. +(== x2 (const (star ok))) +(def x2 + (union (const (@star -1) (star +2)) #1) + [#1=>(const (star +1 -2 ok))]) -x3 :=: ok. -x3 = ((@-1 ok; -2 +3) #1)[#1=>+1 +2; -3]. +(== x3 (const (star ok))) +(def x3 + (union (const (@star -1 ok) (star -2 +3)) #1) + [#1=>(const (star +1 +2) (star -3))]) -x4 :=: ok. -x4 = ((@-f(+g(X)) ok) #1)[#1=>+f(-g(X))]. +(== x4 (const (star ok))) +(def x4 + (union (const (@star (-f (+g X)) ok)) #1) + [#1=>(const (star (+f (-g X))))]) -x5 :=: ok. -x5 = ((+f(a) +f(b); +g(a); @+g(b) ok) #1)[#1=>-f(a); -f(b) -g(a) -g(b)]. +(== x5 (const (star ok))) +(def x5 + (union + (const + (star (+f a) (+f b)) + (star (+g a)) + (@star (+g b) ok)) + #1) + [#1=>(const (star (-f a)) (star (-f b) (-g a) (-g b)))]) diff --git a/exercises/solutions/02-registers.sg b/exercises/solutions/02-registers.sg index 39c55a5..fbec709 100644 --- a/exercises/solutions/02-registers.sg +++ b/exercises/solutions/02-registers.sg @@ -1,32 +1,34 @@ -show-exec process +(show-exec (process 'represents a register with value 0 - +r0(0). + (const (star (+r0 0))) 'update the value to 1 - -r0(X) +tmp0(X). - -tmp0(X) +r0(1). + (const (star (-r0 X) (+tmp0 X))) + (const (star (-tmp0 X) (+r0 1))) 'duplicate the register into two registers r1 and r2 - -r0(X) +r1(X); - -r0(X) +r2(X). + (const + (star (-r0 X) (+r1 X)) + (star (-r0 X) (+r2 X))) 'update r1 to 0 - -r1(X) +tmp0(X). - -tmp0(X) +r1(0). + (const (star (-r1 X) (+tmp0 X))) + (const (star (-tmp0 X) (+r1 0))) 'swap the value of r1 and r2 - -r1(X) +s1(X); -r2(X) +s2(X). - -s1(X) +r2(X); -s2(X) +r1(X). + (const (star (-r1 X) (+s1 X))) + (const (star (-r2 X) (+s2 X))) + (const (star (-s1 X) (+r2 X))) + (const (star (-s2 X) (+r1 X))) 'duplicate r1 and add a copy identifier as first argument - -r1(X) +r1(l X); - -r1(X) +r1(r X). + (const (star (-r1 X) (+r1 l X))) + (const (star (-r1 X) (+r1 r X))) 'update the two copies to 5 at once - -r1(A X) +tmp0(A X). - -tmp0(A X) +r1(A 5). + (const (star (-r1 A X) (+tmp0 A X))) + (const (star (-tmp0 A X) (+r1 A 5))) 'duplicate each copy of r1 again with the same method - -r1(A X) +r1(l A X); - -r1(A X) +r1(r A X). -end + (const (star (-r1 A X) (+r1 l A X))) + (const (star (-r1 A X) (+r1 r A X))))) diff --git a/exercises/solutions/03-boolean.sg b/exercises/solutions/03-boolean.sg new file mode 100644 index 0000000..7a5632c --- /dev/null +++ b/exercises/solutions/03-boolean.sg @@ -0,0 +1,95 @@ +'fill the #your_answer hole by following the specifications + +(def checker + (galaxy + (interaction (union #tested #test)) + (expect (const (star ok))))) + +(def not_spec + (galaxy + (test0 (const (@star (-not 0 1) ok))) + (test1 (const (@star (-not 1 0) ok))))) + +(:: not (not_spec / checker)) +(def not + (const + (star (+not 0 1)) + (star (+not 1 0)))) + +'how to print the truth table of NOT ? +(== table_not (const + (star (table_not 0 1)) + (star (table_not 1 0)))) +(def table_not + (union + #not + (const (@star (-not X Y) (table_not X Y))))) + +(def and_spec + (galaxy + (test00 (const (@star (-and 0 0 0) ok))) + (test01 (const (@star (-and 0 1 0) ok))) + (test10 (const (@star (-and 1 0 0) ok))) + (test11 (const (@star (-and 1 1 1) ok))))) + +(:: and (and_spec / checker)) +(def and + (const + (star (+and 0 0 0)) + (star (+and 0 1 0)) + (star (+and 1 0 0)) + (star (+and 1 1 1)))) + +(:: and (and_spec / checker)) +(def and2 + (const + (star (+and 0 X 0)) + (star (+and 1 X X)))) + +(def or_spec + (galaxy + (test00 (const (@star (-or 0 0 0) ok))) + (test01 (const (@star (-or 0 1 1) ok))) + (test10 (const (@star (-or 1 0 1) ok))) + (test11 (const (@star (-or 1 1 1) ok))))) + +(:: or (or_spec / checker)) +(def or + (const + (star (+or 0 0 0)) + (star (+or 0 1 1)) + (star (+or 1 0 1)) + (star (+or 1 1 1)))) + +(:: or2 (or_spec / checker)) +(def or2 + (const + (star (+or 0 X X)) + (star (+or 1 X 1)))) + +(def impl_spec + (galaxy + (test00 (const (@star (-impl 0 0 1) ok))) + (test01 (const (@star (-impl 0 1 1) ok))) + (test10 (const (@star (-impl 1 0 0) ok))) + (test11 (const (@star (-impl 1 1 1) ok))))) + +(:: impl (impl_spec / checker)) +(def impl + (exec (union (union #not #or) + (const (@star (-not X Y) (-or Y Z R) (+impl X Z R)))))) + +(:: impl2 (impl_spec / checker)) +(def impl2 + (exec (union (union #not #or) + (const (@star (-not X Y) (-or Y Z R) (+impl X Z R)))))) + +(== ex (const (star (+ex 1 1)) (star (+ex 0 1)))) +(def ex + (union (union #not #or) + (const (@star (-not X R1) (-or R1 X R2) (+ex X R2))))) + +'how to show the values of X, Y and Z for which X /\ ~(Y /\ Z) is true? +(show-exec + (union (union (union #or #not) #and) + (const (@star (-or Y Z R1) (-not R1 R2) (-and X R2 1) (x X) (y Y) (z Z))))) diff --git a/exercises/solutions/04-boolean.sg b/exercises/solutions/04-boolean.sg deleted file mode 100644 index a0ee86d..0000000 --- a/exercises/solutions/04-boolean.sg +++ /dev/null @@ -1,63 +0,0 @@ -'fill the #your_answer hole by following the specifications - -checker = galaxy - interaction = #tested #test. - expect = ok. -end - -not_spec = galaxy - test0 = @-not(0 1) ok. - test1 = @-not(1 0) ok. -end - -not :: not_spec [checker]. -not = +not(0 1); +not(1 0). - -'how to print the truth table of NOT ? -table_not :=: table_not(0 1); table_not(1 0). -table_not = #not {@-not(X Y) table_not(X Y)}. - -and_spec = galaxy - test00 = @-and(0 0 0) ok. - test01 = @-and(0 1 0) ok. - test10 = @-and(1 0 0) ok. - test11 = @-and(1 1 1) ok. -end - -and :: and_spec [checker]. -and = +and(0 0 0); +and(0 1 0); +and(1 0 0); +and(1 1 1). - -and2 :: and_spec [checker]. -and2 = +and(0 X 0); +and(1 X X). - -or_spec = galaxy - test00 = @-or(0 0 0) ok. - test01 = @-or(0 1 1) ok. - test10 = @-or(1 0 1) ok. - test11 = @-or(1 1 1) ok. -end - -or :: or_spec [checker]. -or = +or(0 0 0); +or(0 1 1); +or(1 0 1); +or(1 1 1). - -or2 :: or_spec [checker]. -or2 = +or(0 X X); +or(1 X 1). - -impl_spec = galaxy - test00 = @-impl(0 0 1) ok. - test01 = @-impl(0 1 1) ok. - test10 = @-impl(1 0 0) ok. - test11 = @-impl(1 1 1) ok. -end - -impl :: impl_spec [checker]. -impl = exec #not #or @{-not(X Y) -or(Y Z R) +impl(X Z R)} end. - -impl2 :: impl_spec [checker]. -impl2 = exec #not #or @{-not(X Y) -or(Y Z R) +impl(X Z R)} end. - -ex :=: +ex(1 1); +ex(0 1). -ex = #not #or @{-not(X R1) -or(R1 X R2) +ex(X R2)}. - -'how to show the values of X, Y and Z for which X /\ ~(Y /\ Z) is true? -show-exec #or #not #and @{-or(Y Z R1) -not(R1 R2) -and(X R2 1) x(X) y(Y) z(Z)}. diff --git a/nvim/syntax/stellogen.vim b/nvim/syntax/stellogen.vim index 9184566..02ae730 100644 --- a/nvim/syntax/stellogen.vim +++ b/nvim/syntax/stellogen.vim @@ -1,6 +1,6 @@ syn clear -syn keyword sgKeyword def const star show use exec spec linear trace process end galaxy run interface union +syn keyword sgKeyword def kill clean const star show use exec spec linear trace process end galaxy run interface union syn match sgComment "\s*'[^'].*$" syn match sgId "#\%(\l\|\d\)\w*" syn region sgComment start="'''" end="'''" contains=NONE diff --git a/src/lsc/lsc_parser.mly b/src/lsc/lsc_parser.mly index 471c541..f2e896c 100644 --- a/src/lsc/lsc_parser.mly +++ b/src/lsc/lsc_parser.mly @@ -14,7 +14,9 @@ open Lsc_ast %% -let constellation_file := mcs=marked_constellation; EOF; { mcs } +let constellation_file := + | EOF; { [] } + | mcs=marked_constellation; EOF; { mcs } let marked_constellation := | ~=star+; <> @@ -27,8 +29,8 @@ let star_content := | l=ray*; bs=pars(bans)?; { { content=l; bans=Option.to_list bs |> List.concat } } -%public let bans := - | BANS; ~=ban+; <> +let bans := + | ~=pars(ban)+; <> let ban := | NEQ; r1=ray; r2=ray; { Ineq (r1, r2) } @@ -53,10 +55,11 @@ let polarity := let blocks := | LBRACK; AMP; pf=symbol; rs=ray+; RBRACK; - { Base.List.reduce_exn rs ~f:(fun r1 r2 -> to_func (pf, [r2; r1]) ) } + { Base.List.reduce_exn (List.rev rs) + ~f:(fun r1 r2 -> to_func (pf, [r2; r1]) ) } | LBRACK; rs=ray+; RBRACK; - { Base.List.reduce_exn rs ~f:(fun r1 r2 -> - to_func (muted (Null, "cons"), [r2; r1]) ) } + { Base.List.reduce_exn (List.rev rs) + ~f:(fun r1 r2 -> to_func (muted (Null, "cons"), [r2; r1]) ) } | LANGLE; pfs=symbol+; SLASH; r=ray; RANGLE; { Base.List.fold_right pfs ~init:r ~f:(fun pf base -> to_func (pf, [base]) ) } diff --git a/src/lsc/unification.ml b/src/lsc/unification.ml index 1f4b1c7..4035933 100644 --- a/src/lsc/unification.ml +++ b/src/lsc/unification.ml @@ -34,9 +34,12 @@ module Make (Sig : Signature) = struct match (t, u) with | Var x, Var y -> Sig.equal_idvar x y | Func ((Muted, f), ts), Func ((Muted, g), us) - | Func ((Noisy, f), ts), Func ((Noisy, g), us) -> - Sig.equal_idfunc f g - && List.for_all2_exn ~f:(fun t u -> equal_term t u) ts us + | Func ((Noisy, f), ts), Func ((Noisy, g), us) -> begin + try + Sig.equal_idfunc f g + && List.for_all2_exn ~f:(fun t u -> equal_term t u) ts us + with _ -> false + end | _ -> false type substitution = (Sig.idvar * term) list diff --git a/src/stellogen/sgen_lexer.ml b/src/stellogen/sgen_lexer.ml index 0847b93..32642b5 100644 --- a/src/stellogen/sgen_lexer.ml +++ b/src/stellogen/sgen_lexer.ml @@ -11,6 +11,7 @@ let rec read lexbuf = | "run" -> RUN | "const" -> CONST | "union" -> UNION + | "process" -> PROCESS | "get" -> GET (* | "interface" -> INTERFACE *) | "show" -> SHOW @@ -23,14 +24,17 @@ let rec read lexbuf = | "linear-exec" -> LINEXEC | "show-exec" -> SHOWEXEC | "galaxy" -> GALAXY - (* | "process" -> PROCESS *) | "#" -> SHARP | "&" -> AMP | ':' -> CONS + | '=' -> EQ | '"' -> read_string (Buffer.create 255) lexbuf (* Stellar resolution *) | "!=" -> NEQ + | "!@" -> INCOMP + | "=>" -> DRARROW | "star" -> STAR + | "bans" -> BANS | '_' -> PLACEHOLDER | '[' -> LBRACK | ']' -> RBRACK @@ -96,6 +100,7 @@ and read_string buf lexbuf = and comment lexbuf = match%sedlex lexbuf with | eof -> EOF + | '\r' | '\n' | "\r\n" -> read lexbuf | _ -> ignore (Sedlexing.next lexbuf); comment lexbuf diff --git a/src/stellogen/sgen_parser.mly b/src/stellogen/sgen_parser.mly index c9eb9f6..621cb44 100644 --- a/src/stellogen/sgen_parser.mly +++ b/src/stellogen/sgen_parser.mly @@ -11,6 +11,8 @@ open Sgen_ast %token CONST %token GET %token DEF +%token PROCESS +%token DRARROW %token TRACE %token UNION %token SHARP @@ -45,12 +47,12 @@ let type_declaration := | EQ; EQ; x=ident; g=galaxy_expr; { TExp (x, g) } let type_expr := - | t=ident; { (t, None) } - | LPAR; t=ident; ck=ident; RPAR; { (t, Some ck) } + | t=ident; { (t, None) } + | LPAR; t=ident; SLASH; ck=ident; RPAR; { (t, Some ck) } let galaxy_expr := | ~=galaxy_content; <> - (*| ~=pars(process); <> *) + | ~=pars(process); <> (* let interface_item := ~=pars(type_declaration); <> *) @@ -63,9 +65,9 @@ let prefixed_id := SHARP; ~=ident; let galaxy_content := | ~=pars(raw_galaxy); - | ~=galaxy_access; <> - | AT; ~=focussed_galaxy_content; - (*| ~=galaxy_content; ~=bracks(substitution); *) + | ~=pars(galaxy_access); <> + | AT; ~=galaxy_content; + | ~=galaxy_content; ~=bracks(substitution); | ~=pars(galaxy_block); <> | ~=prefixed_id; <> | LPAR; UNION; g1=galaxy_content; g2=galaxy_content; RPAR; @@ -81,16 +83,10 @@ let galaxy_block := | KILL; g=raw_galaxy; { Kill (Raw g) } | CLEAN; g=raw_galaxy; { Clean (Raw g) } -let focussed_galaxy_content := - | ~=galaxy_content; <> - | ~=pars(galaxy_access); <> - (* | ~=pars(galaxy_block); <> *) - let galaxy_access := - | GET; x=ident; y=ident; { Access (Id x, y) } - | GET; ~=galaxy_access; y=ident; + | GET; x=ident; y=ident; { Access (Id x, y) } + | GET; ~=pars(galaxy_access); y=ident; -(* let substitution := | DRARROW; ~=symbol; | ~=symbol; DRARROW; @@ -99,21 +95,17 @@ let substitution := | SHARP; ~=ident; DRARROW; ~=galaxy_expr; | SHARP; x=ident; DRARROW; h=marked_constellation; { SGal (x, Raw (Const h)) } -*) let galaxy_item := - | ~=ident; ~=galaxy_content; - (*| ~=ident; ~=pars(process); *) - | ~=type_declaration; + | ~=ident; ~=galaxy_content; + | ~=ident; ~=pars(process); + | ~=type_declaration; -(* let process := | PROCESS; { Process [] } | PROCESS; ~=process_item+; let process_item := - | ~=galaxy_content; <> - | ~=pars(raw_galaxy); - | pars(AMP; KILL); { Id (const "kill") } - | pars(AMP; CLEAN); { Id (const "clean") } -*) + | ~=galaxy_content; <> + | AMP; KILL; { Id (const "kill") } + | AMP; CLEAN; { Id (const "clean") } diff --git a/test/behavior/automata.sg b/test/behavior/automata.sg index c6eaa80..8230858 100644 --- a/test/behavior/automata.sg +++ b/test/behavior/automata.sg @@ -1,45 +1,45 @@ -binary = - -i(e) ok; - -i(0:X) +i(X); - -i(1:X) +i(X). - -e :: binary. -e = +i(e). - -0 :: binary. -0 = +i(0:e). - -1 :: binary. -1 = +i(1:e). - -a1 = galaxy - initial = - -i(W) +a(W q0). - final = - -a(e q2) accept. - transitions = - -a(0:W q0) +a(W q0); - -a(0:W q0) +a(W q1); - -a(1:W q0) +a(W q0); - -a(0:W q1) +a(W q2). -end - -empty = {}. - -tested :=: {}. -tested = process #e. #a1. &kill. end - -tested :=: {}. -tested = process #0. #a1. &kill. end - -tested :=: {}. -tested = process #1. #a1. &kill. end - -tested :=: accept. -tested = process +i(0:0:0:e). #a1. &kill. end - -tested :=: {}. -tested = process +i(0:1:0:e). #a1. &kill. end - -tested :=: {}. -tested = process +i(1:1:0:e). #a1. &kill. end +(spec binary + (const + (star (-i e) ok) + (star (-i [0 X]) (+i X)) + (star (-i [1 X]) (+i X)))) + +(def a1 + (galaxy + (initial + (const + (star (-i W) (+a W q0)))) + (final + (const + (star (-a e q2) accept))) + (transitions + (const + (star (-a [0 W] q0) (+a W q0)) + (star (-a [0 W] q0) (+a W q1)) + (star (-a [1 W] q0) (+a W q0)) + (star (-a [0 W] q1) (+a W q2)))))) + +(== tested (const)) +(def tested + (kill (exec + (union @(const (star (+i [0 e]))) #a1)))) + +(== tested (const)) +(def tested + (kill (exec + (union @(const (star (+i [1 e]))) #a1)))) + +(== tested (const)) +(def tested + (kill (exec + (union @(const (star (+i [0 1 0 e]))) #a1)))) + +(== tested (const)) +(def tested + (kill (exec + (union @(const (star (+i [1 1 0 e]))) #a1)))) + +(== tested (const (star accept))) +(def tested + (kill (exec + (union @(const (star (+i [0 0 0 e]))) #a1)))) diff --git a/test/behavior/galaxy.sg b/test/behavior/galaxy.sg index 54d1603..b86d722 100644 --- a/test/behavior/galaxy.sg +++ b/test/behavior/galaxy.sg @@ -1,18 +1,22 @@ -g = galaxy - test1 = 1. - test2 = galaxy - test21 = 2. - test22 = galaxy - test3 = 3. - end. - end. -end +(def g + (galaxy + (test1 (const (star 1))) + (test2 + (galaxy + (test21 + (const (star 2))) + (test22 + (galaxy + (test3 (const (star 3))))))))) -x :=: 1. -x = @#g->test1. +(== x (const (star 1))) +(def x + @(get g test1)) -x :=: 2. -x = @#g->test2->test21. +(== x (const (star 2))) +(def x + @(get (get g test2) test21)) -x :=: 3. -x = @#g->test2->test22->test3. +(== x (const (star 3))) +(def x + @(get (get (get g test2) test22) test3)) diff --git a/test/behavior/linear.sg b/test/behavior/linear.sg index 1d410f4..ed27c16 100644 --- a/test/behavior/linear.sg +++ b/test/behavior/linear.sg @@ -1,14 +1,21 @@ -1 = +nat(s(0)). -2 = +nat(s(s(0))). -3 = +nat(s(s(s(0)))). +(def 1 + (const (star (+nat (s 0))))) +(def 2 + (const (star (+nat )))) +(def 3 + (const (star (+nat )))) -nat = -nat(s(X)) +nat(X). +(spec nat + (const (star (-nat (s X)) (+nat X)))) -tested :=: +nat(0). -tested = @linear-exec (@#1) #nat end. +(== tested (const (star (+nat 0)))) +(def tested + @(linear-exec (union @#1 #nat))) -tested :=: +nat(s(0)). -tested = @linear-exec (@#2) #nat end. +(== tested (const (star (+nat )))) +(def tested + @(linear-exec (union @#2 #nat))) -tested :=: +nat(s(s(0))). -tested = @linear-exec (@#3) #nat end. +(== tested (const (star (+nat )))) +(def tested + @(linear-exec (union @#3 #nat))) diff --git a/test/behavior/prolog.sg b/test/behavior/prolog.sg index c7b3dd5..14aead8 100644 --- a/test/behavior/prolog.sg +++ b/test/behavior/prolog.sg @@ -1,25 +1,32 @@ -'''unary addition''' -add = - +add(0 Y Y); - -add(X Y Z) +add(s(X) Y s(Z)). +(def add + (const + (star (+add 0 Y Y)) + (star (-add X Y Z) (+add (s X) Y (s Z))))) -tested :=: 0. -tested = #add @(-add(0 0 R) R). +(== tested (const (star 0))) +(def tested + (union #add @(const (star (-add 0 0 R) R)))) -tested :=: s(0). -tested = #add @(-add(s(0) 0 R) R). +(== tested (const (star (s 0)))) +(def tested + (union #add @(const (star (-add (s 0) 0 R) R)))) -tested :=: s(0). -tested = #add @(-add(0 s(0) R) R). +(== tested (const (star (s 0)))) +(def tested + (union #add @(const (star (-add 0 (s 0) R) R)))) -tested :=: s(s(s(s(0)))). -tested = #add @(-add(s(s(0)) s(s(0)) R) R). +(== tested (const (star ))) +(def tested + (union #add @(const (star (-add R) R)))) -tested :=: 0. -tested = #add @(-add(s(s(0)) R s(s(0))) R). +(== tested (const (star 0))) +(def tested + (union #add @(const (star (-add R ) R)))) -tested :=: s(0). -tested = #add @(-add(s(s(0)) R s(s(s(0)))) R). +(== tested (const (star ))) +(def tested + (union #add @(const (star (-add R ) R)))) -tested :=: s(s(0)). -tested = #add @(-add(s(s(0)) R s(s(s(s(0))))) R). +(== tested (const (star ))) +(def tested + (union #add @(const (star (-add R ) R)))) diff --git a/test/syntax/blocks.sg b/test/syntax/blocks.sg deleted file mode 100644 index 57090c3..0000000 --- a/test/syntax/blocks.sg +++ /dev/null @@ -1,8 +0,0 @@ -x = exec 0 end. -x = linear-exec 0 end. -x = exec exec 0 end end. -x = linear-exec linear-exec 0 end end. -x = exec linear-exec 0 end end. -x = linear-exec exec 0 end end. -x = exec linear-exec 0 end linear-exec end exec. -x = linear-exec exec 0 end exec end linear-exec. diff --git a/test/syntax/definitions.sg b/test/syntax/definitions.sg deleted file mode 100644 index 7731aaf..0000000 --- a/test/syntax/definitions.sg +++ /dev/null @@ -1,99 +0,0 @@ -'normal -x = +a. -x = -a. -x = +a b; -c d. -x = { a }. -x = { [a] }. -x = { +a }. -x = { -a }. -x = { [-a] }. -x = { +a b; -c d }. -x = { [+a b]; -c d }. -x = { +a b; [-c d] }. -x = { a b }. -x = { a b; -c d }. - -'cons -x = +w(0:1:0:1:e). -x = +w((0:(1:(0:(1:e))))). -x = +w((((0:1):0):1):e). -x = +w((0:1):(0:1):e). -x = +w(0:(1:0):(1:e)). -x = +w((0:1):0:(1:e)). - -'trailing end of star -'FIXME: it should work -'x = { a; }. - -'focussed -x = [@+a]. -x = [@+a b]; -c d. -x = +a b; [@-c d]. -x = [@+a b]; [@-c d]. -x = { [@a] }. -x = { @+a }. -x = { [@-a] }. -x = { [@+a b]; -c d }. -x = { [+a b]; @-c d }. -x = { @+a b; [-c d] }. -x = { +a b; [@-c d] }. -x = { @+a b; [@-c d] }. -x = { @a b }. -x = { @a b; -c d }. -x = { a b; @-c d }. -x = { @a b; @-c d }. - -'ineq -x = +f(X); +f(Y) | X!=Y Y!=X X!=g(Y) g(X)!=Y. -x = +f(X) | X!=Y Y!=X X!=g(Y) g(X)!=Y; +f(Y). -x = +f(X) | X!=Y Y!=X X!=g(Y) g(X)!=Y. -x = +f(X) | X!=Y Y!=X X!=g(Y) g(X)!=Y. -x = +f(X) | X != Y Y != X X != g(Y) g(X) != Y. -x = +f(X) | - X!=Y Y!=X X!=g(Y) g(X)!=Y. -x = +f(X) | - X!=Y - Y!=X - X!=g(Y) - g(X)!=Y. -x = +f(X) | - X!=Y Y!=X - X!=g(Y) g(X)!=Y. -'''FIXME - x = +f(X) - | X!=Y Y!=X X!=g(Y) g(X)!=Y. -''' - -'incomp -x = +f(X) | a:b; +f(Y) | a:c. -x = +f(X) | X!=Y a:b X!=Y; +f(Y) | X!=Y a:c X!=Y. -x = +f(X) | a:b a:b a:b; +f(Y) | a:c a:c a:c. - -'with EOL -'''FIX ME -x -= -+a -. - -x -= -@ -+a -. - -x -= -{+a} -. - -x -= -{@+a} -. - -x -= -{[a]} -. -''' diff --git a/test/syntax/galaxy.sg b/test/syntax/galaxy.sg deleted file mode 100644 index 66f96b5..0000000 --- a/test/syntax/galaxy.sg +++ /dev/null @@ -1,37 +0,0 @@ -g = galaxy end -g = galaxy end galaxy - -g = galaxy -end - -g = galaxy - test1 = 1. - test2 = 2. -end - -g = galaxy - test1 = 1. - test2 = 2. -end galaxy - -g = galaxy - test1 = galaxy - test2 = galaxy - end. - end. -end - -g = galaxy - test1 = galaxy - test11 = 11. - test12 = 12. - end. - test2 = galaxy - test21 = 21. - test22 = 22. - end. -end - -x = #g->test1. -x = #g->test1->test11. -x = #g->test1->test11->test111. From a060461b5440b10acf44e406d4a9997bf79dfce9 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 1 Jun 2025 18:16:50 +0200 Subject: [PATCH 07/45] Add interfaces back and fix bans --- examples/mall.sg | 10 ++-------- examples/syntax.sg | 16 +++++++++++++++- src/lsc/lsc_lexer.ml | 1 - src/lsc/lsc_parser.mly | 5 ++--- src/stellogen/sgen_lexer.ml | 5 ++--- src/stellogen/sgen_parser.mly | 23 +++++++++++------------ 6 files changed, 32 insertions(+), 28 deletions(-) diff --git a/examples/mall.sg b/examples/mall.sg index 625106e..a745251 100644 --- a/examples/mall.sg +++ b/examples/mall.sg @@ -1,15 +1,10 @@ -''' (def left (const (star - (+5 [l l X]) (+5 [l r X]) - (!@ c a))))) - ''' + (+5 [l l X]) (+5 [l r X]) / (!@ c a)))) -''' (def right (const - (star (+5 [r l X]) (+5 [r r X) - (bans (!@ c b))))) + (star (+5 [r l X]) (+5 [r r X]) / (!@ c b)))) (def with (union #left #right)) @@ -26,4 +21,3 @@ #with (union #plus #cut) &kill)) -''' diff --git a/examples/syntax.sg b/examples/syntax.sg index c56a09b..2c60be5 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -31,7 +31,11 @@ (star a) (star b) (star c)))) 'inequality constraints -'ineq = +f(a); +f(b); @-f(X) -f(Y) r(X Y) | X!=Y. +(def ineq + (const + (star (+f a)) + (star (+f b)) + (@star (-f X) (-f Y) (r X Y) / (!= X Y)))) 'interactive debugging of execution '(trace ineq) @@ -110,6 +114,16 @@ (def 4 (const (star (+nat )))) +(interface nat_pair + (:: n nat) + (:: m nat)) + +(:: g_pair nat_pair) +(def g_pair + (galaxy + (n (const (star (+nat 0)))) + (m (const (star (+nat 0)))))) + 'galaxy with type declarations (show (galaxy (:: n1 nat) diff --git a/src/lsc/lsc_lexer.ml b/src/lsc/lsc_lexer.ml index 2afa421..53385ea 100644 --- a/src/lsc/lsc_lexer.ml +++ b/src/lsc/lsc_lexer.ml @@ -66,7 +66,6 @@ and comments lexbuf = and read lexbuf = match%sedlex lexbuf with | "star" -> STAR - | "bans" -> BANS | is_var_start, Star is_var_rest -> VAR (Utf8.lexeme lexbuf) | is_func_start, Star is_func_rest -> SYM (Utf8.lexeme lexbuf) | '\'' -> comment lexbuf diff --git a/src/lsc/lsc_parser.mly b/src/lsc/lsc_parser.mly index f2e896c..33b3e02 100644 --- a/src/lsc/lsc_parser.mly +++ b/src/lsc/lsc_parser.mly @@ -4,7 +4,6 @@ open Lsc_ast %token VAR %token SYM -%token BANS %token NEQ INCOMP %token PLUS MINUS %token PLACEHOLDER @@ -26,11 +25,11 @@ let star := | ~=pars(AT; STAR; star_content); let star_content := - | l=ray*; bs=pars(bans)?; + | l=ray*; bs=bans?; { { content=l; bans=Option.to_list bs |> List.concat } } let bans := - | ~=pars(ban)+; <> + | SLASH; ~=pars(ban)+; <> let ban := | NEQ; r1=ray; r2=ray; { Ineq (r1, r2) } diff --git a/src/stellogen/sgen_lexer.ml b/src/stellogen/sgen_lexer.ml index 32642b5..6a14ebb 100644 --- a/src/stellogen/sgen_lexer.ml +++ b/src/stellogen/sgen_lexer.ml @@ -13,7 +13,7 @@ let rec read lexbuf = | "union" -> UNION | "process" -> PROCESS | "get" -> GET - (* | "interface" -> INTERFACE *) + | "interface" -> INTERFACE | "show" -> SHOW | "spec" -> SPEC | "def" -> DEF @@ -30,11 +30,10 @@ let rec read lexbuf = | '=' -> EQ | '"' -> read_string (Buffer.create 255) lexbuf (* Stellar resolution *) - | "!=" -> NEQ | "!@" -> INCOMP + | "!=" -> NEQ | "=>" -> DRARROW | "star" -> STAR - | "bans" -> BANS | '_' -> PLACEHOLDER | '[' -> LBRACK | ']' -> RBRACK diff --git a/src/stellogen/sgen_parser.mly b/src/stellogen/sgen_parser.mly index 621cb44..345fe98 100644 --- a/src/stellogen/sgen_parser.mly +++ b/src/stellogen/sgen_parser.mly @@ -3,7 +3,7 @@ open Sgen_ast %} %token SHOW SHOWEXEC -(* %token INTERFACE *) +%token INTERFACE %token USE %token RUN %token CONS @@ -31,16 +31,15 @@ let program := ~=pars(declaration)*; EOF; <> let ident := ~=ray; <> let declaration := - | SPEC; ~=ident; ~=galaxy_expr; - | DEF; ~=ident; ~=galaxy_expr; - | SHOW; ~=galaxy_expr; - | SHOWEXEC; ~=galaxy_expr; - | TRACE; ~=galaxy_expr; - | RUN; ~=galaxy_expr; - | ~=type_declaration; - | USE; ~=ident+; - (* | INTERFACE; EOL*; x=ident; EOL*; i=interface_item*; END; INTERFACE?; - { Def (x, Raw (Interface i)) } *) + | SPEC; ~=ident; ~=galaxy_expr; + | DEF; ~=ident; ~=galaxy_expr; + | SHOW; ~=galaxy_expr; + | SHOWEXEC; ~=galaxy_expr; + | TRACE; ~=galaxy_expr; + | RUN; ~=galaxy_expr; + | ~=type_declaration; + | USE; ~=ident+; + | INTERFACE; x=ident; i=interface_item*; { Def (x, Raw (Interface i)) } let type_declaration := | CONS; CONS; x=ident; ts=type_expr+; { TDef (x, ts) } @@ -54,7 +53,7 @@ let galaxy_expr := | ~=galaxy_content; <> | ~=pars(process); <> -(* let interface_item := ~=pars(type_declaration); <> *) +let interface_item := ~=pars(type_declaration); <> let raw_galaxy := | CONST; { Const [] } From 05ad3ab591255e495c729f7cc08e06649554cf73 Mon Sep 17 00:00:00 2001 From: engboris Date: Wed, 4 Jun 2025 23:54:33 +0200 Subject: [PATCH 08/45] Update README and examples --- README.md | 80 ++++++++++++++++++++++++++-------------------- examples/syntax.sg | 2 +- 2 files changed, 47 insertions(+), 35 deletions(-) diff --git a/README.md b/README.md index 5c2f586..ac35314 100644 --- a/README.md +++ b/README.md @@ -28,7 +28,6 @@ It draws (or try to draw) inspiration from: - Smalltalk (for message-passing, object-oriented paradigm and minimalism); - Coq (for proof-as-program paradigm and iterative programming with tactics); - Scheme/Racket (for minimalism and metaprogramming); -- Haskell/Ruby/Lua (for syntax); - Shen (for its optional type systems and its "power and responsibility" philosophy). @@ -37,39 +36,52 @@ philosophy). Finite state machine ``` -spec binary = - -i(e) ok; - -i(0:X) +i(X); - -i(1:X) +i(X). - -e :: binary. -e = +i(e). - -000 :: binary. -000 = +i(0:0:0:e). - -010 :: binary. -010 = +i(0:1:0:e). - -110 :: binary. -110 = +i(1:1:0:e). - -a1 = galaxy - initial = - -i(W) +a(W q0). - final = - -a(e q2) accept. - transitions = - -a(0:W q0) +a(W q0); - -a(0:W q0) +a(W q1); - -a(1:W q0) +a(W q0); - -a(0:W q1) +a(W q2). -end - -show process #e. #a1. &kill. end -show process #000. #a1. &kill. end -show process #010. #a1. &kill. end -show process #110. #a1. &kill. end +(spec binary + (const + (star (-i e) ok) + (star (-i [0 X]) (+i X)) + (star (-i [1 X]) (+i X)))) + +'input words +(:: e binary) +(def e + (const (star (+i e)))) + +(:: 000 binary) +(def 000 + (const (star (+i [0 0 0 e])))) + +(:: 010 binary) +(def 010 + (const (star (+i [0 1 0 e])))) + +(:: 110 binary) +(def 110 + (const (star (+i [1 1 0 e])))) + +(def a1 + (galaxy + (initial + (const + (star (-i W) (+a W q0)))) + (final + (const + (star (-a e q2) accept))) + (transitions + (const + (star (-a [0 W] q0) (+a W q0)) + (star (-a [0 W] q0) (+a W q1)) + (star (-a [1 W] q0) (+a W q0)) + (star (-a [0 W] q1) (+a W q2)))))) + +(show (kill (exec + (union @#e #a1)))) +(show (kill (exec + (union @#000 #a1)))) +(show (kill (exec + (union @#010 #a1)))) +(show (kill (exec + (union @#110 #a1)))) ``` More examples can be found in `examples/`. diff --git a/examples/syntax.sg b/examples/syntax.sg index 2c60be5..2ffddcb 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -25,7 +25,7 @@ 'print result of execution (show-exec (const - (star a) (star b) (star c))) + (star a) (star b) (star c))) (show (exec (const (star a) (star b) (star c)))) From e8ce0dd9a27075a8efe1e4b7db14e5dbc938c847 Mon Sep 17 00:00:00 2001 From: engboris Date: Thu, 12 Jun 2025 00:13:20 +0200 Subject: [PATCH 09/45] Add new parsing method for Stellogen and remove LSC binary and library --- bin/dune | 6 +- bin/lscrun.ml | 62 ---------- bin/sgen.ml | 14 ++- examples/automata.sg | 54 +++------ src/{stellogen => archive}/sgen_lexer.ml | 0 src/{stellogen => archive}/sgen_parser.mly | 0 src/common/common_parser.mly | 23 ---- src/common/dune | 3 - src/common/format_exn.ml | 1 - src/dune | 14 +++ src/expr.ml | 134 +++++++++++++++++++++ src/lexer.ml | 47 ++++++++ src/lsc/dune | 16 --- src/lsc/lsc_lexer.ml | 93 -------------- src/lsc/lsc_parser.mly | 64 ---------- src/{lsc => }/lsc_ast.ml | 2 +- src/{lsc => }/lsc_err.ml | 3 +- src/parser.mly | 42 +++++++ src/{common => }/pretty.ml | 0 src/{stellogen => }/sgen_ast.ml | 1 - src/{stellogen => }/sgen_err.ml | 0 src/{stellogen => }/sgen_eval.ml | 19 ++- src/{stellogen => }/sgen_parsing.ml | 6 +- src/stellogen/dune | 15 --- src/stellogen/lsc_ast.ml | 1 - src/stellogen/lsc_err.ml | 1 - src/stellogen/lsc_parser.mly | 1 - src/stellogen/unification.ml | 1 - src/{lsc => }/unification.ml | 0 test/dune | 3 +- test/lsc/basic.stellar | 2 - test/lsc/empty.stellar | 0 test/lsc/prolog.stellar | 3 - test/test.ml | 34 ++---- 34 files changed, 292 insertions(+), 373 deletions(-) delete mode 100644 bin/lscrun.ml rename src/{stellogen => archive}/sgen_lexer.ml (100%) rename src/{stellogen => archive}/sgen_parser.mly (100%) delete mode 100644 src/common/common_parser.mly delete mode 100644 src/common/dune delete mode 100644 src/common/format_exn.ml create mode 100644 src/dune create mode 100644 src/expr.ml create mode 100644 src/lexer.ml delete mode 100644 src/lsc/dune delete mode 100644 src/lsc/lsc_lexer.ml delete mode 100644 src/lsc/lsc_parser.mly rename src/{lsc => }/lsc_ast.ml (99%) rename src/{lsc => }/lsc_err.ml (93%) create mode 100644 src/parser.mly rename src/{common => }/pretty.ml (100%) rename src/{stellogen => }/sgen_ast.ml (98%) rename src/{stellogen => }/sgen_err.ml (100%) rename src/{stellogen => }/sgen_eval.ml (97%) rename src/{stellogen => }/sgen_parsing.ml (92%) delete mode 100644 src/stellogen/dune delete mode 120000 src/stellogen/lsc_ast.ml delete mode 120000 src/stellogen/lsc_err.ml delete mode 120000 src/stellogen/lsc_parser.mly delete mode 120000 src/stellogen/unification.ml rename src/{lsc => }/unification.ml (100%) delete mode 100644 test/lsc/basic.stellar delete mode 100644 test/lsc/empty.stellar delete mode 100644 test/lsc/prolog.stellar diff --git a/bin/dune b/bin/dune index d04003a..1d3a4fc 100644 --- a/bin/dune +++ b/bin/dune @@ -1,7 +1,7 @@ (executables - (public_names lsc sgen isgen) - (names lscrun sgen isgen) - (libraries lsc stellogen base cmdliner)) + (public_names sgen) + (names sgen) + (libraries stellogen base cmdliner)) (env (dev diff --git a/bin/lscrun.ml b/bin/lscrun.ml deleted file mode 100644 index 71d299b..0000000 --- a/bin/lscrun.ml +++ /dev/null @@ -1,62 +0,0 @@ -open Base -open Cmdliner -open Lsc.Lsc_ast -open Lsc.Lsc_err -open Out_channel - -let parse_and_eval input_file unfincomp linear showtrace = - let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in input_file) in - let start_pos filename = - { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } - in - Sedlexing.set_position lexbuf (start_pos input_file); - let lexer = Sedlexing.with_tokenizer Lsc.Lsc_lexer.read lexbuf in - let parser = - MenhirLib.Convert.Simplified.traditional2revised - Lsc.Lsc_parser.constellation_file - in - let mcs = parser lexer in - let result = - match exec ~linear ~showtrace mcs with - | Ok result -> result - | Error e -> - pp_err_effect e |> Out_channel.output_string Out_channel.stderr; - Stdlib.exit 1 - in - if not showtrace then - result - |> (if unfincomp then kill else Fn.id) - |> string_of_constellation |> Stdlib.print_endline - else output_string stdout "No interaction left.\n" - -let input_file_arg = - let doc = "Input file to process." in - Arg.(required & pos 0 (some string) None & info [] ~docv:"FILENAME" ~doc) - -let unfincomp_flag = - let doc = - "Show stars containing polarities which are left after execution\n\n\ - \ (they correspond to unfinished computation and are omitted by \ - default)." - in - Arg.(value & flag & info [ "unfincomp" ] ~doc) - -let showtrace_flag = - let doc = "Interactively show steps of selection and unification." in - Arg.(value & flag & info [ "showtrace" ] ~doc) - -let linear_flag = - let doc = "Actions which are used are consummed." in - Arg.(value & flag & info [ "linear" ] ~doc) - -let term = - let open Term in - const (fun input_file unfincomp showtrace linear -> - try Ok (parse_and_eval input_file unfincomp showtrace linear) - with e -> Error (`Msg (Stdlib.Printexc.to_string e)) ) - $ input_file_arg $ unfincomp_flag $ showtrace_flag $ linear_flag - |> term_result - -let cmd = Cmd.v (Cmd.info "sgen" ~doc:"Run the Stellogen program.") term - -let () = Stdlib.exit (Cmd.eval cmd) diff --git a/bin/sgen.ml b/bin/sgen.ml index de6859e..1d6f706 100644 --- a/bin/sgen.ml +++ b/bin/sgen.ml @@ -1,6 +1,6 @@ open Base open Cmdliner -open Stellogen.Sgen_eval +open Stellogen let parse_and_eval input_file typecheckonly notyping = let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in input_file) in @@ -8,8 +8,16 @@ let parse_and_eval input_file typecheckonly notyping = { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } in Sedlexing.set_position lexbuf (start_pos input_file); - let p = Stellogen.Sgen_parsing.parse_with_error lexbuf in - let _ = eval_program ~typecheckonly ~notyping p in + let expr = Sgen_parsing.parse_with_error lexbuf in + let expanded = List.map ~f:Expr.expand_macro expr in + Stdlib.print_string + (List.map ~f:Expr.to_string expanded |> String.concat ~sep:"\n"); + Stdlib.print_newline (); + Stdlib.print_string "----------------"; + Stdlib.flush Stdlib.stdout; + let p = Expr.program_of_expr expanded in + Stdlib.print_string "\n"; + let _ = Stellogen.Sgen_eval.eval_program ~typecheckonly ~notyping p in () let input_file_arg = diff --git a/examples/automata.sg b/examples/automata.sg index bd96bcb..a065a48 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -1,49 +1,33 @@ -(spec binary - (const - (star (-i e) ok) - (star (-i [0 X]) (+i X)) - (star (-i [1 X]) (+i X)))) +(spec binary [ + [(-i e) ok] + [(-i [0 X]) (+i X)] + [(-i [1 X]) (+i X)]]) 'input words (:: e binary) -(def e - (const (star (+i e)))) +(:= e (+i e)) (:: 000 binary) -(def 000 - (const (star (+i [0 0 0 e])))) +(:= 000 (+i [0 0 0 e])) (:: 010 binary) -(def 010 - (const (star (+i [0 1 0 e])))) +(:= 010 (+i [0 1 0 e])) (:: 110 binary) -(def 110 - (const (star (+i [1 1 0 e])))) +(:= 110 (+i [1 1 0 e])) ''' automaton accepting words ending with 00 ''' -(def a1 - (galaxy - (initial - (const - (star (-i W) (+a W q0)))) - (final - (const - (star (-a e q2) accept))) - (transitions - (const - (star (-a [0 W] q0) (+a W q0)) - (star (-a [0 W] q0) (+a W q1)) - (star (-a [1 W] q0) (+a W q0)) - (star (-a [0 W] q1) (+a W q2)))))) +(:= a1 [ + [(-i W) (+a W q0)] + [((-a e q2) accept)] + [(-a [0 W] q0) (+a W q0)] + [(-a [0 W] q0) (+a W q1)] + [(-a [1 W] q0) (+a W q0)] + [(-a [0 W] q1) (+a W q2)]]) -(show (kill (exec - (union @#e #a1)))) -(show (kill (exec - (union @#000 #a1)))) -(show (kill (exec - (union @#010 #a1)))) -(show (kill (exec - (union @#110 #a1)))) + + + + diff --git a/src/stellogen/sgen_lexer.ml b/src/archive/sgen_lexer.ml similarity index 100% rename from src/stellogen/sgen_lexer.ml rename to src/archive/sgen_lexer.ml diff --git a/src/stellogen/sgen_parser.mly b/src/archive/sgen_parser.mly similarity index 100% rename from src/stellogen/sgen_parser.mly rename to src/archive/sgen_parser.mly diff --git a/src/common/common_parser.mly b/src/common/common_parser.mly deleted file mode 100644 index ee1382b..0000000 --- a/src/common/common_parser.mly +++ /dev/null @@ -1,23 +0,0 @@ -%token PRINT -%token EOF -%token AT -%token EOL -%token AMP -%token STAR -%token SLASH -%token LBRACK RBRACK -%token LBRACE RBRACE -%token LANGLE RANGLE -%token LPAR RPAR - -%% - -let delimited_opt(l, x, r) := - | ~=x; <> - | ~=delimited(l, x, r); <> - -%public let pars(x) == ~=delimited(LPAR; EOL*, x, EOL*; RPAR); <> -%public let bracks(x) == ~=delimited(LBRACK; EOL*, x, EOL*; RBRACK); <> -%public let braces(x) == ~=delimited(LBRACE; EOL*, x, EOL*; RBRACE); <> -%public let bracks_opt(x) == ~=delimited_opt(LBRACK; EOL*, x, EOL*; RBRACK); <> -%public let braces_opt(x) == ~=delimited_opt(LBRACE; EOL*, x, EOL*; RBRACE); <> diff --git a/src/common/dune b/src/common/dune deleted file mode 100644 index 30e6468..0000000 --- a/src/common/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name common) - (libraries base)) diff --git a/src/common/format_exn.ml b/src/common/format_exn.ml deleted file mode 100644 index 7fd3d6a..0000000 --- a/src/common/format_exn.ml +++ /dev/null @@ -1 +0,0 @@ -let red text = "\x1b[31m" ^ text ^ "\x1b[0m" diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..e15b5f4 --- /dev/null +++ b/src/dune @@ -0,0 +1,14 @@ +(library + (name stellogen) + (libraries base menhirLib) + (preprocess + (pps sedlex.ppx))) + +(env + (dev + (flags + (:standard -warn-error -A)))) + +(menhir + (modules parser) + (flags --table --dump --explain)) diff --git a/src/expr.ml b/src/expr.ml new file mode 100644 index 0000000..67fe96a --- /dev/null +++ b/src/expr.ml @@ -0,0 +1,134 @@ +open Base +open Lsc_ast +open Sgen_ast + +type ident = string + +module Raw = struct + type t = + | Symbol of string + | Var of ident + | Focus of t + | Unquote of t + | List of t list + | Stack of t list + | Cons of t list +end + +type expr = + | Symbol of string + | Var of ident + | Unquote of expr + | List of expr list + +let cons_op = "cons" + +let unquote_op = "#" + +let focus_op = "@" + +let def_op = ":=" + +let typedef_op = "::" + +let expect_op = "==" + +let string_of_list lmark rmark l = + l |> String.concat ~sep:" " |> fun l' -> + Printf.sprintf "%s%s%s" lmark l' rmark + +let rec to_string : expr -> string = function + | Symbol s -> s + | Var x -> x + | Unquote e -> Printf.sprintf "%s%s" unquote_op (to_string e) + | List es -> es |> List.map ~f:to_string |> string_of_list "(" ")" + +let rec expand_macro : Raw.t -> expr = function + | Raw.Symbol s -> Symbol s + | Raw.Var x -> Var x + | Raw.Unquote e' -> Unquote (expand_macro e') + | Raw.Focus e' -> List [ Symbol focus_op; expand_macro e' ] + | Raw.List es -> List (List.map ~f:expand_macro es) + | Raw.Cons es -> + List.fold_left es ~init:(Symbol "nil") ~f:(fun acc e -> + List [ Symbol cons_op; expand_macro e; acc ] ) + | Raw.Stack [] -> List [] + | Raw.Stack (h :: t) -> + List.fold_left t ~init:(expand_macro h) ~f:(fun acc e -> + List [ expand_macro e; acc ] ) + +(* --------------------------------------- + Constellation of Expr + --------------------------------------- *) + +let symbol_of_str (s : string) : idfunc = + let rest = String.subo s ~pos:1 in + match String.get s 0 with + | '+' -> (Pos, rest) + | '-' -> (Neg, rest) + | _ -> (Null, s) + +let rec ray_of_expr : expr -> ray = function + | Symbol s -> to_func ((Muted, symbol_of_str s), []) + | Var s -> to_var s + | Unquote _ -> failwith "error: cannot unquote ray" + | List [] -> failwith "error: ray cannot be empty" + | List (Symbol h :: t) -> + to_func ((Muted, symbol_of_str h), List.map ~f:ray_of_expr t) + | List (_ :: _) -> failwith "error: ray must start with constant" + | e -> failwith ("error: unhandled ray" ^ to_string e) + +let rec star_of_expr : expr -> marked_star = function + | Symbol "nil" -> Marked { content = []; bans = [] } + | Symbol s -> Marked { content = []; bans = [] } + | Var x -> Marked { content = []; bans = [] } + | Unquote e -> Marked { content = []; bans = [] } + | List [ Symbol s; h; t ] when equal_string s cons_op -> begin + match star_of_expr t with + | Marked { content = next_content; bans = next_bans } -> + Marked { content = ray_of_expr h :: next_content; bans = next_bans } + end + | e -> failwith ("error: unhandled star" ^ to_string e) + +let rec constellation_of_expr : expr -> marked_constellation = function + | Symbol "nil" -> [] + | Symbol s -> [ Unmarked { content = [ var (s, None) ]; bans = [] } ] + | Var x -> [ Unmarked { content = [ var (x, None) ]; bans = [] } ] + | Unquote e -> failwith "error: can't unquote constellation" + | 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 = [] } ] + | e -> failwith ("error: unhandled constellation " ^ to_string e) + +(* --------------------------------------- + Galaxy expr of Expr + --------------------------------------- *) + +let rec galaxy_expr_of_expr : expr -> galaxy_expr = function + | Symbol s -> + Raw (Const [ Unmarked { content = [ ray_of_expr (Symbol s) ]; bans = [] } ]) + | Unquote g -> Id (ray_of_expr g) + | List [ Symbol k; g ] when equal_string k focus_op -> + Focus (galaxy_expr_of_expr g) + | List [ Symbol k; g ] when equal_string k "exec" -> + Exec (galaxy_expr_of_expr g) + | List [ Symbol k; g ] when equal_string k "linexec" -> + LinExec (galaxy_expr_of_expr g) + | List g -> Raw (Const (constellation_of_expr (List g))) + +(* --------------------------------------- + Stellogen program of Expr + --------------------------------------- *) + +let rec decl_of_expr : expr -> declaration = function + | List [ Symbol k; x; g ] when equal_string k def_op -> + Def (ray_of_expr x, Raw (Const (constellation_of_expr g))) + | List [ Symbol k; g ] when equal_string k "show" -> + Show (galaxy_expr_of_expr g) + | List [ Symbol k; g ] when equal_string k "trace" -> + Show (galaxy_expr_of_expr g) + | List [ Symbol k; x; g ] when equal_string k expect_op -> + TypeDef (TExp (ray_of_expr x, galaxy_expr_of_expr g)) + | _ -> failwith "error: invalid declaration" + +let program_of_expr = List.map ~f:decl_of_expr diff --git a/src/lexer.ml b/src/lexer.ml new file mode 100644 index 0000000..926e82e --- /dev/null +++ b/src/lexer.ml @@ -0,0 +1,47 @@ +open Sedlexing +open Parser + +exception SyntaxError of string + +let space = [%sedlex.regexp? Plus (' ' | '\t')] + +let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"] + +let rec comment lexbuf = + match%sedlex lexbuf with + | newline | eof -> read lexbuf + | _ -> + ignore (Sedlexing.next lexbuf); + comment lexbuf + +and comments lexbuf = + match%sedlex lexbuf with + | "'''" -> read lexbuf + | _ -> + ignore (Sedlexing.next lexbuf); + comments lexbuf + +and read lexbuf = + match%sedlex lexbuf with + | Plus (Compl (Chars "'\" \t\n\r()<>[]@#")) -> + let lexeme = Utf8.lexeme lexbuf in + begin + match lexeme.[0] with 'A' .. 'Z' -> VAR lexeme | _ -> SYM lexeme + end + | '(' -> LPAR + | ')' -> RPAR + | '[' -> LBRACK + | ']' -> RBRACK + | '<' -> LANGLE + | '>' -> RANGLE + | '@' -> AT + | '#' -> UNQUOTE + | '\'' -> comment lexbuf + | "'''" -> comments lexbuf + | '"' -> STRMARK + | space | newline -> read lexbuf + | eof -> EOF + | _ -> + raise + (SyntaxError + ("Unexpected character '" ^ Utf8.lexeme lexbuf ^ "' during lexing") ) diff --git a/src/lsc/dune b/src/lsc/dune deleted file mode 100644 index 518d1d4..0000000 --- a/src/lsc/dune +++ /dev/null @@ -1,16 +0,0 @@ -(library - (name lsc) - (libraries base common menhirLib) - (preprocess - (pps sedlex.ppx)) - (modules lsc_err lsc_ast unification lsc_parser lsc_lexer)) - -(env - (dev - (flags - (:standard -warn-error -A)))) - -(menhir - (modules ../common/common_parser lsc_parser) - (merge_into lsc_parser) - (flags --table --dump --explain)) diff --git a/src/lsc/lsc_lexer.ml b/src/lsc/lsc_lexer.ml deleted file mode 100644 index 53385ea..0000000 --- a/src/lsc/lsc_lexer.ml +++ /dev/null @@ -1,93 +0,0 @@ -open Sedlexing -open Lsc_parser - -exception SyntaxError of string - -let buf = Sedlexing.Utf8.from_channel - -let is_func_start = [%sedlex.regexp? 'a' .. 'z' | '0' .. '9'] - -let is_func_rest = - [%sedlex.regexp? 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '?'] - -let is_var_start = [%sedlex.regexp? 'A' .. 'Z'] - -let is_var_rest = - [%sedlex.regexp? 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '-'] - -let space = [%sedlex.regexp? Plus (' ' | '\t')] - -let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"] - -let rec read_string buf lexbuf = - match%sedlex lexbuf with - | '"' -> SYM ("\"" ^ Buffer.contents buf ^ "\"") - | '\\', '/' -> - Buffer.add_char buf '/'; - read_string buf lexbuf - | '\\', '\\' -> - Buffer.add_char buf '\\'; - read_string buf lexbuf - | '\\', 'b' -> - Buffer.add_char buf '\b'; - read_string buf lexbuf - | '\\', 'f' -> - Buffer.add_char buf '\012'; - read_string buf lexbuf - | '\\', 'n' -> - Buffer.add_char buf '\n'; - read_string buf lexbuf - | '\\', 'r' -> - Buffer.add_char buf '\r'; - read_string buf lexbuf - | '\\', 't' -> - Buffer.add_char buf '\t'; - read_string buf lexbuf - | Plus (Compl ('"' | '\\')) -> - Buffer.add_string buf (Utf8.lexeme lexbuf); - read_string buf lexbuf - | eof -> raise (SyntaxError "String is not terminated") - | _ -> raise (SyntaxError ("Illegal string character: " ^ Utf8.lexeme lexbuf)) - -and comment lexbuf = - match%sedlex lexbuf with - | newline | eof -> read lexbuf - | _ -> - ignore (Sedlexing.next lexbuf); - comment lexbuf - -and comments lexbuf = - match%sedlex lexbuf with - | "'''" -> read lexbuf - | _ -> - ignore (Sedlexing.next lexbuf); - comments lexbuf - -and read lexbuf = - match%sedlex lexbuf with - | "star" -> STAR - | is_var_start, Star is_var_rest -> VAR (Utf8.lexeme lexbuf) - | is_func_start, Star is_func_rest -> SYM (Utf8.lexeme lexbuf) - | '\'' -> comment lexbuf - | "'''" -> comments lexbuf - | '_' -> PLACEHOLDER - | '[' -> LBRACK - | ']' -> RBRACK - | '(' -> LPAR - | ')' -> RPAR - | '<' -> LANGLE - | '>' -> RANGLE - | '/' -> SLASH - | "!=" -> NEQ - | "!@" -> INCOMP - | '@' -> AT - | '&' -> AMP - | '+' -> PLUS - | '-' -> MINUS - | '"' -> read_string (Buffer.create 128) lexbuf - | space | newline -> read lexbuf - | eof -> EOF - | _ -> - raise - (SyntaxError - ("Unexpected character '" ^ Utf8.lexeme lexbuf ^ "' during lexing") ) diff --git a/src/lsc/lsc_parser.mly b/src/lsc/lsc_parser.mly deleted file mode 100644 index 33b3e02..0000000 --- a/src/lsc/lsc_parser.mly +++ /dev/null @@ -1,64 +0,0 @@ -%{ -open Lsc_ast -%} - -%token VAR -%token SYM -%token NEQ INCOMP -%token PLUS MINUS -%token PLACEHOLDER - -%start constellation_file -%start marked_constellation - -%% - -let constellation_file := - | EOF; { [] } - | mcs=marked_constellation; EOF; { mcs } - -let marked_constellation := - | ~=star+; <> - -let star := - | ~=pars(STAR; star_content); - | ~=pars(AT; STAR; star_content); - -let star_content := - | l=ray*; bs=bans?; - { { content=l; bans=Option.to_list bs |> List.concat } } - -let bans := - | SLASH; ~=pars(ban)+; <> - -let ban := - | NEQ; r1=ray; r2=ray; { Ineq (r1, r2) } - | INCOMP; r1=ray; r2=ray; { Incomp (r1, r2) } - -%public let symbol := - | p=polarity; AMP; f=SYM; { noisy (p, f) } - | p=polarity; AMP; PRINT; { noisy (p, "print") } - | p=polarity; f=SYM; { muted (p, f) } - | f=SYM; { muted (Null, f) } - -let polarity := - | PLUS; { Pos } - | MINUS; { Neg } - -%public let ray := - | PLACEHOLDER; { to_var ("_"^(fresh_placeholder ())) } - | ~=VAR; - | pf=symbol; { to_func (pf, []) } - | LPAR; pf=symbol; ts=ray+; RPAR; { to_func (pf, ts) } - | ~=blocks; <> - -let blocks := - | LBRACK; AMP; pf=symbol; rs=ray+; RBRACK; - { Base.List.reduce_exn (List.rev rs) - ~f:(fun r1 r2 -> to_func (pf, [r2; r1]) ) } - | LBRACK; rs=ray+; RBRACK; - { Base.List.reduce_exn (List.rev rs) - ~f:(fun r1 r2 -> to_func (muted (Null, "cons"), [r2; r1]) ) } - | LANGLE; pfs=symbol+; SLASH; r=ray; RANGLE; - { Base.List.fold_right pfs ~init:r ~f:(fun pf base -> - to_func (pf, [base]) ) } diff --git a/src/lsc/lsc_ast.ml b/src/lsc_ast.ml similarity index 99% rename from src/lsc/lsc_ast.ml rename to src/lsc_ast.ml index 88d4195..a957618 100644 --- a/src/lsc/lsc_ast.ml +++ b/src/lsc_ast.ml @@ -1,5 +1,5 @@ open Base -open Common.Pretty +open Pretty open Out_channel open In_channel open Lsc_err diff --git a/src/lsc/lsc_err.ml b/src/lsc_err.ml similarity index 93% rename from src/lsc/lsc_err.ml rename to src/lsc_err.ml index 1d1fee0..259ed32 100644 --- a/src/lsc/lsc_err.ml +++ b/src/lsc_err.ml @@ -1,5 +1,6 @@ open Base -open Common.Format_exn + +let red text = "\x1b[31m" ^ text ^ "\x1b[0m" type err_effect = | TooFewArgs of string diff --git a/src/parser.mly b/src/parser.mly new file mode 100644 index 0000000..b92f40d --- /dev/null +++ b/src/parser.mly @@ -0,0 +1,42 @@ +%{ +open Expr.Raw +%} + +%token VAR +%token SYM +%token STRMARK +%token AT +%token LPAR RPAR +%token LBRACK RBRACK +%token LANGLE RANGLE +%token UNQUOTE +%token EOF + +%start expr_file + +%% + +let delimited_opt(l, x, r) := + | ~=x; <> + | ~=delimited(l, x, r); <> + +let revlist(x) := + | { [] } + | t=revlist(x); h=x; { h::t } + +let pars(x) == ~=delimited(LPAR, x, RPAR); <> +let bracks(x) == ~=delimited(LBRACK, x, RBRACK); <> +let bracks_opt(x) == ~=delimited_opt(LBRACK, x, RBRACK); <> + +let expr_file := + | EOF; { [] } + | es=expr+; EOF; { es } + +let expr := + | ~=SYM; + | ~=VAR; + | UNQUOTE; ~=expr; + | AT; ~=expr; + | ~=pars(expr+); + | LANGLE; es=revlist(expr); RANGLE; + | LBRACK; es=revlist(expr); RBRACK; diff --git a/src/common/pretty.ml b/src/pretty.ml similarity index 100% rename from src/common/pretty.ml rename to src/pretty.ml diff --git a/src/stellogen/sgen_ast.ml b/src/sgen_ast.ml similarity index 98% rename from src/stellogen/sgen_ast.ml rename to src/sgen_ast.ml index 461053e..78f4f76 100644 --- a/src/stellogen/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -66,7 +66,6 @@ let initial_env = type declaration = | Def of ident * galaxy_expr | Show of galaxy_expr - | ShowExec of galaxy_expr | Trace of galaxy_expr | Run of galaxy_expr | TypeDef of type_declaration diff --git a/src/stellogen/sgen_err.ml b/src/sgen_err.ml similarity index 100% rename from src/stellogen/sgen_err.ml rename to src/sgen_err.ml diff --git a/src/stellogen/sgen_eval.ml b/src/sgen_eval.ml similarity index 97% rename from src/stellogen/sgen_eval.ml rename to src/sgen_eval.ml index 490f2a2..3064455 100644 --- a/src/stellogen/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -3,8 +3,7 @@ open Lsc_ast open Lsc_err open Sgen_ast open Sgen_err -open Common.Format_exn -open Common.Pretty +open Pretty open Out_channel let ( let* ) x f = Result.bind x ~f @@ -453,11 +452,9 @@ let rec eval_decl ~typecheckonly ~notyping env : in Ok env | Show _ when typecheckonly -> Ok env - | Show (Id x) -> begin - match get_obj env x with - | None -> Error (UnknownID (string_of_ray x)) - | Some e -> eval_decl ~typecheckonly ~notyping env (Show e) - end + | Show (Id x) -> + Show (Raw (Const [ Marked { content = [ func "#" [ x ] ]; bans = [] } ])) + |> eval_decl ~typecheckonly ~notyping env | Show (Raw (Galaxy g)) -> Galaxy g |> string_of_galaxy ~notyping env |> Stdlib.print_string; Stdlib.print_newline (); @@ -475,8 +472,6 @@ let rec eval_decl ~typecheckonly ~notyping env : |> string_of_constellation |> Stdlib.print_string; Stdlib.print_newline (); Ok env - | ShowExec _ when typecheckonly -> Ok env - | ShowExec e -> eval_decl ~typecheckonly ~notyping env (Show (Exec e)) | Trace _ when typecheckonly -> Ok env | Trace e -> let* eval_e = eval_galaxy_expr ~notyping env e in @@ -507,11 +502,13 @@ let rec eval_decl ~typecheckonly ~notyping env : { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } in Sedlexing.set_position lexbuf (start_pos formatted_filename); - let p = Sgen_parsing.parse_with_error lexbuf in + 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* env = eval_program ~typecheckonly ~notyping p in Ok env -and eval_program ~typecheckonly ~notyping p = +and eval_program ~typecheckonly ~notyping (p : program) = match List.fold_left ~f:(fun acc x -> diff --git a/src/stellogen/sgen_parsing.ml b/src/sgen_parsing.ml similarity index 92% rename from src/stellogen/sgen_parsing.ml rename to src/sgen_parsing.ml index 95006e4..a3bffec 100644 --- a/src/stellogen/sgen_parsing.ml +++ b/src/sgen_parsing.ml @@ -1,6 +1,6 @@ open Lexing -open Sgen_lexer -open Sgen_parser +open Lexer +open Parser let print_position fmt (pos : Lexing.position) = Format.fprintf fmt "%s:%d:%d" pos.pos_fname pos.pos_lnum @@ -8,7 +8,7 @@ let print_position fmt (pos : Lexing.position) = let parse_with_error lexbuf = let lexer = Sedlexing.with_tokenizer read lexbuf in - let parser = MenhirLib.Convert.Simplified.traditional2revised program in + let parser = MenhirLib.Convert.Simplified.traditional2revised expr_file in try parser lexer with SyntaxError msg -> let _start_pos, end_pos = Sedlexing.lexing_positions lexbuf in diff --git a/src/stellogen/dune b/src/stellogen/dune deleted file mode 100644 index 82edf30..0000000 --- a/src/stellogen/dune +++ /dev/null @@ -1,15 +0,0 @@ -(library - (name stellogen) - (libraries base common menhirLib) - (preprocess - (pps sedlex.ppx))) - -(env - (dev - (flags - (:standard -warn-error -A)))) - -(menhir - (modules ../common/common_parser lsc_parser sgen_parser) - (merge_into sgen_parser) - (flags --table --explain --dump)) diff --git a/src/stellogen/lsc_ast.ml b/src/stellogen/lsc_ast.ml deleted file mode 120000 index 6c30619..0000000 --- a/src/stellogen/lsc_ast.ml +++ /dev/null @@ -1 +0,0 @@ -../lsc/lsc_ast.ml \ No newline at end of file diff --git a/src/stellogen/lsc_err.ml b/src/stellogen/lsc_err.ml deleted file mode 120000 index 47e4f3c..0000000 --- a/src/stellogen/lsc_err.ml +++ /dev/null @@ -1 +0,0 @@ -../lsc/lsc_err.ml \ No newline at end of file diff --git a/src/stellogen/lsc_parser.mly b/src/stellogen/lsc_parser.mly deleted file mode 120000 index ea060e8..0000000 --- a/src/stellogen/lsc_parser.mly +++ /dev/null @@ -1 +0,0 @@ -../lsc/lsc_parser.mly \ No newline at end of file diff --git a/src/stellogen/unification.ml b/src/stellogen/unification.ml deleted file mode 120000 index 1d705c1..0000000 --- a/src/stellogen/unification.ml +++ /dev/null @@ -1 +0,0 @@ -../lsc/unification.ml \ No newline at end of file diff --git a/src/lsc/unification.ml b/src/unification.ml similarity index 100% rename from src/lsc/unification.ml rename to src/unification.ml diff --git a/test/dune b/test/dune index b55a4a3..5f5b1e5 100644 --- a/test/dune +++ b/test/dune @@ -2,12 +2,11 @@ (name test) (modules test) (deps - (glob_files ./lsc/*.stellar) (glob_files ./syntax/*.sg) (glob_files ./behavior/*.sg) (glob_files ../examples/*.sg) (glob_files ../exercises/solutions/*.sg)) - (libraries alcotest base stellogen lsc)) + (libraries alcotest base stellogen)) (env (dev diff --git a/test/lsc/basic.stellar b/test/lsc/basic.stellar deleted file mode 100644 index f843ff6..0000000 --- a/test/lsc/basic.stellar +++ /dev/null @@ -1,2 +0,0 @@ -(star (-f a)) -(@star (+f X) X) diff --git a/test/lsc/empty.stellar b/test/lsc/empty.stellar deleted file mode 100644 index e69de29..0000000 diff --git a/test/lsc/prolog.stellar b/test/lsc/prolog.stellar deleted file mode 100644 index 50dd7c7..0000000 --- a/test/lsc/prolog.stellar +++ /dev/null @@ -1,3 +0,0 @@ -(star (+add 0 Y Y)) -(star (-add X Y Z) (+add (s X) Y (s Z))) -(@star (-add R) R) diff --git a/test/test.ml b/test/test.ml index 2b09ffe..1d39489 100644 --- a/test/test.ml +++ b/test/test.ml @@ -1,28 +1,12 @@ open Base -let lsc filename () = - let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in filename) in - let lexer = Sedlexing.with_tokenizer Lsc.Lsc_lexer.read lexbuf in - let parser = - MenhirLib.Convert.Simplified.traditional2revised - Lsc.Lsc_parser.constellation_file - in - let mcs = parser lexer in - match Lsc.Lsc_ast.exec ~showtrace:false mcs with - | Error e -> Lsc.Lsc_err.pp_err_effect e - | Ok res -> Lsc.Lsc_ast.string_of_constellation res - let sgen filename () = let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in filename) in - let p = Stellogen.Sgen_parsing.parse_with_error lexbuf in + let expr = Stellogen.Sgen_parsing.parse_with_error lexbuf in + let expanded = List.map ~f:Stellogen.Expr.expand_macro expr in + let p = Stellogen.Expr.program_of_expr expanded in Stellogen.Sgen_eval.eval_program ~typecheckonly:false ~notyping:false p -let make_expect_test name path f expected = - let test got expected () = - Alcotest.(check string) "same string" got expected - in - (name, `Quick, test (f (path ^ name) ()) expected) - let make_ok_test name path f = let test got () = Alcotest.(check bool) "ending with success" true (Result.is_ok got) @@ -36,18 +20,14 @@ let run_dir test_f directory = not @@ Stdlib.Sys.is_directory (Stdlib.Filename.concat directory f) ) |> List.map ~f:(fun x -> make_ok_test x directory test_f) -let lsc_test_suite () = - let path = "./lsc/" in - [ make_expect_test "empty.stellar" path lsc "{}" - ; make_expect_test "basic.stellar" path lsc "a." - ; make_expect_test "prolog.stellar" path lsc "s(s(s(s(0))))." - ] +let () = Alcotest.run "Stellogen Test Suite" [] +(* FIXME let () = Alcotest.run "Stellogen Test Suite" - [ ("LSC test suite", lsc_test_suite ()) - ; ("Stellogen examples", run_dir sgen "../examples/") + [ ("Stellogen examples", run_dir sgen "../examples/") ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") ; ("Stellogen syntax", run_dir sgen "./syntax/") ; ("Stellogen behavior", run_dir sgen "./behavior/") ] +*) From feae9ee7969b6b90a24214f3c7de497de872b372 Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 13 Jun 2025 00:46:43 +0200 Subject: [PATCH 10/45] Extend binary union to n-ary union --- src/sgen_ast.ml | 2 +- src/sgen_eval.ml | 35 +++++++++++++++++++---------------- 2 files changed, 20 insertions(+), 17 deletions(-) diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index 78f4f76..0707047 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -28,7 +28,7 @@ and galaxy_expr = | Id of ident | Exec of galaxy_expr | LinExec of galaxy_expr - | Union of galaxy_expr * galaxy_expr + | Unions of galaxy_expr list | Subst of galaxy_expr * substitution | Focus of galaxy_expr | Clean of galaxy_expr diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 3064455..c68764d 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -56,10 +56,9 @@ and map_galaxy_expr env ~f : galaxy_expr -> (galaxy_expr, err) Result.t = | LinExec e -> let* map_e = map_galaxy_expr env ~f e in LinExec map_e |> Result.return - | Union (e, e') -> - let* map_e = map_galaxy_expr env ~f e in - let* map_e' = map_galaxy_expr env ~f e' in - Union (map_e, map_e') |> Result.return + | Unions es -> + let* map_es = List.map ~f:(map_galaxy_expr env ~f) es |> Result.all in + Unions map_es |> Result.return | Subst (e, Extend pf) -> let* map_e = map_galaxy_expr env ~f e in Subst (map_e, Extend pf) |> Result.return @@ -103,10 +102,9 @@ let rec replace_id env (_from : ident) (_to : galaxy_expr) e : | LinExec e -> let* g = replace_id env _from _to e in LinExec g |> Result.return - | Union (e1, e2) -> - let* g1 = replace_id env _from _to e1 in - let* g2 = replace_id env _from _to e2 in - Union (g1, g2) |> Result.return + | Unions es -> + let* gs = List.map ~f:(replace_id env _from _to) es |> Result.all in + Unions gs |> Result.return | Focus e -> let* g = replace_id env _from _to e in Focus g |> Result.return @@ -210,12 +208,16 @@ and eval_galaxy_expr ~notyping (env : env) : | Some g -> eval_galaxy_expr ~notyping env g end end - | Union (e, e') -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* eval_e' = eval_galaxy_expr ~notyping env e' in - let* mcs1 = eval_e |> galaxy_to_constellation ~notyping env in - let* mcs2 = eval_e' |> galaxy_to_constellation ~notyping env in - Ok (Const (mcs1 @ mcs2)) + | Unions es -> + let* eval_es = + List.map ~f:(eval_galaxy_expr ~notyping env) es |> Result.all + in + let* mcs = + eval_es + |> List.map ~f:(galaxy_to_constellation ~notyping env) + |> Result.all + in + Ok (Const (List.concat mcs)) | Exec e -> let* eval_e = eval_galaxy_expr ~notyping env e in let* mcs = galaxy_to_constellation ~notyping env eval_e in @@ -261,7 +263,7 @@ and eval_galaxy_expr ~notyping (env : env) : let origin = acc |> remove_mark_all |> focus in let* ev = eval_galaxy_expr ~notyping env - (Focus (Exec (Union (x, Raw (Const origin))))) + (Focus (Exec (Unions [ x; Raw (Const origin) ]))) in galaxy_to_constellation ~notyping env ev ) in @@ -380,7 +382,8 @@ and typecheck ~notyping env x (t : StellarRays.term) (ck : galaxy_expr) : | Error e -> Error e ) |> Result.all_unit -and default_interaction = Union (Focus (Id (const "tested")), Id (const "test")) +and default_interaction = + Unions [ Focus (Id (const "tested")); Id (const "test") ] and default_expect = Raw (Const [ Unmarked { content = [ func "ok" [] ]; bans = [] } ]) From 11792e3c65c342f9f3c05b59b3d83bf65573ef93 Mon Sep 17 00:00:00 2001 From: engboris Date: Sat, 14 Jun 2025 00:59:07 +0200 Subject: [PATCH 11/45] Add generalized unions in parsing --- examples/syntax.sg | 23 +++++++++++------------ examples/test.sg | 3 +++ src/expr.ml | 15 ++++++++++++++- src/sgen_ast.ml | 2 +- src/sgen_eval.ml | 14 +++++++------- test/dune | 14 -------------- test/test.ml | 4 ---- 7 files changed, 36 insertions(+), 39 deletions(-) create mode 100644 examples/test.sg delete mode 100644 test/dune diff --git a/examples/syntax.sg b/examples/syntax.sg index 2ffddcb..3c9781f 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -1,24 +1,22 @@ 'static definition of constellation -(def x - (const - (star +a) - (star -a b))) +(:= x [ + [+a] + [-a b]]) + +(:= y #x) -(def y #x) -(def z - (const (star (-f X)))) +(:= z (-f X)) 'string literals -(def w - (const (star "hello world"))) +'(:= w ["hello world"]) 'cons -(def w - (const (star (+w [0 1 0 1 e])))) +(:= w [+w [0 1 0 1 e]]) 'full focus -(show-exec (union @#w #w)) + +''' 'show (literal) contellations (show (const (star a) (star b) (star c))) @@ -139,3 +137,4 @@ (const (star (function a b)))) (show #(f a b)) +''' diff --git a/examples/test.sg b/examples/test.sg new file mode 100644 index 0000000..efabe73 --- /dev/null +++ b/examples/test.sg @@ -0,0 +1,3 @@ +(:= x a) +(:= x @b) +(show (exec #x)) diff --git a/src/expr.ml b/src/expr.ml index 67fe96a..90f4ce7 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -105,15 +105,24 @@ let rec constellation_of_expr : expr -> marked_constellation = function --------------------------------------- *) let rec galaxy_expr_of_expr : expr -> galaxy_expr = function + (* ray *) | Symbol s -> Raw (Const [ Unmarked { content = [ ray_of_expr (Symbol s) ]; bans = [] } ]) + (* id *) | Unquote g -> Id (ray_of_expr g) + (* focus @ *) | List [ Symbol k; g ] when equal_string k focus_op -> Focus (galaxy_expr_of_expr g) + (* union *) + | List (Symbol k :: gs) when equal_string k "union" -> + Union (List.map ~f:galaxy_expr_of_expr gs) + (* exec *) | List [ Symbol k; g ] when equal_string k "exec" -> Exec (galaxy_expr_of_expr g) + (* linear exec *) | List [ Symbol k; g ] when equal_string k "linexec" -> LinExec (galaxy_expr_of_expr g) + (* raw constellation *) | List g -> Raw (Const (constellation_of_expr (List g))) (* --------------------------------------- @@ -121,12 +130,16 @@ let rec galaxy_expr_of_expr : expr -> galaxy_expr = function --------------------------------------- *) let rec decl_of_expr : expr -> declaration = function + (* definition := *) | List [ Symbol k; x; g ] when equal_string k def_op -> - Def (ray_of_expr x, Raw (Const (constellation_of_expr g))) + Def (ray_of_expr x, galaxy_expr_of_expr g) + (* show *) | List [ Symbol k; g ] when equal_string k "show" -> Show (galaxy_expr_of_expr g) + (* trace *) | List [ Symbol k; g ] when equal_string k "trace" -> Show (galaxy_expr_of_expr g) + (* expect *) | List [ Symbol k; x; g ] when equal_string k expect_op -> TypeDef (TExp (ray_of_expr x, galaxy_expr_of_expr g)) | _ -> failwith "error: invalid declaration" diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index 0707047..9c3e803 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -28,7 +28,7 @@ and galaxy_expr = | Id of ident | Exec of galaxy_expr | LinExec of galaxy_expr - | Unions of galaxy_expr list + | Union of galaxy_expr list | Subst of galaxy_expr * substitution | Focus of galaxy_expr | Clean of galaxy_expr diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index c68764d..7edaaaa 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -56,9 +56,9 @@ and map_galaxy_expr env ~f : galaxy_expr -> (galaxy_expr, err) Result.t = | LinExec e -> let* map_e = map_galaxy_expr env ~f e in LinExec map_e |> Result.return - | Unions es -> + | Union es -> let* map_es = List.map ~f:(map_galaxy_expr env ~f) es |> Result.all in - Unions map_es |> Result.return + Union map_es |> Result.return | Subst (e, Extend pf) -> let* map_e = map_galaxy_expr env ~f e in Subst (map_e, Extend pf) |> Result.return @@ -102,9 +102,9 @@ let rec replace_id env (_from : ident) (_to : galaxy_expr) e : | LinExec e -> let* g = replace_id env _from _to e in LinExec g |> Result.return - | Unions es -> + | Union es -> let* gs = List.map ~f:(replace_id env _from _to) es |> Result.all in - Unions gs |> Result.return + Union gs |> Result.return | Focus e -> let* g = replace_id env _from _to e in Focus g |> Result.return @@ -208,7 +208,7 @@ and eval_galaxy_expr ~notyping (env : env) : | Some g -> eval_galaxy_expr ~notyping env g end end - | Unions es -> + | Union es -> let* eval_es = List.map ~f:(eval_galaxy_expr ~notyping env) es |> Result.all in @@ -263,7 +263,7 @@ and eval_galaxy_expr ~notyping (env : env) : let origin = acc |> remove_mark_all |> focus in let* ev = eval_galaxy_expr ~notyping env - (Focus (Exec (Unions [ x; Raw (Const origin) ]))) + (Focus (Exec (Union [ x; Raw (Const origin) ]))) in galaxy_to_constellation ~notyping env ev ) in @@ -383,7 +383,7 @@ and typecheck ~notyping env x (t : StellarRays.term) (ck : galaxy_expr) : |> Result.all_unit and default_interaction = - Unions [ Focus (Id (const "tested")); Id (const "test") ] + Union [ Focus (Id (const "tested")); Id (const "test") ] and default_expect = Raw (Const [ Unmarked { content = [ func "ok" [] ]; bans = [] } ]) diff --git a/test/dune b/test/dune deleted file mode 100644 index 5f5b1e5..0000000 --- a/test/dune +++ /dev/null @@ -1,14 +0,0 @@ -(test - (name test) - (modules test) - (deps - (glob_files ./syntax/*.sg) - (glob_files ./behavior/*.sg) - (glob_files ../examples/*.sg) - (glob_files ../exercises/solutions/*.sg)) - (libraries alcotest base stellogen)) - -(env - (dev - (flags - (:standard -warn-error -A)))) diff --git a/test/test.ml b/test/test.ml index 1d39489..c8a31a7 100644 --- a/test/test.ml +++ b/test/test.ml @@ -20,9 +20,6 @@ let run_dir test_f directory = not @@ Stdlib.Sys.is_directory (Stdlib.Filename.concat directory f) ) |> List.map ~f:(fun x -> make_ok_test x directory test_f) -let () = Alcotest.run "Stellogen Test Suite" [] - -(* FIXME let () = Alcotest.run "Stellogen Test Suite" [ ("Stellogen examples", run_dir sgen "../examples/") @@ -30,4 +27,3 @@ let () = ; ("Stellogen syntax", run_dir sgen "./syntax/") ; ("Stellogen behavior", run_dir sgen "./behavior/") ] -*) From af14ed330f7cb09b482cb1fde31047e7d389ba7c Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 15 Jun 2025 21:46:03 +0200 Subject: [PATCH 12/45] Implement inequalities/incompatibilities and fix focus --- examples/syntax.sg | 34 ++++++++++----------- examples/test.sg | 3 -- src/expr.ml | 76 ++++++++++++++++++++++++++++++++++------------ src/lexer.ml | 3 +- src/parser.mly | 5 +++ src/sgen_eval.ml | 6 ++-- 6 files changed, 83 insertions(+), 44 deletions(-) delete mode 100644 examples/test.sg diff --git a/examples/syntax.sg b/examples/syntax.sg index 3c9781f..21f8f9d 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -11,33 +11,31 @@ '(:= w ["hello world"]) 'cons -(:= w [+w [0 1 0 1 e]]) +(:= w [(+w [0 1 0 1 e])]) -'full focus - +'print result of execution +(:= x [(+f X) X]) +(:= y (-f a)) + -''' 'show (literal) contellations -(show (const - (star a) (star b) (star c))) - -'print result of execution -(show-exec (const - (star a) (star b) (star c))) +(show [ [a] [b] [c] ]) -(show (exec (const - (star a) (star b) (star c)))) +'full focus +(show @[ [a] [b] [c] ]) 'inequality constraints -(def ineq - (const - (star (+f a)) - (star (+f b)) - (@star (-f X) (-f Y) (r X Y) / (!= X Y)))) +(:= ineq [ + [(+f a)] + [(+f b)] + @[(-f X) (-f Y) (r X Y) | (!= X Y)]]) +(show #ineq) + 'interactive debugging of execution -'(trace ineq) +'(trace #ineq) +''' 'dynamic definition of constellation (def c (process (const (star (+n0 0))) 'base constellation diff --git a/examples/test.sg b/examples/test.sg deleted file mode 100644 index efabe73..0000000 --- a/examples/test.sg +++ /dev/null @@ -1,3 +0,0 @@ -(:= x a) -(:= x @b) -(show (exec #x)) diff --git a/src/expr.ml b/src/expr.ml index 90f4ce7..8023228 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -13,6 +13,7 @@ module Raw = struct | List of t list | Stack of t list | Cons of t list + | ConsWithParams of t list * t list end type expr = @@ -21,7 +22,9 @@ type expr = | Unquote of expr | List of expr list -let cons_op = "cons" +let nil_op = "$nil" + +let cons_op = "$cons" let unquote_op = "#" @@ -33,6 +36,12 @@ let typedef_op = "::" let expect_op = "==" +let params_op = "$params" + +let ineq_op = "!=" + +let incomp_op = "!@" + let string_of_list lmark rmark l = l |> String.concat ~sep:" " |> fun l' -> Printf.sprintf "%s%s%s" lmark l' rmark @@ -50,8 +59,10 @@ let rec expand_macro : Raw.t -> expr = function | Raw.Focus e' -> List [ Symbol focus_op; expand_macro e' ] | Raw.List es -> List (List.map ~f:expand_macro es) | Raw.Cons es -> - List.fold_left es ~init:(Symbol "nil") ~f:(fun acc e -> + List.fold_left es ~init:(Symbol nil_op) ~f:(fun acc e -> List [ Symbol cons_op; expand_macro e; acc ] ) + | Raw.ConsWithParams (es, ps) -> + List [ Symbol params_op; expand_macro (Cons es); expand_macro (List ps) ] | Raw.Stack [] -> List [] | Raw.Stack (h :: t) -> List.fold_left t ~init:(expand_macro h) ~f:(fun acc e -> @@ -76,38 +87,63 @@ let rec ray_of_expr : expr -> ray = function | List (Symbol h :: t) -> to_func ((Muted, symbol_of_str h), List.map ~f:ray_of_expr t) | List (_ :: _) -> failwith "error: ray must start with constant" - | e -> failwith ("error: unhandled ray" ^ to_string e) + +let bans_of_expr : expr list -> ban list = + let ban_of_expr = function + | List [Symbol k; a; b] when equal_string k ineq_op -> + Ineq (ray_of_expr a, ray_of_expr b) + | List [Symbol k; a; b] when equal_string k incomp_op -> + Incomp (ray_of_expr a, ray_of_expr b) + | _ -> failwith "error: invalid ban expression" + in List.map ~f:ban_of_expr + +let rec raylist_of_expr (e : expr) : ray list = + match e with + | Symbol k when equal_string k nil_op -> [] + | Symbol _ | Var _ -> [ray_of_expr e] + | Unquote _ -> failwith "error: cannot unquote star" + | List [ Symbol s; h; t ] when equal_string s cons_op -> + (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 - | Symbol "nil" -> Marked { content = []; bans = [] } - | Symbol s -> Marked { content = []; bans = [] } - | Var x -> Marked { content = []; bans = [] } - | Unquote e -> Marked { content = []; bans = [] } - | List [ Symbol s; h; t ] when equal_string s cons_op -> begin - match star_of_expr t with - | Marked { content = next_content; bans = next_bans } -> - Marked { content = ray_of_expr h :: next_content; bans = next_bans } - end - | e -> failwith ("error: unhandled star" ^ to_string e) + | List [ Symbol k; s ] when equal_string k focus_op -> + star_of_expr s |> Lsc_ast.remove_mark |> Lsc_ast.mark + | 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 = [] } let rec constellation_of_expr : expr -> marked_constellation = function - | Symbol "nil" -> [] + | Symbol k when equal_string k nil_op -> [] | Symbol s -> [ Unmarked { content = [ var (s, None) ]; bans = [] } ] | Var x -> [ Unmarked { content = [ var (x, None) ]; bans = [] } ] - | Unquote e -> failwith "error: can't unquote constellation" + | Unquote _ -> failwith "error: can't unquote constellation" | 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 = [] } ] - | e -> failwith ("error: unhandled constellation " ^ to_string e) (* --------------------------------------- Galaxy expr of Expr --------------------------------------- *) -let rec galaxy_expr_of_expr : expr -> galaxy_expr = function +let is_cons = function + | List [ Symbol s; _; _ ] when equal_string s cons_op -> true + | _ -> false + +let rec contains_cons = function + | List [ Symbol s; h; t ] when equal_string s cons_op -> + is_cons h || contains_cons t + | _ -> false + +let rec galaxy_expr_of_expr (e : expr) : galaxy_expr = + match e with (* ray *) - | Symbol s -> - Raw (Const [ Unmarked { content = [ ray_of_expr (Symbol s) ]; bans = [] } ]) + | Var _ | Symbol _ -> + Raw (Const [ Unmarked { content = [ ray_of_expr e ]; bans = [] } ]) + (* star *) + | List [ Symbol s; h; t ] + when equal_string s cons_op && not @@ is_cons h && not @@ contains_cons t -> + Raw (Const [star_of_expr e]) (* id *) | Unquote g -> Id (ray_of_expr g) (* focus @ *) @@ -138,7 +174,7 @@ let rec decl_of_expr : expr -> declaration = function Show (galaxy_expr_of_expr g) (* trace *) | List [ Symbol k; g ] when equal_string k "trace" -> - Show (galaxy_expr_of_expr g) + Trace (galaxy_expr_of_expr g) (* expect *) | List [ Symbol k; x; g ] when equal_string k expect_op -> TypeDef (TExp (ray_of_expr x, galaxy_expr_of_expr g)) diff --git a/src/lexer.ml b/src/lexer.ml index 926e82e..e418a8c 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -23,7 +23,7 @@ and comments lexbuf = and read lexbuf = match%sedlex lexbuf with - | Plus (Compl (Chars "'\" \t\n\r()<>[]@#")) -> + | Plus (Compl (Chars "'\" \t\n\r()<>[]|@#")) -> let lexeme = Utf8.lexeme lexbuf in begin match lexeme.[0] with 'A' .. 'Z' -> VAR lexeme | _ -> SYM lexeme @@ -36,6 +36,7 @@ and read lexbuf = | '>' -> RANGLE | '@' -> AT | '#' -> UNQUOTE + | '|' -> BAR | '\'' -> comment lexbuf | "'''" -> comments lexbuf | '"' -> STRMARK diff --git a/src/parser.mly b/src/parser.mly index b92f40d..1d64b7e 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -6,6 +6,7 @@ open Expr.Raw %token SYM %token STRMARK %token AT +%token BAR %token LPAR RPAR %token LBRACK RBRACK %token LANGLE RANGLE @@ -32,6 +33,9 @@ let expr_file := | EOF; { [] } | es=expr+; EOF; { es } +let params := + | BAR; ~=expr+; <> + let expr := | ~=SYM; | ~=VAR; @@ -40,3 +44,4 @@ let expr := | ~=pars(expr+); | LANGLE; es=revlist(expr); RANGLE; | LBRACK; es=revlist(expr); RBRACK; + | LBRACK; ~=revlist(expr); ~=params; RBRACK; diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 7edaaaa..3920ef0 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -456,8 +456,10 @@ let rec eval_decl ~typecheckonly ~notyping env : Ok env | Show _ when typecheckonly -> Ok env | Show (Id x) -> - Show (Raw (Const [ Marked { content = [ func "#" [ x ] ]; bans = [] } ])) - |> eval_decl ~typecheckonly ~notyping env + begin match get_obj env x with + | None -> Error (UnknownID (string_of_ray x)) + | Some g -> eval_decl ~typecheckonly ~notyping env (Show g) + end | Show (Raw (Galaxy g)) -> Galaxy g |> string_of_galaxy ~notyping env |> Stdlib.print_string; Stdlib.print_newline (); From 68c4dd3658fa8c0d6bd01925887bb7a47cd96c13 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 15 Jun 2025 22:07:47 +0200 Subject: [PATCH 13/45] dune fmt --- src/expr.ml | 16 +++++++++------- src/sgen_eval.ml | 6 +++--- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/expr.ml b/src/expr.ml index 8023228..6210ea1 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -90,20 +90,21 @@ let rec ray_of_expr : expr -> ray = function let bans_of_expr : expr list -> ban list = let ban_of_expr = function - | List [Symbol k; a; b] when equal_string k ineq_op -> + | List [ Symbol k; a; b ] when equal_string k ineq_op -> Ineq (ray_of_expr a, ray_of_expr b) - | List [Symbol k; a; b] when equal_string k incomp_op -> + | List [ Symbol k; a; b ] when equal_string k incomp_op -> Incomp (ray_of_expr a, ray_of_expr b) | _ -> failwith "error: invalid ban expression" - in List.map ~f:ban_of_expr + in + List.map ~f:ban_of_expr let rec raylist_of_expr (e : expr) : ray list = match e with | Symbol k when equal_string k nil_op -> [] - | Symbol _ | Var _ -> [ray_of_expr e] + | Symbol _ | Var _ -> [ ray_of_expr e ] | Unquote _ -> failwith "error: cannot unquote star" | List [ Symbol s; h; t ] when equal_string s cons_op -> - (ray_of_expr h) :: raylist_of_expr t + 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 @@ -142,8 +143,9 @@ let rec galaxy_expr_of_expr (e : expr) : galaxy_expr = Raw (Const [ Unmarked { content = [ ray_of_expr e ]; bans = [] } ]) (* star *) | List [ Symbol s; h; t ] - when equal_string s cons_op && not @@ is_cons h && not @@ contains_cons t -> - Raw (Const [star_of_expr e]) + when equal_string s cons_op && (not @@ is_cons h) && (not @@ contains_cons t) + -> + Raw (Const [ star_of_expr e ]) (* id *) | Unquote g -> Id (ray_of_expr g) (* focus @ *) diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 3920ef0..1798f1c 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -455,11 +455,11 @@ let rec eval_decl ~typecheckonly ~notyping env : in Ok env | Show _ when typecheckonly -> Ok env - | Show (Id x) -> - begin match get_obj env x with + | Show (Id x) -> begin + match get_obj env x with | None -> Error (UnknownID (string_of_ray x)) | Some g -> eval_decl ~typecheckonly ~notyping env (Show g) - end + end | Show (Raw (Galaxy g)) -> Galaxy g |> string_of_galaxy ~notyping env |> Stdlib.print_string; Stdlib.print_newline (); From 80b03626a97ce7b547d6af7a8f3b7af38f0a6e5d Mon Sep 17 00:00:00 2001 From: engboris Date: Tue, 17 Jun 2025 00:29:14 +0200 Subject: [PATCH 14/45] Add prototype of evaluation --- examples/syntax.sg | 26 +++++++++++++++----------- src/expr.ml | 22 +++++++++++++++++----- src/sgen_ast.ml | 1 + src/sgen_eval.ml | 13 ++++++++++++- 4 files changed, 45 insertions(+), 17 deletions(-) diff --git a/examples/syntax.sg b/examples/syntax.sg index 21f8f9d..720ca78 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -35,20 +35,24 @@ 'interactive debugging of execution '(trace #ineq) -''' 'dynamic definition of constellation -(def c (process - (const (star (+n0 0))) 'base constellation - (const (star (-n0 X) (+n1 (s X)))) 'interacts with previous - (const (star (-n1 X) (+n2 (s X)))))) 'interacts with previous - -'galaxy definition -(def g (galaxy - (test1 (const (star (+f a) ok))) - (test2 (const (star (+f b) ok))))) - +(:= c (process + (+n0 0) 'base constellation + [(-n0 X) (+n1 (s X))] 'interacts with previous + [(-n1 X) (+n2 (s X))])) 'interacts with previous +(show #c) + +'constellation with fields +(:= g [ + [+test1 [(+f a) ok]] + [+test2 [(+f b) ok]]]) (show #g) +'field access and evaluation + + + +''' 'reactive effects (run (const (star (+&print X)) diff --git a/src/expr.ml b/src/expr.ml index 6210ea1..959e869 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -82,7 +82,7 @@ let symbol_of_str (s : string) : idfunc = let rec ray_of_expr : expr -> ray = function | Symbol s -> to_func ((Muted, symbol_of_str s), []) | Var s -> to_var s - | Unquote _ -> failwith "error: cannot unquote ray" + | Unquote e -> failwith ("error: cannot unquote ray " ^ to_string e) | List [] -> failwith "error: ray cannot be empty" | List (Symbol h :: t) -> to_func ((Muted, symbol_of_str h), List.map ~f:ray_of_expr t) @@ -102,7 +102,7 @@ let rec raylist_of_expr (e : expr) : ray list = match e with | Symbol k when equal_string k nil_op -> [] | Symbol _ | Var _ -> [ ray_of_expr e ] - | Unquote _ -> failwith "error: cannot unquote star" + | Unquote e -> failwith ("error: cannot unquote star " ^ to_string e) | List [ Symbol s; h; t ] when equal_string s cons_op -> ray_of_expr h :: raylist_of_expr t | e -> failwith ("error: unhandled star " ^ to_string e) @@ -118,7 +118,7 @@ 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 = [] } ] - | Unquote _ -> failwith "error: can't unquote constellation" + | Unquote e -> failwith ("error: can't unquote constellation" ^ to_string e) | 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 = [] } ] @@ -154,20 +154,32 @@ let rec galaxy_expr_of_expr (e : expr) : galaxy_expr = (* union *) | List (Symbol k :: gs) when equal_string k "union" -> Union (List.map ~f:galaxy_expr_of_expr gs) + (* process *) + | List (Symbol k :: gs) when equal_string k "process" -> + Process (List.map ~f:galaxy_expr_of_expr gs) + (* kill *) + | List [ Symbol k; g ] when equal_string k "kill" -> + Kill (galaxy_expr_of_expr g) + (* clean *) + | List [ Symbol k; g ] when equal_string k "clean" -> + Clean (galaxy_expr_of_expr g) (* exec *) | List [ Symbol k; g ] when equal_string k "exec" -> Exec (galaxy_expr_of_expr g) (* linear exec *) | List [ Symbol k; g ] when equal_string k "linexec" -> LinExec (galaxy_expr_of_expr g) - (* raw constellation *) + (* linear exec *) + | List [ Symbol k; g ] when equal_string k "eval" -> + Eval (ray_of_expr g) + (* KEEP LAST -- raw constellation *) | List g -> Raw (Const (constellation_of_expr (List g))) (* --------------------------------------- Stellogen program of Expr --------------------------------------- *) -let rec decl_of_expr : expr -> declaration = function +let decl_of_expr : expr -> declaration = function (* definition := *) | List [ Symbol k; x; g ] when equal_string k def_op -> Def (ray_of_expr x, galaxy_expr_of_expr g) diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index 9c3e803..2b8774c 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -34,6 +34,7 @@ and galaxy_expr = | Clean of galaxy_expr | Kill of galaxy_expr | Process of galaxy_expr list + | Eval of ray and substitution = | Extend of ray_prefix diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 1798f1c..4f0d585 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -81,6 +81,7 @@ and map_galaxy_expr env ~f : galaxy_expr -> (galaxy_expr, err) Result.t = | Process gs -> let* procs = List.map ~f:(map_galaxy_expr env ~f) gs |> Result.all in Process procs |> Result.return + | Eval e -> Eval e |> Result.return let rec replace_id env (_from : ident) (_to : galaxy_expr) e : (galaxy_expr, err) Result.t = @@ -114,7 +115,7 @@ let rec replace_id env (_from : ident) (_to : galaxy_expr) e : | Process gs -> let* procs = List.map ~f:(replace_id env _from _to) gs |> Result.all in Process procs |> Result.return - | Raw _ | Id _ -> e |> Result.return + | Raw _ | Id _ | Eval _ -> e |> Result.return let subst_vars env _from _to = map_galaxy_expr env ~f:(subst_all_vars [ (_from, _to) ]) @@ -296,6 +297,16 @@ and eval_galaxy_expr ~notyping (env : env) : | Subst (e, SGal (x, _to)) -> let* fill = replace_id env x _to e in eval_galaxy_expr ~notyping env fill + | Eval e -> + let* eval_e = Expr.galaxy_expr_of_expr (expr_of_ray e) + |> eval_galaxy_expr ~notyping env in + eval_galaxy_expr ~notyping env (Raw eval_e) + +and expr_of_ray = function + | Var (x, None) -> Expr.Var x + | Var (x, Some i) -> Expr.Var (x ^ Int.to_string i) + | Func (pf, args) -> + Expr.List (Symbol (Lsc_ast.string_of_polsym pf) :: List.map ~f:expr_of_ray args) and galaxy_to_constellation ~notyping env : galaxy -> (marked_constellation, err) Result.t = function From d8f5756700670e6856bcf19dc69dcd97885f0f1c Mon Sep 17 00:00:00 2001 From: engboris Date: Tue, 17 Jun 2025 21:58:00 +0200 Subject: [PATCH 15/45] Add stellar evaluation of literal expressions --- src/expr.ml | 4 ++-- src/sgen_ast.ml | 2 +- src/sgen_eval.ml | 25 ++++++++++++++++++------- 3 files changed, 21 insertions(+), 10 deletions(-) diff --git a/src/expr.ml b/src/expr.ml index 959e869..4fe2482 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -102,7 +102,7 @@ let rec raylist_of_expr (e : expr) : ray list = match e with | Symbol k when equal_string k nil_op -> [] | Symbol _ | Var _ -> [ ray_of_expr e ] - | Unquote e -> failwith ("error: cannot unquote star " ^ to_string e) + | Unquote e -> failwith ("error: cannot unquote star " ^ to_string e) | List [ Symbol s; h; t ] when equal_string s cons_op -> ray_of_expr h :: raylist_of_expr t | e -> failwith ("error: unhandled star " ^ to_string e) @@ -171,7 +171,7 @@ let rec galaxy_expr_of_expr (e : expr) : galaxy_expr = LinExec (galaxy_expr_of_expr g) (* linear exec *) | List [ Symbol k; g ] when equal_string k "eval" -> - Eval (ray_of_expr g) + Eval (galaxy_expr_of_expr g) (* KEEP LAST -- raw constellation *) | List g -> Raw (Const (constellation_of_expr (List g))) diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index 2b8774c..23dda10 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -34,7 +34,7 @@ and galaxy_expr = | Clean of galaxy_expr | Kill of galaxy_expr | Process of galaxy_expr list - | Eval of ray + | Eval of galaxy_expr and substitution = | Extend of ray_prefix diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 4f0d585..cf89c70 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -81,7 +81,9 @@ and map_galaxy_expr env ~f : galaxy_expr -> (galaxy_expr, err) Result.t = | Process gs -> let* procs = List.map ~f:(map_galaxy_expr env ~f) gs |> Result.all in Process procs |> Result.return - | Eval e -> Eval e |> Result.return + | Eval e -> + let* map_e = map_galaxy_expr env ~f e in + Eval map_e |> Result.return let rec replace_id env (_from : ident) (_to : galaxy_expr) e : (galaxy_expr, err) Result.t = @@ -115,7 +117,10 @@ let rec replace_id env (_from : ident) (_to : galaxy_expr) e : | Process gs -> let* procs = List.map ~f:(replace_id env _from _to) gs |> Result.all in Process procs |> Result.return - | Raw _ | Id _ | Eval _ -> e |> 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_galaxy_expr env ~f:(subst_all_vars [ (_from, _to) ]) @@ -297,16 +302,22 @@ and eval_galaxy_expr ~notyping (env : env) : | Subst (e, SGal (x, _to)) -> let* fill = replace_id env x _to e in eval_galaxy_expr ~notyping env fill - | Eval e -> - let* eval_e = Expr.galaxy_expr_of_expr (expr_of_ray e) - |> eval_galaxy_expr ~notyping env in - eval_galaxy_expr ~notyping env (Raw eval_e) + | Eval e -> ( + let* eval_e = eval_galaxy_expr ~notyping env e in + match eval_e with + | Const [ Marked { content = [ r ]; bans = _ } ] + | Const [ Unmarked { content = [ r ]; bans = _ } ] -> + r |> expr_of_ray |> Expr.galaxy_expr_of_expr + |> eval_galaxy_expr ~notyping env + | _ -> failwith "error: only rays can be evaluated." ) and expr_of_ray = function | Var (x, None) -> Expr.Var x | Var (x, Some i) -> Expr.Var (x ^ Int.to_string i) + | Func (pf, []) -> Symbol (Lsc_ast.string_of_polsym pf) | Func (pf, args) -> - Expr.List (Symbol (Lsc_ast.string_of_polsym pf) :: List.map ~f:expr_of_ray args) + Expr.List + (Symbol (Lsc_ast.string_of_polsym pf) :: List.map ~f:expr_of_ray args) and galaxy_to_constellation ~notyping env : galaxy -> (marked_constellation, err) Result.t = function From 2c200804010407f80db360ce776bd2f2b0648469 Mon Sep 17 00:00:00 2001 From: engboris Date: Wed, 18 Jun 2025 23:47:45 +0200 Subject: [PATCH 16/45] Remove interfaces and refactor AST --- examples/syntax.sg | 74 +++++++----------------- nvim/syntax/stellogen.vim | 4 +- src/expr.ml | 14 ++++- src/sgen_ast.ml | 19 ++---- src/sgen_eval.ml | 118 ++++++-------------------------------- 5 files changed, 59 insertions(+), 170 deletions(-) diff --git a/examples/syntax.sg b/examples/syntax.sg index 720ca78..2714e66 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -18,6 +18,10 @@ (:= y (-f a)) +'complex identifiers +(:= (f a b) [(function a b)]) +(show #(f a b)) + 'show (literal) contellations (show [ [a] [b] [c] ]) @@ -52,47 +56,33 @@ -''' -'reactive effects -(run (const - (star (+&print X)) - (star (-&print "hello world\n")))) - -'access to field of a galaxy -(show (get g test1)) -(show (get g test2)) - 'extend rays with a head function symbol -(show-exec (const (star (+f X)) (star (f X)))[=>+a]) -(show-exec (const (star (+f X)) (star (f X)))[=>a]) +'+a]> +'a]> 'remove head function symbol from a ray -(show-exec (const (star (+f X)) (star (f X)))[+f=>]) +']> 'substitutions -(show-exec - (const (star (+f X)))[X=>(+a X)]) -(show-exec (const (star (+f X)))[+f=>+g]) -(show-exec (union #1 #2) - [#1=>(const (star (+f X) X))] - [#2=>(const (star (-f a)))]) +'(+a X)]> +'+g]> +'[(+f X) X)]] +' [#2=>(-f a)]> 'checkers & typechecking -(def checker (galaxy - (interaction (union @#tested #test)) - (expect (const (star ok))))) +(:= checker [ + [+interaction (union @#tested #test)] + [+expect ok]]) -(spec nat - (galaxy - (test - (const - (star (-nat 0) ok) - (star (-nat (s N)) (+nat N)))))) +(spec nat [ + [(-nat 0) ok)] + [(-nat (s N)) (+nat N)]]) -(:: 0 (nat /checker)) -(def 0 - (const (star (+nat 0)))) +'(:: 0 (nat | checker)) +'(:= 0 (+nat 0)) +''' (:: 1 (nat / checker)) (def 1 (const (star (+nat (s 0))))) @@ -114,29 +104,7 @@ (def 4 (const (star (+nat )))) -(interface nat_pair - (:: n nat) - (:: m nat)) - -(:: g_pair nat_pair) -(def g_pair - (galaxy - (n (const (star (+nat 0)))) - (m (const (star (+nat 0)))))) - -'galaxy with type declarations -(show (galaxy - (:: n1 nat) - (n1 (const (star (+nat 0)))) - (:: n2 nat) - (n2 (const (star (+nat )))))) - 'import file '(use examples automata) -'complex identifiers -(def (f a b) - (const - (star (function a b)))) -(show #(f a b)) ''' diff --git a/nvim/syntax/stellogen.vim b/nvim/syntax/stellogen.vim index 02ae730..9288693 100644 --- a/nvim/syntax/stellogen.vim +++ b/nvim/syntax/stellogen.vim @@ -1,6 +1,6 @@ syn clear -syn keyword sgKeyword def kill clean const star show use exec spec linear trace process end galaxy run interface union +syn keyword sgKeyword kill clean eval show use exec spec linear trace process run union syn match sgComment "\s*'[^'].*$" syn match sgId "#\%(\l\|\d\)\w*" syn region sgComment start="'''" end="'''" contains=NONE @@ -9,7 +9,9 @@ syn match sgSeparator "[\<\>\{\}\[\]|]" syn match sgOperator "@" syn match sgOperator "::" syn match sgOperator "==" +syn match sgOperator ":=" syn match sgOperator "!=" +syn match sgOperator "&" hi link sgKeyword Keyword hi link sgId Identifier diff --git a/src/expr.ml b/src/expr.ml index 4fe2482..fbbcfc7 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -82,7 +82,7 @@ let symbol_of_str (s : string) : idfunc = let rec ray_of_expr : expr -> ray = function | Symbol s -> to_func ((Muted, symbol_of_str s), []) | Var s -> to_var s - | Unquote e -> failwith ("error: cannot unquote ray " ^ to_string e) + | Unquote e -> to_func ((Muted, (Null, "#")), [ ray_of_expr e ]) | List [] -> failwith "error: ray cannot be empty" | List (Symbol h :: t) -> to_func ((Muted, symbol_of_str h), List.map ~f:ray_of_expr t) @@ -179,10 +179,20 @@ let rec galaxy_expr_of_expr (e : expr) : galaxy_expr = 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, galaxy_expr_of_expr g) + | List [ Symbol k; x; g ] when equal_string k "spec" -> + Def (ray_of_expr x, galaxy_expr_of_expr g) + (* type declaration :: *) + (* | List [ Symbol k; x; g ] when equal_string k typedef_op -> + Typedecl (ray_of_expr x, typedecl_of_expr g) *) (* show *) | List [ Symbol k; g ] when equal_string k "show" -> Show (galaxy_expr_of_expr g) @@ -191,7 +201,7 @@ let decl_of_expr : expr -> declaration = function Trace (galaxy_expr_of_expr g) (* expect *) | List [ Symbol k; x; g ] when equal_string k expect_op -> - TypeDef (TExp (ray_of_expr x, galaxy_expr_of_expr g)) + Expect (ray_of_expr x, galaxy_expr_of_expr g) | _ -> failwith "error: invalid declaration" let program_of_expr = List.map ~f:decl_of_expr diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index 23dda10..e9a268a 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -9,18 +9,9 @@ type idfunc = polarity * string type ray_prefix = StellarRays.fmark * idfunc -type type_declaration = - | TDef of ident * (ident * ident option) list - | TExp of ident * galaxy_expr - and galaxy = | Const of marked_constellation - | Galaxy of galaxy_declaration list - | Interface of type_declaration list - -and galaxy_declaration = - | GTypeDef of type_declaration - | GLabelDef of ident * galaxy_expr + | Galaxy of (ident * galaxy_expr) list and galaxy_expr = | Raw of galaxy @@ -54,10 +45,7 @@ type env = let expect (g : galaxy_expr) : galaxy_expr = Raw - (Galaxy - [ GLabelDef (const "interaction", Id (const "tested")) - ; GLabelDef (const "expect", g) - ] ) + (Galaxy [ (const "interaction", Id (const "tested")); (const "expect", g) ]) let initial_env = { objs = [ (const "^empty", Raw (Const [])) ] @@ -69,7 +57,8 @@ type declaration = | Show of galaxy_expr | Trace of galaxy_expr | Run of galaxy_expr - | TypeDef of type_declaration + | Typedecl of ident * (ident * ident option) list + | Expect of ident * galaxy_expr | Use of ident list type program = declaration list diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index cf89c70..d0318f6 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -18,14 +18,11 @@ let get_type env x = List.Assoc.find ~equal:equal_ray env.types x let rec map_galaxy env ~f : galaxy -> (galaxy, err) Result.t = function | Const mcs -> Const (f mcs) |> Result.return - | Interface i -> Interface i |> Result.return | Galaxy g -> let* g' = - List.map g ~f:(function - | GTypeDef tdef -> GTypeDef tdef |> Result.return - | GLabelDef (k, v) -> - let* map_v = map_galaxy_expr env ~f v in - GLabelDef (k, map_v) |> Result.return ) + List.map g ~f:(function k, v -> + let* map_v = map_galaxy_expr env ~f v in + (k, map_v) |> Result.return ) |> Result.all in Galaxy g' |> Result.return @@ -128,39 +125,7 @@ let subst_vars env _from _to = let subst_funcs env _from _to = map_galaxy_expr env ~f:(subst_all_funcs [ (_from, _to) ]) -let group_galaxy : - galaxy_declaration list - -> type_declaration list * (StellarRays.term * galaxy_expr) list = - List.fold_left ~init:([], []) ~f:(function types, fields -> - (function - | GTypeDef d -> (d :: types, fields) - | GLabelDef (x, g') -> (types, (x, g') :: fields) ) ) - -let rec typecheck_galaxy ~notyping env (g : galaxy_declaration list) : - (unit, err) Result.t = - let types, fields = group_galaxy g in - List.map types ~f:(function - | TExp (x, g) -> - let checker = expect g in - let new_env = { types = env.types; objs = fields @ env.objs } in - typecheck ~notyping new_env x (const "^empty") checker - | TDef (x, ts) -> - List.map ts ~f:(fun (t, ck) -> - let* checker = - match ck with - | None -> Ok default_checker - | Some xck -> begin - match get_obj env xck with - | None -> Error (UnknownID (string_of_ray xck)) - | Some g -> Ok g - end - in - let new_env = { types = env.types; objs = fields @ env.objs } in - typecheck ~notyping new_env x t checker ) - |> Result.all_unit ) - |> Result.all_unit - -and pp_err ~notyping e : (string, err) Result.t = +let rec pp_err ~notyping e : (string, err) Result.t = match e with | IllFormedChecker -> "Ill-formed checker.\n" |> Result.return | ExpectedGalaxy -> "Expected galaxy.\n" |> Result.return @@ -189,22 +154,17 @@ and pp_err ~notyping e : (string, err) Result.t = and eval_galaxy_expr ~notyping (env : env) : galaxy_expr -> (galaxy, err) Result.t = function - | Raw (Galaxy g) -> - let* _ = if notyping then Ok () else typecheck_galaxy ~notyping env g in - Ok (Galaxy g) + | Raw (Galaxy g) -> Ok (Galaxy g) | Raw (Const mcs) -> Ok (Const mcs) - | Raw (Interface _) -> Ok (Interface []) | Access (e, x) -> begin match eval_galaxy_expr ~notyping env e with | Ok (Const _) -> Error (UnknownField (string_of_ray x)) - | Ok (Interface _) -> Error (UnknownField (string_of_ray x)) - | Ok (Galaxy g) -> ( - let _, fields = group_galaxy g in + | Ok (Galaxy g) -> begin try - fields |> fun g -> List.Assoc.find_exn ~equal:equal_ray g x |> eval_galaxy_expr ~notyping env - with Not_found_s _ -> Error (UnknownField (string_of_ray x)) ) + with Not_found_s _ -> Error (UnknownField (string_of_ray x)) + end | Error e -> Error e end | Id x -> begin @@ -315,6 +275,8 @@ and expr_of_ray = function | Var (x, None) -> Expr.Var x | Var (x, Some i) -> Expr.Var (x ^ Int.to_string i) | Func (pf, []) -> Symbol (Lsc_ast.string_of_polsym pf) + | Func ((Muted, (Null, k)), [ r ]) when equal_string k "#" -> + Unquote (expr_of_ray r) | Func (pf, args) -> Expr.List (Symbol (Lsc_ast.string_of_polsym pf) :: List.map ~f:expr_of_ray args) @@ -322,10 +284,8 @@ and expr_of_ray = function and galaxy_to_constellation ~notyping env : galaxy -> (marked_constellation, err) Result.t = function | Const mcs -> Ok mcs - | Interface _ -> Ok [] | Galaxy g -> - let _, fields = group_galaxy g in - List.fold_left fields ~init:(Ok []) ~f:(fun acc (_, v) -> + List.fold_left g ~init:(Ok []) ~f:(fun acc (_, v) -> let* acc = acc in let* eval_v = eval_galaxy_expr ~notyping env v in let* mcs = galaxy_to_constellation ~notyping env eval_v in @@ -336,25 +296,11 @@ and equal_galaxy ~notyping env g g' = let* mcs' = galaxy_to_constellation ~notyping env g' in equal_mconstellation mcs mcs' |> Result.return -and check_interface ~notyping env x i = - let* g = - match get_obj env x with - | Some (Raw (Galaxy g)) -> Ok g - | Some _ -> Error ExpectedGalaxy - | None -> Error (UnknownID (string_of_ray x)) - in - let type_decls = List.map i ~f:(fun t -> GTypeDef t) in - typecheck_galaxy ~notyping env (type_decls @ g) - and typecheck ~notyping env x (t : StellarRays.term) (ck : galaxy_expr) : (unit, err) Result.t = let* gtests : (StellarRays.term * galaxy_expr) list = match get_obj env t with | Some (Raw (Const mcs)) -> Ok [ (const "_", Raw (Const mcs)) ] - | Some (Raw (Interface i)) -> - let* _ = check_interface ~notyping env x i in - Ok [] - | Some (Raw (Galaxy gtests)) -> group_galaxy gtests |> snd |> Result.return | Some e -> let* eval_e = eval_galaxy_expr ~notyping env e in let* mcs = galaxy_to_constellation ~notyping env eval_e in @@ -366,10 +312,7 @@ and typecheck ~notyping env x (t : StellarRays.term) (ck : galaxy_expr) : match ck with | Raw (Galaxy gck) -> let format = - try - List.Assoc.find_exn ~equal:equal_ray - (group_galaxy gck |> snd) - (const "interaction") + try List.Assoc.find_exn ~equal:equal_ray gck (const "interaction") with Not_found_s _ -> default_interaction in begin @@ -413,8 +356,8 @@ and default_expect = and default_checker : galaxy_expr = Raw (Galaxy - [ GLabelDef (const "interaction", default_interaction) - ; GLabelDef (const "expect", default_expect) + [ (const "interaction", default_interaction) + ; (const "expect", default_expect) ] ) and string_of_type_expr (t, ck) = @@ -422,35 +365,17 @@ and string_of_type_expr (t, ck) = | None -> Printf.sprintf "%s" (string_of_ray t) | Some xck -> Printf.sprintf "%s [%s]" (string_of_ray t) (string_of_ray xck) -and string_of_type_declaration ~notyping env = function - | TDef (x, ts) -> - let str_x = string_of_ray x in - let str_ts = List.map ts ~f:string_of_type_expr in - Printf.sprintf " %s :: %s.\n" str_x (string_of_list Fn.id ";" str_ts) - | TExp (x, g) -> ( - match eval_galaxy_expr ~notyping env g with - | Error _ -> failwith "Error: string_of_type_declaration" - | Ok eval_g -> - let str_x = string_of_ray x in - Printf.sprintf "%s :=: %s" str_x (string_of_galaxy ~notyping env eval_g) ) - and string_of_galaxy_declaration ~notyping env = function - | GLabelDef (k, v) -> begin + | k, v -> ( match eval_galaxy_expr ~notyping env v with | Error _ -> failwith "Error: string_of_galaxy_declaration" | Ok eval_v -> let str_k = string_of_ray k in Printf.sprintf " %s = %s\n" str_k (string_of_galaxy ~notyping env eval_v) - end - | GTypeDef decl -> string_of_type_declaration ~notyping env decl + ) and string_of_galaxy ~notyping env : galaxy -> string = function | Const mcs -> mcs |> remove_mark_all |> string_of_constellation - | Interface i -> - let content = - string_of_list (string_of_type_declaration ~notyping env) "" i - in - Printf.sprintf "interface\n%send" content | Galaxy g -> Printf.sprintf "galaxy\n%send" (string_of_list (string_of_galaxy_declaration ~notyping env) "" g) @@ -487,11 +412,6 @@ let rec eval_decl ~typecheckonly ~notyping env : Stdlib.print_newline (); Stdlib.flush Stdlib.stdout; Ok env - | Show (Raw (Interface i)) -> - Interface i |> string_of_galaxy ~notyping env |> Stdlib.print_string; - Stdlib.print_newline (); - Stdlib.flush Stdlib.stdout; - Ok env | Show e -> let* eval_e = eval_galaxy_expr ~notyping env e in let* mcs = galaxy_to_constellation ~notyping env eval_e in @@ -512,9 +432,9 @@ let rec eval_decl ~typecheckonly ~notyping env : | Run e -> let _ = eval_galaxy_expr ~notyping env (Exec e) in Ok env - | TypeDef _ when notyping -> Ok env - | TypeDef (TDef (x, ts)) -> Ok { objs = env.objs; types = add_type env x ts } - | TypeDef (TExp (x, mcs)) -> + | Typedecl _ when notyping -> Ok env + | Typedecl (x, ts) -> Ok { objs = env.objs; types = add_type env x ts } + | Expect (x, mcs) -> Ok { objs = add_obj env (const "^expect") (expect mcs) ; types = add_type env x [ (const "^empty", Some (const "^expect")) ] From dfb7aac4f700fc06567353b4ce63b0e666c1537d Mon Sep 17 00:00:00 2001 From: engboris Date: Thu, 19 Jun 2025 22:09:09 +0200 Subject: [PATCH 17/45] Add example of minimal typing --- examples/syntax.sg | 17 +++++- src/archive/sgen_lexer.ml | 112 ------------------------------------ src/archive/sgen_parser.mly | 110 ----------------------------------- 3 files changed, 15 insertions(+), 224 deletions(-) delete mode 100644 src/archive/sgen_lexer.ml delete mode 100644 src/archive/sgen_parser.mly diff --git a/examples/syntax.sg b/examples/syntax.sg index 2714e66..5224c7d 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -56,6 +56,13 @@ +'nested fields +(:= g1 [ + [+test1 [ + [+test2 [(+f c) ok]]]]]) +(:= g2 ) + + 'extend rays with a head function symbol '+a]> 'a]> @@ -76,13 +83,19 @@ [+expect ok]]) (spec nat [ - [(-nat 0) ok)] + [(-nat 0) ok] [(-nat (s N)) (+nat N)]]) +'manual typing +(:= 0 (+nat 0)) +(:= expect ) +(== res_int #expect) +(:= res_int @(exec (union @#0 #nat))) + +''' '(:: 0 (nat | checker)) '(:= 0 (+nat 0)) -''' (:: 1 (nat / checker)) (def 1 (const (star (+nat (s 0))))) diff --git a/src/archive/sgen_lexer.ml b/src/archive/sgen_lexer.ml deleted file mode 100644 index 6a14ebb..0000000 --- a/src/archive/sgen_lexer.ml +++ /dev/null @@ -1,112 +0,0 @@ -open Sgen_parser - -exception SyntaxError of string - -let update_pos_newline lexbuf = Sedlexing.new_line lexbuf - -let rec read lexbuf = - match%sedlex lexbuf with - (* Stellogen *) - | "exec" -> EXEC - | "run" -> RUN - | "const" -> CONST - | "union" -> UNION - | "process" -> PROCESS - | "get" -> GET - | "interface" -> INTERFACE - | "show" -> SHOW - | "spec" -> SPEC - | "def" -> DEF - | "kill" -> KILL - | "clean" -> CLEAN - | "use" -> USE - | "trace" -> TRACE - | "linear-exec" -> LINEXEC - | "show-exec" -> SHOWEXEC - | "galaxy" -> GALAXY - | "#" -> SHARP - | "&" -> AMP - | ':' -> CONS - | '=' -> EQ - | '"' -> read_string (Buffer.create 255) lexbuf - (* Stellar resolution *) - | "!@" -> INCOMP - | "!=" -> NEQ - | "=>" -> DRARROW - | "star" -> STAR - | '_' -> PLACEHOLDER - | '[' -> LBRACK - | ']' -> RBRACK - | '<' -> LANGLE - | '>' -> RANGLE - | '(' -> LPAR - | ')' -> RPAR - | '@' -> AT - | '/' -> SLASH - | '+' -> PLUS - | '-' -> MINUS - | '=' -> EQ - (* Identifiers *) - | Plus 'A' .. 'Z', Star ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-') -> - VAR (Sedlexing.Utf8.lexeme lexbuf) - | ( ('a' .. 'z' | '0' .. '9') - , Star ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '?') ) -> - SYM (Sedlexing.Utf8.lexeme lexbuf) - (* Whitespace *) - | Plus (' ' | '\t') -> read lexbuf - | '\r' | '\n' | "\r\n" -> - update_pos_newline lexbuf; - read lexbuf - (* Comments *) - | '\'' -> comment lexbuf - | "'''" -> comments lexbuf - | eof -> EOF - | _ -> - raise (SyntaxError ("Unexpected character: " ^ Sedlexing.Utf8.lexeme lexbuf)) - -and read_string buf lexbuf = - match%sedlex lexbuf with - | '"' -> SYM ("\"" ^ Buffer.contents buf ^ "\"") - | '\\', '/' -> - Buffer.add_char buf '/'; - read_string buf lexbuf - | '\\', '\\' -> - Buffer.add_char buf '\\'; - read_string buf lexbuf - | '\\', 'b' -> - Buffer.add_char buf '\b'; - read_string buf lexbuf - | '\\', 'f' -> - Buffer.add_char buf '\012'; - read_string buf lexbuf - | '\\', 'n' -> - Buffer.add_char buf '\n'; - read_string buf lexbuf - | '\\', 'r' -> - Buffer.add_char buf '\r'; - read_string buf lexbuf - | '\\', 't' -> - Buffer.add_char buf '\t'; - read_string buf lexbuf - | Plus (Compl ('"' | '\\')) -> - Buffer.add_string buf (Sedlexing.Utf8.lexeme lexbuf); - read_string buf lexbuf - | eof -> raise (SyntaxError "String is not terminated") - | _ -> - raise - (SyntaxError ("Illegal string character: " ^ Sedlexing.Utf8.lexeme lexbuf)) - -and comment lexbuf = - match%sedlex lexbuf with - | eof -> EOF - | '\r' | '\n' | "\r\n" -> read lexbuf - | _ -> - ignore (Sedlexing.next lexbuf); - comment lexbuf - -and comments lexbuf = - match%sedlex lexbuf with - | "'''" -> read lexbuf - | _ -> - ignore (Sedlexing.next lexbuf); - comments lexbuf diff --git a/src/archive/sgen_parser.mly b/src/archive/sgen_parser.mly deleted file mode 100644 index 345fe98..0000000 --- a/src/archive/sgen_parser.mly +++ /dev/null @@ -1,110 +0,0 @@ -%{ -open Sgen_ast -%} - -%token SHOW SHOWEXEC -%token INTERFACE -%token USE -%token RUN -%token CONS -%token SPEC -%token CONST -%token GET -%token DEF -%token PROCESS -%token DRARROW -%token TRACE -%token UNION -%token SHARP -%token KILL CLEAN -%token EXEC LINEXEC -(* %token PROCESS *) -%token GALAXY -%token EQ - -%start program -%start declaration - -%% - -let program := ~=pars(declaration)*; EOF; <> -let ident := ~=ray; <> - -let declaration := - | SPEC; ~=ident; ~=galaxy_expr; - | DEF; ~=ident; ~=galaxy_expr; - | SHOW; ~=galaxy_expr; - | SHOWEXEC; ~=galaxy_expr; - | TRACE; ~=galaxy_expr; - | RUN; ~=galaxy_expr; - | ~=type_declaration; - | USE; ~=ident+; - | INTERFACE; x=ident; i=interface_item*; { Def (x, Raw (Interface i)) } - -let type_declaration := - | CONS; CONS; x=ident; ts=type_expr+; { TDef (x, ts) } - | EQ; EQ; x=ident; g=galaxy_expr; { TExp (x, g) } - -let type_expr := - | t=ident; { (t, None) } - | LPAR; t=ident; SLASH; ck=ident; RPAR; { (t, Some ck) } - -let galaxy_expr := - | ~=galaxy_content; <> - | ~=pars(process); <> - -let interface_item := ~=pars(type_declaration); <> - -let raw_galaxy := - | CONST; { Const [] } - | CONST; ~=marked_constellation; - | GALAXY; ~=pars(galaxy_item)*; - -let prefixed_id := SHARP; ~=ident; - -let galaxy_content := - | ~=pars(raw_galaxy); - | ~=pars(galaxy_access); <> - | AT; ~=galaxy_content; - | ~=galaxy_content; ~=bracks(substitution); - | ~=pars(galaxy_block); <> - | ~=prefixed_id; <> - | LPAR; UNION; g1=galaxy_content; g2=galaxy_content; RPAR; - { Union (g1, g2) } - -let galaxy_block := - | EXEC; ~=galaxy_content; - | LINEXEC; ~=galaxy_content; - | KILL; ~=galaxy_content; - | CLEAN; ~=galaxy_content; - | EXEC; g=raw_galaxy; { Exec (Raw g) } - | LINEXEC; g=raw_galaxy; { LinExec (Raw g) } - | KILL; g=raw_galaxy; { Kill (Raw g) } - | CLEAN; g=raw_galaxy; { Clean (Raw g) } - -let galaxy_access := - | GET; x=ident; y=ident; { Access (Id x, y) } - | GET; ~=pars(galaxy_access); y=ident; - -let substitution := - | DRARROW; ~=symbol; - | ~=symbol; DRARROW; - | ~=VAR; DRARROW; ~=ray; - | f=symbol; DRARROW; g=symbol; { SFunc (f, g) } - | SHARP; ~=ident; DRARROW; ~=galaxy_expr; - | SHARP; x=ident; DRARROW; - h=marked_constellation; { SGal (x, Raw (Const h)) } - -let galaxy_item := - | ~=ident; ~=galaxy_content; - | ~=ident; ~=pars(process); - | ~=type_declaration; - -let process := - | PROCESS; { Process [] } - | PROCESS; ~=process_item+; - -let process_item := - | ~=galaxy_content; <> - | AMP; KILL; { Id (const "kill") } - | AMP; CLEAN; { Id (const "clean") } From e05ce54e589c70085af72c08c793e9bc7488f0a5 Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 20 Jun 2025 00:15:17 +0200 Subject: [PATCH 18/45] Remove galaxies --- src/expr.ml | 36 +-- src/sgen_ast.ml | 47 ++-- src/sgen_err.ml | 5 +- src/sgen_eval.ml | 318 ++++++------------------ test/behavior/{galaxy.sg => records.sg} | 0 5 files changed, 114 insertions(+), 292 deletions(-) rename test/behavior/{galaxy.sg => records.sg} (100%) diff --git a/src/expr.ml b/src/expr.ml index fbbcfc7..a0314ae 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -124,7 +124,7 @@ let rec constellation_of_expr : expr -> marked_constellation = function | List g -> [ Unmarked { content = [ ray_of_expr (List g) ]; bans = [] } ] (* --------------------------------------- - Galaxy expr of Expr + Stellogen expr of Expr --------------------------------------- *) let is_cons = function @@ -136,44 +136,44 @@ let rec contains_cons = function is_cons h || contains_cons t | _ -> false -let rec galaxy_expr_of_expr (e : expr) : galaxy_expr = +let rec sgen_expr_of_expr (e : expr) : sgen_expr = match e with (* ray *) | Var _ | Symbol _ -> - Raw (Const [ Unmarked { content = [ ray_of_expr e ]; bans = [] } ]) + Raw [ Unmarked { content = [ ray_of_expr e ]; bans = [] } ] (* star *) | List [ Symbol s; h; t ] when equal_string s cons_op && (not @@ is_cons h) && (not @@ contains_cons t) -> - Raw (Const [ star_of_expr e ]) + Raw [ star_of_expr e ] (* id *) | Unquote g -> Id (ray_of_expr g) (* focus @ *) | List [ Symbol k; g ] when equal_string k focus_op -> - Focus (galaxy_expr_of_expr g) + Focus (sgen_expr_of_expr g) (* union *) | List (Symbol k :: gs) when equal_string k "union" -> - Union (List.map ~f:galaxy_expr_of_expr gs) + Union (List.map ~f:sgen_expr_of_expr gs) (* process *) | List (Symbol k :: gs) when equal_string k "process" -> - Process (List.map ~f:galaxy_expr_of_expr gs) + Process (List.map ~f:sgen_expr_of_expr gs) (* kill *) | List [ Symbol k; g ] when equal_string k "kill" -> - Kill (galaxy_expr_of_expr g) + Kill (sgen_expr_of_expr g) (* clean *) | List [ Symbol k; g ] when equal_string k "clean" -> - Clean (galaxy_expr_of_expr g) + Clean (sgen_expr_of_expr g) (* exec *) | List [ Symbol k; g ] when equal_string k "exec" -> - Exec (galaxy_expr_of_expr g) + Exec (sgen_expr_of_expr g) (* linear exec *) | List [ Symbol k; g ] when equal_string k "linexec" -> - LinExec (galaxy_expr_of_expr g) + LinExec (sgen_expr_of_expr g) (* linear exec *) | List [ Symbol k; g ] when equal_string k "eval" -> - Eval (galaxy_expr_of_expr g) + Eval (sgen_expr_of_expr g) (* KEEP LAST -- raw constellation *) - | List g -> Raw (Const (constellation_of_expr (List g))) + | List g -> Raw (constellation_of_expr (List g)) (* --------------------------------------- Stellogen program of Expr @@ -187,21 +187,21 @@ let rec galaxy_expr_of_expr (e : expr) : galaxy_expr = let decl_of_expr : expr -> declaration = function (* definition := *) | List [ Symbol k; x; g ] when equal_string k def_op -> - Def (ray_of_expr x, galaxy_expr_of_expr g) + 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, galaxy_expr_of_expr g) + Def (ray_of_expr x, sgen_expr_of_expr g) (* type declaration :: *) (* | List [ Symbol k; x; g ] when equal_string k typedef_op -> Typedecl (ray_of_expr x, typedecl_of_expr g) *) (* show *) | List [ Symbol k; g ] when equal_string k "show" -> - Show (galaxy_expr_of_expr g) + Show (sgen_expr_of_expr g) (* trace *) | List [ Symbol k; g ] when equal_string k "trace" -> - Trace (galaxy_expr_of_expr g) + Trace (sgen_expr_of_expr g) (* expect *) | List [ Symbol k; x; g ] when equal_string k expect_op -> - Expect (ray_of_expr x, galaxy_expr_of_expr g) + Expect (ray_of_expr x, sgen_expr_of_expr g) | _ -> failwith "error: invalid declaration" let program_of_expr = List.map ~f:decl_of_expr diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index e9a268a..23447cd 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -9,56 +9,47 @@ type idfunc = polarity * string type ray_prefix = StellarRays.fmark * idfunc -and galaxy = - | Const of marked_constellation - | Galaxy of (ident * galaxy_expr) list - -and galaxy_expr = - | Raw of galaxy - | Access of galaxy_expr * ident +and sgen_expr = + | Raw of marked_constellation | Id of ident - | Exec of galaxy_expr - | LinExec of galaxy_expr - | Union of galaxy_expr list - | Subst of galaxy_expr * substitution - | Focus of galaxy_expr - | Clean of galaxy_expr - | Kill of galaxy_expr - | Process of galaxy_expr list - | Eval of galaxy_expr + | Exec of sgen_expr + | LinExec of sgen_expr + | Union of sgen_expr list + | Subst of sgen_expr * substitution + | Focus of sgen_expr + | Clean of sgen_expr + | Kill of sgen_expr + | Process of sgen_expr list + | Eval of sgen_expr and substitution = | Extend of ray_prefix | Reduce of ray_prefix | SVar of string * StellarRays.term | SFunc of (StellarRays.fmark * idfunc) * (StellarRays.fmark * idfunc) - | SGal of ident * galaxy_expr + | SGal of ident * sgen_expr let reserved_words = [ const "clean"; const "kill" ] let is_reserved = List.mem reserved_words ~equal:equal_ray type env = - { objs : (ident * galaxy_expr) list + { objs : (ident * sgen_expr) list ; types : (ident * (ident * ident option) list) list } -let expect (g : galaxy_expr) : galaxy_expr = - Raw - (Galaxy [ (const "interaction", Id (const "tested")); (const "expect", g) ]) - let initial_env = - { objs = [ (const "^empty", Raw (Const [])) ] + { objs = [ (const "^empty", Raw []) ] ; types = [ (const "^empty", [ (const "^empty", None) ]) ] } type declaration = - | Def of ident * galaxy_expr - | Show of galaxy_expr - | Trace of galaxy_expr - | Run of galaxy_expr + | Def of ident * sgen_expr + | Show of sgen_expr + | Trace of sgen_expr + | Run of sgen_expr | Typedecl of ident * (ident * ident option) list - | Expect of ident * galaxy_expr + | Expect of ident * sgen_expr | Use of ident list type program = declaration list diff --git a/src/sgen_err.ml b/src/sgen_err.ml index 4b956c5..6098eae 100644 --- a/src/sgen_err.ml +++ b/src/sgen_err.ml @@ -1,11 +1,10 @@ open Base open Sgen_ast +open Lsc_ast type err = | IllFormedChecker - | ExpectedGalaxy | ReservedWord of string - | UnknownField of string | UnknownID of string - | TestFailed of string * string * string * galaxy * galaxy + | TestFailed of string * string * string * marked_constellation * marked_constellation | LscError of Lsc_err.err_effect diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index d0318f6..5aad22d 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -3,7 +3,6 @@ open Lsc_ast open Lsc_err open Sgen_ast open Sgen_err -open Pretty open Out_channel let ( let* ) x f = Result.bind x ~f @@ -16,80 +15,61 @@ let add_type env x e = List.Assoc.add ~equal:equal_ray env.types x e let get_type env x = List.Assoc.find ~equal:equal_ray env.types x -let rec map_galaxy env ~f : galaxy -> (galaxy, err) Result.t = function - | Const mcs -> Const (f mcs) |> Result.return - | Galaxy g -> - let* g' = - List.map g ~f:(function k, v -> - let* map_v = map_galaxy_expr env ~f v in - (k, map_v) |> Result.return ) - |> Result.all - in - Galaxy g' |> Result.return - -and map_galaxy_expr env ~f : galaxy_expr -> (galaxy_expr, err) Result.t = +let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function - | Raw g -> - let* map_g = map_galaxy env ~f g in - Raw map_g |> Result.return - | Access (e, x) -> - let* map_e = map_galaxy_expr env ~f e in - Access (map_e, x) |> Result.return + | Raw g -> Raw (f g) |> Result.return | Id x when is_reserved x -> Ok (Id x) | Id x -> begin match get_obj env x with | None -> Error (UnknownID (string_of_ray x)) - | Some g -> map_galaxy_expr env ~f g + | Some g -> map_sgen_expr env ~f g end | Exec e -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Exec map_e |> Result.return | Kill e -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Kill map_e |> Result.return | Clean e -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Clean map_e |> Result.return | LinExec e -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in LinExec map_e |> Result.return | Union es -> - let* map_es = List.map ~f:(map_galaxy_expr env ~f) es |> Result.all in + let* map_es = List.map ~f:(map_sgen_expr env ~f) es |> Result.all in Union map_es |> Result.return | Subst (e, Extend pf) -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Subst (map_e, Extend pf) |> Result.return | Subst (e, Reduce pf) -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Subst (map_e, Reduce pf) |> Result.return | Focus e -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Focus map_e |> Result.return | Subst (e, SVar (x, r)) -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Subst (map_e, SVar (x, r)) |> Result.return | Subst (e, SFunc (pf, pf')) -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Subst (map_e, SFunc (pf, pf')) |> Result.return | Subst (e', SGal (x, e)) -> - let* map_e = map_galaxy_expr env ~f e in - let* map_e' = map_galaxy_expr env ~f e' in + let* map_e = map_sgen_expr env ~f e in + let* map_e' = map_sgen_expr env ~f e' in Subst (map_e', SGal (x, map_e)) |> Result.return | Process gs -> - let* procs = List.map ~f:(map_galaxy_expr env ~f) gs |> Result.all in + let* procs = List.map ~f:(map_sgen_expr env ~f) gs |> Result.all in Process procs |> Result.return | Eval e -> - let* map_e = map_galaxy_expr env ~f e in + let* map_e = map_sgen_expr env ~f e in Eval map_e |> Result.return -let rec replace_id env (_from : ident) (_to : galaxy_expr) e : - (galaxy_expr, err) Result.t = +let rec replace_id env (_from : ident) (_to : sgen_expr) e : + (sgen_expr, err) Result.t = match e with | Id x when is_reserved x -> Ok (Id x) | Id x when equal_ray x _from -> Ok _to - | Access (g, x) -> - let* g' = replace_id env _from _to g in - Access (g', x) |> Result.return | Exec e -> let* g = replace_id env _from _to e in Exec g |> Result.return @@ -120,103 +100,73 @@ let rec replace_id env (_from : ident) (_to : galaxy_expr) e : | Raw _ | Id _ -> e |> Result.return let subst_vars env _from _to = - map_galaxy_expr env ~f:(subst_all_vars [ (_from, _to) ]) + map_sgen_expr env ~f:(subst_all_vars [ (_from, _to) ]) let subst_funcs env _from _to = - map_galaxy_expr env ~f:(subst_all_funcs [ (_from, _to) ]) + map_sgen_expr env ~f:(subst_all_funcs [ (_from, _to) ]) -let rec pp_err ~notyping e : (string, err) Result.t = +let rec pp_err e : (string, err) Result.t = match e with | IllFormedChecker -> "Ill-formed checker.\n" |> Result.return - | ExpectedGalaxy -> "Expected galaxy.\n" |> Result.return | ReservedWord x -> Printf.sprintf "%s: identifier '%s' is reserved.\n" (red "ReservedWord Error") x |> Result.return - | UnknownField x -> - Printf.sprintf "%s: field '%s' not found.\n" (red "UnknownField Error") x - |> Result.return | UnknownID x -> Printf.sprintf "%s: identifier '%s' not found.\n" (red "UnknownID Error") x |> Result.return - | TestFailed (x, t, id, got, expected) -> - let* eval_got = galaxy_to_constellation ~notyping initial_env got in - let* eval_exp = galaxy_to_constellation ~notyping initial_env expected in + | TestFailed (x, t, id, got, exp) -> Printf.sprintf "%s: %s.\nChecking %s :: %s\n* got: %s\n* expected: %s\n" (red "TestFailed Error") ( if equal_string id "_" then "unique test of '" ^ t ^ "' failed" else "test '" ^ id ^ "' failed" ) x t - (eval_got |> List.map ~f:remove_mark |> string_of_constellation) - (eval_exp |> List.map ~f:remove_mark |> string_of_constellation) + (got |> List.map ~f:remove_mark |> string_of_constellation) + (exp |> List.map ~f:remove_mark |> string_of_constellation) |> Result.return | LscError e -> pp_err_effect e |> Result.return -and eval_galaxy_expr ~notyping (env : env) : - galaxy_expr -> (galaxy, err) Result.t = function - | Raw (Galaxy g) -> Ok (Galaxy g) - | Raw (Const mcs) -> Ok (Const mcs) - | Access (e, x) -> begin - match eval_galaxy_expr ~notyping env e with - | Ok (Const _) -> Error (UnknownField (string_of_ray x)) - | Ok (Galaxy g) -> begin - try - List.Assoc.find_exn ~equal:equal_ray g x - |> eval_galaxy_expr ~notyping env - with Not_found_s _ -> Error (UnknownField (string_of_ray x)) - end - | Error e -> Error e - end +and eval_sgen_expr ~notyping (env : env) : + sgen_expr -> (marked_constellation, err) Result.t = function + | Raw mcs -> Ok mcs | Id x -> begin begin match get_obj env x with | None -> Error (UnknownID (string_of_ray x)) - | Some g -> eval_galaxy_expr ~notyping env g + | Some g -> eval_sgen_expr ~notyping env g end end | Union es -> - let* eval_es = - List.map ~f:(eval_galaxy_expr ~notyping env) es |> Result.all - in - let* mcs = - eval_es - |> List.map ~f:(galaxy_to_constellation ~notyping env) - |> Result.all - in - Ok (Const (List.concat mcs)) + let* eval_es = List.map ~f:(eval_sgen_expr ~notyping env) es |> Result.all in + let* mcs = Ok eval_es in + Ok (List.concat mcs) | Exec e -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in + let* eval_e = eval_sgen_expr ~notyping env e in begin - match exec ~linear:false ~showtrace:false mcs with - | Ok res -> Ok (Const (unmark_all res)) + match exec ~linear:false ~showtrace:false eval_e with + | Ok res -> Ok (unmark_all res) | Error e -> Error (LscError e) end | LinExec e -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in + let* eval_e = eval_sgen_expr ~notyping env e in begin - match exec ~linear:true ~showtrace:false mcs with - | Ok mcs -> Ok (Const (unmark_all mcs)) + match exec ~linear:true ~showtrace:false eval_e with + | Ok mcs -> Ok (unmark_all mcs) | Error e -> Error (LscError e) end | Focus e -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in - Const (mcs |> remove_mark_all |> focus) |> Result.return + let* eval_e = eval_sgen_expr ~notyping env e in + (eval_e |> remove_mark_all |> focus) |> Result.return | Kill e -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in - Const (mcs |> remove_mark_all |> kill |> focus) |> Result.return + let* eval_e = eval_sgen_expr ~notyping env e in + (eval_e |> remove_mark_all |> kill |> focus) |> Result.return | Clean e -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in - Const (mcs |> remove_mark_all |> clean |> focus) |> Result.return - | Process [] -> Ok (Const []) + let* eval_e = eval_sgen_expr ~notyping env e in + (eval_e |> remove_mark_all |> clean |> focus) |> Result.return + | Process [] -> Ok [] | Process (h :: t) -> - let* eval_e = eval_galaxy_expr ~notyping env h in - let* mcs = galaxy_to_constellation ~notyping env eval_e in - let init = mcs |> remove_mark_all |> focus in + let* eval_e = eval_sgen_expr ~notyping env h in + let init = eval_e |> remove_mark_all |> focus in let* res = List.fold_left t ~init:(Ok init) ~f:(fun acc x -> let* acc = acc in @@ -227,23 +177,18 @@ and eval_galaxy_expr ~notyping (env : env) : acc |> remove_mark_all |> clean |> focus |> Result.return | _ -> let origin = acc |> remove_mark_all |> focus in - let* ev = - eval_galaxy_expr ~notyping env - (Focus (Exec (Union [ x; Raw (Const origin) ]))) - in - galaxy_to_constellation ~notyping env ev ) + eval_sgen_expr ~notyping env + (Focus (Exec (Union [ x; Raw origin ]))) + ) in - Const res |> Result.return + res |> Result.return | Subst (e, Extend pf) -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in - Const (List.map mcs ~f:(map_mstar ~f:(fun r -> gfunc pf [ r ]))) + let* eval_e = eval_sgen_expr ~notyping env e in + (List.map eval_e ~f:(map_mstar ~f:(fun r -> gfunc pf [ r ]))) |> Result.return | Subst (e, Reduce pf) -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in - Const - (List.map mcs + let* eval_e = eval_sgen_expr ~notyping env e in + (List.map eval_e ~f: (map_mstar ~f:(fun r -> match r with @@ -255,20 +200,20 @@ and eval_galaxy_expr ~notyping (env : env) : |> Result.return | Subst (e, SVar (x, r)) -> let* subst = subst_vars env (x, None) r e in - eval_galaxy_expr ~notyping env subst + eval_sgen_expr ~notyping env subst | Subst (e, SFunc (pf1, pf2)) -> let* subst = subst_funcs env pf1 pf2 e in - eval_galaxy_expr ~notyping env subst + eval_sgen_expr ~notyping env subst | Subst (e, SGal (x, _to)) -> let* fill = replace_id env x _to e in - eval_galaxy_expr ~notyping env fill + eval_sgen_expr ~notyping env fill | Eval e -> ( - let* eval_e = eval_galaxy_expr ~notyping env e in + let* eval_e = eval_sgen_expr ~notyping env e in match eval_e with - | Const [ Marked { content = [ r ]; bans = _ } ] - | Const [ Unmarked { content = [ r ]; bans = _ } ] -> - r |> expr_of_ray |> Expr.galaxy_expr_of_expr - |> eval_galaxy_expr ~notyping env + | [ Marked { content = [ r ]; bans = _ } ] + | [ Unmarked { content = [ r ]; bans = _ } ] -> + r |> expr_of_ray |> Expr.sgen_expr_of_expr + |> eval_sgen_expr ~notyping env | _ -> failwith "error: only rays can be evaluated." ) and expr_of_ray = function @@ -281,164 +226,51 @@ and expr_of_ray = function Expr.List (Symbol (Lsc_ast.string_of_polsym pf) :: List.map ~f:expr_of_ray args) -and galaxy_to_constellation ~notyping env : - galaxy -> (marked_constellation, err) Result.t = function - | Const mcs -> Ok mcs - | Galaxy g -> - List.fold_left g ~init:(Ok []) ~f:(fun acc (_, v) -> - let* acc = acc in - let* eval_v = eval_galaxy_expr ~notyping env v in - let* mcs = galaxy_to_constellation ~notyping env eval_v in - Ok (mcs @ acc) ) - -and equal_galaxy ~notyping env g g' = - let* mcs = galaxy_to_constellation ~notyping env g in - let* mcs' = galaxy_to_constellation ~notyping env g' in - equal_mconstellation mcs mcs' |> Result.return - -and typecheck ~notyping env x (t : StellarRays.term) (ck : galaxy_expr) : - (unit, err) Result.t = - let* gtests : (StellarRays.term * galaxy_expr) list = - match get_obj env t with - | Some (Raw (Const mcs)) -> Ok [ (const "_", Raw (Const mcs)) ] - | Some e -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in - [ (const "test", Raw (Const mcs)) ] |> Result.return - | None -> Error (UnknownID (string_of_ray t)) - in - let testing = - List.map gtests ~f:(fun (idtest, test) -> - match ck with - | Raw (Galaxy gck) -> - let format = - try List.Assoc.find_exn ~equal:equal_ray gck (const "interaction") - with Not_found_s _ -> default_interaction - in - begin - match get_obj env x with - | None -> Error (UnknownID (string_of_ray x)) - | Some obj_x -> - Ok - ( idtest - , Exec - (Subst - ( Subst (format, SGal (const "test", test)) - , SGal (const "tested", obj_x) ) ) - |> eval_galaxy_expr ~notyping env ) - end - | _ -> Error IllFormedChecker ) - in - let expect = Access (ck, const "expect") in - let* eval_exp = eval_galaxy_expr ~notyping env expect in - List.map testing ~f:(function - | Ok (idtest, got) -> - let* got = got in - let* eq = equal_galaxy ~notyping env got eval_exp in - if not eq then - Error - (TestFailed - ( string_of_ray x - , string_of_ray t - , string_of_ray idtest - , got - , eval_exp ) ) - else Ok () - | Error e -> Error e ) - |> Result.all_unit - -and default_interaction = - Union [ Focus (Id (const "tested")); Id (const "test") ] - -and default_expect = - Raw (Const [ Unmarked { content = [ func "ok" [] ]; bans = [] } ]) - -and default_checker : galaxy_expr = - Raw - (Galaxy - [ (const "interaction", default_interaction) - ; (const "expect", default_expect) - ] ) - and string_of_type_expr (t, ck) = match ck with | None -> Printf.sprintf "%s" (string_of_ray t) | Some xck -> Printf.sprintf "%s [%s]" (string_of_ray t) (string_of_ray xck) -and string_of_galaxy_declaration ~notyping env = function - | k, v -> ( - match eval_galaxy_expr ~notyping env v with - | Error _ -> failwith "Error: string_of_galaxy_declaration" - | Ok eval_v -> - let str_k = string_of_ray k in - Printf.sprintf " %s = %s\n" str_k (string_of_galaxy ~notyping env eval_v) - ) - -and string_of_galaxy ~notyping env : galaxy -> string = function - | Const mcs -> mcs |> remove_mark_all |> string_of_constellation - | Galaxy g -> - Printf.sprintf "galaxy\n%send" - (string_of_list (string_of_galaxy_declaration ~notyping env) "" g) - let rec eval_decl ~typecheckonly ~notyping env : declaration -> (env, err) Result.t = function | Def (x, _) when is_reserved x -> Error (ReservedWord (string_of_ray x)) | Def (x, e) -> let env = { objs = add_obj env x e; types = env.types } in - let* _ = - if notyping then Ok () - else - List.filter env.types ~f:(fun (y, _) -> equal_ray x y) - |> List.map ~f:(fun (_, ts) -> - List.map ts ~f:(fun (t, ck) -> - match ck with - | None -> typecheck ~notyping env x t default_checker - | Some xck -> begin - match get_obj env xck with - | None -> Error (UnknownID (string_of_ray xck)) - | Some obj_xck -> typecheck ~notyping env x t obj_xck - end ) ) - |> List.concat |> Result.all_unit - in Ok env | Show _ when typecheckonly -> Ok env | Show (Id x) -> begin match get_obj env x with | None -> Error (UnknownID (string_of_ray x)) - | Some g -> eval_decl ~typecheckonly ~notyping env (Show g) + | Some e -> eval_decl ~typecheckonly ~notyping env (Show e) end - | Show (Raw (Galaxy g)) -> - Galaxy g |> string_of_galaxy ~notyping env |> Stdlib.print_string; + | Show (Raw mcs) -> + mcs |> remove_mark_all + |> string_of_constellation |> Stdlib.print_string; Stdlib.print_newline (); Stdlib.flush Stdlib.stdout; Ok env | Show e -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in - List.map mcs ~f:remove_mark + let* eval_e = eval_sgen_expr ~notyping env e in + List.map eval_e ~f:remove_mark |> string_of_constellation |> Stdlib.print_string; Stdlib.print_newline (); Ok env | Trace _ when typecheckonly -> Ok env | Trace e -> - let* eval_e = eval_galaxy_expr ~notyping env e in - let* mcs = galaxy_to_constellation ~notyping env eval_e in + let* eval_e = eval_sgen_expr ~notyping env e in begin - match exec ~showtrace:true mcs with + match exec ~showtrace:true eval_e with | Ok _ -> Ok env | Error e -> Error (LscError e) end | Run _ when typecheckonly -> Ok env | Run e -> - let _ = eval_galaxy_expr ~notyping env (Exec e) in + let _ = eval_sgen_expr ~notyping env (Exec e) in Ok env | Typedecl _ when notyping -> Ok env | Typedecl (x, ts) -> Ok { objs = env.objs; types = add_type env x ts } - | Expect (x, mcs) -> - Ok - { objs = add_obj env (const "^expect") (expect mcs) - ; types = add_type env x [ (const "^empty", Some (const "^expect")) ] - } + | Expect (_x, _mcs) -> Ok { objs = []; types = [] } + (* TODO *) | Use path -> let path = List.map path ~f:string_of_ray in let formatted_filename = String.concat ~sep:"/" path ^ ".sg" in @@ -465,6 +297,6 @@ and eval_program ~typecheckonly ~notyping (p : program) = with | Ok env -> Ok env | Error e -> - let* pp = pp_err ~notyping e in + let* pp = pp_err e in output_string stderr pp; Error e diff --git a/test/behavior/galaxy.sg b/test/behavior/records.sg similarity index 100% rename from test/behavior/galaxy.sg rename to test/behavior/records.sg From becebc2244ea694327c91ea42e7f1046885df268 Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 20 Jun 2025 20:00:32 +0200 Subject: [PATCH 19/45] Remove type declaration --- examples/syntax.sg | 36 ++++++------------------------------ src/sgen_ast.ml | 7 ++++++- src/sgen_err.ml | 10 ---------- src/sgen_eval.ml | 12 ------------ 4 files changed, 12 insertions(+), 53 deletions(-) delete mode 100644 src/sgen_err.ml diff --git a/examples/syntax.sg b/examples/syntax.sg index 5224c7d..cbfc391 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -86,38 +86,14 @@ [(-nat 0) ok] [(-nat (s N)) (+nat N)]]) -'manual typing +'manual type checking (:= 0 (+nat 0)) -(:= expect ) -(== res_int #expect) -(:= res_int @(exec (union @#0 #nat))) +(== test ok) +(:= test @(exec (union @#0 #nat))) -''' -'(:: 0 (nat | checker)) -'(:= 0 (+nat 0)) - -(:: 1 (nat / checker)) -(def 1 - (const (star (+nat (s 0))))) - -'plural typing -(def nat2 - (const (star (-nat X) ok))) - -(:: 2 nat) -(:: 2 nat2) -(def 2 - (const (star (+nat )))) - -(:: 3 nat nat2) -(def 3 - (const (star (+nat )))) - -(:: 4 (nat / checker) (nat2 / checker)) -(def 4 - (const (star (+nat )))) +(:= 2 <+nat s s 0>) +(== test ok) +(:= test @(exec (union @#0 #nat))) 'import file '(use examples automata) - -''' diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index 23447cd..e868beb 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -1,6 +1,12 @@ open Base open Lsc_ast +type err = + | IllFormedChecker + | ReservedWord of string + | UnknownID of string + | LscError of Lsc_err.err_effect + type ident = StellarRays.term type idvar = string * int option @@ -48,7 +54,6 @@ type declaration = | Show of sgen_expr | Trace of sgen_expr | Run of sgen_expr - | Typedecl of ident * (ident * ident option) list | Expect of ident * sgen_expr | Use of ident list diff --git a/src/sgen_err.ml b/src/sgen_err.ml deleted file mode 100644 index 6098eae..0000000 --- a/src/sgen_err.ml +++ /dev/null @@ -1,10 +0,0 @@ -open Base -open Sgen_ast -open Lsc_ast - -type err = - | IllFormedChecker - | ReservedWord of string - | UnknownID of string - | TestFailed of string * string * string * marked_constellation * marked_constellation - | LscError of Lsc_err.err_effect diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 5aad22d..497af59 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -2,7 +2,6 @@ open Base open Lsc_ast open Lsc_err open Sgen_ast -open Sgen_err open Out_channel let ( let* ) x f = Result.bind x ~f @@ -115,15 +114,6 @@ let rec pp_err e : (string, err) Result.t = | UnknownID x -> Printf.sprintf "%s: identifier '%s' not found.\n" (red "UnknownID Error") x |> Result.return - | TestFailed (x, t, id, got, exp) -> - Printf.sprintf "%s: %s.\nChecking %s :: %s\n* got: %s\n* expected: %s\n" - (red "TestFailed Error") - ( if equal_string id "_" then "unique test of '" ^ t ^ "' failed" - else "test '" ^ id ^ "' failed" ) - x t - (got |> List.map ~f:remove_mark |> string_of_constellation) - (exp |> List.map ~f:remove_mark |> string_of_constellation) - |> Result.return | LscError e -> pp_err_effect e |> Result.return and eval_sgen_expr ~notyping (env : env) : @@ -267,8 +257,6 @@ let rec eval_decl ~typecheckonly ~notyping env : | Run e -> let _ = eval_sgen_expr ~notyping env (Exec e) in Ok env - | Typedecl _ when notyping -> Ok env - | Typedecl (x, ts) -> Ok { objs = env.objs; types = add_type env x ts } | Expect (_x, _mcs) -> Ok { objs = []; types = [] } (* TODO *) | Use path -> From 734a14e2663486b04952d3ce597b4a0175be4089 Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 20 Jun 2025 20:06:08 +0200 Subject: [PATCH 20/45] dune fmt --- src/sgen_ast.ml | 5 +---- src/sgen_eval.ml | 47 +++++++++++++++++++++-------------------------- 2 files changed, 22 insertions(+), 30 deletions(-) diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index e868beb..c6ba7b2 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -44,10 +44,7 @@ type env = ; types : (ident * (ident * ident option) list) list } -let initial_env = - { objs = [ (const "^empty", Raw []) ] - ; types = [ (const "^empty", [ (const "^empty", None) ]) ] - } +let initial_env = { objs = []; types = [] } type declaration = | Def of ident * sgen_expr diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 497af59..3be27f0 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -14,8 +14,7 @@ let add_type env x e = List.Assoc.add ~equal:equal_ray env.types x e let get_type env x = List.Assoc.find ~equal:equal_ray env.types x -let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = - function +let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function | Raw g -> Raw (f g) |> Result.return | Id x when is_reserved x -> Ok (Id x) | Id x -> begin @@ -127,7 +126,9 @@ and eval_sgen_expr ~notyping (env : env) : end end | Union es -> - let* eval_es = List.map ~f:(eval_sgen_expr ~notyping env) es |> Result.all in + let* eval_es = + List.map ~f:(eval_sgen_expr ~notyping env) es |> Result.all + in let* mcs = Ok eval_es in Ok (List.concat mcs) | Exec e -> @@ -146,13 +147,13 @@ and eval_sgen_expr ~notyping (env : env) : end | Focus e -> let* eval_e = eval_sgen_expr ~notyping env e in - (eval_e |> remove_mark_all |> focus) |> Result.return + eval_e |> remove_mark_all |> focus |> Result.return | Kill e -> let* eval_e = eval_sgen_expr ~notyping env e in - (eval_e |> remove_mark_all |> kill |> focus) |> Result.return + eval_e |> remove_mark_all |> kill |> focus |> Result.return | Clean e -> let* eval_e = eval_sgen_expr ~notyping env e in - (eval_e |> remove_mark_all |> clean |> focus) |> Result.return + eval_e |> remove_mark_all |> clean |> focus |> Result.return | Process [] -> Ok [] | Process (h :: t) -> let* eval_e = eval_sgen_expr ~notyping env h in @@ -167,26 +168,23 @@ and eval_sgen_expr ~notyping (env : env) : acc |> remove_mark_all |> clean |> focus |> Result.return | _ -> let origin = acc |> remove_mark_all |> focus in - eval_sgen_expr ~notyping env - (Focus (Exec (Union [ x; Raw origin ]))) - ) + eval_sgen_expr ~notyping env (Focus (Exec (Union [ x; Raw origin ]))) ) in res |> Result.return | Subst (e, Extend pf) -> let* eval_e = eval_sgen_expr ~notyping env e in - (List.map eval_e ~f:(map_mstar ~f:(fun r -> gfunc pf [ r ]))) - |> Result.return + List.map eval_e ~f:(map_mstar ~f:(fun r -> gfunc pf [ r ])) |> Result.return | Subst (e, Reduce pf) -> let* eval_e = eval_sgen_expr ~notyping env e in - (List.map eval_e - ~f: - (map_mstar ~f:(fun r -> - match r with - | StellarRays.Func (pf', ts) - when StellarSig.equal_idfunc (snd pf) (snd pf') - && List.length ts = 1 -> - List.hd_exn ts - | _ -> r ) ) ) + List.map eval_e + ~f: + (map_mstar ~f:(fun r -> + match r with + | StellarRays.Func (pf', ts) + when StellarSig.equal_idfunc (snd pf) (snd pf') + && List.length ts = 1 -> + List.hd_exn ts + | _ -> r ) ) |> Result.return | Subst (e, SVar (x, r)) -> let* subst = subst_vars env (x, None) r e in @@ -202,8 +200,7 @@ and eval_sgen_expr ~notyping (env : env) : match eval_e with | [ Marked { content = [ r ]; bans = _ } ] | [ Unmarked { content = [ r ]; bans = _ } ] -> - r |> expr_of_ray |> Expr.sgen_expr_of_expr - |> eval_sgen_expr ~notyping env + r |> expr_of_ray |> Expr.sgen_expr_of_expr |> eval_sgen_expr ~notyping env | _ -> failwith "error: only rays can be evaluated." ) and expr_of_ray = function @@ -234,8 +231,7 @@ let rec eval_decl ~typecheckonly ~notyping env : | Some e -> eval_decl ~typecheckonly ~notyping env (Show e) end | Show (Raw mcs) -> - mcs |> remove_mark_all - |> string_of_constellation |> Stdlib.print_string; + mcs |> remove_mark_all |> string_of_constellation |> Stdlib.print_string; Stdlib.print_newline (); Stdlib.flush Stdlib.stdout; Ok env @@ -257,8 +253,7 @@ let rec eval_decl ~typecheckonly ~notyping env : | Run e -> let _ = eval_sgen_expr ~notyping env (Exec e) in Ok env - | Expect (_x, _mcs) -> Ok { objs = []; types = [] } - (* TODO *) + | Expect (_x, _mcs) -> Ok { objs = []; types = [] } (* TODO *) | Use path -> let path = List.map path ~f:string_of_ray in let formatted_filename = String.concat ~sep:"/" path ^ ".sg" in From a1df89ab7347ce4b9ddb68339c6b1ff1b592fa8c Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 20 Jun 2025 20:55:18 +0200 Subject: [PATCH 21/45] Fix infinite loop with unclosed comments --- src/expr.ml | 2 -- src/lexer.ml | 2 +- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/src/expr.ml b/src/expr.ml index a0314ae..f37b15f 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -32,8 +32,6 @@ let focus_op = "@" let def_op = ":=" -let typedef_op = "::" - let expect_op = "==" let params_op = "$params" diff --git a/src/lexer.ml b/src/lexer.ml index e418a8c..58877b6 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -16,7 +16,7 @@ let rec comment lexbuf = and comments lexbuf = match%sedlex lexbuf with - | "'''" -> read lexbuf + | "'''" | eof -> read lexbuf | _ -> ignore (Sedlexing.next lexbuf); comments lexbuf From 2d1611a82e3ed8cb2ab516a99bd1a5fded687f4d Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 20 Jun 2025 22:28:06 +0200 Subject: [PATCH 22/45] Update README.md --- README.md | 72 ++++++++++++++++++++++--------------------------------- 1 file changed, 28 insertions(+), 44 deletions(-) diff --git a/README.md b/README.md index ac35314..d9f3bb1 100644 --- a/README.md +++ b/README.md @@ -9,15 +9,15 @@ It has been designed from concepts of Girard's transcendental syntax. ## Key characteristics -- dynamically/statically **typed** but without primitive types nor type systems, -by using very flexible assert-like expressions defining *sets of tests* to pass; -- everything is based on **term unification**. +- **typable** but without primitive types nor type systems +- both computation and typing are based on basic **term unification** between +blocks of terms. It is multi-paradigm: -- _logic programs_ called "constellations" are the elementary bricks of -computation and typing; -- _functional programs_ correspond to logic programs enforcing an order of -interaction; +- _logic programs_ called "constellations" are the elementary blocks of +programming; +- _functional programs_ correspond to layered constellations enforcing an order +of interaction; - _imperative programs_ are iterative recipes constructing constellations; - _objects_ are ways to structure constellations. @@ -36,52 +36,36 @@ philosophy). Finite state machine ``` -(spec binary - (const - (star (-i e) ok) - (star (-i [0 X]) (+i X)) - (star (-i [1 X]) (+i X)))) +(spec binary [ + [(-i e) ok] + [(-i [0 X]) (+i X)] + [(-i [1 X]) (+i X)]]) 'input words (:: e binary) -(def e - (const (star (+i e)))) +(:= e (+i e)) (:: 000 binary) -(def 000 - (const (star (+i [0 0 0 e])))) +(:= 000 (+i [0 0 0 e])) (:: 010 binary) -(def 010 - (const (star (+i [0 1 0 e])))) +(:= 010 (+i [0 1 0 e])) (:: 110 binary) -(def 110 - (const (star (+i [1 1 0 e])))) - -(def a1 - (galaxy - (initial - (const - (star (-i W) (+a W q0)))) - (final - (const - (star (-a e q2) accept))) - (transitions - (const - (star (-a [0 W] q0) (+a W q0)) - (star (-a [0 W] q0) (+a W q1)) - (star (-a [1 W] q0) (+a W q0)) - (star (-a [0 W] q1) (+a W q2)))))) - -(show (kill (exec - (union @#e #a1)))) -(show (kill (exec - (union @#000 #a1)))) -(show (kill (exec - (union @#010 #a1)))) -(show (kill (exec - (union @#110 #a1)))) +(:= 110 (+i [1 1 0 e])) + +(:= a1 [ + [(-i W) (+a W q0)] + [(-a e q2) accept] + [(-a [0 W] q0) (+a W q0)] + [(-a [0 W] q0) (+a W q1)] + [(-a [1 W] q0) (+a W q0)] + [(-a [0 W] q1) (+a W q2)]]) + + + + + ``` More examples can be found in `examples/`. From a925e1462ea6b8b4f631f61926ed9e1ecefd69ca Mon Sep 17 00:00:00 2001 From: engboris Date: Fri, 20 Jun 2025 23:27:48 +0200 Subject: [PATCH 23/45] Make lexing more lax --- examples/automata.sg | 8 ++++---- src/expr.ml | 8 +++++--- src/lexer.ml | 3 ++- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/examples/automata.sg b/examples/automata.sg index a065a48..8299635 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -7,21 +7,21 @@ (:: e binary) (:= e (+i e)) -(:: 000 binary) (:= 000 (+i [0 0 0 e])) +(:: 000 binary) -(:: 010 binary) (:= 010 (+i [0 1 0 e])) +(:: 010 binary) -(:: 110 binary) (:= 110 (+i [1 1 0 e])) +(:: 110 binary) ''' automaton accepting words ending with 00 ''' (:= a1 [ [(-i W) (+a W q0)] - [((-a e q2) accept)] + [(-a e q2) accept] [(-a [0 W] q0) (+a W q0)] [(-a [0 W] q0) (+a W q1)] [(-a [1 W] q0) (+a W q0)] diff --git a/src/expr.ml b/src/expr.ml index f37b15f..45c2d90 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -22,9 +22,11 @@ type expr = | Unquote of expr | List of expr list -let nil_op = "$nil" +let primitive = String.append "%" -let cons_op = "$cons" +let nil_op = primitive "nil" + +let cons_op = primitive "cons" let unquote_op = "#" @@ -34,7 +36,7 @@ let def_op = ":=" let expect_op = "==" -let params_op = "$params" +let params_op = primitive "params" let ineq_op = "!=" diff --git a/src/lexer.ml b/src/lexer.ml index 58877b6..831f952 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -23,7 +23,8 @@ and comments lexbuf = and read lexbuf = match%sedlex lexbuf with - | Plus (Compl (Chars "'\" \t\n\r()<>[]|@#")) -> + | Compl (Chars "'\" \t\n\r()<>[]|@#%"), Star (Compl (Chars " \t\n\r()<>[]|")) + -> let lexeme = Utf8.lexeme lexbuf in begin match lexeme.[0] with 'A' .. 'Z' -> VAR lexeme | _ -> SYM lexeme From 54472ce796856b7bbda885827da3d2ec9cd15479 Mon Sep 17 00:00:00 2001 From: engboris Date: Sat, 21 Jun 2025 00:01:09 +0200 Subject: [PATCH 24/45] Remove errors in LSC --- src/expr.ml | 4 +-- src/lsc_ast.ml | 72 +++++++++++++++++------------------------------- src/lsc_err.ml | 21 -------------- src/sgen_ast.ml | 5 +--- src/sgen_eval.ml | 44 ++++++++--------------------- 5 files changed, 40 insertions(+), 106 deletions(-) delete mode 100644 src/lsc_err.ml diff --git a/src/expr.ml b/src/expr.ml index 45c2d90..9036939 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -165,10 +165,10 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr = Clean (sgen_expr_of_expr g) (* exec *) | List [ Symbol k; g ] when equal_string k "exec" -> - Exec (sgen_expr_of_expr g) + Exec (false, sgen_expr_of_expr g) (* linear exec *) | List [ Symbol k; g ] when equal_string k "linexec" -> - LinExec (sgen_expr_of_expr g) + Exec (true, sgen_expr_of_expr g) (* linear exec *) | List [ Symbol k; g ] when equal_string k "eval" -> Eval (sgen_expr_of_expr g) diff --git a/src/lsc_ast.ml b/src/lsc_ast.ml index a957618..c980829 100644 --- a/src/lsc_ast.ml +++ b/src/lsc_ast.ml @@ -2,7 +2,6 @@ open Base open Pretty open Out_channel open In_channel -open Lsc_err let ( let* ) x f = Result.bind x ~f @@ -339,21 +338,6 @@ let fusion repl1 repl2 s1 s2 bans1 bans2 theta : star = ; bans = List.map (nbans1 @ nbans2) ~f:(fmap_ban ~f:(subst theta)) } -let apply_effect r theta : (unit, err_effect) Result.t = - match (r, theta) with - | Func ((Noisy, (_, "print")), _), [] -> Error (TooFewArgs "print") - | Func ((Noisy, (_, "print")), _), _ :: _ :: _ -> Error (TooManyArgs "print") - | Func ((Noisy, (_, "print")), _), [ (_, Func ((_, (Null, arg)), [])) ] -> - String.strip ~drop:(fun x -> equal_char x '\"') arg |> output_string stdout; - flush stdout; - Ok () - | Func ((Noisy, (_, "print")), _), [ (_, arg) ] -> - output_string stdout (string_of_ray arg); - flush stdout; - Ok () - | Func ((Noisy, (_, s)), _), _ -> Error (UnknownEffect s) - | _ -> Ok () - let pause () = flush stdout; let _ = input_line stdin in @@ -384,9 +368,9 @@ let coherent_bans bans = (* interaction between one selected ray and one selected action *) let rec interaction ~showtrace ~queue repl1 repl2 (selected_action, other_actions) (selected_ray, other_rays, bans) : - (star list, err_effect) Result.t = + star list = match selected_action.content with - | [] -> Ok [] + | [] -> [] | r' :: s' when not (is_polarised r') -> interaction ~showtrace ~queue:(r' :: queue) repl1 repl2 ({ content = s'; bans }, other_actions) @@ -405,7 +389,6 @@ let rec interaction ~showtrace ~queue repl1 repl2 (selected_ray, other_rays, bans) (* if there is an actual connection between rays *) | Some theta -> - let* _ = apply_effect selected_ray theta in begin if showtrace then output_string stdout @@ -413,7 +396,7 @@ let rec interaction ~showtrace ~queue repl1 repl2 if showtrace then pause () end; (* action is consumed when execution is linear *) - let* next = + let next = interaction ~showtrace ~queue:(r' :: queue) repl1 repl2 ({ content = s'; bans }, other_actions) (selected_ray, other_rays, bans) @@ -423,29 +406,29 @@ let rec interaction ~showtrace ~queue repl1 repl2 fusion repl1 repl2 other_rays other_rays' bans selected_action.bans theta in - let* res = + let res = if coherent_bans after_fusion.bans then begin let _ = if showtrace then output_string stdout @@ Printf.sprintf " add star %s." (string_of_star after_fusion) in - Ok (after_fusion :: next) + after_fusion :: next end else begin if showtrace then output_string stdout @@ Printf.sprintf " result filtered out by constraint."; - Ok next + next end in if showtrace then pause (); ident_counter := !ident_counter + 2; - Ok res ) + res ) (* search partner for a selected ray within a set of available actions *) let search_partners ~linear ~showtrace (selected_ray, other_rays, bans) actions - : (star list * star list, err_effect) Result.t = + : star list * star list = if showtrace then begin let str_ray = string_of_ray selected_ray in let str_rays = string_of_raylist other_rays in @@ -455,29 +438,29 @@ let search_partners ~linear ~showtrace (selected_ray, other_rays, bans) actions end; let repl1 = replace_indices !ident_counter in let rec try_actions acc = function - | [] -> Ok ([], acc) + | [] -> ([], acc) | selected_action :: other_actions -> let repl2 = replace_indices (!ident_counter + 1) in - let* res = + let res = interaction ~showtrace ~queue:[] repl1 repl2 (selected_action, other_actions) (selected_ray, other_rays, bans) in if (not @@ List.is_empty res) && linear then - let* next, new_actions = try_actions acc other_actions in - Ok (res @ next, new_actions) + let next, new_actions = try_actions acc other_actions in + (res @ next, new_actions) else - let* next, new_actions = + let next, new_actions = try_actions (selected_action :: acc) other_actions in - Ok (res @ next, new_actions) + (res @ next, new_actions) in try_actions [] actions let rec select_ray ~linear ~showtrace ~queue actions other_states - (selected_state, bans) : (star list option * star list, err_effect) Result.t = + (selected_state, bans) : star list option * star list = match selected_state with - | [] -> Ok (None, actions) + | [] -> (None, actions) (* if unpolarized, no need to try, try other stars *) | r :: rs when not (is_polarised r) -> select_ray ~linear ~showtrace ~queue:(r :: queue) actions other_states @@ -490,16 +473,15 @@ let rec select_ray ~linear ~showtrace ~queue actions other_states actions with (* interaction did nothing (no partner), try other rays *) - | Ok ([], new_actions) -> + | ([], new_actions) -> select_ray ~linear ~showtrace ~queue:(selected_ray :: queue) new_actions other_states (other_rays, bans) (* interaction returns a result, keep it for the next round *) - | Ok (new_stars, new_actions) -> Ok (Some new_stars, new_actions) - | Error e -> Error e ) + | (new_stars, new_actions) -> (Some new_stars, new_actions)) let rec select_star ~linear ~showtrace ~queue actions : - star list -> (star list option * star list, err_effect) Result.t = function - | [] -> Ok (None, actions) + star list -> star list option * star list = function + | [] -> (None, actions) (* select a state star and try finding a partner for each ray *) | selected_state :: other_states -> ( match @@ -507,13 +489,12 @@ let rec select_star ~linear ~showtrace ~queue actions : (selected_state.content, selected_state.bans) with (* no success with this star, try other stars *) - | Ok (None, new_actions) -> + | (None, new_actions) -> select_star ~linear ~showtrace new_actions ~queue:(selected_state :: queue) other_states (* got new stars to add, construct the result for the next round *) - | Ok (Some new_stars, new_actions) -> - Ok (Some (List.rev queue @ other_states @ new_stars), new_actions) - | Error e -> Error e ) + | (Some new_stars, new_actions) -> + (Some (List.rev queue @ other_states @ new_stars), new_actions)) let string_of_cfg (actions, states) : string = Printf.sprintf ">> actions: %s\n>> states: %s\n" @@ -521,7 +502,7 @@ let string_of_cfg (actions, states) : string = (string_of_constellation states) let exec ?(showtrace = false) ?(linear = false) mcs : - (constellation, err_effect) Result.t = + constellation = (* do a sequence of rounds with a single interaction on state per round *) let rec loop ((actions, states) as cfg) = if showtrace then begin @@ -529,9 +510,8 @@ let exec ?(showtrace = false) ?(linear = false) mcs : pause () end; match select_star ~linear ~showtrace ~queue:[] actions states with - | Ok (None, _) -> Ok states (* no more possible interaction *) - | Ok (Some res, new_actions) -> loop (new_actions, res) - | Error e -> Error e + | (None, _) -> states (* no more possible interaction *) + | (Some res, new_actions) -> loop (new_actions, res) in let cfg = extract_intspace mcs in if showtrace then diff --git a/src/lsc_err.ml b/src/lsc_err.ml deleted file mode 100644 index 259ed32..0000000 --- a/src/lsc_err.ml +++ /dev/null @@ -1,21 +0,0 @@ -open Base - -let red text = "\x1b[31m" ^ text ^ "\x1b[0m" - -type err_effect = - | TooFewArgs of string - | TooManyArgs of string - | UnknownEffect of string - -let pp_err_effect = function - | TooFewArgs x when equal_string x "print" -> - Printf.sprintf "%s: effect '%s' expects 1 arguments.\n" - (red "Missing argument") x - | TooFewArgs x -> - Printf.sprintf "%s: for effect '%s'.\n" (red "Missing argument") x - | TooManyArgs x when equal_string x "print" -> - Printf.sprintf "%s: effect '%s' expects 1 arguments.\n" - (red "Too many arguments") x - | TooManyArgs x -> - Printf.sprintf "%s: for effect '%s'.\n" (red "Too many arguments") x - | UnknownEffect x -> Printf.sprintf "%s '%s'.\n" (red "UnknownEffect") x diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index c6ba7b2..d8f2fec 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -2,10 +2,8 @@ open Base open Lsc_ast type err = - | IllFormedChecker | ReservedWord of string | UnknownID of string - | LscError of Lsc_err.err_effect type ident = StellarRays.term @@ -18,8 +16,7 @@ type ray_prefix = StellarRays.fmark * idfunc and sgen_expr = | Raw of marked_constellation | Id of ident - | Exec of sgen_expr - | LinExec of sgen_expr + | Exec of bool * sgen_expr | Union of sgen_expr list | Subst of sgen_expr * substitution | Focus of sgen_expr diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 3be27f0..efc552a 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -1,6 +1,5 @@ open Base open Lsc_ast -open Lsc_err open Sgen_ast open Out_channel @@ -22,18 +21,15 @@ let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function | None -> Error (UnknownID (string_of_ray x)) | Some g -> map_sgen_expr env ~f g end - | Exec e -> + | Exec (b, e) -> let* map_e = map_sgen_expr env ~f e in - Exec map_e |> Result.return + Exec (b, map_e) |> Result.return | Kill e -> let* map_e = map_sgen_expr env ~f e in Kill map_e |> Result.return | Clean e -> let* map_e = map_sgen_expr env ~f e in Clean map_e |> Result.return - | LinExec e -> - let* map_e = map_sgen_expr env ~f e in - LinExec map_e |> Result.return | Union es -> let* map_es = List.map ~f:(map_sgen_expr env ~f) es |> Result.all in Union map_es |> Result.return @@ -68,18 +64,15 @@ let rec replace_id env (_from : ident) (_to : sgen_expr) e : match e with | Id x when is_reserved x -> Ok (Id x) | Id x when equal_ray x _from -> Ok _to - | Exec e -> + | Exec (b, e) -> let* g = replace_id env _from _to e in - Exec g |> Result.return + 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 - | LinExec e -> - let* g = replace_id env _from _to e in - LinExec g |> Result.return | Union es -> let* gs = List.map ~f:(replace_id env _from _to) es |> Result.all in Union gs |> Result.return @@ -104,8 +97,8 @@ let subst_funcs env _from _to = map_sgen_expr env ~f:(subst_all_funcs [ (_from, _to) ]) let rec pp_err e : (string, err) Result.t = + let red text = "\x1b[31m" ^ text ^ "\x1b[0m" in match e with - | IllFormedChecker -> "Ill-formed checker.\n" |> Result.return | ReservedWord x -> Printf.sprintf "%s: identifier '%s' is reserved.\n" (red "ReservedWord Error") x @@ -113,7 +106,6 @@ let rec pp_err e : (string, err) Result.t = | UnknownID x -> Printf.sprintf "%s: identifier '%s' not found.\n" (red "UnknownID Error") x |> Result.return - | LscError e -> pp_err_effect e |> Result.return and eval_sgen_expr ~notyping (env : env) : sgen_expr -> (marked_constellation, err) Result.t = function @@ -131,20 +123,9 @@ and eval_sgen_expr ~notyping (env : env) : in let* mcs = Ok eval_es in Ok (List.concat mcs) - | Exec e -> - let* eval_e = eval_sgen_expr ~notyping env e in - begin - match exec ~linear:false ~showtrace:false eval_e with - | Ok res -> Ok (unmark_all res) - | Error e -> Error (LscError e) - end - | LinExec e -> + | Exec (b, e) -> let* eval_e = eval_sgen_expr ~notyping env e in - begin - match exec ~linear:true ~showtrace:false eval_e with - | Ok mcs -> Ok (unmark_all mcs) - | Error e -> Error (LscError e) - end + Ok (exec ~linear:b ~showtrace:false eval_e |> unmark_all) | Focus e -> let* eval_e = eval_sgen_expr ~notyping env e in eval_e |> remove_mark_all |> focus |> Result.return @@ -168,7 +149,7 @@ and eval_sgen_expr ~notyping (env : env) : acc |> remove_mark_all |> clean |> focus |> Result.return | _ -> let origin = acc |> remove_mark_all |> focus in - eval_sgen_expr ~notyping env (Focus (Exec (Union [ x; Raw origin ]))) ) + eval_sgen_expr ~notyping env (Focus (Exec (false, Union [ x; Raw origin ]))) ) in res |> Result.return | Subst (e, Extend pf) -> @@ -244,14 +225,11 @@ let rec eval_decl ~typecheckonly ~notyping env : | Trace _ when typecheckonly -> Ok env | Trace e -> let* eval_e = eval_sgen_expr ~notyping env e in - begin - match exec ~showtrace:true eval_e with - | Ok _ -> Ok env - | Error e -> Error (LscError e) - end + let _ = exec ~showtrace:true eval_e in + Ok env | Run _ when typecheckonly -> Ok env | Run e -> - let _ = eval_sgen_expr ~notyping env (Exec e) in + let _ = eval_sgen_expr ~notyping env (Exec (false, e)) in Ok env | Expect (_x, _mcs) -> Ok { objs = []; types = [] } (* TODO *) | Use path -> From a55ed46b0e2faa82ba953b648a2922f2ad2bb420 Mon Sep 17 00:00:00 2001 From: engboris Date: Sat, 21 Jun 2025 12:05:54 +0200 Subject: [PATCH 25/45] Remove signals/fmark and implement Expect with custom messages --- examples/syntax.sg | 4 ++-- src/expr.ml | 14 ++++++-------- src/lsc_ast.ml | 44 ++++++++++++++++++-------------------------- src/sgen_ast.ml | 23 +++++++++-------------- src/sgen_eval.ml | 44 ++++++++++++++++++++++++++++---------------- src/unification.ml | 40 ++++++++-------------------------------- 6 files changed, 71 insertions(+), 98 deletions(-) diff --git a/examples/syntax.sg b/examples/syntax.sg index cbfc391..fbd1bd2 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -88,12 +88,12 @@ 'manual type checking (:= 0 (+nat 0)) -(== test ok) (:= test @(exec (union @#0 #nat))) +(== test ok) (:= 2 <+nat s s 0>) -(== test ok) (:= test @(exec (union @#0 #nat))) +(== test ok) 'import file '(use examples automata) diff --git a/src/expr.ml b/src/expr.ml index 9036939..5fb768c 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -80,12 +80,11 @@ let symbol_of_str (s : string) : idfunc = | _ -> (Null, s) let rec ray_of_expr : expr -> ray = function - | Symbol s -> to_func ((Muted, symbol_of_str s), []) + | Symbol s -> to_func (symbol_of_str s, []) | Var s -> to_var s - | Unquote e -> to_func ((Muted, (Null, "#")), [ ray_of_expr e ]) + | Unquote e -> to_func ((Null, "#"), [ ray_of_expr e ]) | List [] -> failwith "error: ray cannot be empty" - | List (Symbol h :: t) -> - to_func ((Muted, symbol_of_str h), List.map ~f:ray_of_expr t) + | List (Symbol h :: t) -> to_func (symbol_of_str h, List.map ~f:ray_of_expr t) | List (_ :: _) -> failwith "error: ray must start with constant" let bans_of_expr : expr list -> ban list = @@ -190,9 +189,6 @@ let decl_of_expr : expr -> declaration = function 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) - (* type declaration :: *) - (* | List [ Symbol k; x; g ] when equal_string k typedef_op -> - Typedecl (ray_of_expr x, typedecl_of_expr g) *) (* show *) | List [ Symbol k; g ] when equal_string k "show" -> Show (sgen_expr_of_expr g) @@ -201,7 +197,9 @@ let decl_of_expr : expr -> declaration = function 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) + 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) | _ -> failwith "error: invalid declaration" let program_of_expr = List.map ~f:decl_of_expr diff --git a/src/lsc_ast.ml b/src/lsc_ast.ml index c980829..ba47219 100644 --- a/src/lsc_ast.ml +++ b/src/lsc_ast.ml @@ -70,7 +70,7 @@ let rec compare_ray r1 r2 = String.compare (x ^ i') (y ^ j') | Func _, Var _ -> 1 | Var _, Func _ -> -1 - | Func ((_, pf1), args1), Func ((_, pf2), args2) -> begin + | Func (pf1, args1), Func (pf2, args2) -> begin match (pf1, pf2) with | pf1, pf2 when StellarSig.equal_idfunc pf1 pf2 -> List.compare compare_ray args1 args2 @@ -103,17 +103,13 @@ let neg f = (Neg, f) let null f = (Null, f) -let muted pf = (Muted, pf) - -let noisy pf = (Noisy, pf) - let gfunc c ts = Func (c, ts) -let pfunc f ts = gfunc (muted (pos f)) ts +let pfunc f ts = gfunc (pos f) ts -let nfunc f ts = gfunc (muted (neg f)) ts +let nfunc f ts = gfunc (neg f) ts -let func f ts = gfunc (muted (null f)) ts +let func f ts = gfunc (null f) ts let var x = Var x @@ -124,7 +120,7 @@ let nconst f = nfunc f [] let const f = func f [] let is_polarised r : bool = - let aux = function _, (Pos, _) | _, (Neg, _) -> true | _ -> false in + let aux = function Pos, _ | Neg, _ -> true | _ -> false in exists_func aux r let replace_indices (i : int) : ray -> ray = @@ -139,10 +135,7 @@ let raymatcher r r' : substitution option = let string_of_polarity = function Pos -> "+" | Neg -> "-" | Null -> "" -let string_of_polsym (m, (p, f)) = - match m with - | Noisy -> string_of_polarity p ^ "#" ^ f - | Muted -> string_of_polarity p ^ f +let string_of_polsym (p, f) = string_of_polarity p ^ f let string_of_var (x, i) = match i with None -> x | Some i' -> x ^ Int.to_string i' @@ -150,9 +143,9 @@ let string_of_var (x, i) = let rec string_of_ray = function | Var xi -> string_of_var xi | Func (pf, []) -> string_of_polsym pf - | Func ((_, (Null, ":")), [ Func ((_, (Null, ":")), [ r1; r2 ]); r3 ]) -> + | Func ((Null, "$cons"), [ Func ((Null, "$cons"), [ r1; r2 ]); r3 ]) -> "(" ^ string_of_ray r1 ^ ":" ^ string_of_ray r2 ^ "):" ^ string_of_ray r3 - | Func ((_, (Null, ":")), [ r1; r2 ]) -> + | Func ((Null, "$cons"), [ r1; r2 ]) -> string_of_ray r1 ^ ":" ^ string_of_ray r2 | Func (pf, ts) -> string_of_polsym pf ^ surround "(" ")" @@ -367,8 +360,8 @@ let coherent_bans bans = (* interaction between one selected ray and one selected action *) let rec interaction ~showtrace ~queue repl1 repl2 - (selected_action, other_actions) (selected_ray, other_rays, bans) : - star list = + (selected_action, other_actions) (selected_ray, other_rays, bans) : star list + = match selected_action.content with | [] -> [] | r' :: s' when not (is_polarised r') -> @@ -473,11 +466,11 @@ let rec select_ray ~linear ~showtrace ~queue actions other_states actions with (* interaction did nothing (no partner), try other rays *) - | ([], new_actions) -> + | [], new_actions -> select_ray ~linear ~showtrace ~queue:(selected_ray :: queue) new_actions other_states (other_rays, bans) (* interaction returns a result, keep it for the next round *) - | (new_stars, new_actions) -> (Some new_stars, new_actions)) + | new_stars, new_actions -> (Some new_stars, new_actions) ) let rec select_star ~linear ~showtrace ~queue actions : star list -> star list option * star list = function @@ -489,20 +482,19 @@ let rec select_star ~linear ~showtrace ~queue actions : (selected_state.content, selected_state.bans) with (* no success with this star, try other stars *) - | (None, new_actions) -> + | None, new_actions -> select_star ~linear ~showtrace new_actions ~queue:(selected_state :: queue) other_states (* got new stars to add, construct the result for the next round *) - | (Some new_stars, new_actions) -> - (Some (List.rev queue @ other_states @ new_stars), new_actions)) + | Some new_stars, new_actions -> + (Some (List.rev queue @ other_states @ new_stars), new_actions) ) let string_of_cfg (actions, states) : string = Printf.sprintf ">> actions: %s\n>> states: %s\n" (string_of_constellation actions) (string_of_constellation states) -let exec ?(showtrace = false) ?(linear = false) mcs : - constellation = +let exec ?(showtrace = false) ?(linear = false) mcs : constellation = (* do a sequence of rounds with a single interaction on state per round *) let rec loop ((actions, states) as cfg) = if showtrace then begin @@ -510,8 +502,8 @@ let exec ?(showtrace = false) ?(linear = false) mcs : pause () end; match select_star ~linear ~showtrace ~queue:[] actions states with - | (None, _) -> states (* no more possible interaction *) - | (Some res, new_actions) -> loop (new_actions, res) + | None, _ -> states (* no more possible interaction *) + | Some res, new_actions -> loop (new_actions, res) in let cfg = extract_intspace mcs in if showtrace then diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index d8f2fec..4752f07 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -1,19 +1,13 @@ open Base open Lsc_ast -type err = - | ReservedWord of string - | UnknownID of string - type ident = StellarRays.term type idvar = string * int option type idfunc = polarity * string -type ray_prefix = StellarRays.fmark * idfunc - -and sgen_expr = +type sgen_expr = | Raw of marked_constellation | Id of ident | Exec of bool * sgen_expr @@ -26,15 +20,16 @@ and sgen_expr = | Eval of sgen_expr and substitution = - | Extend of ray_prefix - | Reduce of ray_prefix + | Extend of idfunc + | Reduce of idfunc | SVar of string * StellarRays.term - | SFunc of (StellarRays.fmark * idfunc) * (StellarRays.fmark * idfunc) + | SFunc of idfunc * idfunc | SGal of ident * sgen_expr -let reserved_words = [ const "clean"; const "kill" ] - -let is_reserved = List.mem reserved_words ~equal:equal_ray +type err = + | ReservedWord of string + | ExpectError of marked_constellation * marked_constellation * ident + | UnknownID of string type env = { objs : (ident * sgen_expr) list @@ -48,7 +43,7 @@ type declaration = | Show of sgen_expr | Trace of sgen_expr | Run of sgen_expr - | Expect of ident * sgen_expr + | Expect of ident * sgen_expr * ident | Use of ident list type program = declaration list diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index efc552a..612f329 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -15,7 +15,6 @@ let get_type env x = List.Assoc.find ~equal:equal_ray env.types x let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function | Raw g -> Raw (f g) |> Result.return - | Id x when is_reserved x -> Ok (Id x) | Id x -> begin match get_obj env x with | None -> Error (UnknownID (string_of_ray x)) @@ -62,7 +61,6 @@ let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function let rec replace_id env (_from : ident) (_to : sgen_expr) e : (sgen_expr, err) Result.t = match e with - | Id x when is_reserved x -> Ok (Id x) | Id x when equal_ray x _from -> Ok _to | Exec (b, e) -> let* g = replace_id env _from _to e in @@ -96,18 +94,28 @@ let subst_vars env _from _to = let subst_funcs env _from _to = map_sgen_expr env ~f:(subst_all_funcs [ (_from, _to) ]) -let rec pp_err e : (string, err) Result.t = +let pp_err e : (string, err) Result.t = let red text = "\x1b[31m" ^ text ^ "\x1b[0m" in + let open Lsc_ast.StellarRays in + let open Printf in match e with | ReservedWord x -> - Printf.sprintf "%s: identifier '%s' is reserved.\n" - (red "ReservedWord Error") x + sprintf "%s: identifier '%s' is reserved.\n" (red "ReservedWord Error") x |> Result.return + | ExpectError (x, e, Func ((Null, f), [])) when equal_string f "default" -> + sprintf "%s:\n* expected: %s\n* got: %s\n" (red "Expect Error") + (x |> remove_mark_all |> string_of_constellation) + (e |> remove_mark_all |> string_of_constellation) + |> Result.return + | ExpectError (_x, _e, Func ((Null, f), [ t ])) when equal_string f "error" -> + sprintf "%s: %s\n" (red "Expect Error") (string_of_ray t) |> Result.return + | ExpectError (_x, _e, message) -> + sprintf "%s\n" (string_of_ray message) |> Result.return | UnknownID x -> - Printf.sprintf "%s: identifier '%s' not found.\n" (red "UnknownID Error") x + sprintf "%s: identifier '%s' not found.\n" (red "UnknownID Error") x |> Result.return -and eval_sgen_expr ~notyping (env : env) : +let rec eval_sgen_expr ~notyping (env : env) : sgen_expr -> (marked_constellation, err) Result.t = function | Raw mcs -> Ok mcs | Id x -> begin @@ -143,13 +151,14 @@ and eval_sgen_expr ~notyping (env : env) : List.fold_left t ~init:(Ok init) ~f:(fun acc x -> let* acc = acc in match x with - | Id (Func ((Muted, (Null, "kill")), [])) -> + | Id (Func ((Null, "kill"), [])) -> acc |> remove_mark_all |> kill |> focus |> Result.return - | Id (Func ((Muted, (Null, "clean")), [])) -> + | Id (Func ((Null, "clean"), [])) -> acc |> remove_mark_all |> clean |> focus |> Result.return | _ -> let origin = acc |> remove_mark_all |> focus in - eval_sgen_expr ~notyping env (Focus (Exec (false, Union [ x; Raw origin ]))) ) + eval_sgen_expr ~notyping env + (Focus (Exec (false, Union [ x; Raw origin ]))) ) in res |> Result.return | Subst (e, Extend pf) -> @@ -162,8 +171,7 @@ and eval_sgen_expr ~notyping (env : env) : (map_mstar ~f:(fun r -> match r with | StellarRays.Func (pf', ts) - when StellarSig.equal_idfunc (snd pf) (snd pf') - && List.length ts = 1 -> + when StellarSig.equal_idfunc pf pf' && List.length ts = 1 -> List.hd_exn ts | _ -> r ) ) |> Result.return @@ -188,8 +196,7 @@ and expr_of_ray = function | Var (x, None) -> Expr.Var x | Var (x, Some i) -> Expr.Var (x ^ Int.to_string i) | Func (pf, []) -> Symbol (Lsc_ast.string_of_polsym pf) - | Func ((Muted, (Null, k)), [ r ]) when equal_string k "#" -> - Unquote (expr_of_ray r) + | Func ((Null, k), [ r ]) when equal_string k "#" -> Unquote (expr_of_ray r) | Func (pf, args) -> Expr.List (Symbol (Lsc_ast.string_of_polsym pf) :: List.map ~f:expr_of_ray args) @@ -201,7 +208,6 @@ and string_of_type_expr (t, ck) = let rec eval_decl ~typecheckonly ~notyping env : declaration -> (env, err) Result.t = function - | Def (x, _) when is_reserved x -> Error (ReservedWord (string_of_ray x)) | Def (x, e) -> let env = { objs = add_obj env x e; types = env.types } in Ok env @@ -231,7 +237,13 @@ let rec eval_decl ~typecheckonly ~notyping env : | Run e -> let _ = eval_sgen_expr ~notyping env (Exec (false, e)) in Ok env - | Expect (_x, _mcs) -> Ok { objs = []; types = [] } (* TODO *) + | Expect (x, e, message) -> + let* eval_x = eval_sgen_expr ~notyping env (Id x) in + let* eval_e = eval_sgen_expr ~notyping env e in + let normalize x = x |> remove_mark_all |> unmark_all in + if not @@ equal_mconstellation (normalize eval_e) (normalize eval_x) then + Error (ExpectError (eval_x, eval_e, message)) + else Ok env | Use path -> let path = List.map path ~f:string_of_ray in let formatted_filename = String.concat ~sep:"/" path ^ ".sg" in diff --git a/src/unification.ml b/src/unification.ml index 4035933..9b1a834 100644 --- a/src/unification.ml +++ b/src/unification.ml @@ -17,24 +17,14 @@ end --------------------------------------- *) module Make (Sig : Signature) = struct - type fmark = - | Noisy - | Muted - type term = | Var of Sig.idvar - | Func of (fmark * Sig.idfunc) * term list - - let equal_mark m m' = - match (m, m') with Noisy, Noisy | Muted, Muted -> true | _ -> false - - let equal_func (m, f) (m', f') = equal_mark m m' && Sig.equal_idfunc f f' + | Func of Sig.idfunc * term list let rec equal_term t u = match (t, u) with | Var x, Var y -> Sig.equal_idvar x y - | Func ((Muted, f), ts), Func ((Muted, g), us) - | Func ((Noisy, f), ts), Func ((Noisy, g), us) -> begin + | Func (f, ts), Func (g, us) -> begin try Sig.equal_idfunc f g && List.for_all2_exn ~f:(fun t u -> equal_term t u) ts us @@ -80,7 +70,9 @@ module Make (Sig : Signature) = struct let subst sub = map Fn.id (apply sub) let replace_func from_pf to_pf = - map (fun pf -> if equal_func pf from_pf then to_pf else pf) (fun x -> Var x) + map + (fun pf -> if Sig.equal_idfunc pf from_pf then to_pf else pf) + (fun x -> Var x) let replace_funcs fsub t = List.fold_left fsub ~init:t ~f:(fun acc (from_pf, to_pf) -> @@ -106,13 +98,6 @@ module Make (Sig : Signature) = struct ~init:[] ts |> List.rev - let signals = ref [] - - (* FIXME: doesn't work as expected *) - let emit_signals sub = - let new_signals = List.map ~f:(fun (_, t) -> t) sub in - signals := new_signals @ !signals - let rec solve sub : problem -> substitution option = function | [] -> Some sub (* Clear *) @@ -120,18 +105,9 @@ module Make (Sig : Signature) = struct (* Orient + Replace *) | (Var x, t) :: pbs | (t, Var x) :: pbs -> elim x t pbs sub (* Open *) - | (Func ((m, f), ts), Func ((m', g), us)) :: pbs - when equal_mark m m' && Sig.compatible f g - && List.length ts = List.length us -> begin - match solve sub (List.zip_exn ts us @ pbs) with - | None -> None - | Some s -> begin - match m with - | Noisy -> - emit_signals s; - Some s - | _ -> Some s - end + | (Func (f, ts), Func (g, us)) :: pbs + when Sig.compatible f g && List.length ts = List.length us -> begin + solve sub (List.zip_exn ts us @ pbs) end | _ -> None From 257afe8f6c4af3bf3c71600618f4dcef2752a13e Mon Sep 17 00:00:00 2001 From: engboris Date: Sat, 21 Jun 2025 12:12:34 +0200 Subject: [PATCH 26/45] Remove types --- examples/automata.sg | 2 +- src/sgen_ast.ml | 6 ++---- src/sgen_eval.ml | 6 +----- 3 files changed, 4 insertions(+), 10 deletions(-) diff --git a/examples/automata.sg b/examples/automata.sg index 8299635..ba5b88e 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -4,8 +4,8 @@ [(-i [1 X]) (+i X)]]) 'input words -(:: e binary) (:= e (+i e)) +(:: e binary) (:= 000 (+i [0 0 0 e])) (:: 000 binary) diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index 4752f07..aace8ef 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -32,11 +32,9 @@ type err = | UnknownID of string type env = - { objs : (ident * sgen_expr) list - ; types : (ident * (ident * ident option) list) list - } + { objs : (ident * sgen_expr) list } -let initial_env = { objs = []; types = [] } +let initial_env = { objs = [] } type declaration = | Def of ident * sgen_expr diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 612f329..1ef1e20 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -9,10 +9,6 @@ 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 add_type env x e = List.Assoc.add ~equal:equal_ray env.types x e - -let get_type env x = List.Assoc.find ~equal:equal_ray env.types x - 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 @@ -209,7 +205,7 @@ and string_of_type_expr (t, ck) = let rec eval_decl ~typecheckonly ~notyping env : declaration -> (env, err) Result.t = function | Def (x, e) -> - let env = { objs = add_obj env x e; types = env.types } in + let env = { objs = add_obj env x e } in Ok env | Show _ when typecheckonly -> Ok env | Show (Id x) -> begin From c6e3c6414330104b8e6475dbcb5f9d694de0cded Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 22 Jun 2025 00:39:45 +0200 Subject: [PATCH 27/45] Reimplement string literals --- examples/syntax.sg | 57 +++++++++++++++++++++++++-------------- nvim/syntax/stellogen.vim | 2 +- src/expr.ml | 4 +++ src/lexer.ml | 26 +++++++++++++++++- src/parser.mly | 3 ++- src/sgen_ast.ml | 4 +-- src/sgen_eval.ml | 3 --- 7 files changed, 70 insertions(+), 29 deletions(-) diff --git a/examples/syntax.sg b/examples/syntax.sg index fbd1bd2..ae81783 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -1,33 +1,49 @@ -'static definition of constellation -(:= x [ - [+a] +'define ray +(:= a (-f X)) + +'define star +(:= b [(-f X)]) + +'define constellation +(:= c [ + @[+a] 'focus [-a b]]) -(:= y #x) +'full focus +(show @[ [a] [b] [c] ]) + +'identifier +(:= x #a) -(:= z (-f X)) +'union +(:= x (union #a #b)) 'string literals -'(:= w ["hello world"]) +(:= s ["hello world"]) 'cons -(:= w [(+w [0 1 0 1 e])]) +' [0 1 e] == %cons(0 (%cons 1 %nil)) +(:= w (+w [0 1 0 1])) + +'stack +' == (s (s 0)) +(:= n (+nat )) -'print result of execution +'execution (:= x [(+f X) X]) (:= y (-f a)) +(:= ex (exec (union #x #y))) 'non-linear +(:= ex (linexec (union #x #y))) 'linear + +'show constellation +(show [ [a] [b] [c] ]) +(show #s) 'complex identifiers (:= (f a b) [(function a b)]) (show #(f a b)) -'show (literal) contellations -(show [ [a] [b] [c] ]) - -'full focus -(show @[ [a] [b] [c] ]) - 'inequality constraints (:= ineq [ [(+f a)] @@ -39,7 +55,7 @@ 'interactive debugging of execution '(trace #ineq) -'dynamic definition of constellation +'process (:= c (process (+n0 0) 'base constellation [(-n0 X) (+n1 (s X))] 'interacts with previous @@ -77,15 +93,16 @@ ' [#1=>[(+f X) X)]] ' [#2=>(-f a)]> -'checkers & typechecking -(:= checker [ - [+interaction (union @#tested #test)] - [+expect ok]]) - +'define type (spec nat [ [(-nat 0) ok] [(-nat (s N)) (+nat N)]]) +'expect +(:= x 0) +(== x 0) +'(== x 1) + 'manual type checking (:= 0 (+nat 0)) (:= test @(exec (union @#0 #nat))) diff --git a/nvim/syntax/stellogen.vim b/nvim/syntax/stellogen.vim index 9288693..6a6d82e 100644 --- a/nvim/syntax/stellogen.vim +++ b/nvim/syntax/stellogen.vim @@ -1,6 +1,6 @@ syn clear -syn keyword sgKeyword kill clean eval show use exec spec linear trace process run union +syn keyword sgKeyword 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 diff --git a/src/expr.ml b/src/expr.ml index 5fb768c..5caa302 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -8,6 +8,7 @@ module Raw = struct type t = | Symbol of string | Var of ident + | String of string | Focus of t | Unquote of t | List of t list @@ -32,6 +33,8 @@ let unquote_op = "#" let focus_op = "@" +let string_op = primitive "string" + let def_op = ":=" let expect_op = "==" @@ -55,6 +58,7 @@ let rec to_string : expr -> string = function let rec expand_macro : Raw.t -> expr = function | Raw.Symbol s -> Symbol s | Raw.Var x -> Var x + | Raw.String s -> List [ Symbol string_op; Symbol s ] | Raw.Unquote e' -> Unquote (expand_macro e') | Raw.Focus e' -> List [ Symbol focus_op; expand_macro e' ] | Raw.List es -> List (List.map ~f:expand_macro es) diff --git a/src/lexer.ml b/src/lexer.ml index 831f952..b1d4701 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -40,10 +40,34 @@ and read lexbuf = | '|' -> BAR | '\'' -> comment lexbuf | "'''" -> comments lexbuf - | '"' -> STRMARK + | '"' -> string_literal lexbuf | space | newline -> read lexbuf | eof -> EOF | _ -> raise (SyntaxError ("Unexpected character '" ^ Utf8.lexeme lexbuf ^ "' during lexing") ) + +and string_literal lexbuf = + let buffer = Buffer.create 32 in + let rec loop () = + match%sedlex lexbuf with + | '"' -> STRING (Buffer.contents buffer) + | '\\', any -> + let escaped = + match%sedlex lexbuf with + | 'n' -> '\n' + | 't' -> '\t' + | '\\' -> '\\' + | '"' -> '"' + | _ -> failwith "Unknown escape sequence" + in + Buffer.add_char buffer escaped; + loop () + | eof -> failwith "Unterminated string literal" + | any -> + Buffer.add_string buffer (Sedlexing.Utf8.lexeme lexbuf); + loop () + | _ -> failwith "Invalid character in string literal" + in + loop () diff --git a/src/parser.mly b/src/parser.mly index 1d64b7e..81cd2e6 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -4,7 +4,7 @@ open Expr.Raw %token VAR %token SYM -%token STRMARK +%token STRING %token AT %token BAR %token LPAR RPAR @@ -39,6 +39,7 @@ let params := let expr := | ~=SYM; | ~=VAR; + | ~=STRING; | UNQUOTE; ~=expr; | AT; ~=expr; | ~=pars(expr+); diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index aace8ef..3358796 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -27,12 +27,10 @@ and substitution = | SGal of ident * sgen_expr type err = - | ReservedWord of string | ExpectError of marked_constellation * marked_constellation * ident | UnknownID of string -type env = - { objs : (ident * sgen_expr) list } +type env = { objs : (ident * sgen_expr) list } let initial_env = { objs = [] } diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 1ef1e20..61a30bf 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -95,9 +95,6 @@ let pp_err e : (string, err) Result.t = let open Lsc_ast.StellarRays in let open Printf in match e with - | ReservedWord x -> - sprintf "%s: identifier '%s' is reserved.\n" (red "ReservedWord Error") x - |> Result.return | ExpectError (x, e, Func ((Null, f), [])) when equal_string f "default" -> sprintf "%s:\n* expected: %s\n* got: %s\n" (red "Expect Error") (x |> remove_mark_all |> string_of_constellation) From b701fa59255e0841e84564c92428eedcaaadfe55 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 22 Jun 2025 01:11:11 +0200 Subject: [PATCH 28/45] Reimplement use for importing files --- examples/syntax.sg | 2 +- src/expr.ml | 4 +++- src/lexer.ml | 24 ++++++++++++------------ src/sgen_ast.ml | 2 +- src/sgen_eval.ml | 8 ++++++-- 5 files changed, 23 insertions(+), 17 deletions(-) diff --git a/examples/syntax.sg b/examples/syntax.sg index ae81783..697d655 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -113,4 +113,4 @@ (== test ok) 'import file -'(use examples automata) +'(use "examples/automata.sg") diff --git a/src/expr.ml b/src/expr.ml index 5caa302..1ca619a 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -172,7 +172,7 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr = (* linear exec *) | List [ Symbol k; g ] when equal_string k "linexec" -> Exec (true, sgen_expr_of_expr g) - (* linear exec *) + (* eval *) | List [ Symbol k; g ] when equal_string k "eval" -> Eval (sgen_expr_of_expr g) (* KEEP LAST -- raw constellation *) @@ -204,6 +204,8 @@ let decl_of_expr : expr -> declaration = function 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" let program_of_expr = List.map ~f:decl_of_expr diff --git a/src/lexer.ml b/src/lexer.ml index b1d4701..ddb3ec6 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -54,20 +54,20 @@ and string_literal lexbuf = match%sedlex lexbuf with | '"' -> STRING (Buffer.contents buffer) | '\\', any -> - let escaped = - match%sedlex lexbuf with - | 'n' -> '\n' - | 't' -> '\t' - | '\\' -> '\\' - | '"' -> '"' - | _ -> failwith "Unknown escape sequence" - in - Buffer.add_char buffer escaped; - loop () + let escaped = + match%sedlex lexbuf with + | 'n' -> '\n' + | 't' -> '\t' + | '\\' -> '\\' + | '"' -> '"' + | _ -> failwith "Unknown escape sequence" + in + Buffer.add_char buffer escaped; + loop () | eof -> failwith "Unterminated string literal" | any -> - Buffer.add_string buffer (Sedlexing.Utf8.lexeme lexbuf); - loop () + Buffer.add_string buffer (Sedlexing.Utf8.lexeme lexbuf); + loop () | _ -> failwith "Invalid character in string literal" in loop () diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index 3358796..ba654e9 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -40,6 +40,6 @@ type declaration = | Trace of sgen_expr | Run of sgen_expr | Expect of ident * sgen_expr * ident - | Use of ident list + | Use of ident type program = declaration list diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 61a30bf..25390af 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -238,8 +238,12 @@ let rec eval_decl ~typecheckonly ~notyping env : Error (ExpectError (eval_x, eval_e, message)) else Ok env | Use path -> - let path = List.map path ~f:string_of_ray in - let formatted_filename = String.concat ~sep:"/" path ^ ".sg" in + let open Lsc_ast.StellarRays in + let formatted_filename : string = + match path with + | Func ((Null, f), [ s ]) when equal_string f "%string" -> string_of_ray s + | path -> string_of_ray path ^ ".sg" + in let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in formatted_filename) in From eea51b47dde87af1cd13d9de9f2d653d53a962f9 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 22 Jun 2025 01:21:21 +0200 Subject: [PATCH 29/45] Remove typing option --- bin/sgen.ml | 18 ++++---------- src/sgen_eval.ml | 64 ++++++++++++++++++++---------------------------- 2 files changed, 31 insertions(+), 51 deletions(-) diff --git a/bin/sgen.ml b/bin/sgen.ml index 1d6f706..96aa8e7 100644 --- a/bin/sgen.ml +++ b/bin/sgen.ml @@ -2,7 +2,7 @@ open Base open Cmdliner open Stellogen -let parse_and_eval input_file typecheckonly notyping = +let parse_and_eval input_file = let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in input_file) in let start_pos filename = { Lexing.pos_fname = filename; pos_lnum = 1; pos_bol = 0; pos_cnum = 0 } @@ -17,27 +17,19 @@ let parse_and_eval input_file typecheckonly notyping = Stdlib.flush Stdlib.stdout; let p = Expr.program_of_expr expanded in Stdlib.print_string "\n"; - let _ = Stellogen.Sgen_eval.eval_program ~typecheckonly ~notyping p in + let _ = Stellogen.Sgen_eval.eval_program p in () let input_file_arg = let doc = "Input file to process." in Arg.(required & pos 0 (some string) None & info [] ~docv:"FILENAME" ~doc) -let typecheckonly_flag = - let doc = "Only perform typechecking." in - Arg.(value & flag & info [ "typecheck-only" ] ~doc) - -let notyping_flag = - let doc = "Perform execution without typing." in - Arg.(value & flag & info [ "no-typing" ] ~doc) - let term = let open Term in - const (fun input_file typecheckonly notyping -> - try Ok (parse_and_eval input_file typecheckonly notyping) + const (fun input_file -> + try Ok (parse_and_eval input_file) with e -> Error (`Msg (Stdlib.Printexc.to_string e)) ) - $ input_file_arg $ typecheckonly_flag $ notyping_flag |> term_result + $ input_file_arg |> term_result let cmd = Cmd.v (Cmd.info "sgen" ~doc:"Run the Stellogen program.") term diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 25390af..8f45455 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -108,37 +108,35 @@ let pp_err e : (string, err) Result.t = sprintf "%s: identifier '%s' not found.\n" (red "UnknownID Error") x |> Result.return -let rec eval_sgen_expr ~notyping (env : env) : +let rec eval_sgen_expr (env : env) : sgen_expr -> (marked_constellation, err) Result.t = function | Raw mcs -> Ok mcs | Id x -> begin begin match get_obj env x with | None -> Error (UnknownID (string_of_ray x)) - | Some g -> eval_sgen_expr ~notyping env g + | Some g -> eval_sgen_expr env g end end | Union es -> - let* eval_es = - List.map ~f:(eval_sgen_expr ~notyping env) es |> Result.all - in + let* eval_es = List.map ~f:(eval_sgen_expr env) es |> Result.all in let* mcs = Ok eval_es in Ok (List.concat mcs) | Exec (b, e) -> - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in Ok (exec ~linear:b ~showtrace:false eval_e |> unmark_all) | Focus e -> - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in eval_e |> remove_mark_all |> focus |> Result.return | Kill e -> - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in eval_e |> remove_mark_all |> kill |> focus |> Result.return | Clean e -> - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in eval_e |> remove_mark_all |> clean |> focus |> Result.return | Process [] -> Ok [] | Process (h :: t) -> - let* eval_e = eval_sgen_expr ~notyping env h in + let* eval_e = eval_sgen_expr env h in let init = eval_e |> remove_mark_all |> focus in let* res = List.fold_left t ~init:(Ok init) ~f:(fun acc x -> @@ -150,15 +148,14 @@ let rec eval_sgen_expr ~notyping (env : env) : acc |> remove_mark_all |> clean |> focus |> Result.return | _ -> let origin = acc |> remove_mark_all |> focus in - eval_sgen_expr ~notyping env - (Focus (Exec (false, Union [ x; Raw origin ]))) ) + eval_sgen_expr env (Focus (Exec (false, Union [ x; Raw origin ]))) ) in res |> Result.return | Subst (e, Extend pf) -> - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in List.map eval_e ~f:(map_mstar ~f:(fun r -> gfunc pf [ r ])) |> Result.return | Subst (e, Reduce pf) -> - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in List.map eval_e ~f: (map_mstar ~f:(fun r -> @@ -170,19 +167,19 @@ let rec eval_sgen_expr ~notyping (env : env) : |> Result.return | Subst (e, SVar (x, r)) -> let* subst = subst_vars env (x, None) r e in - eval_sgen_expr ~notyping env subst + eval_sgen_expr env subst | Subst (e, SFunc (pf1, pf2)) -> let* subst = subst_funcs env pf1 pf2 e in - eval_sgen_expr ~notyping env subst + eval_sgen_expr env subst | Subst (e, SGal (x, _to)) -> let* fill = replace_id env x _to e in - eval_sgen_expr ~notyping env fill + eval_sgen_expr env fill | Eval e -> ( - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in match eval_e with | [ Marked { content = [ r ]; bans = _ } ] | [ Unmarked { content = [ r ]; bans = _ } ] -> - r |> expr_of_ray |> Expr.sgen_expr_of_expr |> eval_sgen_expr ~notyping env + r |> expr_of_ray |> Expr.sgen_expr_of_expr |> eval_sgen_expr env | _ -> failwith "error: only rays can be evaluated." ) and expr_of_ray = function @@ -194,21 +191,14 @@ and expr_of_ray = function Expr.List (Symbol (Lsc_ast.string_of_polsym pf) :: List.map ~f:expr_of_ray args) -and string_of_type_expr (t, ck) = - match ck with - | None -> Printf.sprintf "%s" (string_of_ray t) - | Some xck -> Printf.sprintf "%s [%s]" (string_of_ray t) (string_of_ray xck) - -let rec eval_decl ~typecheckonly ~notyping env : - declaration -> (env, err) Result.t = function +let rec eval_decl env : declaration -> (env, err) Result.t = function | Def (x, e) -> let env = { objs = add_obj env x e } in Ok env - | Show _ when typecheckonly -> Ok env | Show (Id x) -> begin match get_obj env x with | None -> Error (UnknownID (string_of_ray x)) - | Some e -> eval_decl ~typecheckonly ~notyping env (Show e) + | Some e -> eval_decl env (Show e) end | Show (Raw mcs) -> mcs |> remove_mark_all |> string_of_constellation |> Stdlib.print_string; @@ -216,23 +206,21 @@ let rec eval_decl ~typecheckonly ~notyping env : Stdlib.flush Stdlib.stdout; Ok env | Show e -> - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in List.map eval_e ~f:remove_mark |> string_of_constellation |> Stdlib.print_string; Stdlib.print_newline (); Ok env - | Trace _ when typecheckonly -> Ok env | Trace e -> - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_e = eval_sgen_expr env e in let _ = exec ~showtrace:true eval_e in Ok env - | Run _ when typecheckonly -> Ok env | Run e -> - let _ = eval_sgen_expr ~notyping env (Exec (false, e)) in + let _ = eval_sgen_expr env (Exec (false, e)) in Ok env | Expect (x, e, message) -> - let* eval_x = eval_sgen_expr ~notyping env (Id x) in - let* eval_e = eval_sgen_expr ~notyping env e in + let* eval_x = eval_sgen_expr env (Id x) in + let* eval_e = eval_sgen_expr env e in let normalize x = x |> remove_mark_all |> unmark_all in if not @@ equal_mconstellation (normalize eval_e) (normalize eval_x) then Error (ExpectError (eval_x, eval_e, message)) @@ -254,15 +242,15 @@ let rec eval_decl ~typecheckonly ~notyping env : 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* env = eval_program ~typecheckonly ~notyping p in + let* env = eval_program p in Ok env -and eval_program ~typecheckonly ~notyping (p : program) = +and eval_program (p : program) = match List.fold_left ~f:(fun acc x -> let* acc = acc in - eval_decl ~typecheckonly ~notyping acc x ) + eval_decl acc x ) ~init:(Ok initial_env) p with | Ok env -> Ok env From fea0a31e8257cf74102a246e5d732e7ac7566bd0 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 22 Jun 2025 12:56:50 +0200 Subject: [PATCH 30/45] Add declaration definition (macro) --- bin/sgen.ml | 6 +-- examples/syntax.sg | 24 ++++++------ nvim/syntax/stellogen.vim | 2 +- src/expr.ml | 77 ++++++++++++++++++++++++++------------- src/sgen_eval.ml | 66 ++++++++++++++++----------------- 5 files changed, 101 insertions(+), 74 deletions(-) diff --git a/bin/sgen.ml b/bin/sgen.ml index 96aa8e7..856d342 100644 --- a/bin/sgen.ml +++ b/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 () diff --git a/examples/syntax.sg b/examples/syntax.sg index 697d655..e1cc854 100644 --- a/examples/syntax.sg +++ b/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 #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) diff --git a/nvim/syntax/stellogen.vim b/nvim/syntax/stellogen.vim index 6a6d82e..cc106fa 100644 --- a/nvim/syntax/stellogen.vim +++ b/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 diff --git a/src/expr.ml b/src/expr.ml index 1ca619a..9ee4672 100644 --- a/src/expr.ml +++ b/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,26 +192,19 @@ 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)) @@ -182,23 +212,16 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr = 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") @@ -206,6 +229,8 @@ let decl_of_expr : expr -> declaration = function 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 [] diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 8f45455..f603021 100644 --- a/src/sgen_eval.ml +++ b/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 From 9d9e400edc3e25a9c253f172a7287774058027fe Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 22 Jun 2025 15:19:52 +0200 Subject: [PATCH 31/45] Fix cons and fix automata example --- examples/automata.sg | 31 +++++++++++++++++++------------ examples/syntax.sg | 2 +- src/expr.ml | 6 ++++-- src/lsc_ast.ml | 4 ++-- src/parser.mly | 3 ++- src/sgen_eval.ml | 2 +- 6 files changed, 29 insertions(+), 19 deletions(-) diff --git a/examples/automata.sg b/examples/automata.sg index ba5b88e..36b154b 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -1,19 +1,26 @@ +(new-declaration (:: tested test) + (:= test @(exec (union @#tested #test))) + (== test ok)) + (spec binary [ - [(-i e) ok] - [(-i [0 X]) (+i X)] - [(-i [1 X]) (+i X)]]) + [(-i []) ok] + [(-i [0|X]) (+i X)] + [(-i [1|X]) (+i X)]]) 'input words -(:= e (+i e)) +(:= e (+i [])) (:: e binary) -(:= 000 (+i [0 0 0 e])) +(:= 0 (+i [0])) +(:: 0 binary) + +(:= 000 (+i [0 0 0])) (:: 000 binary) -(:= 010 (+i [0 1 0 e])) +(:= 010 (+i [0 1 0])) (:: 010 binary) -(:= 110 (+i [1 1 0 e])) +(:= 110 (+i [1 1 0])) (:: 110 binary) ''' @@ -21,11 +28,11 @@ automaton accepting words ending with 00 ''' (:= a1 [ [(-i W) (+a W q0)] - [(-a e q2) accept] - [(-a [0 W] q0) (+a W q0)] - [(-a [0 W] q0) (+a W q1)] - [(-a [1 W] q0) (+a W q0)] - [(-a [0 W] q1) (+a W q2)]]) + [(-a [] q2) accept] + [(-a [0|W] q0) (+a W q0)] + [(-a [0|W] q0) (+a W q1)] + [(-a [1|W] q0) (+a W q0)] + [(-a [0|W] q1) (+a W q2)]]) diff --git a/examples/syntax.sg b/examples/syntax.sg index e1cc854..664f7fd 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -48,7 +48,7 @@ (:= ineq [ [(+f a)] [(+f b)] - @[(-f X) (-f Y) (r X Y) | (!= X Y)]]) + @[(-f X) (-f Y) (r X Y) || (!= X Y)]]) (show #ineq) diff --git a/src/expr.ml b/src/expr.ml index 9ee4672..f6ea50a 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -15,6 +15,7 @@ module Raw = struct | Stack of t list | Cons of t list | ConsWithParams of t list * t list + | ConsWithBase of t list * t end type expr = @@ -62,8 +63,9 @@ let rec expand_macro : Raw.t -> expr = function | Raw.Unquote e' -> Unquote (expand_macro e') | Raw.Focus e' -> List [ Symbol focus_op; expand_macro e' ] | Raw.List es -> List (List.map ~f:expand_macro es) - | Raw.Cons es -> - List.fold_left es ~init:(Symbol nil_op) ~f:(fun acc e -> + | Raw.Cons es -> expand_macro (Raw.ConsWithBase (es, Symbol nil_op)) + | Raw.ConsWithBase (es, base) -> + List.fold_left es ~init:(expand_macro base) ~f:(fun acc e -> List [ Symbol cons_op; expand_macro e; acc ] ) | Raw.ConsWithParams (es, ps) -> List [ Symbol params_op; expand_macro (Cons es); expand_macro (List ps) ] diff --git a/src/lsc_ast.ml b/src/lsc_ast.ml index ba47219..dcb3f06 100644 --- a/src/lsc_ast.ml +++ b/src/lsc_ast.ml @@ -143,9 +143,9 @@ let string_of_var (x, i) = let rec string_of_ray = function | Var xi -> string_of_var xi | Func (pf, []) -> string_of_polsym pf - | Func ((Null, "$cons"), [ Func ((Null, "$cons"), [ r1; r2 ]); r3 ]) -> + | Func ((Null, "%cons"), [ Func ((Null, "%cons"), [ r1; r2 ]); r3 ]) -> "(" ^ string_of_ray r1 ^ ":" ^ string_of_ray r2 ^ "):" ^ string_of_ray r3 - | Func ((Null, "$cons"), [ r1; r2 ]) -> + | Func ((Null, "%cons"), [ r1; r2 ]) -> string_of_ray r1 ^ ":" ^ string_of_ray r2 | Func (pf, ts) -> string_of_polsym pf ^ surround "(" ")" diff --git a/src/parser.mly b/src/parser.mly index 81cd2e6..8e27407 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -34,7 +34,7 @@ let expr_file := | es=expr+; EOF; { es } let params := - | BAR; ~=expr+; <> + | BAR; BAR; ~=expr+; <> let expr := | ~=SYM; @@ -46,3 +46,4 @@ let expr := | LANGLE; es=revlist(expr); RANGLE; | LBRACK; es=revlist(expr); RBRACK; | LBRACK; ~=revlist(expr); ~=params; RBRACK; + | LBRACK; ~=revlist(expr); BAR; ~=expr; RBRACK; diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index f603021..0f96b8d 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -97,8 +97,8 @@ let pp_err e : (string, err) Result.t = match e with | ExpectError (x, e, Func ((Null, f), [])) when equal_string f "default" -> sprintf "%s:\n* expected: %s\n* got: %s\n" (red "Expect Error") - (x |> remove_mark_all |> string_of_constellation) (e |> remove_mark_all |> string_of_constellation) + (x |> remove_mark_all |> string_of_constellation) |> Result.return | ExpectError (_x, _e, Func ((Null, f), [ t ])) when equal_string f "error" -> sprintf "%s: %s\n" (red "Expect Error") (string_of_ray t) |> Result.return From 64f99d3260e71839a875b3dd7ac3197a60d8f5c6 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 22 Jun 2025 16:18:43 +0200 Subject: [PATCH 32/45] Implement placeholder variable and fix examples --- README.md | 34 ++++++++++------ examples/binary4.sg | 10 +++-- examples/nat.sg | 61 +++++++++++++---------------- examples/npda.sg | 65 ++++++++++++++----------------- examples/prolog.sg | 42 ++++++++------------ examples/stack.sg | 23 +++++------ examples/sumtypes.sg | 44 +++++++++------------ examples/turing.sg | 92 ++++++++++++++++++-------------------------- src/expr.ml | 1 + src/lexer.ml | 2 +- src/sgen_eval.ml | 4 +- 11 files changed, 171 insertions(+), 207 deletions(-) diff --git a/README.md b/README.md index d9f3bb1..83b1ea3 100644 --- a/README.md +++ b/README.md @@ -36,31 +36,41 @@ philosophy). Finite state machine ``` +(new-declaration (:: tested test) + (:= test @(exec (union @#tested #test))) + (== test ok)) + (spec binary [ - [(-i e) ok] - [(-i [0 X]) (+i X)] - [(-i [1 X]) (+i X)]]) + [(-i []) ok] + [(-i [0|X]) (+i X)] + [(-i [1|X]) (+i X)]]) 'input words +(:= e (+i [])) (:: e binary) -(:= e (+i e)) +(:= 0 (+i [0])) +(:: 0 binary) + +(:= 000 (+i [0 0 0])) (:: 000 binary) -(:= 000 (+i [0 0 0 e])) +(:= 010 (+i [0 1 0])) (:: 010 binary) -(:= 010 (+i [0 1 0 e])) +(:= 110 (+i [1 1 0])) (:: 110 binary) -(:= 110 (+i [1 1 0 e])) +''' +automaton accepting words ending with 00 +''' (:= a1 [ [(-i W) (+a W q0)] - [(-a e q2) accept] - [(-a [0 W] q0) (+a W q0)] - [(-a [0 W] q0) (+a W q1)] - [(-a [1 W] q0) (+a W q0)] - [(-a [0 W] q1) (+a W q2)]]) + [(-a [] q2) accept] + [(-a [0|W] q0) (+a W q0)] + [(-a [0|W] q0) (+a W q1)] + [(-a [1|W] q0) (+a W q0)] + [(-a [0|W] q1) (+a W q2)]]) diff --git a/examples/binary4.sg b/examples/binary4.sg index b29e1b5..f3058d3 100644 --- a/examples/binary4.sg +++ b/examples/binary4.sg @@ -1,8 +1,10 @@ -(spec u4 - (const - (star (-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))) + (== test ok)) -(def checker +(:= checker (galaxy (interaction (process diff --git a/examples/nat.sg b/examples/nat.sg index 1219542..95230ea 100644 --- a/examples/nat.sg +++ b/examples/nat.sg @@ -1,42 +1,35 @@ -(spec nat - (const - (star (-nat 0) ok) - (star (-nat (s N)) (+nat N)))) +(spec nat [ + [(-nat 0) ok] + [(-nat (s N)) (+nat N)]]) -(def fchecker - (galaxy - (interaction (union @#tested #test)) - (expect (const (star arg out))))) +(new-declaration (:: tested test) + (:= test @(exec (union @#tested #test))) + (== test ok)) -(spec (arrow nat nat) - (const - (star (+nat X) arg) - (star (-nat X) out))) +(new-declaration (:: tested test fchecker) + (:= test @(exec (union @#tested #test))) + (== test [arg out])) +(spec (arrow nat nat) [ + [(+nat X) arg] + [(-nat X) out]]) + +(:= 0 (+nat 0)) (:: 0 nat) -(def 0 - (const (star (+nat 0)))) +(:= 1 (+nat (s 0))) (:: 1 nat) -(def 1 - (const - (star (+nat (s 0))))) +(:= 2 <+nat s s 0>) (:: 2 nat) -(def 2 - (const - (star <+nat s s /0>))) - -(:: add1 ((arrow nat nat) / fchecker)) -(def add1 - (const - (star (-nat X) (+nat (s X))))) - -(def is_empty - (const - (star (-nat 0) (res 1)) - (star (-nat (s _)) (res 0)))) - -(show-exec (union @#add1 #2)) -(show-exec (union #is_empty @#0)) -(show-exec (union #is_empty @#1)) + +(:= add1 [(-nat X) (+nat (s X))]) +(:: add1 (arrow nat nat) fchecker) + +(:= is_empty [ + [(-nat 0) (res 1)] + [(-nat (s _)) (res 0)]]) + + + + diff --git a/examples/npda.sg b/examples/npda.sg index 458e5f5..1679ffa 100644 --- a/examples/npda.sg +++ b/examples/npda.sg @@ -1,48 +1,39 @@ -(spec binary - (const - (star (-i e) ok) - (star (-i [0 X]) (+i X)) - (star (-i [1 X]) (+i X)))) +(new-declaration (:: tested test) + (:= test @(exec (union @#tested #test))) + (== test ok)) + +(spec binary [ + [(-i []) ok] + [(-i [0|X]) (+i X)] + [(-i [1|X]) (+i X)]]) 'input words +(:= e (+i [])) (:: e binary) -(def e - (const (star (+i e)))) +(:= 0000 (+i [0 0 0 0])) (:: 0000 binary) -(def 0000 - (const (star (+i [0 0 0 0 e])))) +(:= 0110 (+i [0 1 1 0])) (:: 0110 binary) -(def 0110 - (const (star (+i [0 1 1 0 e])))) +(:= 1110 (+i [1 1 1 0])) (:: 1110 binary) -(def 1110 - (const (star (+i [1 1 1 0 e])))) -(def a1 - (galaxy - (initial - (const - (star (-i W) (+a W e q0)))) - (final - (const - (star (-a e e q0) accept) - (star (-a e e q1) accept))) - (transitions - (const - (star (-a [0 W] S q0) (+a W [0 S] q0)) - (star (-a [1 W] S q0) (+a W [1 S] q0)) - (star (-a W S q0) (+a W S q1)) - (star (-a [0 W] [0 S] q1) (+a W S q1)) - (star (-a [1 W] [1 S] q1) (+a W S q1)))))) +(:= a1 [ + 'initial + [(-i W) (+a W [] q0)] + 'final + [(-a [] [] q0) accept] + [(-a [] [] q1) accept] + 'transitions + [(-a [0|W] S q0) (+a W [0|S] q0)] + [(-a [1|W] S q0) (+a W [1|S] q0)] + [(-a W S q0) (+a W S q1)] + [(-a [0|W] [0|S] q1) (+a W S q1)] + [(-a [1|W] [1|S] q1) (+a W S q1)]]) -(show (kill (exec - (union @#e #a1)))) -(show (kill (exec - (union @#0000 #a1)))) -(show (kill (exec - (union @#0110 #a1)))) -(show (kill (exec - (union @#1110 #a1)))) + + + + diff --git a/examples/prolog.sg b/examples/prolog.sg index 0ccea06..bfbba51 100644 --- a/examples/prolog.sg +++ b/examples/prolog.sg @@ -1,35 +1,27 @@ ' unary addition -(def add - (const - (star (+add 0 Y Y)) - (star (-add X Y Z) (+add (s X) Y (s Z))))) +(:= add [ + [(+add 0 Y Y)] + [(-add X Y Z) (+add (s X) Y (s Z))]]) ' 2 + 2 = R -(def query - (const - (star (-add R) R))) +(:= query [(-add R) R]) -(show-exec (union #add @#query)) + -(def graph - (const - (star (+from 1) (+to 2)) - (star (+from 1) (+to 3)) - (star (+from 3) (+to 2)) - (star (+from 3) (+to 4)))) - '(star (+from 4) (+to 3)) +(:= graph [ + [(+from 1) (+to 2)] + [(+from 1) (+to 3)] + [(+from 3) (+to 2)] + '[(+from 4) (+to 3)] + [(+from 3) (+to 4)]]) -(def composition - (const - (star (-to X) (-from X)))) +(:= composition [(-to X) (-from X)]) ' is there a path between 1 and 4? -(def query - (const - (@star (-from 1)) - (star (-to 4) ok))) +(:= query [ + @[(-from 1)] + [(-to 4) ok]]) -(show-exec (process + diff --git a/examples/stack.sg b/examples/stack.sg index 957d79f..f44d55a 100644 --- a/examples/stack.sg +++ b/examples/stack.sg @@ -1,21 +1,18 @@ -(show-exec (process - (const (star (+stack0 e))) + diff --git a/examples/sumtypes.sg b/examples/sumtypes.sg index 9ea1e24..6c0cff3 100644 --- a/examples/sumtypes.sg +++ b/examples/sumtypes.sg @@ -1,32 +1,26 @@ -(def checker - (galaxy - (interaction (union @#tested #test)) - (expect (const (star ok))))) +(new-declaration (:: tested test) + (:= test @(exec (union @#tested #test))) + (== test ok)) -(spec direction - (const - (star -north ok) - (star -south ok) - (star -west ok) - (star -east ok))) +(spec direction [ + [-north ok] + [-south ok] + [-west ok] + [-east ok]]) -(:: n (direction / checker)) -(def n - (const (star +north))) +(:= n +north) +(:: n direction) -(spec result - (const - (star (-ok X) ok) - (star (-error X) ok))) +(spec result [ + [(-ok X) ok] + [(-error X) ok]]) -(:: x (result / checker)) -(def x - (const (star (+ok a)))) +(:= x (+ok a)) +(:: x result) 'pattern matching -(def get_ok - (const - (star (-ok X) X) - (star (-error X) (+error X)))) +(:= get_ok [ + [(-ok X) X] + [(-error X) (+error X)]]) -(show-exec (union #get_ok @#x)) + diff --git a/examples/turing.sg b/examples/turing.sg index 44a4eef..9075cd4 100644 --- a/examples/turing.sg +++ b/examples/turing.sg @@ -1,56 +1,40 @@ ' Turing machine accepting words with as many 'a' as 'b' -(def mt - (galaxy - (initial - (const - (star (-i [C W]) (+m q0 [e e] C W)) - (star (-i e) (+m q0 e e e)))) - (accept - (const - (star (-m q0 L e R) (+m qa L e R)) - (star (-m qa L e R) accept))) - (initial_skip - (const - (star (-m q0 L sep [C R]) (+m q0 [sep L] C R)))) - (mark - (const - (star (-m q0 L a [C R]) (+m q2 [sep L] C R)) - (star (-m q0 L b [C R]) (+m q3 [sep L] C R)))) - (skip - (const - (star (-m q2 L a [C R]) (+m q2 [a L] C R)) - (star (-m q2 L sep [C R]) (+m q2 [sep L] C R)) - (star (-m q3 L b [C R]) (+m q3 [b L] C R)) - (star (-m q3 L sep [C R]) (+m q3 [sep L] C R)))) - (join - (const - (star (-m q2 [C L] b R) (+m q1 L C [sep R])) - (star (-m q3 [C L] a R) (+m q1 L C [sep R])))) - (return - (const - (star (-m q1 [C L] a R) (+m q1 L C [a R])) - (star (-m q1 [C L] b R) (+m q1 L C [b R])) - (star (-m q1 [C L] sep R) (+m q1 L C [sep R])) - (star (-m q1 L e [C R]) (+m q0 [e L] C R)))) - (reject - (const - (star (-m q2 L e R) (+m qr L e R)) - (star (-m q3 L e R) (+m qr L e R)) - (star (-m qr L C R) reject))))) +(:= mt [ + 'initial + [(-i [C|W]) (+m q0 [e e] C W)] + [(-i []) (+m q0 e e e)] + 'accept + [(-m q0 L e R) (+m qa L e R)] + [(-m qa L e R) accept] + 'initial skip + [(-m q0 L sep [C|R]) (+m q0 [sep|L] C R)] + 'mark + [(-m q0 L a [C|R]) (+m q2 [sep|L] C R)] + [(-m q0 L b [C|R]) (+m q3 [sep|L] C R)] + 'skip + [(-m q2 L a [C|R]) (+m q2 [a|L] C R)] + [(-m q2 L sep [C|R]) (+m q2 [sep|L] C R)] + [(-m q3 L b [C|R]) (+m q3 [b|L] C R)] + [(-m q3 L sep [C|R]) (+m q3 [sep|L] C R)] + 'join + [(-m q2 [C|L] b R) (+m q1 L C [sep|R])] + [(-m q3 [C|L] a R) (+m q1 L C [sep|R])] + 'return + [(-m q1 [C|L] a R) (+m q1 L C [a|R])] + [(-m q1 [C|L] b R) (+m q1 L C [b|R])] + [(-m q1 [C|L] sep R) (+m q1 L C [sep|R])] + [(-m q1 L e [C|R]) (+m q0 [e|L] C R)] + 'reject + [(-m q2 L e R) (+m qr L e R)] + [(-m q3 L e R) (+m qr L e R)] + [(-m qr L C R) reject]]) -(show (kill (exec - (union @(const (star (+i [a e e]))) #mt)))) -(show (kill (exec - (union @(const (star (+i [b e e]))) #mt)))) -(show (kill (exec - (union @(const (star (+i [a b b e e]))) #mt)))) -(show (kill (exec - (union @(const (star (+i [e e]))) #mt)))) -(show (kill (exec - (union @(const (star (+i [a b e e]))) #mt)))) -(show (kill (exec - (union @(const (star (+i [a a b b e e]))) #mt)))) -(show (kill (exec - (union @(const (star (+i [a b b a e e]))) #mt)))) -(show (kill (exec - (union @(const (star (+i [a b a b e e]))) #mt)))) + + + + + + + + + diff --git a/src/expr.ml b/src/expr.ml index f6ea50a..ddd4e29 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -124,6 +124,7 @@ let symbol_of_str (s : string) : idfunc = let rec ray_of_expr : expr -> ray = function | Symbol s -> to_func (symbol_of_str s, []) + | Var "_" -> to_var ("_"^(fresh_placeholder ())) | Var s -> to_var s | Unquote e -> to_func ((Null, "#"), [ ray_of_expr e ]) | List [] -> failwith "error: ray cannot be empty" diff --git a/src/lexer.ml b/src/lexer.ml index ddb3ec6..e36d761 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -27,7 +27,7 @@ and read lexbuf = -> let lexeme = Utf8.lexeme lexbuf in begin - match lexeme.[0] with 'A' .. 'Z' -> VAR lexeme | _ -> SYM lexeme + match lexeme.[0] with ('_' | 'A' .. 'Z') -> VAR lexeme | _ -> SYM lexeme end | '(' -> LPAR | ')' -> RPAR diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 0f96b8d..4cce4c6 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -142,9 +142,9 @@ let rec eval_sgen_expr (env : env) : List.fold_left t ~init:(Ok init) ~f:(fun acc x -> let* acc = acc in match x with - | Id (Func ((Null, "kill"), [])) -> + | Id (Func ((Null, "&kill"), [])) -> acc |> remove_mark_all |> kill |> focus |> Result.return - | Id (Func ((Null, "clean"), [])) -> + | Id (Func ((Null, "&clean"), [])) -> acc |> remove_mark_all |> clean |> focus |> Result.return | _ -> let origin = acc |> remove_mark_all |> focus in From 6902a3bf22d6324b497737519e666b4f13816672 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 22 Jun 2025 18:38:43 +0200 Subject: [PATCH 33/45] Add placeholder --- src/expr.ml | 2 +- src/lexer.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/expr.ml b/src/expr.ml index ddd4e29..446cfbc 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -124,7 +124,7 @@ let symbol_of_str (s : string) : idfunc = let rec ray_of_expr : expr -> ray = function | Symbol s -> to_func (symbol_of_str s, []) - | Var "_" -> to_var ("_"^(fresh_placeholder ())) + | Var "_" -> to_var ("_" ^ fresh_placeholder ()) | Var s -> to_var s | Unquote e -> to_func ((Null, "#"), [ ray_of_expr e ]) | List [] -> failwith "error: ray cannot be empty" diff --git a/src/lexer.ml b/src/lexer.ml index e36d761..80317b1 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -27,7 +27,7 @@ and read lexbuf = -> let lexeme = Utf8.lexeme lexbuf in begin - match lexeme.[0] with ('_' | 'A' .. 'Z') -> VAR lexeme | _ -> SYM lexeme + match lexeme.[0] with '_' | 'A' .. 'Z' -> VAR lexeme | _ -> SYM lexeme end | '(' -> LPAR | ')' -> RPAR From 6c9e76d392e9243aacc1dba2cd3cb65b02b3159f Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 22 Jun 2025 19:44:58 +0200 Subject: [PATCH 34/45] Fix examples --- examples/automata.sg | 4 -- examples/mll.sg | 121 ++++++++++++++++++++----------------------- examples/nat.sg | 15 ++---- 3 files changed, 58 insertions(+), 82 deletions(-) diff --git a/examples/automata.sg b/examples/automata.sg index 36b154b..cf53073 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -1,7 +1,3 @@ -(new-declaration (:: tested test) - (:= test @(exec (union @#tested #test))) - (== test ok)) - (spec binary [ [(-i []) ok] [(-i [0|X]) (+i X)] diff --git a/examples/mll.sg b/examples/mll.sg index 71fd5af..c3346d9 100644 --- a/examples/mll.sg +++ b/examples/mll.sg @@ -1,75 +1,64 @@ -' test of linear identity -(spec (larrow a a) - (galaxy - (testrl - (const - (star (-1 X) (-2 X) (+c5 X)) - (star (-3 X)) (star (-4 X) (+c6 X)) - (star (-c5 X) (+7 X)) (star (-c6 X)) - (@star (-7 X) ok))) - (testrr - (const - (star (-1 X) (-2 X) (+c5 X)) - (star (-3 X)) (star (-4 X) (+c6 X)) - (star (-c5 X)) (star (+7 X) (-c6 X)) - (@star (-7 X) ok))) - (testll - (const - (star (-1 X) (-2 X) (+c5 X)) - (star (-4 X)) (star (-3 X) (+c6 X)) - (star (-c5 X) (+7 X)) (star (-c6 X)) - (@star (-7 X) ok))) - (testlr - (const - (star (-1 X) (-2 X) (+c5 X)) - (star (-4 X)) (star (-3 X) (+c6 X)) - (star (-c5 X)) (star (+7 X) (-c6 X)) - (@star (-7 X) ok))))) +(new-declaration (:: tested test) + (:= test @(exec (union #tested #test))) + (== test ok)) -(def checker - (galaxy - (interaction (union #tested #test)) - (expect (const (star ok))))) +' test of linear identity +(spec (larrow a a) [ + [+testrl [ + [(-1 X) (-2 X) (+c5 X)] + [(-3 X)] [(-4 X) (+c6 X)] + [(-c5 X) (+7 X)] [(-c6 X)] + @[(-7 X) ok]]] + [+testrr [ + [(-1 X) (-2 X) (+c5 X)] + [(-3 X)] [(-4 X) (+c6 X)] + [(-c5 X)] [(+7 X) (-c6 X)] + @[(-7 X) ok]]] + [+testll [ + [(-1 X) (-2 X) (+c5 X)] + [(-4 X)] [(-3 X) (+c6 X)] + [(-c5 X) (+7 X)] [(-c6 X)] + @[(-7 X) ok]]] + [+testlr [ + [(-1 X) (-2 X) (+c5 X)] + [(-4 X)] [(-3 X) (+c6 X)] + [(-c5 X)] [(+7 X) (-c6 X)] + @[(-7 X) ok]]]]) -(:: id ((larrow a a) / checker)) -(def id - (const - (star (-5 [l X]) (+1 X)) - (star (-5 [r X]) (+2 X)) - (star (-6 [l X]) (+3 X)) - (star (-6 [r X]) (+4 X)) - (star (+5 [l X]) (+6 [l X])) - (star (+5 [r X]) (+6 [r X])))) +(:= id [ + [(-5 [l|X]) (+1 X)] + [(-5 [r|X]) (+2 X)] + [(-6 [l|X]) (+3 X)] + [(-6 [r|X]) (+4 X)] + [(+5 [l|X]) (+6 [l|X])] + [(+5 [r|X]) (+6 [r|X])]]) +'TODO (:: id (larrow a a)) 'cut-elimination -(def ps1 - (galaxy - (vehicle - (const - (star (+7 [l X]) (+7 [r X])) - (star (3 X) (+8 [l X])) - (@star (+8 [r X]) (6 X)))) - (cuts - (const - (star (-7 X) (-8 X)))))) +(:= ps1 [ + [+vehicle [ + [(+7 [l|X]) (+7 [r|X])] + @[(3 X) (+8 [l|X])] + [(+8 [r|X]) (6 X)]]] + [+cuts [ + [(-7 X) (-8 X)]]]]) + +(:= vehicle ) +(:= cuts ) -(show-exec (union (get ps1 vehicle) (get ps1 cuts))) + -(spec (tens a b) - (const - (star (-1 [g X]) (-2 [g X]) (+3 [g X])) - (@star (-3 [g X]) ok))) +(spec (tens a b) [ + [(-1 [g|X]) (-2 [g|X]) (+3 [g|X])] + @[(-3 [g|X]) ok]]) -(def linear - (galaxy - (interaction - (linear-exec (union #tested #test))) - (expect (const (star ok))))) +(new-declaration (::lin tested test) + (:= test @(linexec (union #tested #test))) + (== test ok)) ' does not typecheck -' (:: vehicle ((tens a a) linear)) -(def vehicle - (const - (star (+3 [l X]) (+3 [r X])) - (star (-3 [l X]) (+1 [g X])) - (star (-3 [r X]) (+2 [g X])))) +' (::lin vehicle ((tens a a) linear)) +(:= vehicle [ + [(+3 [l|X]) (+3 [r|X])] + [(-3 [l|X]) (+1 [g|X])] + [(-3 [r|X]) (+2 [g|X])]]) diff --git a/examples/nat.sg b/examples/nat.sg index 95230ea..3bc81e5 100644 --- a/examples/nat.sg +++ b/examples/nat.sg @@ -1,18 +1,10 @@ -(spec nat [ - [(-nat 0) ok] - [(-nat (s N)) (+nat N)]]) - (new-declaration (:: tested test) (:= test @(exec (union @#tested #test))) (== test ok)) -(new-declaration (:: tested test fchecker) - (:= test @(exec (union @#tested #test))) - (== test [arg out])) - -(spec (arrow nat nat) [ - [(+nat X) arg] - [(-nat X) out]]) +(spec nat [ + [(-nat 0) ok] + [(-nat (s N)) (+nat N)]]) (:= 0 (+nat 0)) (:: 0 nat) @@ -24,7 +16,6 @@ (:: 2 nat) (:= add1 [(-nat X) (+nat (s X))]) -(:: add1 (arrow nat nat) fchecker) (:= is_empty [ [(-nat 0) (res 1)] From e5f3a18372bcd5fe2b01e46c64cc194ae5c40aae Mon Sep 17 00:00:00 2001 From: engboris Date: Mon, 23 Jun 2025 21:25:38 +0200 Subject: [PATCH 35/45] Fix examples --- examples/binary4.sg | 83 ++++++++++++--------------------- examples/circuits.sg | 50 +++++++++----------- examples/lambda.sg | 46 +++++++----------- examples/linear_lambda.sg | 76 ++++++++++++------------------ examples/mall.sg | 27 ++++------- src/expr.ml | 9 ++-- test/{behavior => }/automata.sg | 0 test/{behavior => }/linear.sg | 0 test/{behavior => }/prolog.sg | 0 test/{behavior => }/records.sg | 0 test/syntax/empty.sg | 0 11 files changed, 118 insertions(+), 173 deletions(-) rename test/{behavior => }/automata.sg (100%) rename test/{behavior => }/linear.sg (100%) rename test/{behavior => }/prolog.sg (100%) rename test/{behavior => }/records.sg (100%) delete mode 100644 test/syntax/empty.sg diff --git a/examples/binary4.sg b/examples/binary4.sg index f3058d3..1a3942d 100644 --- a/examples/binary4.sg +++ b/examples/binary4.sg @@ -1,67 +1,46 @@ (spec u4 [(-b 1 _) (-b 2 _) (-b 3 _) (-b 4 _) ok]) (new-declaration (:: tested test) - (:= test @(exec (process #test #test))) + (:= test @(exec (process #test #test{b=>+b}))) (== test ok)) -(:= checker - (galaxy - (interaction - (process - #test - #tested[b=>+b])) - (expect (const (star ok))))) +(:= b1 [ [(b 1 1)] [(b 2 0)] [(b 3 0)] [(b 4 1)]]) +(:: b1 u4) -(:: b1 (u4 / checker)) -(def b1 - (const - (star (b 1 1)) - (star (b 2 0)) - (star (b 3 0)) - (star (b 4 1)))) +(:= b2 [ [(b 1 0)] [(b 2 0)] [(b 3 1)] [(b 4 1)]]) +(:: b1 u4) -(:: b1 (u4 / checker)) -(def b2 - (const - (star (b 1 0)) - (star (b 2 0)) - (star (b 3 1)) - (star (b 4 1)))) +(:= and [ + [(-b1 arg 0) (-b2 arg X) (b arg 0)] + [(-b1 arg 1) (-b2 arg X) (b arg X)]]) -(def and - (const - (star (-b1 arg 0) (-b2 arg X) (b arg 0)) - (star (-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)]]) -(def or - (const - (star (-b1 arg 0) (-b2 arg X) (b arg X)) - (star (-b1 arg 1) (-b2 arg X) (b arg 1)))) - -(def xor - (const - (star (-b1 arg 1) (-b2 arg 0) (b arg 1)) - (star (-b1 arg 0) (-b2 arg 1) (b arg 1)) - (star (-b1 arg 0) (-b2 arg 0) (b arg 0)) - (star (-b1 arg 1) (-b2 arg 1) (b arg 0)))) +(:= 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)) ++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)) ++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)) ++b1} + #xor{arg=>1} #xor{arg=>2} #xor{arg=>3} #xor{arg=>4} + #b2{b=>+b2} + kill)> diff --git a/examples/circuits.sg b/examples/circuits.sg index 01dc4a3..e4ee551 100644 --- a/examples/circuits.sg +++ b/examples/circuits.sg @@ -1,43 +1,39 @@ ''' FIXME ''' -(def semantics - (const - (star (+1 1)) - (star (+0 0)) - (star (+s X X X)) - (star (+not 1 0)) (star (+not 0 1)) - (star (+and 1 X X)) (star (+and 0 X 0)))) +(:= semantics [ + [(+1 1)] + [(+0 0)] + [(+s X X X)] + [(+not 1 0)] [(+not 0 1)] + [(+and 1 X X)][(+and 0 X 0)]]) -(show-exec (process + -(show-exec (process + '&kill diff --git a/examples/lambda.sg b/examples/lambda.sg index 5453485..eaff7f0 100644 --- a/examples/lambda.sg +++ b/examples/lambda.sg @@ -1,40 +1,30 @@ ' id id -(def id - (const - (star (+id (exp [l X] d)) (+id [r X])))) +(:= id [(+id (exp [l|X] d)) (+id [r|X])]) -(def id_arg - (const - (star (ida (exp [l X] Y)) (+arg (exp [l r X] Y))))) +(:= id_arg [(ida (exp [l|X] Y)) (+arg (exp [l r|X] Y))]) -(def linker - (const - (star (-id X) (-arg X)) - (@star (+arg [r X]) (out X)))) +(:= linker [ + [(-id X) (-arg X)] + @[(+arg [r|X]) (out X)]]) -(show-exec (union (union #id #id_arg) #linker)) + ' id x -(def var_x - (const - (star (x (exp X Y)) (+arg (exp [l X] Y))))) +(:= var_x [(x (exp X Y)) (+arg (exp [l|X] Y))]) -(def linker - (const - (star (-id X) (-arg X)) - (@star (+arg [r X]) (out X)))) +(:= linker [ + [(-id X) (-arg X)] + @[(+arg [r|X]) (out X)]]) -(show-exec (union (union #id #var_x) #linker)) + ' lproj x -(def lproj - (const - (star (+lproj [l X])) 'weakening - (star (lproj (exp [r l X] d)) (+lproj [r r X])))) +(:= lproj [ + [(+lproj [l|X])] 'weakening + [(lproj (exp [r l|X] d)) (+lproj [r r|X])]]) -(def linker - (const - (star (-lproj X) (-arg X)) - (@star (+arg [r X]) (out X)))) +(:= linker [ + [(-lproj X) (-arg X)] + @[(+arg [r|X]) (out X)]]) -(show-exec (union (union #lproj #var_x) #linker)) + diff --git a/examples/linear_lambda.sg b/examples/linear_lambda.sg index f2a6a69..9303028 100644 --- a/examples/linear_lambda.sg +++ b/examples/linear_lambda.sg @@ -1,56 +1,42 @@ +(new-declaration (:: tested test) + (:= test @(exec (union #tested #test))) + (== test ok)) + ' identity function (\x -> x) -(def id - (const - (star (+id [l X]) (+id [r X])))) +(:= id [(+id [l|X]) (+id [r|X])]) ' id id -(def id_arg - (const - (star (ida [l X]) (+arg [l r X])))) +(:= id_arg [(ida [l|X]) (+arg [l r|X])]) -(def linker - (const - (star (-id X) (-arg X)) - (@star (+arg [r X]) (out X)))) +(:= linker [ + [(-id X) (-arg X)] + @[(+arg [r|X]) (out X)]]) -(show-exec (union (union #id #id_arg) #linker)) + ' id x -(def x_arg - (const - (star (x X) (+arg [l X])))) +(:= x_arg [(x X) (+arg [l X])]) -(def linker - (const - (star (-id X) (-arg X)) - (@star (+arg [r X]) (out X)))) +(:= linker [ + [(-id X) (-arg X)] + @[(+arg [r|X]) (out X)]]) -(show-exec (union (union #id #x_arg) #linker)) + ' linear types -(spec (larrow a a) - (galaxy - (test1 - (const - (star (-x X) (+parxy X)) - (star (-y X)) - (@star (-parxy X) ok))) - (test2 - (const - (star (-x X)) - (star (-y X) (+parxy X)) - (@star (-parxy X) ok))))) - -(def adapter - (const - (star (-id [l X]) (+x X)) - (star (-id [r X]) (+y X)))) - -(def checker - (galaxy - (interaction (union #tested #test)) - (expect (const (star ok))))) - -(:: vehicle ((larrow a a) / checker)) -(def vehicle - (union #id #adapter)) +(spec (larrow a a) [ + [+test1 [ + [(-x X) (+parxy X)] + [(-y X)] + @[(-parxy X) ok]]] + [+test2 [ + [(-x X)] + [(-y X) (+parxy X)] + @[(-parxy X) ok]]]]) + +(:= adapter [ + [(-id [l|X]) (+x X)] + [(-id [r|X]) (+y X)]]) + +(:= vehicle (union #id #adapter)) +'TODO (:: vehicle (larrow a a)) diff --git a/examples/mall.sg b/examples/mall.sg index a745251..414ce68 100644 --- a/examples/mall.sg +++ b/examples/mall.sg @@ -1,23 +1,14 @@ -(def left - (const (star - (+5 [l l X]) (+5 [l r X]) / (!@ c a)))) +(:= left [(+5 [l l|X]) (+5 [l r|X]) || (slice c a)]) +(:= right [(+5 [r l|X]) (+5 [r r|X]) || (slice c b)]) -(def right - (const - (star (+5 [r l X]) (+5 [r r X]) / (!@ c b)))) +(:= with (union #left #right)) -(def with - (union #left #right)) +(:= plus [ + [(+3 [l l|X]) (c X)] + [(+3 [l r|X]) (d X)]]) -(def plus - (const - (star (+3 [l l X]) (c X)) - (star (+3 [l r X]) (d X)))) +(:= cut [(-5 X) (-3 X)]) -(def cut - (const (star (-5 X) (-3 X)))) - -(show-exec (process + diff --git a/src/expr.ml b/src/expr.ml index 446cfbc..8102cc3 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -44,7 +44,7 @@ let params_op = primitive "params" let ineq_op = "!=" -let incomp_op = "!@" +let incomp_op = "slice" let string_of_list lmark rmark l = l |> String.concat ~sep:" " |> fun l' -> @@ -129,7 +129,8 @@ let rec ray_of_expr : expr -> ray = function | Unquote e -> to_func ((Null, "#"), [ ray_of_expr e ]) | List [] -> failwith "error: ray cannot be empty" | List (Symbol h :: t) -> to_func (symbol_of_str h, List.map ~f:ray_of_expr t) - | List (_ :: _) -> failwith "error: ray must start with constant" + | List (_ :: _) as e -> + failwith ("error: ray " ^ to_string e ^ " must start with constant") let bans_of_expr : expr list -> ban list = let ban_of_expr = function @@ -185,6 +186,8 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr = | Var _ | Symbol _ -> Raw [ Unmarked { content = [ ray_of_expr e ]; bans = [] } ] (* star *) + | List (Symbol s :: _) when equal_string s params_op -> + Raw [ star_of_expr e ] | List [ Symbol s; h; t ] when equal_string s cons_op && (not @@ is_cons h) && (not @@ contains_cons t) -> @@ -232,7 +235,7 @@ let decl_of_expr : expr -> declaration = function 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) - | e -> failwith ("error: invalid declaration ^ " ^ to_string e) + | e -> failwith ("error: invalid declaration " ^ to_string e) let program_of_expr = List.map ~f:decl_of_expr diff --git a/test/behavior/automata.sg b/test/automata.sg similarity index 100% rename from test/behavior/automata.sg rename to test/automata.sg diff --git a/test/behavior/linear.sg b/test/linear.sg similarity index 100% rename from test/behavior/linear.sg rename to test/linear.sg diff --git a/test/behavior/prolog.sg b/test/prolog.sg similarity index 100% rename from test/behavior/prolog.sg rename to test/prolog.sg diff --git a/test/behavior/records.sg b/test/records.sg similarity index 100% rename from test/behavior/records.sg rename to test/records.sg diff --git a/test/syntax/empty.sg b/test/syntax/empty.sg deleted file mode 100644 index e69de29..0000000 From 8dd9233b4f2b26729a21744a4cd45dcb22cb72b4 Mon Sep 17 00:00:00 2001 From: engboris Date: Mon, 23 Jun 2025 21:26:19 +0200 Subject: [PATCH 36/45] dune fmt --- src/expr.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/expr.ml b/src/expr.ml index 8102cc3..d0e1c3e 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -186,8 +186,7 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr = | Var _ | Symbol _ -> Raw [ Unmarked { 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 params_op -> Raw [ star_of_expr e ] | List [ Symbol s; h; t ] when equal_string s cons_op && (not @@ is_cons h) && (not @@ contains_cons t) -> From 1d7d67d059f8b99e2c90d66ca66d4a268fdcb9fd Mon Sep 17 00:00:00 2001 From: engboris Date: Tue, 24 Jun 2025 00:22:57 +0200 Subject: [PATCH 37/45] Fix tests --- examples/binary4.sg | 2 ++ test/automata.sg | 45 ---------------------------------------- test/dune | 13 ++++++++++++ test/linear.sg | 21 ------------------- test/prolog.sg | 32 ---------------------------- test/records.sg | 22 -------------------- test/subjects/linear.sg | 14 +++++++++++++ test/subjects/prolog.sg | 24 +++++++++++++++++++++ test/subjects/records.sg | 18 ++++++++++++++++ test/test.ml | 11 +++++----- 10 files changed, 76 insertions(+), 126 deletions(-) delete mode 100644 test/automata.sg create mode 100644 test/dune delete mode 100644 test/linear.sg delete mode 100644 test/prolog.sg delete mode 100644 test/records.sg create mode 100644 test/subjects/linear.sg create mode 100644 test/subjects/prolog.sg create mode 100644 test/subjects/records.sg diff --git a/examples/binary4.sg b/examples/binary4.sg index 1a3942d..ed59e98 100644 --- a/examples/binary4.sg +++ b/examples/binary4.sg @@ -1,3 +1,4 @@ +''' (spec u4 [(-b 1 _) (-b 2 _) (-b 3 _) (-b 4 _) ok]) (new-declaration (:: tested test) @@ -44,3 +45,4 @@ #xor{arg=>1} #xor{arg=>2} #xor{arg=>3} #xor{arg=>4} #b2{b=>+b2} kill)> + ''' diff --git a/test/automata.sg b/test/automata.sg deleted file mode 100644 index 8230858..0000000 --- a/test/automata.sg +++ /dev/null @@ -1,45 +0,0 @@ -(spec binary - (const - (star (-i e) ok) - (star (-i [0 X]) (+i X)) - (star (-i [1 X]) (+i X)))) - -(def a1 - (galaxy - (initial - (const - (star (-i W) (+a W q0)))) - (final - (const - (star (-a e q2) accept))) - (transitions - (const - (star (-a [0 W] q0) (+a W q0)) - (star (-a [0 W] q0) (+a W q1)) - (star (-a [1 W] q0) (+a W q0)) - (star (-a [0 W] q1) (+a W q2)))))) - -(== tested (const)) -(def tested - (kill (exec - (union @(const (star (+i [0 e]))) #a1)))) - -(== tested (const)) -(def tested - (kill (exec - (union @(const (star (+i [1 e]))) #a1)))) - -(== tested (const)) -(def tested - (kill (exec - (union @(const (star (+i [0 1 0 e]))) #a1)))) - -(== tested (const)) -(def tested - (kill (exec - (union @(const (star (+i [1 1 0 e]))) #a1)))) - -(== tested (const (star accept))) -(def tested - (kill (exec - (union @(const (star (+i [0 0 0 e]))) #a1)))) diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..723e018 --- /dev/null +++ b/test/dune @@ -0,0 +1,13 @@ +(test + (name test) + (modules test) + (deps + (glob_files ./subjects/*.sg) + (glob_files ../examples/*.sg) + (glob_files ../exercises/solutions/*.sg)) + (libraries alcotest base stellogen)) + +(env + (dev + (flags + (:standard -warn-error -A)))) diff --git a/test/linear.sg b/test/linear.sg deleted file mode 100644 index ed27c16..0000000 --- a/test/linear.sg +++ /dev/null @@ -1,21 +0,0 @@ -(def 1 - (const (star (+nat (s 0))))) -(def 2 - (const (star (+nat )))) -(def 3 - (const (star (+nat )))) - -(spec nat - (const (star (-nat (s X)) (+nat X)))) - -(== tested (const (star (+nat 0)))) -(def tested - @(linear-exec (union @#1 #nat))) - -(== tested (const (star (+nat )))) -(def tested - @(linear-exec (union @#2 #nat))) - -(== tested (const (star (+nat )))) -(def tested - @(linear-exec (union @#3 #nat))) diff --git a/test/prolog.sg b/test/prolog.sg deleted file mode 100644 index 14aead8..0000000 --- a/test/prolog.sg +++ /dev/null @@ -1,32 +0,0 @@ -(def add - (const - (star (+add 0 Y Y)) - (star (-add X Y Z) (+add (s X) Y (s Z))))) - -(== tested (const (star 0))) -(def tested - (union #add @(const (star (-add 0 0 R) R)))) - -(== tested (const (star (s 0)))) -(def tested - (union #add @(const (star (-add (s 0) 0 R) R)))) - -(== tested (const (star (s 0)))) -(def tested - (union #add @(const (star (-add 0 (s 0) R) R)))) - -(== tested (const (star ))) -(def tested - (union #add @(const (star (-add R) R)))) - -(== tested (const (star 0))) -(def tested - (union #add @(const (star (-add R ) R)))) - -(== tested (const (star ))) -(def tested - (union #add @(const (star (-add R ) R)))) - -(== tested (const (star ))) -(def tested - (union #add @(const (star (-add R ) R)))) diff --git a/test/records.sg b/test/records.sg deleted file mode 100644 index b86d722..0000000 --- a/test/records.sg +++ /dev/null @@ -1,22 +0,0 @@ -(def g - (galaxy - (test1 (const (star 1))) - (test2 - (galaxy - (test21 - (const (star 2))) - (test22 - (galaxy - (test3 (const (star 3))))))))) - -(== x (const (star 1))) -(def x - @(get g test1)) - -(== x (const (star 2))) -(def x - @(get (get g test2) test21)) - -(== x (const (star 3))) -(def x - @(get (get (get g test2) test22) test3)) diff --git a/test/subjects/linear.sg b/test/subjects/linear.sg new file mode 100644 index 0000000..c8257d8 --- /dev/null +++ b/test/subjects/linear.sg @@ -0,0 +1,14 @@ +(:= 1 (+nat (s 0))) +(:= 2 (+nat )) +(:= 3 (+nat )) + +(spec nat [(-nat (s X)) (+nat X)]) + +(:= tested @(linexec (union @#1 #nat))) +(== tested (+nat 0)) + +(:= tested @(linexec (union @#2 #nat))) +(== tested (+nat (s 0))) + +(:= tested @(linexec (union @#3 #nat))) +(== tested (+nat )) diff --git a/test/subjects/prolog.sg b/test/subjects/prolog.sg new file mode 100644 index 0000000..afee0e9 --- /dev/null +++ b/test/subjects/prolog.sg @@ -0,0 +1,24 @@ +(:= add [ + [(+add 0 Y Y)] + [(-add X Y Z) (+add (s X) Y (s Z))]]) + +(:= tested (exec (union #add @[(-add 0 0 R) R]))) +(== tested 0) + +(:= tested (exec (union #add @[(-add (s 0) 0 R) R]))) +(== tested (s 0)) + +(:= tested (exec (union #add @[(-add 0 (s 0) R) R]))) +(== tested (s 0)) + +(:= tested (exec (union #add @[(-add R) R]))) +(== tested ) + +(:= tested (exec (union #add @[(-add R ) R]))) +(== tested 0) + +(:= tested (exec (union #add @[(-add R ) R]))) +(== tested ) + +(:= tested (exec (union #add @[(-add R ) R]))) +(== tested ) diff --git a/test/subjects/records.sg b/test/subjects/records.sg new file mode 100644 index 0000000..e8dccdf --- /dev/null +++ b/test/subjects/records.sg @@ -0,0 +1,18 @@ +(:= g [ + [+test1 1] + [+test2 [ + [+test21 2] + [+test22 [ + [+test3 3]]]]]]) + +(:= x ) +(== x 1) + +(:= x ) +(:= y ) +(== y 2) + +(:= x ) +(:= y ) +(:= z ) +(== z 3) diff --git a/test/test.ml b/test/test.ml index c8a31a7..eacbe64 100644 --- a/test/test.ml +++ b/test/test.ml @@ -3,9 +3,9 @@ open Base let sgen filename () = let lexbuf = Sedlexing.Utf8.from_channel (Stdlib.open_in filename) in let expr = Stellogen.Sgen_parsing.parse_with_error lexbuf in - let expanded = List.map ~f:Stellogen.Expr.expand_macro expr in - let p = Stellogen.Expr.program_of_expr expanded in - Stellogen.Sgen_eval.eval_program ~typecheckonly:false ~notyping:false p + let preprocessed = Stellogen.Expr.preprocess expr in + let p = Stellogen.Expr.program_of_expr preprocessed in + Stellogen.Sgen_eval.eval_program p let make_ok_test name path f = let test got () = @@ -22,8 +22,7 @@ let run_dir test_f directory = let () = Alcotest.run "Stellogen Test Suite" - [ ("Stellogen examples", run_dir sgen "../examples/") + [ (* ("Stellogen examples", run_dir sgen "../examples/") ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") - ; ("Stellogen syntax", run_dir sgen "./syntax/") - ; ("Stellogen behavior", run_dir sgen "./behavior/") + ; *) ("Stellogen syntax", run_dir sgen "./subjects/") ] From fb3caeb9e7a1d9a11cd1e8c5798f45d090cbb550 Mon Sep 17 00:00:00 2001 From: engboris Date: Wed, 25 Jun 2025 23:55:26 +0200 Subject: [PATCH 38/45] Add examples in test --- examples/automata.sg | 4 ++++ test/test.ml | 5 +++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/examples/automata.sg b/examples/automata.sg index cf53073..36b154b 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -1,3 +1,7 @@ +(new-declaration (:: tested test) + (:= test @(exec (union @#tested #test))) + (== test ok)) + (spec binary [ [(-i []) ok] [(-i [0|X]) (+i X)] diff --git a/test/test.ml b/test/test.ml index eacbe64..977e726 100644 --- a/test/test.ml +++ b/test/test.ml @@ -22,7 +22,8 @@ let run_dir test_f directory = let () = Alcotest.run "Stellogen Test Suite" - [ (* ("Stellogen examples", run_dir sgen "../examples/") - ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") + [ ("Stellogen examples", run_dir sgen "../examples/") + ; + (* ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") ; *) ("Stellogen syntax", run_dir sgen "./subjects/") ] From 23cdd924b7cf0d1f1db6af8cfd03e07a71207b75 Mon Sep 17 00:00:00 2001 From: engboris Date: Wed, 25 Jun 2025 23:55:56 +0200 Subject: [PATCH 39/45] dune fmt --- test/test.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/test.ml b/test/test.ml index 977e726..8fca86c 100644 --- a/test/test.ml +++ b/test/test.ml @@ -23,7 +23,7 @@ let run_dir test_f directory = let () = Alcotest.run "Stellogen Test Suite" [ ("Stellogen examples", run_dir sgen "../examples/") - ; - (* ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") - ; *) ("Stellogen syntax", run_dir sgen "./subjects/") + ; (* ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") + ; *) + ("Stellogen syntax", run_dir sgen "./subjects/") ] From 901a890d736a429bd1c48bb0e1c0effaf4b7b0dc Mon Sep 17 00:00:00 2001 From: engboris Date: Thu, 26 Jun 2025 21:20:04 +0200 Subject: [PATCH 40/45] Turn unquote into call and update declaration definition --- examples/automata.sg | 4 ++-- examples/linear_lambda.sg | 4 ++-- examples/mll.sg | 8 ++++---- examples/nat.sg | 4 ++-- examples/npda.sg | 4 ++-- examples/sumtypes.sg | 4 ++-- examples/syntax.sg | 4 ++-- src/expr.ml | 34 ++++++++++++++++------------------ src/lexer.ml | 2 +- src/parser.mly | 4 ++-- src/sgen_eval.ml | 1 - 11 files changed, 35 insertions(+), 38 deletions(-) diff --git a/examples/automata.sg b/examples/automata.sg index 36b154b..1ac54bb 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -1,5 +1,5 @@ -(new-declaration (:: tested test) - (:= test @(exec (union @#tested #test))) +(new-declaration (:: Tested Test) + (:= test @(exec (union @#Tested #Test))) (== test ok)) (spec binary [ diff --git a/examples/linear_lambda.sg b/examples/linear_lambda.sg index 9303028..e88bd9f 100644 --- a/examples/linear_lambda.sg +++ b/examples/linear_lambda.sg @@ -1,5 +1,5 @@ -(new-declaration (:: tested test) - (:= test @(exec (union #tested #test))) +(new-declaration (:: Tested Test) + (:= test @(exec (union #Tested #Test))) (== test ok)) ' identity function (\x -> x) diff --git a/examples/mll.sg b/examples/mll.sg index c3346d9..35330b6 100644 --- a/examples/mll.sg +++ b/examples/mll.sg @@ -1,5 +1,5 @@ -(new-declaration (:: tested test) - (:= test @(exec (union #tested #test))) +(new-declaration (:: Tested Test) + (:= test @(exec (union #Tested #Test))) (== test ok)) ' test of linear identity @@ -52,8 +52,8 @@ [(-1 [g|X]) (-2 [g|X]) (+3 [g|X])] @[(-3 [g|X]) ok]]) -(new-declaration (::lin tested test) - (:= test @(linexec (union #tested #test))) +(new-declaration (::lin Tested Test) + (:= test @(linexec (union #Tested #Test))) (== test ok)) ' does not typecheck diff --git a/examples/nat.sg b/examples/nat.sg index 3bc81e5..6d54116 100644 --- a/examples/nat.sg +++ b/examples/nat.sg @@ -1,5 +1,5 @@ -(new-declaration (:: tested test) - (:= test @(exec (union @#tested #test))) +(new-declaration (:: Tested Test) + (:= test @(exec (union @#Tested #Test))) (== test ok)) (spec nat [ diff --git a/examples/npda.sg b/examples/npda.sg index 1679ffa..c5b2eba 100644 --- a/examples/npda.sg +++ b/examples/npda.sg @@ -1,5 +1,5 @@ -(new-declaration (:: tested test) - (:= test @(exec (union @#tested #test))) +(new-declaration (:: Tested Test) + (:= test @(exec (union @#Tested #Test))) (== test ok)) (spec binary [ diff --git a/examples/sumtypes.sg b/examples/sumtypes.sg index 6c0cff3..843f355 100644 --- a/examples/sumtypes.sg +++ b/examples/sumtypes.sg @@ -1,5 +1,5 @@ -(new-declaration (:: tested test) - (:= test @(exec (union @#tested #test))) +(new-declaration (:: Tested Test) + (:= test @(exec (union @#Tested #Test))) (== test ok)) (spec direction [ diff --git a/examples/syntax.sg b/examples/syntax.sg index 664f7fd..a64aa65 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -112,7 +112,7 @@ '(use "examples/automata.sg") 'declaration definition -(new-declaration (:: tested test) - (:= test @(exec (union @#tested #test))) +(new-declaration (:: Tested Test) + (:= test @(exec (union @#Tested #Test))) (== test ok)) (:: 2 nat) diff --git a/src/expr.ml b/src/expr.ml index d0e1c3e..fa7d440 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -10,7 +10,7 @@ module Raw = struct | Var of ident | String of string | Focus of t - | Unquote of t + | Call of t | List of t list | Stack of t list | Cons of t list @@ -21,7 +21,6 @@ end type expr = | Symbol of string | Var of ident - | Unquote of expr | List of expr list let primitive = String.append "%" @@ -30,7 +29,7 @@ let nil_op = primitive "nil" let cons_op = primitive "cons" -let unquote_op = "#" +let call_op = "#" let focus_op = "@" @@ -53,14 +52,13 @@ let string_of_list lmark rmark l = let rec to_string : expr -> string = function | Symbol s -> s | Var x -> x - | Unquote e -> Printf.sprintf "%s%s" unquote_op (to_string e) | List es -> es |> List.map ~f:to_string |> string_of_list "(" ")" let rec expand_macro : Raw.t -> expr = function | Raw.Symbol s -> Symbol s | Raw.Var x -> Var x | Raw.String s -> List [ Symbol string_op; Symbol s ] - | Raw.Unquote e' -> Unquote (expand_macro e') + | Raw.Call e' -> List [ Symbol call_op; expand_macro e' ] | Raw.Focus e' -> List [ Symbol focus_op; expand_macro e' ] | Raw.List es -> List (List.map ~f:expand_macro es) | Raw.Cons es -> expand_macro (Raw.ConsWithBase (es, Symbol nil_op)) @@ -77,24 +75,27 @@ let rec expand_macro : Raw.t -> expr = function 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 +let rec replace_id (xfrom : ident) xto e = + match e with + | Var x when equal_string x xfrom -> xto + | Symbol _ | Var _ -> e | List es -> List (List.map ~f:(replace_id xfrom xto) es) -let unfold_decl_def (env : (string * (expr list * expr list)) list) es : +let unfold_decl_def (env : (string * (string 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) + let var_args = + List.map args ~f:(function + | Var x -> x + | _ -> failwith "error: syntax declaration must contain variables" ) + in + ((k, (var_args, content)) :: env, acc) | List (Symbol k :: args) when List.Assoc.find ~equal:equal_string env k |> Option.is_some -> let syntax_args, content = @@ -105,7 +106,7 @@ let unfold_decl_def (env : (string * (expr list * expr list)) list) es : 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 ) + ~f:(fun acc (xfrom, xto) -> replace_id xfrom xto acc ) in (env, (List.map ~f:replace_ids content |> List.rev) @ acc) | e -> (env, e :: acc) ) @@ -126,7 +127,6 @@ let rec ray_of_expr : expr -> ray = function | Symbol s -> to_func (symbol_of_str s, []) | Var "_" -> to_var ("_" ^ fresh_placeholder ()) | Var s -> to_var s - | Unquote e -> to_func ((Null, "#"), [ ray_of_expr e ]) | List [] -> failwith "error: ray cannot be empty" | List (Symbol h :: t) -> to_func (symbol_of_str h, List.map ~f:ray_of_expr t) | List (_ :: _) as e -> @@ -146,7 +146,6 @@ let rec raylist_of_expr (e : expr) : ray list = match e with | Symbol k when equal_string k nil_op -> [] | Symbol _ | Var _ -> [ ray_of_expr e ] - | Unquote e -> failwith ("error: cannot unquote star " ^ to_string e) | List [ Symbol s; h; t ] when equal_string s cons_op -> ray_of_expr h :: raylist_of_expr t | e -> failwith ("error: unhandled star " ^ to_string e) @@ -162,7 +161,6 @@ 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 = [] } ] - | Unquote e -> failwith ("error: can't unquote constellation" ^ to_string e) | 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 = [] } ] @@ -192,7 +190,7 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr = -> Raw [ star_of_expr e ] (* id *) - | Unquote g -> Id (ray_of_expr g) + | List [ Symbol k; g ] when equal_string k call_op -> Id (ray_of_expr g) (* focus @ *) | List [ Symbol k; g ] when equal_string k focus_op -> Focus (sgen_expr_of_expr g) diff --git a/src/lexer.ml b/src/lexer.ml index 80317b1..9765a94 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -36,7 +36,7 @@ and read lexbuf = | '<' -> LANGLE | '>' -> RANGLE | '@' -> AT - | '#' -> UNQUOTE + | '#' -> SHARP | '|' -> BAR | '\'' -> comment lexbuf | "'''" -> comments lexbuf diff --git a/src/parser.mly b/src/parser.mly index 8e27407..ae73a25 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -10,7 +10,7 @@ open Expr.Raw %token LPAR RPAR %token LBRACK RBRACK %token LANGLE RANGLE -%token UNQUOTE +%token SHARP %token EOF %start expr_file @@ -40,7 +40,7 @@ let expr := | ~=SYM; | ~=VAR; | ~=STRING; - | UNQUOTE; ~=expr; + | SHARP; ~=expr; | AT; ~=expr; | ~=pars(expr+); | LANGLE; es=revlist(expr); RANGLE; diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 4cce4c6..46e5c6a 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -186,7 +186,6 @@ and expr_of_ray = function | Var (x, None) -> Expr.Var x | Var (x, Some i) -> Expr.Var (x ^ Int.to_string i) | Func (pf, []) -> Symbol (Lsc_ast.string_of_polsym pf) - | Func ((Null, k), [ r ]) when equal_string k "#" -> Unquote (expr_of_ray r) | Func (pf, args) -> Expr.List (Symbol (Lsc_ast.string_of_polsym pf) :: List.map ~f:expr_of_ray args) From d3b9f24e1937135d964a9859881619401fd90dc9 Mon Sep 17 00:00:00 2001 From: engboris Date: Sat, 28 Jun 2025 23:42:35 +0200 Subject: [PATCH 41/45] Fix parametric definitions --- examples/syntax.sg | 19 ++++++++++--------- src/expr.ml | 3 +++ src/lexer.ml | 6 ++++-- src/parser.mly | 2 ++ src/sgen_eval.ml | 46 ++++++++++++++++++++++++++++------------------ 5 files changed, 47 insertions(+), 29 deletions(-) diff --git a/examples/syntax.sg b/examples/syntax.sg index a64aa65..9298236 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -22,7 +22,7 @@ (:= s "hello world") 'cons -' [0 1 e] == %cons(0 (%cons 1 %nil)) +' [0 1] == %cons(0 (%cons 1 %nil)) (:= w (+w [0 1 0 1])) 'stack @@ -64,20 +64,21 @@ 'constellation with fields (:= g [ - [+test1 [(+f a) ok]] - [+test2 [(+f b) ok]]]) + [(+field test1) [(+f a) ok]] + [(+field test2) [(+f b) ok]]]) (show #g) 'field access and evaluation - - +(:= (get G X) ) +(show #(get g test1)) +(show #(get g test2)) 'nested fields (:= g1 [ - [+test1 [ - [+test2 [(+f c) ok]]]]]) -(:= g2 ) - + [(+field test1) [ + [(+field test2) [(+f c) ok]]]]]) +(:= g2 ) + 'extend rays with a head function symbol '+a]> diff --git a/src/expr.ml b/src/expr.ml index fa7d440..1802298 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -13,6 +13,7 @@ module Raw = struct | Call of t | List of t list | Stack of t list + | Group of t list | Cons of t list | ConsWithParams of t list * t list | ConsWithBase of t list * t @@ -45,6 +46,8 @@ let ineq_op = "!=" let incomp_op = "slice" +let group_op = "%group" + let string_of_list lmark rmark l = l |> String.concat ~sep:" " |> fun l' -> Printf.sprintf "%s%s%s" lmark l' rmark diff --git a/src/lexer.ml b/src/lexer.ml index 9765a94..7c27ee3 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -23,8 +23,8 @@ and comments lexbuf = and read lexbuf = match%sedlex lexbuf with - | Compl (Chars "'\" \t\n\r()<>[]|@#%"), Star (Compl (Chars " \t\n\r()<>[]|")) - -> + | ( Compl (Chars "'\" \t\n\r()<>[]{}|@#%") + , Star (Compl (Chars " \t\n\r()<>[]{}|")) ) -> let lexeme = Utf8.lexeme lexbuf in begin match lexeme.[0] with '_' | 'A' .. 'Z' -> VAR lexeme | _ -> SYM lexeme @@ -33,6 +33,8 @@ and read lexbuf = | ')' -> RPAR | '[' -> LBRACK | ']' -> RBRACK + | '{' -> LBRACE + | '}' -> RBRACE | '<' -> LANGLE | '>' -> RANGLE | '@' -> AT diff --git a/src/parser.mly b/src/parser.mly index ae73a25..3825941 100644 --- a/src/parser.mly +++ b/src/parser.mly @@ -9,6 +9,7 @@ open Expr.Raw %token BAR %token LPAR RPAR %token LBRACK RBRACK +%token LBRACE RBRACE %token LANGLE RANGLE %token SHARP %token EOF @@ -45,5 +46,6 @@ let expr := | ~=pars(expr+); | LANGLE; es=revlist(expr); RANGLE; | LBRACK; es=revlist(expr); RBRACK; + | LBRACE; es=revlist(expr); RBRACE; | LBRACK; ~=revlist(expr); ~=params; RBRACK; | LBRACK; ~=revlist(expr); BAR; ~=expr; RBRACK; diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 46e5c6a..59c2025 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -5,9 +5,21 @@ open Out_channel let ( let* ) x f = Result.bind x ~f -let add_obj env x e = List.Assoc.add ~equal:equal_ray env.objs x e +let unifiable r r' = StellarRays.solution [ (r, r') ] |> Option.is_some -let get_obj env x = List.Assoc.find ~equal:equal_ray env.objs x +let find_with_solution env x = + let rec aux = function + | [] -> None + | (key, value) :: rest -> ( + match StellarRays.solution [ (key, x) ] with + | Some subst -> Some (value, subst) + | None -> aux rest ) + in + aux env.objs + +let add_obj env x e = List.Assoc.add ~equal:unifiable env.objs x e + +let get_obj env x = find_with_solution env x let rec replace_id (xfrom : ident) (xto : sgen_expr) e : (sgen_expr, err) Result.t = @@ -41,11 +53,7 @@ let rec replace_id (xfrom : ident) (xto : sgen_expr) e : 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 - match get_obj env x with - | None -> Error (UnknownID (string_of_ray x)) - | Some g -> map_sgen_expr env ~f g - end + | Id x -> Id x |> Result.return | Exec (b, e) -> let* map_e = map_sgen_expr env ~f e in Exec (b, map_e) |> Result.return @@ -112,11 +120,14 @@ let rec eval_sgen_expr (env : env) : sgen_expr -> (marked_constellation, err) Result.t = function | Raw mcs -> Ok mcs | Id x -> begin - begin - match get_obj env x with - | None -> Error (UnknownID (string_of_ray x)) - | Some g -> eval_sgen_expr env g - end + match get_obj env x with + | None -> Error (UnknownID (string_of_ray x)) + | Some (g, subst) -> + let result = + List.fold_result subst ~init:g ~f:(fun g_acc (xfrom, xto) -> + subst_vars env xfrom xto g_acc ) + in + Result.bind result ~f:(eval_sgen_expr env) end | Union es -> let* eval_es = List.map ~f:(eval_sgen_expr env) es |> Result.all in @@ -180,7 +191,11 @@ let rec eval_sgen_expr (env : env) : | [ Marked { content = [ r ]; bans = _ } ] | [ Unmarked { content = [ r ]; bans = _ } ] -> r |> expr_of_ray |> Expr.sgen_expr_of_expr |> eval_sgen_expr env - | _ -> failwith "error: only rays can be evaluated." ) + | e -> + failwith + ( "eval error: " + ^ string_of_constellation (remove_mark_all e) + ^ " is not a ray." ) ) and expr_of_ray = function | Var (x, None) -> Expr.Var x @@ -194,11 +209,6 @@ let rec eval_decl env : declaration -> (env, err) Result.t = function | Def (x, e) -> let env = { objs = add_obj env x e } in Ok env - | Show (Id x) -> begin - match get_obj env x with - | None -> Error (UnknownID (string_of_ray x)) - | Some e -> eval_decl env (Show e) - end | Show (Raw mcs) -> mcs |> remove_mark_all |> string_of_constellation |> Stdlib.print_string; Stdlib.print_newline (); From a55d50e7609e4a16c1848bee6b7fceda21b996e8 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 29 Jun 2025 23:16:12 +0200 Subject: [PATCH 42/45] Rewrite examples using generic definitions --- README.md | 18 +++++++-------- examples/automata.sg | 35 +++++++++++++++------------- examples/circuits.sg | 14 ++++++------ examples/lambda.sg | 22 +++++++++--------- examples/linear_lambda.sg | 17 +++++++------- examples/mall.sg | 8 +++---- examples/mll.sg | 32 ++++++++++++-------------- examples/nat.sg | 17 +++++++------- examples/npda.sg | 44 ++++++++++++++++++----------------- examples/prolog.sg | 16 ++++++------- examples/sumtypes.sg | 17 +++++++------- examples/syntax.sg | 48 +++++++++++++++++++-------------------- examples/turing.sg | 22 +++++++++--------- src/expr.ml | 14 +++++++----- src/lexer.ml | 2 +- src/sgen_ast.ml | 4 ++-- src/sgen_eval.ml | 22 +++++++++--------- test/test.ml | 8 +++---- 18 files changed, 180 insertions(+), 180 deletions(-) diff --git a/README.md b/README.md index 83b1ea3..0ef3075 100644 --- a/README.md +++ b/README.md @@ -37,13 +37,13 @@ Finite state machine ``` (new-declaration (:: tested test) - (:= test @(exec (union @#tested #test))) +(:= test @(exec { @#tested #test })) (== test ok)) -(spec binary [ +(spec binary { [(-i []) ok] [(-i [0|X]) (+i X)] - [(-i [1|X]) (+i X)]]) + [(-i [1|X]) (+i X)]}) 'input words (:= e (+i [])) @@ -64,18 +64,18 @@ Finite state machine ''' automaton accepting words ending with 00 ''' -(:= a1 [ +(:= a1 { [(-i W) (+a W q0)] [(-a [] q2) accept] [(-a [0|W] q0) (+a W q0)] [(-a [0|W] q0) (+a W q1)] [(-a [1|W] q0) (+a W q0)] - [(-a [0|W] q1) (+a W q2)]]) + [(-a [0|W] q1) (+a W q2)]}) - - - - + + + + ``` More examples can be found in `examples/`. diff --git a/examples/automata.sg b/examples/automata.sg index 1ac54bb..bced06e 100644 --- a/examples/automata.sg +++ b/examples/automata.sg @@ -1,11 +1,10 @@ (new-declaration (:: Tested Test) - (:= test @(exec (union @#Tested #Test))) - (== test ok)) + (== @(exec { @#Tested #Test }) ok)) -(spec binary [ +(spec binary { [(-i []) ok] [(-i [0|X]) (+i X)] - [(-i [1|X]) (+i X)]]) + [(-i [1|X]) (+i X)]}) 'input words (:= e (+i [])) @@ -26,15 +25,19 @@ ''' automaton accepting words ending with 00 ''' -(:= a1 [ - [(-i W) (+a W q0)] - [(-a [] q2) accept] - [(-a [0|W] q0) (+a W q0)] - [(-a [0|W] q0) (+a W q1)] - [(-a [1|W] q0) (+a W q0)] - [(-a [0|W] q1) (+a W q2)]]) - - - - - +(:= (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)]) + +(:= a1 { + #(initial q0) + #(accept q2) + #(if read 0 on q0 then q0) + #(if read 0 on q0 then q1) + #(if read 1 on q0 then q0) + #(if read 0 on q1 then q2)}) + + + + + diff --git a/examples/circuits.sg b/examples/circuits.sg index e4ee551..4aac685 100644 --- a/examples/circuits.sg +++ b/examples/circuits.sg @@ -1,12 +1,12 @@ ''' FIXME ''' -(:= semantics [ +(:= semantics { [(+1 1)] [(+0 0)] [(+s X X X)] [(+not 1 0)] [(+not 0 1)] - [(+and 1 X X)][(+and 0 X 0)]]) + [(+and 1 X X)][(+and 0 X 0)]}) + ' id x (:= var_x [(x (exp X Y)) (+arg (exp [l|X] Y))]) -(:= linker [ +(:= linker { [(-id X) (-arg X)] - @[(+arg [r|X]) (out X)]]) + @[(+arg [r|X]) (out X)]}) - + ' lproj x -(:= lproj [ +(:= lproj { [(+lproj [l|X])] 'weakening - [(lproj (exp [r l|X] d)) (+lproj [r r|X])]]) + [(lproj (exp [r l|X] d)) (+lproj [r r|X])]}) -(:= linker [ +(:= linker { [(-lproj X) (-arg X)] - @[(+arg [r|X]) (out X)]]) + @[(+arg [r|X]) (out X)]}) - + diff --git a/examples/linear_lambda.sg b/examples/linear_lambda.sg index e88bd9f..7571cfb 100644 --- a/examples/linear_lambda.sg +++ b/examples/linear_lambda.sg @@ -1,6 +1,5 @@ (new-declaration (:: Tested Test) - (:= test @(exec (union #Tested #Test))) - (== test ok)) + (== @(exec { #Tested #Test }) ok)) ' identity function (\x -> x) (:= id [(+id [l|X]) (+id [r|X])]) @@ -12,7 +11,7 @@ [(-id X) (-arg X)] @[(+arg [r|X]) (out X)]]) - + ' id x (:= x_arg [(x X) (+arg [l X])]) @@ -21,10 +20,10 @@ [(-id X) (-arg X)] @[(+arg [r|X]) (out X)]]) - + ' linear types -(spec (larrow a a) [ +(spec (larrow a a) { [+test1 [ [(-x X) (+parxy X)] [(-y X)] @@ -32,11 +31,11 @@ [+test2 [ [(-x X)] [(-y X) (+parxy X)] - @[(-parxy X) ok]]]]) + @[(-parxy X) ok]]]}) -(:= adapter [ +(:= adapter { [(-id [l|X]) (+x X)] - [(-id [r|X]) (+y X)]]) + [(-id [r|X]) (+y X)]}) -(:= vehicle (union #id #adapter)) +(:= vehicle { #id #adapter }) 'TODO (:: vehicle (larrow a a)) diff --git a/examples/mall.sg b/examples/mall.sg index 414ce68..c00dda6 100644 --- a/examples/mall.sg +++ b/examples/mall.sg @@ -1,14 +1,14 @@ (:= left [(+5 [l l|X]) (+5 [l r|X]) || (slice c a)]) (:= right [(+5 [r l|X]) (+5 [r r|X]) || (slice c b)]) -(:= with (union #left #right)) +(:= with { #left #right }) -(:= plus [ +(:= plus { [(+3 [l l|X]) (c X)] - [(+3 [l r|X]) (d X)]]) + [(+3 [l r|X]) (d X)]}) (:= cut [(-5 X) (-3 X)]) + { #plus #cut })> diff --git a/examples/mll.sg b/examples/mll.sg index 35330b6..ef72d90 100644 --- a/examples/mll.sg +++ b/examples/mll.sg @@ -1,9 +1,8 @@ (new-declaration (:: Tested Test) - (:= test @(exec (union #Tested #Test))) - (== test ok)) + (== @(exec { #Tested #Test }) ok)) ' test of linear identity -(spec (larrow a a) [ +(spec (larrow a a) { [+testrl [ [(-1 X) (-2 X) (+c5 X)] [(-3 X)] [(-4 X) (+c6 X)] @@ -23,42 +22,41 @@ [(-1 X) (-2 X) (+c5 X)] [(-4 X)] [(-3 X) (+c6 X)] [(-c5 X)] [(+7 X) (-c6 X)] - @[(-7 X) ok]]]]) + @[(-7 X) ok]]]}) -(:= id [ +(:= id { [(-5 [l|X]) (+1 X)] [(-5 [r|X]) (+2 X)] [(-6 [l|X]) (+3 X)] [(-6 [r|X]) (+4 X)] [(+5 [l|X]) (+6 [l|X])] - [(+5 [r|X]) (+6 [r|X])]]) + [(+5 [r|X]) (+6 [r|X])]}) 'TODO (:: id (larrow a a)) 'cut-elimination -(:= ps1 [ +(:= ps1 { [+vehicle [ [(+7 [l|X]) (+7 [r|X])] @[(3 X) (+8 [l|X])] [(+8 [r|X]) (6 X)]]] [+cuts [ - [(-7 X) (-8 X)]]]]) + [(-7 X) (-8 X)]]]}) -(:= vehicle ) -(:= cuts ) +(:= vehicle ) +(:= cuts ) - + -(spec (tens a b) [ +(spec (tens a b) { [(-1 [g|X]) (-2 [g|X]) (+3 [g|X])] - @[(-3 [g|X]) ok]]) + @[(-3 [g|X]) ok]}) (new-declaration (::lin Tested Test) - (:= test @(linexec (union #Tested #Test))) - (== test ok)) + (== @(linexec { #Tested #Test }) ok)) ' does not typecheck ' (::lin vehicle ((tens a a) linear)) -(:= vehicle [ +(:= vehicle { [(+3 [l|X]) (+3 [r|X])] [(-3 [l|X]) (+1 [g|X])] - [(-3 [r|X]) (+2 [g|X])]]) + [(-3 [r|X]) (+2 [g|X])]}) diff --git a/examples/nat.sg b/examples/nat.sg index 6d54116..bc609b7 100644 --- a/examples/nat.sg +++ b/examples/nat.sg @@ -1,10 +1,9 @@ (new-declaration (:: Tested Test) - (:= test @(exec (union @#Tested #Test))) - (== test ok)) + (== @(exec { @#Tested #Test }) ok)) -(spec nat [ +(spec nat { [(-nat 0) ok] - [(-nat (s N)) (+nat N)]]) + [(-nat (s N)) (+nat N)]}) (:= 0 (+nat 0)) (:: 0 nat) @@ -17,10 +16,10 @@ (:= add1 [(-nat X) (+nat (s X))]) -(:= is_empty [ +(:= is_empty { [(-nat 0) (res 1)] - [(-nat (s _)) (res 0)]]) + [(-nat (s _)) (res 0)]}) - - - + + + diff --git a/examples/npda.sg b/examples/npda.sg index c5b2eba..021736e 100644 --- a/examples/npda.sg +++ b/examples/npda.sg @@ -1,11 +1,10 @@ (new-declaration (:: Tested Test) - (:= test @(exec (union @#Tested #Test))) - (== test ok)) + (== @(exec { @#Tested #Test }) ok)) -(spec binary [ +(spec binary { [(-i []) ok] [(-i [0|X]) (+i X)] - [(-i [1|X]) (+i X)]]) + [(-i [1|X]) (+i X)]}) 'input words (:= e (+i [])) @@ -20,20 +19,23 @@ (:= 1110 (+i [1 1 1 0])) (:: 1110 binary) -(:= a1 [ - 'initial - [(-i W) (+a W [] q0)] - 'final - [(-a [] [] q0) accept] - [(-a [] [] q1) accept] - 'transitions - [(-a [0|W] S q0) (+a W [0|S] q0)] - [(-a [1|W] S q0) (+a W [1|S] q0)] - [(-a W S q0) (+a W S q1)] - [(-a [0|W] [0|S] q1) (+a W S q1)] - [(-a [1|W] [1|S] q1) (+a W S q1)]]) - - - - - +(:= (initial Q) [(-i W) (+a W [] Q)]) +(:= (accept Q) [(-a [] [] Q) accept]) +(:= (if read C1 on Q1 then Q2 and push C2) [(-a [C1|W] S Q1) (+a W [C2|S] Q2)]) +(:= (if read C1 with C2 on Q1 then Q2) [(-a [C1|W] [C2|S] Q1) (+a W S Q2)]) +(:= (if on Q1 then Q2) [(-a W S Q1) (+a W S Q2)]) + +(:= a1 { + #(initial q0) + #(accept q0) + #(accept q1) + #(if read 0 on q0 then q0 and push 0) + #(if read 1 on q0 then q0 and push 1) + #(if on q0 then q1) + #(if read 0 with 0 on q1 then q1) + #(if read 1 with 1 on q1 then q1)}) + + + + + diff --git a/examples/prolog.sg b/examples/prolog.sg index bfbba51..220a0a9 100644 --- a/examples/prolog.sg +++ b/examples/prolog.sg @@ -1,27 +1,27 @@ ' unary addition -(:= add [ +(:= add { [(+add 0 Y Y)] - [(-add X Y Z) (+add (s X) Y (s Z))]]) + [(-add X Y Z) (+add (s X) Y (s Z))]}) ' 2 + 2 = R (:= query [(-add R) R]) - + -(:= graph [ +(:= graph { [(+from 1) (+to 2)] [(+from 1) (+to 3)] [(+from 3) (+to 2)] '[(+from 4) (+to 3)] - [(+from 3) (+to 4)]]) + [(+from 3) (+to 4)]}) (:= composition [(-to X) (-from X)]) ' is there a path between 1 and 4? -(:= query [ +(:= query { @[(-from 1)] - [(-to 4) ok]]) + [(-to 4) ok]}) + { #graph #composition })> diff --git a/examples/sumtypes.sg b/examples/sumtypes.sg index 843f355..b8ca74a 100644 --- a/examples/sumtypes.sg +++ b/examples/sumtypes.sg @@ -1,26 +1,25 @@ (new-declaration (:: Tested Test) - (:= test @(exec (union @#Tested #Test))) - (== test ok)) + (== @(exec { @#Tested #Test }) ok)) -(spec direction [ +(spec direction { [-north ok] [-south ok] [-west ok] - [-east ok]]) + [-east ok]}) (:= n +north) (:: n direction) -(spec result [ +(spec result { [(-ok X) ok] - [(-error X) ok]]) + [(-error X) ok]}) (:= x (+ok a)) (:: x result) 'pattern matching -(:= get_ok [ +(:= get_ok { [(-ok X) X] - [(-error X) (+error X)]]) + [(-error X) (+error X)]}) - + diff --git a/examples/syntax.sg b/examples/syntax.sg index 9298236..c685077 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -5,18 +5,18 @@ (:= b [(-f X)]) 'define constellation -(:= c [ +(:= c { @[+a] 'focus - [-a b]]) + [-a b]}) 'full focus -(:= f @[ [a] [b] [c] ]) +(:= f @{ [a] [b] [c] }) 'identifier (:= x #a) -'union -(:= x (union #a #b)) +'group +(:= x { #a #b }) 'string literals (:= s "hello world") @@ -32,12 +32,12 @@ 'execution (:= x [(+f X) X]) (:= y (-f a)) -(:= ex (linexec (union @#x #y))) 'linear -(:= ex (exec (union @#x #y))) 'non-linear +(:= ex (linexec { @#x #y })) 'linear +(:= ex (exec { @#x #y })) 'non-linear 'show constellation (show #ex) -(show [ [a] [b] [c] ]) +(show { [a] [b] [c] }) (show #s) 'complex identifiers @@ -45,10 +45,10 @@ (show #(f a b)) 'inequality constraints -(:= ineq [ +(:= ineq { [(+f a)] [(+f b)] - @[(-f X) (-f Y) (r X Y) || (!= X Y)]]) + @[(-f X) (-f Y) (r X Y) || (!= X Y)]}) (show #ineq) @@ -63,22 +63,22 @@ (show #c) 'constellation with fields -(:= g [ +(:= g { [(+field test1) [(+f a) ok]] - [(+field test2) [(+f b) ok]]]) + [(+field test2) [(+f b) ok]]}) (show #g) 'field access and evaluation -(:= (get G X) ) +(:= (get G X) ) (show #(get g test1)) (show #(get g test2)) 'nested fields -(:= g1 [ +(:= g1 { [(+field test1) [ - [(+field test2) [(+f c) ok]]]]]) -(:= g2 ) - + [(+field test2) [(+f c) ok]]]]}) +(:= g2 ) + 'extend rays with a head function symbol '+a]> @@ -95,25 +95,23 @@ ' [#2=>(-f a)]> 'define type -(spec nat [ +(spec nat { [(-nat 0) ok] - [(-nat (s N)) (+nat N)]]) + [(-nat (s N)) (+nat N)]}) 'expect -(:= x 0) -(== x 0) +(:= #x 0) +(== #x 0) '(== x 1) 'type checking (:= 2 <+nat s s 0>) -(:= test @(exec (union @#2 #nat))) -(== test ok) +(== @(exec { @#2 #nat }) ok) 'import file '(use "examples/automata.sg") 'declaration definition (new-declaration (:: Tested Test) - (:= test @(exec (union @#Tested #Test))) - (== test ok)) + (== @(exec { @#Tested #Test }) ok)) (:: 2 nat) diff --git a/examples/turing.sg b/examples/turing.sg index 9075cd4..dcdcadd 100644 --- a/examples/turing.sg +++ b/examples/turing.sg @@ -1,8 +1,8 @@ ' Turing machine accepting words with as many 'a' as 'b' -(:= mt [ +(:= mt { 'initial [(-i [C|W]) (+m q0 [e e] C W)] - [(-i []) (+m q0 e e e)] + [(-i []) (+m q0 e e e)] 'accept [(-m q0 L e R) (+m qa L e R)] [(-m qa L e R) accept] @@ -27,14 +27,14 @@ 'reject [(-m q2 L e R) (+m qr L e R)] [(-m q3 L e R) (+m qr L e R)] - [(-m qr L C R) reject]]) + [(-m qr L C R) reject]}) - - - + + + - - - - - + + + + + diff --git a/src/expr.ml b/src/expr.ml index 1802298..908637b 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -63,6 +63,7 @@ let rec expand_macro : Raw.t -> expr = function | Raw.String s -> List [ Symbol string_op; Symbol s ] | Raw.Call e' -> List [ Symbol call_op; expand_macro e' ] | Raw.Focus e' -> List [ Symbol focus_op; expand_macro e' ] + | Raw.Group es -> List (Symbol group_op :: List.map ~f:expand_macro es) | Raw.List es -> List (List.map ~f:expand_macro es) | Raw.Cons es -> expand_macro (Raw.ConsWithBase (es, Symbol nil_op)) | Raw.ConsWithBase (es, base) -> @@ -197,8 +198,9 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr = (* focus @ *) | List [ Symbol k; g ] when equal_string k focus_op -> Focus (sgen_expr_of_expr g) - (* union *) - | List (Symbol "union" :: gs) -> Union (List.map ~f:sgen_expr_of_expr gs) + (* group *) + | List (Symbol k :: gs) when equal_string k group_op -> + Group (List.map ~f:sgen_expr_of_expr gs) (* process *) | List (Symbol "process" :: gs) -> Process (List.map ~f:sgen_expr_of_expr gs) (* kill *) @@ -229,10 +231,10 @@ let decl_of_expr : expr -> declaration = function (* trace *) | 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) + | List [ Symbol k; g1; g2 ] when equal_string k expect_op -> + Expect (sgen_expr_of_expr g1, sgen_expr_of_expr g2, const "default") + | List [ Symbol k; g1; g2; m ] when equal_string k expect_op -> + Expect (sgen_expr_of_expr g1, sgen_expr_of_expr g2, ray_of_expr m) (* use *) | List [ Symbol k; r ] when equal_string k "use" -> Use (ray_of_expr r) | e -> failwith ("error: invalid declaration " ^ to_string e) diff --git a/src/lexer.ml b/src/lexer.ml index 7c27ee3..f3edb17 100644 --- a/src/lexer.ml +++ b/src/lexer.ml @@ -23,7 +23,7 @@ and comments lexbuf = and read lexbuf = match%sedlex lexbuf with - | ( Compl (Chars "'\" \t\n\r()<>[]{}|@#%") + | ( Compl (Chars "'\" \t\n\r()<>[]{}|@#") , Star (Compl (Chars " \t\n\r()<>[]{}|")) ) -> let lexeme = Utf8.lexeme lexbuf in begin diff --git a/src/sgen_ast.ml b/src/sgen_ast.ml index ba654e9..1c365cb 100644 --- a/src/sgen_ast.ml +++ b/src/sgen_ast.ml @@ -11,7 +11,7 @@ type sgen_expr = | Raw of marked_constellation | Id of ident | Exec of bool * sgen_expr - | Union of sgen_expr list + | Group of sgen_expr list | Subst of sgen_expr * substitution | Focus of sgen_expr | Clean of sgen_expr @@ -39,7 +39,7 @@ type declaration = | Show of sgen_expr | Trace of sgen_expr | Run of sgen_expr - | Expect of ident * sgen_expr * ident + | Expect of sgen_expr * sgen_expr * ident | Use of ident type program = declaration list diff --git a/src/sgen_eval.ml b/src/sgen_eval.ml index 59c2025..1e466b2 100644 --- a/src/sgen_eval.ml +++ b/src/sgen_eval.ml @@ -34,9 +34,9 @@ let rec replace_id (xfrom : ident) (xto : sgen_expr) e : | Clean e -> let* g = replace_id xfrom xto e in Clean g |> Result.return - | Union es -> + | Group es -> let* gs = List.map ~f:(replace_id xfrom xto) es |> Result.all in - Union gs |> Result.return + Group gs |> Result.return | Focus e -> let* g = replace_id xfrom xto e in Focus g |> Result.return @@ -63,9 +63,9 @@ let rec map_sgen_expr env ~f : sgen_expr -> (sgen_expr, err) Result.t = function | Clean e -> let* map_e = map_sgen_expr env ~f e in Clean map_e |> Result.return - | Union es -> + | Group es -> let* map_es = List.map ~f:(map_sgen_expr env ~f) es |> Result.all in - Union map_es |> Result.return + Group map_es |> Result.return | Subst (e, Extend pf) -> let* map_e = map_sgen_expr env ~f e in Subst (map_e, Extend pf) |> Result.return @@ -129,7 +129,7 @@ let rec eval_sgen_expr (env : env) : in Result.bind result ~f:(eval_sgen_expr env) end - | Union es -> + | Group es -> let* eval_es = List.map ~f:(eval_sgen_expr env) es |> Result.all in let* mcs = Ok eval_es in Ok (List.concat mcs) @@ -159,7 +159,7 @@ let rec eval_sgen_expr (env : env) : acc |> remove_mark_all |> clean |> focus |> Result.return | _ -> let origin = acc |> remove_mark_all |> focus in - eval_sgen_expr env (Focus (Exec (false, Union [ x; Raw origin ]))) ) + eval_sgen_expr env (Focus (Exec (false, Group [ x; Raw origin ]))) ) in res |> Result.return | Subst (e, Extend pf) -> @@ -227,12 +227,12 @@ let rec eval_decl env : declaration -> (env, err) Result.t = function | Run e -> let _ = eval_sgen_expr env (Exec (false, e)) in Ok env - | Expect (x, e, message) -> - let* eval_x = eval_sgen_expr env (Id x) in - let* eval_e = eval_sgen_expr env e in + | Expect (e1, e2, message) -> + let* eval_e1 = eval_sgen_expr env e1 in + let* eval_e2 = eval_sgen_expr env e2 in let normalize x = x |> remove_mark_all |> unmark_all in - if not @@ equal_mconstellation (normalize eval_e) (normalize eval_x) then - Error (ExpectError (eval_x, eval_e, message)) + if not @@ equal_mconstellation (normalize eval_e1) (normalize eval_e2) then + Error (ExpectError (eval_e1, eval_e2, message)) else Ok env | Use path -> let open Lsc_ast.StellarRays in diff --git a/test/test.ml b/test/test.ml index 8fca86c..c913bf5 100644 --- a/test/test.ml +++ b/test/test.ml @@ -22,8 +22,8 @@ let run_dir test_f directory = let () = Alcotest.run "Stellogen Test Suite" - [ ("Stellogen examples", run_dir sgen "../examples/") - ; (* ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") + [ (* ("Stellogen examples", run_dir sgen "../examples/") ; *) - ("Stellogen syntax", run_dir sgen "./subjects/") - ] + (* ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") + ; *) + (* ("Stellogen syntax", run_dir sgen "./subjects/") *) ] From e55eb6d0dbfb80277678edaa9e91f052f747acde Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 6 Jul 2025 17:11:04 +0200 Subject: [PATCH 43/45] Fix grammar to handle braces --- examples/lambda.sg | 2 -- examples/syntax.sg | 6 +++--- src/expr.ml | 5 +---- test/subjects/linear.sg | 12 ++++++------ test/subjects/prolog.sg | 32 ++++++++++++++++---------------- test/subjects/records.sg | 26 +++++++++++++------------- test/test.ml | 8 ++++---- 7 files changed, 43 insertions(+), 48 deletions(-) diff --git a/examples/lambda.sg b/examples/lambda.sg index 5501148..c379e9a 100644 --- a/examples/lambda.sg +++ b/examples/lambda.sg @@ -26,5 +26,3 @@ (:= linker { [(-lproj X) (-arg X)] @[(+arg [r|X]) (out X)]}) - - diff --git a/examples/syntax.sg b/examples/syntax.sg index c685077..d36fa2c 100644 --- a/examples/syntax.sg +++ b/examples/syntax.sg @@ -74,9 +74,9 @@ (show #(get g test2)) 'nested fields -(:= g1 { +(:= g1 [ [(+field test1) [ - [(+field test2) [(+f c) ok]]]]}) + [(+field test2) [(+f c) ok]]]]]) (:= g2 ) @@ -100,7 +100,7 @@ [(-nat (s N)) (+nat N)]}) 'expect -(:= #x 0) +(:= x 0) (== #x 0) '(== x 1) diff --git a/src/expr.ml b/src/expr.ml index 908637b..5f4304c 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -189,10 +189,7 @@ let rec sgen_expr_of_expr (e : expr) : sgen_expr = Raw [ Unmarked { content = [ ray_of_expr e ]; bans = [] } ] (* star *) | List (Symbol s :: _) when equal_string s params_op -> Raw [ star_of_expr e ] - | List [ Symbol s; h; t ] - when equal_string s cons_op && (not @@ is_cons h) && (not @@ contains_cons t) - -> - Raw [ star_of_expr e ] + | List (Symbol s :: _) when equal_string s cons_op -> Raw [ star_of_expr e ] (* id *) | List [ Symbol k; g ] when equal_string k call_op -> Id (ray_of_expr g) (* focus @ *) diff --git a/test/subjects/linear.sg b/test/subjects/linear.sg index c8257d8..e44ea9b 100644 --- a/test/subjects/linear.sg +++ b/test/subjects/linear.sg @@ -4,11 +4,11 @@ (spec nat [(-nat (s X)) (+nat X)]) -(:= tested @(linexec (union @#1 #nat))) -(== tested (+nat 0)) +(:= tested @(linexec { @#1 #nat })) +(== #tested (+nat 0)) -(:= tested @(linexec (union @#2 #nat))) -(== tested (+nat (s 0))) +(:= tested @(linexec { @#2 #nat })) +(== #tested (+nat (s 0))) -(:= tested @(linexec (union @#3 #nat))) -(== tested (+nat )) +(:= tested @(linexec { @#3 #nat })) +(== #tested (+nat )) diff --git a/test/subjects/prolog.sg b/test/subjects/prolog.sg index afee0e9..e767c8a 100644 --- a/test/subjects/prolog.sg +++ b/test/subjects/prolog.sg @@ -1,24 +1,24 @@ -(:= add [ +(:= add { [(+add 0 Y Y)] - [(-add X Y Z) (+add (s X) Y (s Z))]]) + [(-add X Y Z) (+add (s X) Y (s Z))]}) -(:= tested (exec (union #add @[(-add 0 0 R) R]))) -(== tested 0) +(:= tested (exec { #add @[(-add 0 0 R) R] })) +(== #tested 0) -(:= tested (exec (union #add @[(-add (s 0) 0 R) R]))) -(== tested (s 0)) +(:= tested (exec { #add @[(-add (s 0) 0 R) R] })) +(== #tested (s 0)) -(:= tested (exec (union #add @[(-add 0 (s 0) R) R]))) -(== tested (s 0)) +(:= tested (exec { #add @[(-add 0 (s 0) R) R] })) +(== #tested (s 0)) -(:= tested (exec (union #add @[(-add R) R]))) -(== tested ) +(:= tested (exec { #add @[(-add R) R] })) +(== #tested ) -(:= tested (exec (union #add @[(-add R ) R]))) -(== tested 0) +(:= tested (exec { #add @[(-add R ) R] })) +(== #tested 0) -(:= tested (exec (union #add @[(-add R ) R]))) -(== tested ) +(:= tested (exec { #add @[(-add R ) R] })) +(== #tested ) -(:= tested (exec (union #add @[(-add R ) R]))) -(== tested ) +(:= tested (exec { #add @[(-add R ) R] })) +(== #tested ) diff --git a/test/subjects/records.sg b/test/subjects/records.sg index e8dccdf..0afe23a 100644 --- a/test/subjects/records.sg +++ b/test/subjects/records.sg @@ -1,18 +1,18 @@ -(:= g [ +(:= g { [+test1 1] - [+test2 [ + [+test2 { [+test21 2] - [+test22 [ - [+test3 3]]]]]]) + [+test22 { + [+test3 3]}]}]}) -(:= x ) -(== x 1) +(:= x ) +(== #x 1) -(:= x ) -(:= y ) -(== y 2) +(:= x ) +(:= y ) +(== #y 2) -(:= x ) -(:= y ) -(:= z ) -(== z 3) +(:= x ) +(:= y ) +(:= z ) +(== #z 3) diff --git a/test/test.ml b/test/test.ml index c913bf5..8fca86c 100644 --- a/test/test.ml +++ b/test/test.ml @@ -22,8 +22,8 @@ let run_dir test_f directory = let () = Alcotest.run "Stellogen Test Suite" - [ (* ("Stellogen examples", run_dir sgen "../examples/") + [ ("Stellogen examples", run_dir sgen "../examples/") + ; (* ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") ; *) - (* ; ("Stellogen exercises solutions", run_dir sgen "../exercises/solutions/") - ; *) - (* ("Stellogen syntax", run_dir sgen "./subjects/") *) ] + ("Stellogen syntax", run_dir sgen "./subjects/") + ] From c417711673a6a9b3a228a0608c9a2db9f7cc6a68 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 6 Jul 2025 17:14:16 +0200 Subject: [PATCH 44/45] Remove dead code --- src/expr.ml | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/expr.ml b/src/expr.ml index 5f4304c..32e169d 100644 --- a/src/expr.ml +++ b/src/expr.ml @@ -173,15 +173,6 @@ let rec constellation_of_expr : expr -> marked_constellation = function Stellogen expr of Expr --------------------------------------- *) -let is_cons = function - | List [ Symbol s; _; _ ] when equal_string s cons_op -> true - | _ -> false - -let rec contains_cons = function - | List [ Symbol s; h; t ] when equal_string s cons_op -> - is_cons h || contains_cons t - | _ -> false - let rec sgen_expr_of_expr (e : expr) : sgen_expr = match e with (* ray *) From ebdfc819c26e1fb2c95a50228101ba34285d8f97 Mon Sep 17 00:00:00 2001 From: engboris Date: Sun, 6 Jul 2025 17:16:43 +0200 Subject: [PATCH 45/45] Fix README --- README.md | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 0ef3075..9d15f22 100644 --- a/README.md +++ b/README.md @@ -36,9 +36,8 @@ philosophy). Finite state machine ``` -(new-declaration (:: tested test) -(:= test @(exec { @#tested #test })) - (== test ok)) +(new-declaration (:: Tested Test) + (== @(exec { @#Tested #Test }) ok)) (spec binary { [(-i []) ok] @@ -64,13 +63,17 @@ Finite state machine ''' 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)]) + (:= a1 { - [(-i W) (+a W q0)] - [(-a [] q2) accept] - [(-a [0|W] q0) (+a W q0)] - [(-a [0|W] q0) (+a W q1)] - [(-a [1|W] q0) (+a W q0)] - [(-a [0|W] q1) (+a W q2)]}) + #(initial q0) + #(accept q2) + #(if read 0 on q0 then q0) + #(if read 0 on q0 then q1) + #(if read 1 on q0 then q0) + #(if read 0 on q1 then q2)})