- Removed "lux text last-index" procedure.

- Removed "lux text trim" procedure.
- Modified "lux text clip" procedure.
- Some bug fixes.

5 files changed, 104 insertions, 62 deletions

diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux
index 9f5f61d59..8ab868036 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure.lux
@@ -20,7 +20,7 @@
 
 (def: #export (analyse-procedure analyse eval proc-name proc-args)
   (-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis))
-  (<| (maybe;default (&;throw Unknown-Procedure proc-name))
+  (<| (maybe;default (&;throw Unknown-Procedure (%t proc-name)))
       (do maybe;Monad<Maybe>
         [proc (dict;get proc-name procedures)]
         (wrap ((proc proc-name) analyse eval proc-args)))))
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index 1f1ef15d7..d2107c640 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -85,26 +85,47 @@
          [#;ExQ tc;var])
 
         (#;Apply inputT funT)
-        (case (type;apply (list inputT) funT)
-          #;None
-          (&;throw Not-Quantified-Type (%type funT))
-          
-          (#;Some outputT)
-          (&;with-expected-type outputT
-            (analyse-sum analyse tag valueC)))
+        (case funT
+          (#;Var funT-id)
+          (do @
+            [?funT' (&;with-type-env (tc;read funT-id))]
+            (case ?funT'
+              (#;Some funT')
+              (&;with-expected-type (#;Apply inputT funT')
+                (analyse-sum analyse tag valueC))
+
+              _
+              (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n"
+                                                "  Tag: " (%n tag) "\n"
+                                                "Value: " (%code  valueC)))))
+
+          _
+          (case (type;apply (list inputT) funT)
+            #;None
+            (&;throw Not-Quantified-Type (%type funT))
+            
+            (#;Some outputT)
+            (&;with-expected-type outputT
+              (analyse-sum analyse tag valueC))))
         
         _
         (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n"
                                           "  Tag: " (%n tag) "\n"
                                           "Value: " (%code  valueC)))))))
 
-(def: (analyse-typed-product analyse members)
+(def: (analyse-typed-product analyse membersC+)
   (-> &;Analyser (List Code) (Meta la;Analysis))
   (do meta;Monad<Meta>
     [expectedT meta;expected-type]
     (loop [expectedT expectedT
-           members members]
-      (case [expectedT members]
+           membersC+ membersC+]
+      (case [expectedT membersC+]
+        ## If the tuple runs out, whatever expression is the last gets
+        ## matched to the remaining type.
+        [tailT (#;Cons tailC #;Nil)]
+        (&;with-expected-type tailT
+          (analyse tailC))
+
         ## If the type and the code are still ongoing, match each
         ## sub-expression to its corresponding type.
         [(#;Product leftT rightT) (#;Cons leftC rightC)]
@@ -114,12 +135,6 @@
            rightA (recur rightT rightC)]
           (wrap (` [(~ leftA) (~ rightA)])))
 
-        ## If the tuple runs out, whatever expression is the last gets
-        ## matched to the remaining type.
-        [tailT (#;Cons tailC #;Nil)]
-        (&;with-expected-type tailT
-          (analyse tailC))
-
         ## If, however, the type runs out but there is still enough
         ## tail, the remaining elements get packaged into another
         ## tuple, and analysed through the intermediation of a
@@ -190,13 +205,27 @@
          [#;ExQ tc;var])
 
         (#;Apply inputT funT)
-        (case (type;apply (list inputT) funT)
-          #;None
-          (&;throw Not-Quantified-Type (%type funT))
-          
-          (#;Some outputT)
-          (&;with-expected-type outputT
-            (analyse-product analyse membersC)))
+        (case funT
+          (#;Var funT-id)
+          (do @
+            [?funT' (&;with-type-env (tc;read funT-id))]
+            (case ?funT'
+              (#;Some funT')
+              (&;with-expected-type (#;Apply inputT funT')
+                (analyse-product analyse membersC))
+
+              _
+              (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
+                                              "Value: " (%code (` [(~@ membersC)]))))))
+
+          _
+          (case (type;apply (list inputT) funT)
+            #;None
+            (&;throw Not-Quantified-Type (%type funT))
+            
+            (#;Some outputT)
+            (&;with-expected-type outputT
+              (analyse-product analyse membersC))))
         
         _
         (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
diff --git a/new-luxc/source/luxc/lang/syntax.lux b/new-luxc/source/luxc/lang/syntax.lux
index 93800c1b7..2d8cb364a 100644
--- a/new-luxc/source/luxc/lang/syntax.lux
+++ b/new-luxc/source/luxc/lang/syntax.lux
@@ -518,18 +518,20 @@
      tail tail-lexer]
     (wrap (format head tail))))
 
-(def: ident^
-  (l;Lexer [Ident Nat])
+(def: current-module-mark Text (format identifier-separator identifier-separator))
+
+(def: (ident^ current-module)
+  (-> Text (l;Lexer [Ident Nat]))
   ($_ p;either
-      ## When an identifier starts with 2 marks, it's module is
+      ## When an identifier starts with 2 marks, its module is
       ## taken to be the current-module being compiled at the moment.
       ## This can be useful when mentioning identifiers and tags
       ## inside quoted/templated code in macros.
       (do p;Monad<Parser>
-        [#let [current-module-mark (format identifier-separator identifier-separator)]
-         _ (l;this current-module-mark)
+        [_ (l;this current-module-mark)
          def-name ident-part^]
-        (p;fail (format "Cannot handle " current-module-mark " syntax for identifiers.")))
+        (wrap [[current-module def-name]
+               (n.+ +2 (text;size def-name))]))
       ## If the identifier is prefixed by the mark, but no module
       ## part, the module is assumed to be "lux" (otherwise known as
       ## the 'prelude').
@@ -571,38 +573,40 @@
 ## provide the compiler with information related to data-structure
 ## construction and de-structuring (during pattern-matching).
 (do-template [<name> <tag> <lexer> <extra>]
-  [(def: #export (<name> where)
-     (-> Cursor (l;Lexer [Cursor Code]))
+  [(def: #export (<name> current-module where)
+     (-> Text Cursor (l;Lexer [Cursor Code]))
      (do p;Monad<Parser>
        [[value length] <lexer>]
        (wrap [(update@ #;column (|>. ($_ n.+ <extra> length)) where)
               [where (<tag> value)]])))]
 
-  [symbol #;Symbol ident^                        +0]
-  [tag    #;Tag    (p;after (l;this "#") ident^) +1]
+  [symbol #;Symbol (ident^ current-module)                        +0]
+  [tag    #;Tag    (p;after (l;this "#") (ident^ current-module)) +1]
   )
 
-(def: (ast where)
-  (-> Cursor (l;Lexer [Cursor Code]))
-  (do p;Monad<Parser>
-    [where (left-padding^ where)]
-    ($_ p;either
-        (form where ast)
-        (tuple where ast)
-        (record where ast)
-        (bool where)
-        (nat where)
-        (frac where)
-        (int where)
-        (deg where)
-        (symbol where)
-        (tag where)
-        (text where)
-        )))
-
-(def: #export (parse [where offset source])
-  (-> Source (e;Error [Source Code]))
-  (case (p;run [offset source] (ast where))
+(def: (ast current-module)
+  (-> Text Cursor (l;Lexer [Cursor Code]))
+  (: (-> Cursor (l;Lexer [Cursor Code]))
+     (function ast' [where]
+       (do p;Monad<Parser>
+         [where (left-padding^ where)]
+         ($_ p;either
+             (form where ast')
+             (tuple where ast')
+             (record where ast')
+             (bool where)
+             (nat where)
+             (frac where)
+             (int where)
+             (deg where)
+             (symbol current-module where)
+             (tag current-module where)
+             (text where)
+             )))))
+
+(def: #export (parse current-module [where offset source])
+  (-> Text Source (e;Error [Source Code]))
+  (case (p;run [offset source] (ast current-module where))
     (#e;Error error)
     (#e;Error error)
 
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index 6726470cc..62b56783c 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -145,10 +145,10 @@
      _ (&module;flag-compiled! module-name)]
     (wrap output)))
 
-(def: parse
-  (Meta Code)
+(def: (parse current-module)
+  (-> Text (Meta Code))
   (function [compiler]
-    (case (&syntax;parse (get@ #;source compiler))
+    (case (&syntax;parse current-module (get@ #;source compiler))
       (#e;Error error)
       (#e;Error error)
 
@@ -171,7 +171,7 @@
                                                                       file-content]
                                               (exhaust
                                                (do @
-                                                 [code parse
+                                                 [code (parse module-name)
                                                   #let [[cursor _] code]]
                                                  (&;with-cursor cursor
                                                    (translate code)))))))]
diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
index 2cdf65e32..e680c46e8 100644
--- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
@@ -423,8 +423,16 @@
   [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI
    ($i;INVOKESTATIC hostL;runtime-class "text_clip"
                     ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)]
-  [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
-   ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)]
+  [text//replace-once ($i;CHECKCAST "java.lang.String")
+   (<| ($i;INVOKESTATIC "java.util.regex.Pattern" "quote" ($t;method (list $String) (#;Some $String) (list)) false)
+       ($i;CHECKCAST "java.lang.String"))
+   ($i;CHECKCAST "java.lang.String")
+   ($i;INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t;method (list $String $String) (#;Some $String) (list)) false)]
+  [text//replace-all ($i;CHECKCAST "java.lang.String")
+   (<| ($i;INVOKESTATIC "java.util.regex.Pattern" "quote" ($t;method (list $String) (#;Some $String) (list)) false)
+       ($i;CHECKCAST "java.lang.String"))
+   ($i;CHECKCAST "java.lang.String")
+   ($i;INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t;method (list $String $String) (#;Some $String) (list)) false)]
   )
 
 (def: index-method $;Method ($t;method (list $String $t;int) (#;Some $t;int) (list)))
@@ -674,7 +682,8 @@
       (install "text index" (trinary text//index))
       (install "text size" (unary text//size))
       (install "text hash" (unary text//hash))
-      (install "text replace" (trinary text//replace))
+      (install "text replace-once" (trinary text//replace-once))
+      (install "text replace-all" (trinary text//replace-all))
       (install "text char" (binary text//char))
       (install "text clip" (trinary text//clip))
       ))