From e35f31c170be160b30f22eae22871eba74db2767 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 30 Oct 2017 23:55:33 -0400
Subject: - Added "^code" pattern-matching macro for easier handling of code.

---
 lux-mode/lux-mode.el                        |  2 +-
 new-luxc/source/luxc/generator/expr.jvm.lux | 20 ++++----
 stdlib/source/lux.lux                       | 76 +++++++++++++++++++++++++++++
 3 files changed, 87 insertions(+), 11 deletions(-)

diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el
index ed440db65..558cf92f6 100644
--- a/lux-mode/lux-mode.el
+++ b/lux-mode/lux-mode.el
@@ -231,7 +231,7 @@ Called by `imenu--generic-function'."
             "list" "list&" "io" "sequence" "tree"
             "get@" "set@" "update@" "|>" "|>." "<|" "<|." "_$" "$_" "~" "~@" "~'" "::" ":::"
             "|" "&" "->" "All" "Ex" "Rec" "primitive" "$" "type"
-            "^" "^or" "^slots" "^multi" "^~" "^@" "^template" "^open" "^|>" "^stream&" "^regex"
+            "^" "^or" "^slots" "^multi" "^~" "^@" "^template" "^open" "^|>" "^code" "^stream&" "^regex"
             "bin" "oct" "hex"
             "pre" "post"
             "sig" "struct" "derive"
diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux
index b439ff17a..61120ef86 100644
--- a/new-luxc/source/luxc/generator/expr.jvm.lux
+++ b/new-luxc/source/luxc/generator/expr.jvm.lux
@@ -27,10 +27,10 @@
 (def: #export (generate synthesis)
   (-> ls;Synthesis (Meta $;Inst))
   (case synthesis
-    [_ (#;Tuple #;Nil)]
+    (^code [])
     &primitive;generate-unit
 
-    (^ [_ (#;Tuple (list singleton))])
+    (^code [(~ singleton)])
     (generate singleton)
 
     (^template [<tag> <generator>]
@@ -43,10 +43,10 @@
      [#;Frac &primitive;generate-frac]
      [#;Text &primitive;generate-text])
 
-    (^ [_ (#;Form (list [_ (#;Nat tag)] [_ (#;Bool last?)] valueS))])
+    (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Bool last?)]) (~ valueS)))
     (&structure;generate-variant generate tag last? valueS)
-    
-    [_ (#;Tuple members)]
+
+    (^code [(~@ members)])
     (&structure;generate-tuple generate members)
 
     (^ [_ (#;Form (list [_ (#;Int var)]))])
@@ -57,20 +57,20 @@
     [_ (#;Symbol definition)]
     (&reference;generate-definition definition)
 
-    (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS exprS))])
+    (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ exprS)))
     (caseG;generate-let generate register inputS exprS)
 
-    (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathPS))])
+    (^code ("lux case" (~ inputS) (~ pathPS)))
     (caseG;generate-case generate inputS pathPS)
 
-    (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity)] [_ (#;Tuple environment)] bodyS))])
+    (^multi (^code ("lux function" (~ [_ (#;Nat arity)]) [(~@ environment)] (~ bodyS)))
             [(s;run environment (p;some s;int)) (#e;Success environment)])
     (&function;generate-function generate environment arity bodyS)
 
-    (^ [_ (#;Form (list& [_ (#;Text "lux call")] functionS argsS))])
+    (^code ("lux call" (~ functionS) (~@ argsS)))
     (&function;generate-call generate functionS argsS)
 
-    (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))])
+    (^code ((~ [_ (#;Text procedure)]) (~@ argsS)))
     (&procedure;generate-procedure generate procedure argsS)
 
     _
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index bf77ca259..e3a81cebd 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -5973,3 +5973,79 @@
     _
     (fail "Wrong syntax for ``")
     ))
+
+(def: (ident$ [module name])
+  (-> Ident Code)
+  (` [(~ (text$ module)) (~ (text$ name))]))
+
+(def: (untemplate-list& last inits)
+  (-> Code (List Code) Code)
+  (case inits
+    #Nil
+    last
+
+    (#Cons [init inits'])
+    (` (#;Cons (~ init) (~ (untemplate-list& last inits'))))))
+
+(def: (untemplate-pattern pattern)
+  (-> Code (Meta Code))
+  (case pattern
+    (^template [<tag> <name> <gen>]
+      [_ (<tag> value)]
+      (do Monad<Meta>
+        [g!meta (gensym "g!meta")]
+        (wrap (` [(~ g!meta) (<tag> (~ (<gen> value)))]))))
+    ([#Bool "Bool" bool$]
+     [#Nat "Nat" nat$]
+     [#Int "Int" int$]
+     [#Deg "Deg" deg$]
+     [#Frac "Frac" frac$]
+     [#Text "Text" text$]
+     [#Tag "Tag" ident$]
+     [#Symbol "Symbol" ident$])
+
+    [_ (#Record fields)]
+    (do Monad<Meta>
+      [=fields (mapM Monad<Meta>
+                     (function [[key value]]
+                       (do Monad<Meta>
+                         [=key (untemplate-pattern key)
+                          =value (untemplate-pattern value)]
+                         (wrap (` [(~ =key) (~ =value)]))))
+                     fields)
+       g!meta (gensym "g!meta")]
+      (wrap (` [(~ g!meta) (#;Record (~ (untemplate-list =fields)))])))
+
+    [_ (#Form (#Cons [[_ (#Symbol ["" "~"])] (#Cons [unquoted #Nil])]))]
+    (:: Monad<Meta> wrap unquoted)
+
+    [_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))]
+    (fail "Cannot use (~@) inside of ^code unless it is the last element in a form or a tuple.")
+
+    (^template [<tag>]
+      [_ (<tag> elems)]
+      (case (reverse elems)
+        (#;Cons [_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))]
+                inits)
+        (do Monad<Meta>
+          [=inits (mapM Monad<Meta> untemplate-pattern (reverse inits))
+           g!meta (gensym "g!meta")]
+          (wrap (` [(~ g!meta) (<tag> (~ (untemplate-list& spliced =inits)))])))
+
+        _
+        (do Monad<Meta>
+          [=elems (mapM Monad<Meta> untemplate-pattern elems)
+           g!meta (gensym "g!meta")]
+          (wrap (` [(~ g!meta) (<tag> (~ (untemplate-list =elems)))])))))
+    ([#;Tuple] [#;Form])
+    ))
+
+(macro: #export (^code tokens)
+  (case tokens
+    (^ (list& [_meta (#;Form (list template))] body branches))
+    (do Monad<Meta>
+      [pattern (untemplate-pattern template)]
+      (wrap (list& pattern body branches)))
+    
+    _
+    (fail "Wrong syntax for ^code")))
-- 
cgit v1.2.3