From 196f56b83ed357169efb75b864f81f26c10641f1 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 29 Aug 2015 23:17:27 -0400
Subject: - Remove the (unnec) "All'" and "->'" macros. - Improved the "struct"
 macro so that (once again) it doesn't ask for the prefixes of the members. -
 Added tests for the lux.reader namespace.

---
 source/lux.lux | 291 +++++++++++++++++++++++++++++----------------------------
 1 file changed, 146 insertions(+), 145 deletions(-)

(limited to 'source/lux.lux')

diff --git a/source/lux.lux b/source/lux.lux
index 422fb4fad..3ba8ec897 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -539,9 +539,9 @@
                                                                         #Nil))))))
                              #Nil))
 
-              (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)))
+              (#Cons [_ (#SymbolS "" self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)))
               (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda"))
-                                                   (#Cons (_meta (#SymbolS self))
+                                                   (#Cons (_meta (#SymbolS "" self))
                                                           (#Cons arg
                                                                  (#Cons (_lux_case args'
                                                                           #Nil
@@ -649,26 +649,6 @@
 (defmacro #export (comment tokens)
   (return #Nil))
 
-(defmacro (->' tokens)
-  (_lux_case tokens
-    (#Cons input (#Cons output #Nil))
-    (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "LambdaT"])
-                                         (#Cons (_meta (#TupleS (#Cons input (#Cons output #Nil))))
-                                                #Nil))))
-                   #Nil))
-
-    (#Cons input (#Cons output others))
-    (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "LambdaT"])
-                                         (#Cons (_meta (#TupleS (#Cons input
-                                                                       (#Cons (_meta (#FormS (#Cons (symbol$ ["lux" "->'"])
-                                                                                                    (#Cons output others))))
-                                                                              #Nil))))
-                                                #Nil))))
-                   #Nil))
-
-    _
-    (fail "Wrong syntax for ->'")))
-
 (defmacro ($' tokens)
   (_lux_case tokens
     (#Cons x #Nil)
@@ -687,7 +667,9 @@
 (def'' (map f xs)
   (#UnivQ #Nil
           (#UnivQ #Nil
-                  (->' (->' (#BoundT 3) (#BoundT 1)) ($' List (#BoundT 3)) ($' List (#BoundT 1)))))
+                  (#LambdaT (#LambdaT (#BoundT 3) (#BoundT 1))
+                            (#LambdaT ($' List (#BoundT 3))
+                                      ($' List (#BoundT 1))))))
   (_lux_case xs
     #Nil
     #Nil
@@ -700,7 +682,7 @@
   ($' List (#TupleT (#Cons Text (#Cons AST #Nil)))))
 
 (def'' (make-env xs ys)
-  (->' ($' List Text) ($' List AST) RepEnv)
+  (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv))
   (_lux_case (_lux_: (#TupleT (#Cons ($' List Text) (#Cons ($' List AST) #Nil)))
                      [xs ys])
     [(#Cons x xs') (#Cons y ys')]
@@ -710,12 +692,12 @@
     #Nil))
 
 (def'' (text:= x y)
-  (->' Text Text Bool)
+  (#LambdaT Text (#LambdaT Text Bool))
   (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"]
                       x [y]))
 
 (def'' (get-rep key env)
-  (->' Text RepEnv ($' Maybe AST))
+  (#LambdaT Text (#LambdaT RepEnv ($' Maybe AST)))
   (_lux_case env
     #Nil
     #None
@@ -729,7 +711,7 @@
       (get-rep key env'))))
 
 (def'' (replace-syntax reps syntax)
-  (->' RepEnv AST AST)
+  (#LambdaT RepEnv (#LambdaT AST AST))
   (_lux_case syntax
     [_ (#SymbolS "" name)]
     (_lux_case (get-rep name reps)
@@ -746,7 +728,7 @@
     [meta (#TupleS (map (replace-syntax reps) members))]
 
     [meta (#RecordS slots)]
-    [meta (#RecordS (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil))))
+    [meta (#RecordS (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil))))
                                  (lambda'' [slot]
                                            (_lux_case slot
                                              [k v]
@@ -758,7 +740,7 @@
   )
 
 (def'' (update-bounds ast)
-  (->' AST AST)
+  (#LambdaT AST AST)
   (_lux_case ast
     [_ (#BoolS value)]
     (bool$ value)
@@ -785,7 +767,7 @@
     (tuple$ (map update-bounds members))
 
     [_ (#RecordS pairs)]
-    (record$ (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil))))
+    (record$ (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil))))
                           (lambda'' [pair]
                                     (let'' [name val] pair
                                            [name (update-bounds val)])))
@@ -798,32 +780,33 @@
     (form$ (map update-bounds members)))
   )
 
-(defmacro (All' tokens)
-  (_lux_case tokens
-    (#Cons [_ (#TupleS (#Cons [_ (#SymbolS "" arg-name)] other-args))]
-           (#Cons body #Nil))
-    (let'' bound-var (_meta (#FormS (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ 1) #Nil))))
-           (let'' body' (replace-syntax (#Cons [arg-name bound-var] #Nil)
-                                        (update-bounds body))
-                  (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "UnivQ"])
-                                                       (#Cons (tag$ ["lux" "Nil"])
-                                                              (#Cons (_lux_case other-args
-                                                                       #Nil
-                                                                       body'
-
-                                                                       _
-                                                                       (_meta (#FormS (#Cons (symbol$ ["lux" "All'"])
-                                                                                             (#Cons (_meta (#TupleS other-args))
-                                                                                                    (#Cons body'
-                                                                                                           #Nil))))))
-                                                                     #Nil)))))
-                                 #Nil))))
+(def'' (parse-univq-args args next)
+  ## (All [a] (-> (List AST) (-> (List Text) (Lux a)) (Lux a)))
+  (#UnivQ #Nil (#LambdaT ($' List AST)
+                         (#LambdaT (#LambdaT  ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 1)))
+                                   (#AppT (#AppT StateE Compiler) (#BoundT 1)))))
+  (_lux_case args
+    #Nil
+    (next #Nil)
+
+    (#Cons [_ (#SymbolS "" arg-name)] args')
+    (parse-univq-args args' (lambda'' [names] (next (#Cons arg-name names))))
 
     _
-    (fail "Wrong syntax for All'")))
+    (fail "Expected symbol.")))
+
+(def'' (make-bound idx)
+  (#LambdaT  Int AST)
+  (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ idx) #Nil))))
 
 (def'' (foldL f init xs)
-  (All' [a b] (->' (->' a b a) a ($' List b) a)) 
+  ## (All [a b] (-> (-> a b a) a (List b) a))
+  (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 3)
+                                                (#LambdaT (#BoundT 1)
+                                                          (#BoundT 3)))
+                                      (#LambdaT (#BoundT 3)
+                                                (#LambdaT ($' List (#BoundT 1))
+                                                          (#BoundT 3))))))
   (_lux_case xs
     #Nil
     init
@@ -831,27 +814,66 @@
     (#Cons x xs')
     (foldL f (f init x) xs')))
 
+(defmacro #export (All tokens)
+  (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil)))
+                                    (_lux_case tokens
+                                      (#Cons [_ (#SymbolS "" self-name)] tokens)
+                                      [self-name tokens]
+
+                                      _
+                                      ["" tokens]))
+         (_lux_case tokens
+           (#Cons [_ (#TupleS args)] (#Cons body #Nil))
+           (parse-univq-args args
+                             (lambda'' [names]
+                                  (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST))
+                                                              (lambda'' [body' name']
+                                                                        (form$ (#Cons (tag$ ["lux" "UnivQ"])
+                                                                                      (#Cons (tag$ ["lux" "Nil"])
+                                                                                             (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil)
+                                                                                                                    (update-bounds body')) #Nil))))))
+                                                      (replace-syntax (#Cons [self-name (make-bound -2)] #Nil)
+                                                                      body)
+                                                      names)
+                                         (return (#Cons body' #Nil)))))
+           
+           _
+           (fail "Wrong syntax for All"))
+         ))
+
 (def'' (reverse list)
-  (All' [a] (->' ($' List a) ($' List a)))
+  (All [a] (#LambdaT ($' List a) ($' List a)))
   (foldL (lambda'' [tail head] (#Cons head tail))
          #Nil
          list))
 
+(defmacro #export (-> tokens)
+  (_lux_case (reverse tokens)
+    (#Cons output inputs)
+    (return (#Cons (foldL (_lux_: (#LambdaT AST (#LambdaT AST AST))
+                                  (lambda'' [o i] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil))))))
+                          output
+                          inputs)
+                   #Nil))
+    
+    _
+    (fail "Wrong syntax for ->")))
+
 (defmacro (list xs)
-  (return (#Cons [(foldL (lambda'' [tail head]
-                                   (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"]))
-                                                          (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])])))
-                                                                  #Nil])]))))
-                         (_meta (#TagS ["lux" "Nil"]))
-                         (reverse xs))
-                  #Nil])))
+  (return (#Cons (foldL (lambda'' [tail head]
+                                  (form$ (#Cons (tag$ ["lux" "Cons"])
+                                                (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])]))
+                                                       #Nil))))
+                        (tag$ ["lux" "Nil"])
+                        (reverse xs))
+                 #Nil)))
 
 (defmacro (list& xs)
   (_lux_case (reverse xs)
-    (#Cons [last init])
+    (#Cons last init)
     (return (list (foldL (lambda'' [tail head]
-                                   (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"]))
-                                                        (_meta (#TupleS (list head tail)))))))
+                                   (form$ (list (tag$ ["lux" "Cons"])
+                                                (tuple$ (list head tail)))))
                          last
                          init)))
 
@@ -859,13 +881,13 @@
     (fail "Wrong syntax for list&")))
 
 (defmacro (lambda' tokens)
-  (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST)))
+  (let'' [name tokens'] (_lux_: (#TupleT (list Text ($' List AST)))
                                 (_lux_case tokens
-                                  (#Cons [[_ (#SymbolS name)] tokens'])
+                                  (#Cons [[_ (#SymbolS ["" name])] tokens'])
                                   [name tokens']
 
                                   _
-                                  [["" ""] tokens]))
+                                  ["" tokens]))
          (_lux_case tokens'
            (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])])
            (_lux_case args
@@ -874,7 +896,7 @@
              
              (#Cons [harg targs])
              (return (list (form$ (list (symbol$ ["" "_lux_lambda"])
-                                        (symbol$ name)
+                                        (symbol$ ["" name])
                                         harg
                                         (foldL (lambda'' [body' arg]
                                                          (form$ (list (symbol$ ["" "_lux_lambda"])
@@ -931,7 +953,7 @@
     ))
 
 (def''' (as-pairs xs)
-  (All' [a] (->' ($' List a) ($' List (#TupleT (list a a)))))
+  (All [a] (-> ($' List a) ($' List (#TupleT (list a a)))))
   (_lux_case xs
     (#Cons x (#Cons y xs'))
     (#Cons [x y] (as-pairs xs'))
@@ -942,8 +964,8 @@
 (defmacro (let' tokens)
   (_lux_case tokens
     (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])])
-    (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST))
-                                      AST)
+    (return (list (foldL (_lux_: (-> AST (#TupleT (list AST AST))
+                                     AST)
                                  (lambda' [body binding]
                                           (_lux_case binding
                                             [label value]
@@ -955,8 +977,8 @@
     (fail "Wrong syntax for let'")))
 
 (def''' (any? p xs)
-  (All' [a]
-        (->' (->' a Bool) ($' List a) Bool))
+  (All [a]
+    (-> (-> a Bool) ($' List a) Bool))
   (_lux_case xs
     #Nil
     false
@@ -967,7 +989,7 @@
       false (any? p xs'))))
 
 (def''' (spliced? token)
-  (->' AST Bool)
+  (-> AST Bool)
   (_lux_case token
     [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))]
     true
@@ -976,12 +998,12 @@
     false))
 
 (def''' (wrap-meta content)
-  (->' AST AST)
+  (-> AST AST)
   (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1)))
                 content)))
 
 (def''' (untemplate-list tokens)
-  (->' ($' List AST) AST)
+  (-> ($' List AST) AST)
   (_lux_case tokens
     #Nil
     (_meta (#TagS ["lux" "Nil"]))
@@ -991,7 +1013,7 @@
                          (_meta (#TupleS (list token (untemplate-list tokens')))))))))
 
 (def''' #export (list:++ xs ys)
-  (All' [a] (->' ($' List a) ($' List a) ($' List a)))
+  (All [a] (-> ($' List a) ($' List a) ($' List a)))
   (_lux_case xs
     (#Cons x xs')
     (#Cons x (list:++ xs' ys))
@@ -1010,7 +1032,7 @@
     (fail "Wrong syntax for $")))
 
 (def''' (splice replace? untemplate tag elems)
-  (->' Bool (->' AST AST) AST ($' List AST) AST)
+  (-> Bool (-> AST AST) AST ($' List AST) AST)
   (_lux_case replace?
     true
     (_lux_case (any? spliced? elems)
@@ -1037,7 +1059,7 @@
     (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))))
 
 (def''' (untemplate replace? subst token)
-  (->' Bool Text AST AST)
+  (-> Bool Text AST AST)
   (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token])
     [_ [_ (#BoolS value)]]
     (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))
@@ -1084,7 +1106,7 @@
 
     [_ [_ (#RecordS fields)]]
     (wrap-meta (form$ (list (tag$ ["lux" "RecordS"])
-                            (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST)
+                            (untemplate-list (map (_lux_: (-> (#TupleT (list AST AST)) AST)
                                                           (lambda' [kv]
                                                                    (let' [[k v] kv]
                                                                          (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v))))))
@@ -1110,7 +1132,7 @@
 (defmacro #export (|> tokens)
   (_lux_case tokens
     (#Cons [init apps])
-    (return (list (foldL (_lux_: (->' AST AST AST)
+    (return (list (foldL (_lux_: (-> AST AST AST)
                                  (lambda' [acc app]
                                           (_lux_case app
                                             [_ (#TupleS parts)]
@@ -1141,8 +1163,8 @@
 ##   (-> Compiler (Either Text (, Compiler a))))
 (def''' #export Lux
   Type
-  (All' [a]
-        (->' Compiler ($' Either Text (#TupleT (list Compiler a))))))
+  (All [a]
+    (-> Compiler ($' Either Text (#TupleT (list Compiler a))))))
 
 ## (defsig (Monad m)
 ##   (: (All [a] (-> a (m a)))
@@ -1152,11 +1174,11 @@
 (def''' Monad
   Type
   (#NamedT ["lux" "Monad"]
-           (All' [m]
-                 (#TupleT (list (All' [a] (->' a ($' m a)))
-                                (All' [a b] (->' (->' a ($' m b))
-                                                 ($' m a)
-                                                 ($' m b))))))))
+           (All [m]
+             (#TupleT (list (All [a] (-> a ($' m a)))
+                            (All [a b] (-> (-> a ($' m b))
+                                           ($' m a)
+                                           ($' m b))))))))
 (_lux_declare-tags [#return #bind] Monad)
 
 (def''' Maybe/Monad
@@ -1196,17 +1218,6 @@
     _
     (fail "Wrong syntax for ^")))
 
-(defmacro #export (-> tokens)
-  (_lux_case (reverse tokens)
-    (#Cons output inputs)
-    (return (list (foldL (_lux_: (->' AST AST AST)
-                                 (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))))
-                         output
-                         inputs)))
-    
-    _
-    (fail "Wrong syntax for ->")))
-
 (defmacro #export (, tokens)
   (return (list (`' (#;TupleT (~ (untemplate-list tokens)))))))
 
@@ -1237,11 +1248,11 @@
 (def''' (map% m f xs)
   ## (All [m a b]
   ##   (-> (Monad m) (-> a (m b)) (List a) (m (List b))))
-  (All' [m a b]
-        (-> ($' Monad m)
-            (-> a ($' m b))
-            ($' List a)
-            ($' m ($' List b))))
+  (All [m a b]
+    (-> ($' Monad m)
+        (-> a ($' m b))
+        ($' List a)
+        ($' m ($' List b))))
   (let' [{#;return wrap #;bind _} m]
         (_lux_case xs
           #Nil
@@ -1255,8 +1266,8 @@
           )))
 
 (def''' (. f g)
-  (All' [a b c]
-        (-> (-> b c) (-> a b) (-> a c)))
+  (All [a b c]
+    (-> (-> b c) (-> a b) (-> a c)))
   (lambda' [x]
            (f (g x))))
 
@@ -1315,8 +1326,8 @@
     template))
 
 (def''' (join-map f xs)
-  (All' [a b]
-        (-> (-> a ($' List b)) ($' List a) ($' List b)))
+  (All [a b]
+    (-> (-> a ($' List b)) ($' List a) ($' List b)))
   (_lux_case xs
     #Nil
     #Nil
@@ -1408,39 +1419,6 @@
   (let' [[module name] ident]
         ($ text:++ module ";" name)))
 
-(def''' (make-bound idx)
-  (-> Int AST)
-  (`' (#;BoundT (~ (int$ idx)))))
-
-(defmacro #export (All tokens)
-  (let' [[self-name tokens] (_lux_: (, Text ASTList)
-                                    (_lux_case tokens
-                                      (#Cons [_ (#SymbolS "" self-name)] tokens)
-                                      [self-name tokens]
-
-                                      _
-                                      ["" tokens]))]
-        (_lux_case tokens
-          (#Cons [_ (#TupleS (#Cons harg targs))] (#Cons body #Nil))
-          (_lux_case (map% Maybe/Monad get-name (#Cons harg targs))
-            (#Some names)
-            (let' [body' (foldL (_lux_: (-> AST Text AST)
-                                        (lambda' [body' name']
-                                                 (`' (#;UnivQ #;Nil (~ (|> body'
-                                                                           (update-bounds)
-                                                                           (replace-syntax (list [name' (make-bound 1)]))))))))
-                                (replace-syntax (list [self-name (make-bound -2)])
-                                                body)
-                                names)]
-                  (return (list body')))
-            
-            #None
-            (fail "\"All\" arguments must be symbols."))
-          
-          _
-          (fail "Wrong syntax for All"))
-        ))
-
 (def''' (get k plist)
   (All [a]
     (-> Text ($' List (, Text a)) ($' Maybe a)))
@@ -1980,7 +1958,7 @@
              (\ (list [_ (#TupleS (#Cons head tail))] body))
              (#Some ["" ""] head tail body)
 
-             (\ (list [_ (#SymbolS [_ name])] [_ (#TupleS (#Cons head tail))] body))
+             (\ (list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body))
              (#Some ["" name] head tail body)
              
              _
@@ -2379,17 +2357,40 @@
 
 (defmacro #export (struct tokens)
   (do Lux/Monad
-    [tokens' (map% Lux/Monad macro-expand tokens)]
+    [tokens' (map% Lux/Monad macro-expand tokens)
+     struct-type expected-type
+     tags+type (resolve-type-tags struct-type)
+     tags (: (Lux (List Ident))
+             (case tags+type
+               (#Some [tags _])
+               (return tags)
+
+               _
+               (fail "No tags available for type.")))
+     #let [tag-mappings (: (List (, Text AST))
+                           (map (lambda [tag] [(second tag) (tag$ tag)])
+                                tags))]
+     _ (: (Lux Unit)
+          (let [msg ($ text:++ "struct/tag-mappings: " "[" (|> tag-mappings (map first) (interpose " ") (foldL text:++ "")) "]" " " (type:show struct-type))
+                _ (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.Object"]
+                                      (_jvm_getstatic "java.lang.System" "out") [msg])]
+            (return (: Unit []))))
+     ]
     (do Lux/Monad
       [members (map% Lux/Monad
                      (: (-> AST (Lux (, AST AST)))
                         (lambda [token]
                           (case token
-                            (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS tag-name)] value))])
-                            (wrap (: (, AST AST) [(tag$ tag-name) value]))
+                            (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))])
+                            (case (get tag-name tag-mappings)
+                              (#Some tag)
+                              (wrap (: (, AST AST) [tag value]))
+
+                              _
+                              (fail (text:++ "Unknown structure member: " tag-name)))
 
                             _
-                            (fail "Structures members must be unqualified."))))
+                            (fail (text:++ "Invalid structure member: " (ast:show token))))))
                      (list:join tokens'))]
       (wrap (list (record$ members))))))
 
-- 
cgit v1.2.3