- The lexer now takes cursors into account.

2 files changed, 230 insertions, 119 deletions

diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux
index 010911128..10f406bc7 100644
--- a/new-luxc/source/luxc/parser.lux
+++ b/new-luxc/source/luxc/parser.lux
@@ -1,11 +1,15 @@
 (;module:
   lux
   (lux (control monad)
-       (data [char]
+       (data [bool]
+             [char]
              [text]
              [number]
              (text ["l" lexer #+ Lexer Monad<Lexer> "l/" Monad<Lexer>]
-                   format))))
+                   format)
+             [product]
+             (coll [list "L/" Functor<List> Fold<List>]
+                   ["V" vector]))))
 
 (def: default-cursor
   Cursor
@@ -13,55 +17,85 @@
    #;line   +0
    #;column +0})
 
-(def: space^
-  (Lexer Text)
-  (l;some' l;space))
+(def: (space^ where)
+  (-> Cursor (Lexer [Text Cursor]))
+  (do Monad<Lexer>
+    [head (l;some' (l;one-of "\t\v \r\f"))]
+    (l;either (l;after (l;one-of "\n")
+                       (do @
+                         [[tail end] (space^ (|> where
+                                                 (update@ #;line n.inc)
+                                                 (set@ #;column +0)))]
+                         (wrap [(format head tail)
+                                end])))
+              (wrap [head
+                     (|> where
+                         (update@ #;column (n.+ (text;size head))))]))))
 
-(def: single-line-comment^
-  (Lexer Text)
+(def: (single-line-comment^ where)
+  (-> Cursor (Lexer [Text Cursor]))
   (l;enclosed ["##" "\n"]
-              (l;some' (l;none-of "\n"))))
+              (do Monad<Lexer>
+                [comment (l;some' (l;none-of "\n"))]
+                (wrap [comment
+                       (|> where
+                           (update@ #;line n.inc)
+                           (set@ #;column +0))]))))
 
-(def: multi-line-comment^
+(def: comment-bound^
   (Lexer Text)
-  (let [bound^ (l;alt (l;text ")#")
-                      (l;text "#("))]
-    (l;rec
-     (function [multi-line-comment^]
-       (do Monad<Lexer>
-         [_ (l;text "#(")
-          chunks (l;some (l;either (l;some' (l;not bound^))
-                                   (do @
-                                     [sub multi-line-comment^]
-                                     (wrap (format "#(" sub ")#")))))
-          _ (l;text ")#")]
-         (wrap (text;join-with "" chunks)))))))
+  ($_ l;either
+      (l;text "\n")
+      (l;text ")#")
+      (l;text "#(")))
 
-(def: comment^
-  (Lexer Text)
-  (l;either single-line-comment^
-            multi-line-comment^))
+(def: (multi-line-comment^ where)
+  (-> Cursor (Lexer [Text Cursor]))
+  (do Monad<Lexer>
+    [_ (l;text "#(")
+     [comment end] (loop [comment ""
+                          where (|> where
+                                    (update@ #;column (n.+ +2)))]
+                     ($_ l;either
+                         (do @
+                           [_ (l;one-of "\n")]
+                           (recur (format comment "\n")
+                                  (|> where
+                                      (update@ #;line n.inc)
+                                      (set@ #;column +0))))
+                         (do @
+                           [chunk (l;some' (l;not comment-bound^))]
+                           (recur (format comment chunk)
+                                  (|> where
+                                      (update@ #;column (n.+ (text;size chunk))))))
+                         (do @
+                           [[sub-comment sub-where] (multi-line-comment^ where)]
+                           (wrap [(format comment "#(" sub-comment ")#")
+                                  sub-where]))))
+     _ (l;text ")#")]
+    (wrap [comment
+           (|> end
+               (update@ #;column (n.+ +2)))])))
 
-(def: padded^
-  (All [a] (-> (Lexer a) (Lexer a)))
-  (let [padding^ (l;either space^ comment^)]
-    (|>. (l;before padding^)
-         (l;after padding^))))
+(def: (comment^ where)
+  (-> Cursor (Lexer [Text Cursor]))
+  (l;either (single-line-comment^ where)
+            (multi-line-comment^ where)))
 
 (def: escaped-char^
-  (Lexer Char)
+  (Lexer [Text Char])
   (l;after (l;char #"\\")
            (do Monad<Lexer>
              [code l;any]
              (case code
-               #"t" (wrap #"\t")
-               #"v" (wrap #"\v")
-               #"b" (wrap #"\b")
-               #"n" (wrap #"\n")
-               #"r" (wrap #"\r")
-               #"f" (wrap #"\f")
-               #"\"" (wrap #"\"")
-               #"\\" (wrap #"\\")
+               #"t" (wrap ["\\t" #"\t"])
+               #"v" (wrap ["\\v" #"\v"])
+               #"b" (wrap ["\\b" #"\b"])
+               #"n" (wrap ["\\n" #"\n"])
+               #"r" (wrap ["\\r" #"\r"])
+               #"f" (wrap ["\\f" #"\f"])
+               #"\"" (wrap ["\\\"" #"\""])
+               #"\\" (wrap ["\\\\" #"\\"])
 
                #"u"
                (do Monad<Lexer>
@@ -69,7 +103,7 @@
                  (wrap (case (:: number;Hex@Codec<Text,Nat> decode
                                  (format "+" code))
                          (#;Right value)
-                         (char;char value)
+                         [(format "\\u" code) (char;char value)]
 
                          _
                          (undefined))))
@@ -78,70 +112,137 @@
                (l;fail (format "Invalid escaping syntax: " (%c code)))))))
 
 (def: raw-char^
-  (Lexer Char)
-  (l;either (l;none-of "\\\"\n")
+  (Lexer [Text Char])
+  (l;either (do Monad<Lexer>
+              [char (l;none-of "\\\"\n")]
+              (wrap [(char;as-text char) char]))
             escaped-char^))
 
-(do-template [<name> <tag> <lexer>]
-  [(def: <name>
-     (Lexer AST)
+(do-template [<name> <tag> <lexer> <codec>]
+  [(def: (<name> where)
+     (-> Cursor (Lexer [AST Cursor]))
      (do Monad<Lexer>
-       [value <lexer>]
-       (wrap [default-cursor (<tag> value)])))]
+       [chunk <lexer>]
+       (case (:: <codec> decode chunk)
+         (#;Left error)
+         (l;fail error)
+
+         (#;Right value)
+         (wrap [[default-cursor (<tag> value)]
+                (|> where
+                    (update@ #;column (n.+ (text;size chunk))))]))))]
 
   [bool^ #;BoolS
-   (l;either (l;after (l;text "true") (l/wrap true))
-             (l;after (l;text "false") (l/wrap false)))]
+   (l;either (l;text "true") (l;text "false"))
+   bool;Codec<Text,Bool>]
   [nat^ #;NatS
-   (l;codec number;Codec<Text,Nat>
-            (do @
-              [sign (l;text "+")
-               digits (l;many' l;digit)]
-              (wrap (format sign digits))))]
+   (l;seq' (l;text "+") (l;many' l;digit))
+   number;Codec<Text,Nat>]
   [int^ #;IntS
-   (l;codec number;Codec<Text,Int>
-            (do @
-              [sign (l;opt (l;text "-"))
-               digits (l;many' l;digit)]
-              (wrap (format (default "" sign)
-                            digits))))]
+   (l;seq' (l;default "" (l;text "-"))
+           (l;many' l;digit))
+   number;Codec<Text,Int>]
   [real^ #;RealS
-   (l;codec number;Codec<Text,Real>
-            (do @
-              [sign (l;opt (l;text "-"))
-               whole (l;many' l;digit)
-               _ (l;text ".")
-               frac (l;many' l;digit)]
-              (wrap (format (default "" sign)
-                            whole
-                            "."
-                            frac))))]
+   ($_ l;seq'
+       (l;default "" (l;text "-"))
+       (l;many' l;digit)
+       (l;text ".")
+       (l;many' l;digit))
+   number;Codec<Text,Real>]
   [deg^ #;DegS
-   (l;codec number;Codec<Text,Deg>
-            (do @
-              [_ (l;text ".")
-               frac (l;many' l;digit)]
-              (wrap (format "." frac))))]
-  [char^ #;CharS
-   (l;enclosed ["#\"" "\""] raw-char^)]
-  [text^ #;TextS
-   (l;enclosed ["\"" "\""]
-               (l;some' raw-char^))]
+   (l;seq' (l;text ".")
+           (l;many' l;digit))
+   number;Codec<Text,Deg>]
   )
 
-(do-template [<name> <tag> <open> <close> <lexer>]
-  [(def: (<name> ast^)
-     (-> (Lexer AST) (Lexer AST))
+(def: (char^ where)
+  (-> Cursor (Lexer [AST Cursor]))
+  (do Monad<Lexer>
+    [[chunk value] (l;enclosed ["#\"" "\""]
+                               raw-char^)]
+    (wrap [[default-cursor (#;CharS value)]
+           (|> where
+               (update@ #;column (function [column]
+                                   ($_ n.+
+                                       +3
+                                       column
+                                       (text;size chunk)))))])))
+
+(def: (text^ where)
+  (-> Cursor (Lexer [AST Cursor]))
+  (do Monad<Lexer>
+    [_ (l;text "\"")
+     [columns-read text-read] (loop [columns-read +1
+                                     text-read ""]
+                                ($_ l;either
+                                    (do @
+                                      [normal (l;many' (l;none-of "\\\"\n"))]
+                                      (recur (n.+ columns-read (text;size normal))
+                                             (format text-read normal)))
+                                    (do @
+                                      [_ (l;text "\"")]
+                                      (wrap [(n.inc columns-read)
+                                             text-read]))
+                                    (do @
+                                      [[chunk char] escaped-char^]
+                                      (wrap [(n.+ columns-read (text;size chunk))
+                                             (format text-read (char;as-text char))]))))]
+    (wrap [[default-cursor (#;TextS text-read)]
+           (|> where
+               (update@ #;column (n.+ columns-read)))])))
+
+(do-template [<name> <tag> <open> <close>]
+  [(def: (<name> where ast^)
+     (-> Cursor
+         (-> Cursor (Lexer [AST Cursor]))
+         (Lexer [AST Cursor]))
      (do Monad<Lexer>
-       [elems (l;enclosed [<open> <close>]
-                          (l;some <lexer>))]
-       (wrap [default-cursor (<tag> elems)])))]
+       [_ (l;text <open>)
+        [elems where'] (loop [elems (: (V;Vector AST)
+                                       V;empty)
+                              where where]
+                         (l;either (do @
+                                     [[elem where'] (ast^ where)]
+                                     (recur (V;add elem elems)
+                                            where'))
+                                   (do @
+                                     [[_ where'] (l;either (space^ where)
+                                                           (comment^ where))
+                                      _ (l;text <close>)]
+                                     (wrap [(V;to-list elems)
+                                            (|> where'
+                                                (update@ #;column n.inc))]))))]
+       (wrap [[default-cursor (<tag> elems)]
+              where'])))]
 
-  [form^   #;FormS   "(" ")" ast^]
-  [tuple^  #;TupleS  "[" "]" ast^]
-  [record^ #;RecordS "{" "}" (l;seq ast^ ast^)]
+  [form^   #;FormS   "(" ")"]
+  [tuple^  #;TupleS  "[" "]"]
   )
 
+(def: (record^ where ast^)
+  (-> Cursor
+      (-> Cursor (Lexer [AST Cursor]))
+      (Lexer [AST Cursor]))
+  (do Monad<Lexer>
+    [_ (l;text "{")
+     [elems where'] (loop [elems (: (V;Vector [AST AST])
+                                    V;empty)
+                           where where]
+                      (l;either (do @
+                                  [[key where] (ast^ where)
+                                   [val where'] (ast^ where)]
+                                  (recur (V;add [key val] elems)
+                                         where'))
+                                (do @
+                                  [[_ where'] (l;either (space^ where)
+                                                        (comment^ where))
+                                   _ (l;text "}")]
+                                  (wrap [(V;to-list elems)
+                                         (|> where'
+                                             (update@ #;column n.inc))]))))]
+    (wrap [[default-cursor (#;RecordS elems)]
+           where'])))
+
 (def: ident-part^
   (Lexer Text)
   (do Monad<Lexer>
@@ -156,49 +257,59 @@
                   tail))))
 
 (def: ident^
-  (Lexer Ident)
+  (Lexer [Ident Nat])
   ($_ l;either
       (do Monad<Lexer>
         [_ (l;text ";;")
          def-name ident-part^]
         (l;fail "Cannot handle ;; syntax for identifiers."))
-      (l;seq (l;after (l;text ";")
-                      (l/wrap "lux"))
-             ident-part^)
+      (do Monad<Lexer>
+        [_ (l;text ";")
+         def-name ident-part^]
+        (wrap [["lux" def-name]
+               (n.inc (text;size def-name))]))
       (do Monad<Lexer>
         [first-part ident-part^]
         (l;either (do @
                     [_ (l;char #";")
                      second-part ident-part^]
-                    (wrap [first-part second-part]))
-                  (wrap ["" first-part])))))
+                    (wrap [[first-part second-part]
+                           ($_ n.+
+                               (text;size first-part)
+                               +1
+                               (text;size second-part))]))
+                  (wrap [["" first-part]
+                         (text;size first-part)])))))
 
 (do-template [<name> <tag> <lexer>]
-  [(def: <name>
-     (Lexer AST)
+  [(def: (<name> where)
+     (-> Cursor (Lexer [AST Cursor]))
      (do Monad<Lexer>
-       [value <lexer>]
-       (wrap [default-cursor (<tag> value)])))]
+       [[value length] <lexer>]
+       (wrap [[default-cursor (<tag> value)]
+              (|> where
+                  (update@ #;column (n.+ length)))])))]
 
   [symbol^ #;SymbolS ident^]
   [tag^    #;TagS    (l;after (l;char #"#") ident^)]
   )
 
-(def: #export ast^
-  (Lexer AST)
-  (l;rec (function [ast^]
-           (padded^
-            ($_ l;either
-                bool^
-                nat^
-                real^
-                int^
-                deg^
-                char^
-                text^
-                symbol^
-                tag^
-                (form^ ast^)
-                (tuple^ ast^)
-                (record^ ast^)
-                )))))
+(def: #export (ast^ where)
+  (-> Cursor (Lexer [AST Cursor]))
+  (do Monad<Lexer>
+    [[_ where] (l;either (space^ where)
+                         (comment^ where))]
+    ($_ l;either
+        (bool^ where)
+        (nat^ where)
+        (real^ where)
+        (int^ where)
+        (deg^ where)
+        (char^ where)
+        (text^ where)
+        (symbol^ where)
+        (tag^ where)
+        (form^ where ast^)
+        (tuple^ where ast^)
+        (record^ where ast^)
+        )))
diff --git a/new-luxc/test/test/luxc/parser.lux b/new-luxc/test/test/luxc/parser.lux
index 7ccc0c451..d6b420660 100644
--- a/new-luxc/test/test/luxc/parser.lux
+++ b/new-luxc/test/test/luxc/parser.lux
@@ -71,11 +71,11 @@
 (test: "Lux code parser."
   [sample ast^]
   (assert "Can parse Lux code."
-          (|> &;ast^
+          (|> (&;ast^ default-cursor)
               (l;run (ast;to-text sample))
               (case> (#;Left error)
                      false
 
-                     (#;Right parsed)
+                     (#;Right [parsed _])
                      (:: ast;Eq<AST> = parsed sample))
               )))