From 686a46f569b818681583e6ce75b37b25642b375b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 14 Nov 2017 14:59:45 -0400 Subject: - Removed "lux text last-index" procedure. - Removed "lux text trim" procedure. - Modified "lux text clip" procedure. - Some bug fixes. --- new-luxc/source/luxc/lang/analysis/procedure.lux | 2 +- new-luxc/source/luxc/lang/analysis/structure.lux | 75 +++++++++++++++------- new-luxc/source/luxc/lang/syntax.lux | 66 ++++++++++--------- new-luxc/source/luxc/lang/translation.lux | 8 +-- .../luxc/lang/translation/procedure/common.jvm.lux | 15 ++++- 5 files changed, 104 insertions(+), 62 deletions(-) (limited to 'new-luxc/source') 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 [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 [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 - [#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 [ ] - [(def: #export ( where) - (-> Cursor (l;Lexer [Cursor Code])) + [(def: #export ( current-module where) + (-> Text Cursor (l;Lexer [Cursor Code])) (do p;Monad [[value length] ] (wrap [(update@ #;column (|>. ($_ n.+ length)) where) [where ( 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 - [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 + [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)) )) -- cgit v1.2.3