aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure.lux2
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux75
-rw-r--r--new-luxc/source/luxc/lang/syntax.lux66
-rw-r--r--new-luxc/source/luxc/lang/translation.lux8
-rw-r--r--new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux15
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))
))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 12:34:28 +0000