From eb424eeb33d8fc9bb7ad2acda0c58fcb037717d3 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 14 Jul 2015 22:47:10 -0400
Subject: - Added a ' (quote) macro that works like ` (backquote), without
 unquote or unquote splice working and not automatic prefixing of unprefixed
 symbols/tags. - Added (slightly) better type-error messages.

---
 input/lux.lux | 88 +++++++++++++++++++++++++++++++++--------------------------
 1 file changed, 50 insertions(+), 38 deletions(-)

(limited to 'input/lux.lux')

diff --git a/input/lux.lux b/input/lux.lux
index de407bafe..2bad33439 100644
--- a/input/lux.lux
+++ b/input/lux.lux
@@ -791,48 +791,52 @@
     _
     (fail "Wrong syntax for $")))
 
-(def'' (splice untemplate tag elems)
-  (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
-  (_lux_case (any? spliced? elems)
+(def'' (splice replace? untemplate tag elems)
+  (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
+  (_lux_case replace?
     true
-    (let [elems' (map (lambda [elem]
-                        (_lux_case elem
-                          (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
-                          spliced
-
-                          _
-                          (form$ (list (symbol$ ["" "_lux_:"])
-                                       (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"])))))
-                                       (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem)
-                                                                                        (tag$ ["lux" "Nil"])))))))))
-                      elems)]
-      (wrap-meta (form$ (list tag
-                              (form$ (list& (symbol$ ["lux" "$"])
-                                            (symbol$ ["lux" "list:++"])
-                                            elems'))))))
-
+    (_lux_case (any? spliced? elems)
+      true
+      (let [elems' (map (lambda [elem]
+                          (_lux_case elem
+                            (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))])
+                            spliced
+
+                            _
+                            (form$ (list (symbol$ ["" "_lux_:"])
+                                         (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"])))))
+                                         (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem)
+                                                                                          (tag$ ["lux" "Nil"])))))))))
+                        elems)]
+        (wrap-meta (form$ (list tag
+                                (form$ (list& (symbol$ ["lux" "$"])
+                                              (symbol$ ["lux" "list:++"])
+                                              elems'))))))
+
+      false
+      (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))
     false
     (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))))
 
-(def'' (untemplate subst token)
-  (->' Text Syntax Syntax)
-  (_lux_case token
-    (#Meta [_ (#BoolS value)])
+(def'' (untemplate replace? subst token)
+  (->' Bool Text Syntax Syntax)
+  (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token])
+    [_ (#Meta [_ (#BoolS value)])]
     (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))
 
-    (#Meta [_ (#IntS value)])
+    [_ (#Meta [_ (#IntS value)])]
     (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))
 
-    (#Meta [_ (#RealS value)])
+    [_ (#Meta [_ (#RealS value)])]
     (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))
 
-    (#Meta [_ (#CharS value)])
+    [_ (#Meta [_ (#CharS value)])]
     (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))
 
-    (#Meta [_ (#TextS value)])
+    [_ (#Meta [_ (#TextS value)])]
     (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))
 
-    (#Meta [_ (#TagS [module name])])
+    [_ (#Meta [_ (#TagS [module name])])]
     (let [module' (_lux_case module
                     ""
                     subst
@@ -841,7 +845,7 @@
                     module)]
       (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))
 
-    (#Meta [_ (#SymbolS [module name])])
+    [_ (#Meta [_ (#SymbolS [module name])])]
     (let [module' (_lux_case module
                     ""
                     subst
@@ -850,32 +854,40 @@
                     module)]
       (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name)))))))
 
-    (#Meta [_ (#TupleS elems)])
-    (splice (untemplate subst) (tag$ ["lux" "TupleS"]) elems)
+    [_ (#Meta [_ (#TupleS elems)])]
+    (splice (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems)
 
-    (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])
+    [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])]
     unquoted
 
-    (#Meta [_ (#FormS elems)])
-    (splice (untemplate subst) (tag$ ["lux" "FormS"]) elems)
+    [_ (#Meta [_ (#FormS elems)])]
+    (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)
 
-    (#Meta [_ (#RecordS fields)])
+    [_ (#Meta [_ (#RecordS fields)])]
     (wrap-meta (form$ (list (tag$ ["lux" "RecordS"])
                             (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax)
                                                           (lambda [kv]
                                                             (let [[k v] kv]
-                                                              (tuple$ (list (untemplate subst k) (untemplate subst v))))))
+                                                              (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v))))))
                                                   fields)))))
     ))
 
 (defmacro (`' tokens)
   (_lux_case tokens
     (#Cons [template #Nil])
-    (return (list (untemplate "" template)))
+    (return (list (untemplate true "" template)))
 
     _
     (fail "Wrong syntax for `'")))
 
+(defmacro (' tokens)
+  (_lux_case tokens
+    (#Cons [template #Nil])
+    (return (list (untemplate false "" template)))
+
+    _
+    (fail "Wrong syntax for '")))
+
 (defmacro #export (|> tokens)
   (_lux_case tokens
     (#Cons [init apps])
@@ -1648,7 +1660,7 @@
     [module-name get-module-name]
     (case tokens
       (\ (list template))
-      (;return (list (untemplate module-name template)))
+      (;return (list (untemplate true module-name template)))
 
       _
       (fail "Wrong syntax for `"))))
-- 
cgit v1.2.3