diff options
| author | Eduardo Julian | 2017-11-21 16:09:07 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2017-11-21 16:09:07 -0400 |
| commit | e37e3713e080606930a5f8442f03dabc4c26a7f9 (patch) | |
| tree | ad772c1801af0d01dc105bccf85703f13b127e50 | |
| parent | 3eabc421e559e7e2f903e06eb6b47a2ee0cd25b9 (diff) | |
- Fixed some bugs.
- Some small refactoring.
Diffstat (limited to '')
29 files changed, 781 insertions, 737 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 0c38132a4..1dce02b2c 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -121,8 +121,8 @@ (&/|list =text) (&/|list))))))) - ^:private analyse-text-upper-case "upper-case" - ^:private analyse-text-lower-case "lower-case" + ^:private analyse-text-upper "upper" + ^:private analyse-text-lower "lower" ) (defn ^:private analyse-text-char [analyse exo-type ?values] @@ -260,18 +260,18 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T <op>) (&/|list) (&/|list))))))) - ^:private analyse-nat-min-value &type/Nat ["nat" "min-value"] - ^:private analyse-nat-max-value &type/Nat ["nat" "max-value"] + ^:private analyse-nat-min &type/Nat ["nat" "min"] + ^:private analyse-nat-max &type/Nat ["nat" "max"] - ^:private analyse-int-min-value &type/Int ["int" "min-value"] - ^:private analyse-int-max-value &type/Int ["int" "max-value"] + ^:private analyse-int-min &type/Int ["int" "min"] + ^:private analyse-int-max &type/Int ["int" "max"] - ^:private analyse-deg-min-value &type/Deg ["deg" "min-value"] - ^:private analyse-deg-max-value &type/Deg ["deg" "max-value"] + ^:private analyse-deg-min &type/Deg ["deg" "min"] + ^:private analyse-deg-max &type/Deg ["deg" "max"] - ^:private analyse-frac-smallest-value &type/Frac ["frac" "smallest-value"] - ^:private analyse-frac-min-value &type/Frac ["frac" "min-value"] - ^:private analyse-frac-max-value &type/Frac ["frac" "max-value"] + ^:private analyse-frac-smallest &type/Frac ["frac" "smallest"] + ^:private analyse-frac-min &type/Frac ["frac" "min"] + ^:private analyse-frac-max &type/Frac ["frac" "max"] ^:private analyse-frac-not-a-number &type/Frac ["frac" "not-a-number"] ^:private analyse-frac-positive-infinity &type/Frac ["frac" "positive-infinity"] ^:private analyse-frac-negative-infinity &type/Frac ["frac" "negative-infinity"] @@ -491,8 +491,8 @@ "lux text hash" (analyse-text-hash analyse exo-type ?values) "lux text replace-all" (analyse-text-replace-all analyse exo-type ?values) "lux text char" (analyse-text-char analyse exo-type ?values) - "lux text upper-case" (analyse-text-upper-case analyse exo-type ?values) - "lux text lower-case" (analyse-text-lower-case analyse exo-type ?values) + "lux text upper" (analyse-text-upper analyse exo-type ?values) + "lux text lower" (analyse-text-lower analyse exo-type ?values) "lux text contains?" (analyse-text-contains? analyse exo-type ?values) "lux bit count" (analyse-bit-count analyse exo-type ?values) @@ -516,8 +516,8 @@ "lux nat %" (analyse-nat-rem analyse exo-type ?values) "lux nat =" (analyse-nat-eq analyse exo-type ?values) "lux nat <" (analyse-nat-lt analyse exo-type ?values) - "lux nat min-value" (analyse-nat-min-value analyse exo-type ?values) - "lux nat max-value" (analyse-nat-max-value analyse exo-type ?values) + "lux nat min" (analyse-nat-min analyse exo-type ?values) + "lux nat max" (analyse-nat-max analyse exo-type ?values) "lux nat to-int" (analyse-nat-to-int analyse exo-type ?values) "lux nat to-char" (analyse-nat-to-char analyse exo-type ?values) @@ -528,8 +528,8 @@ "lux int %" (analyse-int-rem analyse exo-type ?values) "lux int =" (analyse-int-eq analyse exo-type ?values) "lux int <" (analyse-int-lt analyse exo-type ?values) - "lux int min-value" (analyse-int-min-value analyse exo-type ?values) - "lux int max-value" (analyse-int-max-value analyse exo-type ?values) + "lux int min" (analyse-int-min analyse exo-type ?values) + "lux int max" (analyse-int-max analyse exo-type ?values) "lux int to-nat" (analyse-int-to-nat analyse exo-type ?values) "lux int to-frac" (analyse-int-to-frac analyse exo-type ?values) @@ -540,8 +540,8 @@ "lux deg %" (analyse-deg-rem analyse exo-type ?values) "lux deg =" (analyse-deg-eq analyse exo-type ?values) "lux deg <" (analyse-deg-lt analyse exo-type ?values) - "lux deg min-value" (analyse-deg-min-value analyse exo-type ?values) - "lux deg max-value" (analyse-deg-max-value analyse exo-type ?values) + "lux deg min" (analyse-deg-min analyse exo-type ?values) + "lux deg max" (analyse-deg-max analyse exo-type ?values) "lux deg to-frac" (analyse-deg-to-frac analyse exo-type ?values) "lux deg scale" (analyse-deg-scale analyse exo-type ?values) "lux deg reciprocal" (analyse-deg-reciprocal analyse exo-type ?values) @@ -555,9 +555,9 @@ "lux frac <" (analyse-frac-lt analyse exo-type ?values) "lux frac encode" (analyse-frac-encode analyse exo-type ?values) "lux frac decode" (analyse-frac-decode analyse exo-type ?values) - "lux frac smallest-value" (analyse-frac-smallest-value analyse exo-type ?values) - "lux frac min-value" (analyse-frac-min-value analyse exo-type ?values) - "lux frac max-value" (analyse-frac-max-value analyse exo-type ?values) + "lux frac smallest" (analyse-frac-smallest analyse exo-type ?values) + "lux frac min" (analyse-frac-min analyse exo-type ?values) + "lux frac max" (analyse-frac-max analyse exo-type ?values) "lux frac not-a-number" (analyse-frac-not-a-number analyse exo-type ?values) "lux frac positive-infinity" (analyse-frac-positive-infinity analyse exo-type ?values) "lux frac negative-infinity" (analyse-frac-negative-infinity analyse exo-type ?values) diff --git a/luxc/src/lux/compiler/js/proc/common.clj b/luxc/src/lux/compiler/js/proc/common.clj index af4ff99e9..1fe6f2e5e 100644 --- a/luxc/src/lux/compiler/js/proc/common.clj +++ b/luxc/src/lux/compiler/js/proc/common.clj @@ -156,18 +156,18 @@ (|do [:let [(&/$Nil) ?values]] (<compiler> <value>))) - ^:private compile-nat-min-value &&lux/compile-nat 0 - ^:private compile-nat-max-value &&lux/compile-nat -1 + ^:private compile-nat-min &&lux/compile-nat 0 + ^:private compile-nat-max &&lux/compile-nat -1 - ^:private compile-int-min-value &&lux/compile-int Long/MIN_VALUE - ^:private compile-int-max-value &&lux/compile-int Long/MAX_VALUE + ^:private compile-int-min &&lux/compile-int Long/MIN_VALUE + ^:private compile-int-max &&lux/compile-int Long/MAX_VALUE - ^:private compile-deg-min-value &&lux/compile-deg 0 - ^:private compile-deg-max-value &&lux/compile-deg -1 + ^:private compile-deg-min &&lux/compile-deg 0 + ^:private compile-deg-max &&lux/compile-deg -1 - ^:private compile-frac-smallest-value &&lux/compile-frac Double/MIN_VALUE - ^:private compile-frac-min-value &&lux/compile-frac (* -1.0 Double/MAX_VALUE) - ^:private compile-frac-max-value &&lux/compile-frac Double/MAX_VALUE + ^:private compile-frac-smallest &&lux/compile-frac Double/MIN_VALUE + ^:private compile-frac-min &&lux/compile-frac (* -1.0 Double/MAX_VALUE) + ^:private compile-frac-max &&lux/compile-frac Double/MAX_VALUE ^:private compile-frac-not-a-number &&lux/compile-frac "NaN" ^:private compile-frac-positive-infinity &&lux/compile-frac "Infinity" @@ -295,8 +295,8 @@ (return (str "(" =text ")." <method> "()")))) ^:private compile-text-trim "trim" - ^:private compile-text-upper-case "toUpperCase" - ^:private compile-text-lower-case "toLowerCase" + ^:private compile-text-upper "toUpperCase" + ^:private compile-text-lower "toLowerCase" ) (defn ^:private compile-char-to-text [compile ?values special-args] @@ -455,8 +455,8 @@ "replace-all" (compile-text-replace-all compile ?values special-args) "trim" (compile-text-trim compile ?values special-args) "char" (compile-text-char compile ?values special-args) - "upper-case" (compile-text-upper-case compile ?values special-args) - "lower-case" (compile-text-lower-case compile ?values special-args) + "upper" (compile-text-upper compile ?values special-args) + "lower" (compile-text-lower compile ?values special-args) "contains?" (compile-text-contains? compile ?values special-args) ) @@ -487,8 +487,8 @@ "%" (compile-nat-rem compile ?values special-args) "=" (compile-nat-eq compile ?values special-args) "<" (compile-nat-lt compile ?values special-args) - "max-value" (compile-nat-max-value compile ?values special-args) - "min-value" (compile-nat-min-value compile ?values special-args) + "max" (compile-nat-max compile ?values special-args) + "min" (compile-nat-min compile ?values special-args) "to-int" (compile-nat-to-int compile ?values special-args) "to-char" (compile-nat-to-char compile ?values special-args) ) @@ -502,8 +502,8 @@ "%" (compile-int-rem compile ?values special-args) "=" (compile-int-eq compile ?values special-args) "<" (compile-int-lt compile ?values special-args) - "max-value" (compile-int-max-value compile ?values special-args) - "min-value" (compile-int-min-value compile ?values special-args) + "max" (compile-int-max compile ?values special-args) + "min" (compile-int-min compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) "to-frac" (compile-int-to-frac compile ?values special-args) ) @@ -517,8 +517,8 @@ "%" (compile-deg-rem compile ?values special-args) "=" (compile-deg-eq compile ?values special-args) "<" (compile-deg-lt compile ?values special-args) - "max-value" (compile-deg-max-value compile ?values special-args) - "min-value" (compile-deg-min-value compile ?values special-args) + "max" (compile-deg-max compile ?values special-args) + "min" (compile-deg-min compile ?values special-args) "to-frac" (compile-deg-to-frac compile ?values special-args) "scale" (compile-deg-scale compile ?values special-args) "reciprocal" (compile-deg-reciprocal compile ?values special-args) @@ -535,9 +535,9 @@ "<" (compile-frac-lt compile ?values special-args) "encode" (compile-frac-encode compile ?values special-args) "decode" (compile-frac-decode compile ?values special-args) - "smallest-value" (compile-frac-smallest-value compile ?values special-args) - "max-value" (compile-frac-max-value compile ?values special-args) - "min-value" (compile-frac-min-value compile ?values special-args) + "smallest" (compile-frac-smallest compile ?values special-args) + "max" (compile-frac-max compile ?values special-args) + "min" (compile-frac-min compile ?values special-args) "not-a-number" (compile-frac-not-a-number compile ?values special-args) "positive-infinity" (compile-frac-positive-infinity compile ?values special-args) "negative-infinity" (compile-frac-negative-infinity compile ?values special-args) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 16774a479..3c948e8bc 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -334,18 +334,18 @@ <wrapper>)]] (return nil))) - ^:private compile-nat-min-value (.visitLdcInsn 0) &&/wrap-long - ^:private compile-nat-max-value (.visitLdcInsn -1) &&/wrap-long + ^:private compile-nat-min (.visitLdcInsn 0) &&/wrap-long + ^:private compile-nat-max (.visitLdcInsn -1) &&/wrap-long - ^:private compile-int-min-value (.visitLdcInsn Long/MIN_VALUE) &&/wrap-long - ^:private compile-int-max-value (.visitLdcInsn Long/MAX_VALUE) &&/wrap-long + ^:private compile-int-min (.visitLdcInsn Long/MIN_VALUE) &&/wrap-long + ^:private compile-int-max (.visitLdcInsn Long/MAX_VALUE) &&/wrap-long - ^:private compile-deg-min-value (.visitLdcInsn 0) &&/wrap-long - ^:private compile-deg-max-value (.visitLdcInsn -1) &&/wrap-long + ^:private compile-deg-min (.visitLdcInsn 0) &&/wrap-long + ^:private compile-deg-max (.visitLdcInsn -1) &&/wrap-long - ^:private compile-frac-smallest-value (.visitLdcInsn Double/MIN_VALUE) &&/wrap-double - ^:private compile-frac-min-value (.visitLdcInsn (* -1.0 Double/MAX_VALUE)) &&/wrap-double - ^:private compile-frac-max-value (.visitLdcInsn Double/MAX_VALUE) &&/wrap-double + ^:private compile-frac-smallest (.visitLdcInsn Double/MIN_VALUE) &&/wrap-double + ^:private compile-frac-min (.visitLdcInsn (* -1.0 Double/MAX_VALUE)) &&/wrap-double + ^:private compile-frac-max (.visitLdcInsn Double/MAX_VALUE) &&/wrap-double ^:private compile-frac-not-a-number (.visitLdcInsn Double/NaN) &&/wrap-double ^:private compile-frac-positive-infinity (.visitLdcInsn Double/POSITIVE_INFINITY) &&/wrap-double @@ -606,8 +606,8 @@ (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" <method> "()Ljava/lang/String;"))]] (return nil))) - ^:private compile-text-upper-case "toUpperCase" - ^:private compile-text-lower-case "toLowerCase" + ^:private compile-text-upper "toUpperCase" + ^:private compile-text-lower "toLowerCase" ) (defn ^:private compile-text-char [compile ?values special-args] @@ -830,8 +830,8 @@ "hash" (compile-text-hash compile ?values special-args) "replace-all" (compile-text-replace-all compile ?values special-args) "char" (compile-text-char compile ?values special-args) - "upper-case" (compile-text-upper-case compile ?values special-args) - "lower-case" (compile-text-lower-case compile ?values special-args) + "upper" (compile-text-upper compile ?values special-args) + "lower" (compile-text-lower compile ?values special-args) "contains?" (compile-text-contains? compile ?values special-args) ) @@ -862,8 +862,8 @@ "%" (compile-nat-rem compile ?values special-args) "=" (compile-nat-eq compile ?values special-args) "<" (compile-nat-lt compile ?values special-args) - "max-value" (compile-nat-max-value compile ?values special-args) - "min-value" (compile-nat-min-value compile ?values special-args) + "max" (compile-nat-max compile ?values special-args) + "min" (compile-nat-min compile ?values special-args) "to-int" (compile-nat-to-int compile ?values special-args) "to-char" (compile-nat-to-char compile ?values special-args) ) @@ -877,8 +877,8 @@ "%" (compile-deg-rem compile ?values special-args) "=" (compile-deg-eq compile ?values special-args) "<" (compile-deg-lt compile ?values special-args) - "max-value" (compile-deg-max-value compile ?values special-args) - "min-value" (compile-deg-min-value compile ?values special-args) + "max" (compile-deg-max compile ?values special-args) + "min" (compile-deg-min compile ?values special-args) "to-frac" (compile-deg-to-frac compile ?values special-args) "scale" (compile-deg-scale compile ?values special-args) "reciprocal" (compile-deg-reciprocal compile ?values special-args) @@ -893,8 +893,8 @@ "%" (compile-int-rem compile ?values special-args) "=" (compile-int-eq compile ?values special-args) "<" (compile-int-lt compile ?values special-args) - "max-value" (compile-int-max-value compile ?values special-args) - "min-value" (compile-int-min-value compile ?values special-args) + "max" (compile-int-max compile ?values special-args) + "min" (compile-int-min compile ?values special-args) "to-nat" (compile-int-to-nat compile ?values special-args) "to-frac" (compile-int-to-frac compile ?values special-args) ) @@ -908,9 +908,9 @@ "%" (compile-frac-rem compile ?values special-args) "=" (compile-frac-eq compile ?values special-args) "<" (compile-frac-lt compile ?values special-args) - "smallest-value" (compile-frac-smallest-value compile ?values special-args) - "max-value" (compile-frac-max-value compile ?values special-args) - "min-value" (compile-frac-min-value compile ?values special-args) + "smallest" (compile-frac-smallest compile ?values special-args) + "max" (compile-frac-max compile ?values special-args) + "min" (compile-frac-min compile ?values special-args) "not-a-number" (compile-frac-not-a-number compile ?values special-args) "positive-infinity" (compile-frac-positive-infinity compile ?values special-args) "negative-infinity" (compile-frac-negative-infinity compile ?values special-args) diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux index 4a28ce436..5d4c592aa 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -239,7 +239,7 @@ (^ [cursor (#;Form (list& [_ (#;Tag tag)] values))]) (&;with-cursor cursor (do macro;Monad<Meta> - [tag (macro;canonical tag) + [tag (macro;normalize tag) [idx group variantT] (macro;resolve-tag tag) _ (&;with-type-env (tc;check inputT variantT))] diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index 89fb3b93e..6abe8e62b 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -93,13 +93,14 @@ (case ?macro (#;Some macro) (do @ - [expansion (function [compiler] - (case (macroL;expand macro args compiler) - (#e;Success [compiler' output]) - (#e;Success [compiler' output]) - - (#e;Error error) - ((&;throw Macro-Expansion-Failed error) compiler)))] + [expansion (: (Meta (List Code)) + (function [compiler] + (case (macroL;expand macro args compiler) + (#e;Error error) + ((&;throw Macro-Expansion-Failed error) compiler) + + output + output)))] (case expansion (^ (list single)) (analyse single) diff --git a/new-luxc/source/luxc/lang/analysis/function.lux b/new-luxc/source/luxc/lang/analysis/function.lux index a2aa95c08..b4aa31c90 100644 --- a/new-luxc/source/luxc/lang/analysis/function.lux +++ b/new-luxc/source/luxc/lang/analysis/function.lux @@ -17,6 +17,7 @@ ["&;" inference]) [";L" variable #+ Variable]))) +(exception: #export Cannot-Analyse-Function) (exception: #export Invalid-Function-Type) (exception: #export Cannot-Apply-Function) @@ -27,7 +28,10 @@ [functionT macro;expected-type] (loop [expectedT functionT] (&;with-stacked-errors - (function [_] (Invalid-Function-Type (%type expectedT))) + (function [_] (Cannot-Analyse-Function (format " Type: " (%type expectedT) "\n" + "Function: " func-name "\n" + "Argument: " arg-name "\n" + " Body: " (%code body)))) (case expectedT (#;Named name unnamedT) (recur unnamedT) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux index 747e9f61d..489414c2a 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux @@ -273,6 +273,8 @@ (install "replace-all" (trinary Text Text Text Text)) (install "char" (binary Text Nat (type (Maybe Nat)))) (install "clip" (trinary Text Nat Nat (type (Maybe Text)))) + (install "upper" (unary Text Text)) + (install "lower" (unary Text Text)) ))) (def: (array-get proc) diff --git a/new-luxc/source/luxc/lang/analysis/reference.lux b/new-luxc/source/luxc/lang/analysis/reference.lux index 7475f269f..c660408de 100644 --- a/new-luxc/source/luxc/lang/analysis/reference.lux +++ b/new-luxc/source/luxc/lang/analysis/reference.lux @@ -21,7 +21,8 @@ _ (do @ - [_ (&;infer actualT)] + [_ (&;infer actualT) + def-name (macro;normalize def-name)] (wrap (code;symbol def-name)))))) (def: (analyse-variable var-name) diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index 19eebbc46..e6cd2dbad 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -20,10 +20,13 @@ (analysis ["&;" common] ["&;" inference])))) -(exception: #export Not-Variant-Type) -(exception: #export Not-Tuple-Type) +(exception: #export Invalid-Variant-Type) +(exception: #export Invalid-Tuple-Type) (exception: #export Not-Quantified-Type) +(exception: #export Cannot-Analyse-Variant) +(exception: #export Cannot-Analyse-Tuple) + (exception: #export Cannot-Infer-Numeric-Tag) (exception: #export Record-Keys-Must-Be-Tags) (exception: #export Cannot-Repeat-Tag) @@ -35,9 +38,9 @@ (do macro;Monad<Meta> [expectedT macro;expected-type] (&;with-stacked-errors - (function [_] (Not-Variant-Type (format " Type: " (%type expectedT) "\n" - "Value: " (%code valueC) "\n" - " Tag: " (%n tag)))) + (function [_] (Cannot-Analyse-Variant (format " Type: " (%type expectedT) "\n" + " Tag: " (%n tag) "\n" + "Expression: " (%code valueC)))) (case expectedT (#;Sum _) (let [flat (type;flatten-variant expectedT) @@ -70,9 +73,9 @@ ## Cannot do inference when the tag is numeric. ## This is because there is no way of knowing how many ## cases the inferred sum type would have. - (&;throw Cannot-Infer-Numeric-Tag (format " Tag: " (%n tag) "\n" - "Value: " (%code valueC) "\n" - " Type: " (%type expectedT))) + (&;throw Cannot-Infer-Numeric-Tag (format " Type: " (%type expectedT) "\n" + " Tag: " (%n tag) "\n" + "Expression: " (%code valueC))) )) (^template [<tag> <instancer>] @@ -95,9 +98,9 @@ (analyse-sum analyse tag valueC)) _ - (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n" - " Tag: " (%n tag) "\n" - "Value: " (%code valueC))))) + (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" + " Tag: " (%n tag) "\n" + "Expression: " (%code valueC))))) _ (case (type;apply (list inputT) funT) @@ -109,9 +112,9 @@ (analyse-sum analyse tag valueC)))) _ - (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n" - " Tag: " (%n tag) "\n" - "Value: " (%code valueC))))))) + (&;throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n" + " Tag: " (%n tag) "\n" + "Expression: " (%code valueC))))))) (def: (analyse-typed-product analyse membersC+) (-> &;Analyser (List Code) (Meta la;Analysis)) @@ -166,8 +169,8 @@ (do macro;Monad<Meta> [expectedT macro;expected-type] (&;with-stacked-errors - (function [_] (Not-Tuple-Type (format " Type: " (%type expectedT) "\n" - "Value: " (%code (` [(~@ membersC)]))))) + (function [_] (Cannot-Analyse-Tuple (format " Type: " (%type expectedT) "\n" + "Expression: " (%code (` [(~@ membersC)]))))) (case expectedT (#;Product _) (analyse-typed-product analyse membersC) @@ -215,8 +218,8 @@ (analyse-product analyse membersC)) _ - (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n" - "Value: " (%code (` [(~@ membersC)])))))) + (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Expression: " (%code (` [(~@ membersC)])))))) _ (case (type;apply (list inputT) funT) @@ -228,14 +231,14 @@ (analyse-product analyse membersC)))) _ - (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n" - "Value: " (%code (` [(~@ membersC)])))) + (&;throw Invalid-Tuple-Type (format " Type: " (%type expectedT) "\n" + "Expression: " (%code (` [(~@ membersC)])))) )))) (def: #export (analyse-tagged-sum analyse tag valueC) (-> &;Analyser Ident Code (Meta la;Analysis)) (do macro;Monad<Meta> - [tag (macro;canonical tag) + [tag (macro;normalize tag) [idx group variantT] (macro;resolve-tag tag) expectedT macro;expected-type] (case expectedT @@ -261,7 +264,7 @@ (case key [_ (#;Tag key)] (do macro;Monad<Meta> - [key (macro;canonical key)] + [key (macro;normalize key)] (wrap [key val])) _ @@ -281,22 +284,26 @@ (#;Cons [head-k head-v] _) (do macro;Monad<Meta> - [head-k (macro;canonical head-k) + [head-k (macro;normalize head-k) [_ tag-set recordT] (macro;resolve-tag head-k) #let [size-record (list;size record) size-ts (list;size tag-set)] _ (if (n.= size-ts size-record) (wrap []) (&;throw Record-Size-Mismatch - (format "Expected: " (|> size-ts nat-to-int %i) "\n" - " Actual: " (|> size-record nat-to-int %i) "\n" - " Type: " (%type recordT)))) + (format " Expected: " (|> size-ts nat-to-int %i) "\n" + " Actual: " (|> size-record nat-to-int %i) "\n" + " Type: " (%type recordT) "\n" + "Expression: " (%code (|> record + (list/map (function [[keyI valueC]] + [(code;tag keyI) valueC])) + code;record))))) #let [tuple-range (list;n.range +0 (n.dec size-ts)) tag->idx (dict;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] idx->val (monad;fold @ (function [[key val] idx->val] (do @ - [key (macro;canonical key)] + [key (macro;normalize key)] (case (dict;get key tag->idx) #;None (&;throw Tag-Does-Not-Belong-To-Record diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux index dfe05e1bf..c35483dd8 100644 --- a/new-luxc/source/luxc/lang/synthesis/case.lux +++ b/new-luxc/source/luxc/lang/synthesis/case.lux @@ -13,45 +13,52 @@ (def: popPS ls;Path (' ("lux case pop"))) -(def: (path' outer-arity pattern) - (-> ls;Arity la;Pattern (List ls;Path)) +(def: (path' arity num-locals pattern) + (-> ls;Arity Nat la;Pattern [Nat (List ls;Path)]) (case pattern (^code ("lux case tuple" [(~@ membersP)])) (case membersP #;Nil - (list popPS) + [num-locals + (list popPS)] (#;Cons singletonP #;Nil) - (path' outer-arity singletonP) + (path' arity num-locals singletonP) (#;Cons _) (let [last-idx (n.dec (list;size membersP)) - [_ tuple-path] (list/fold (function [current-pattern [current-idx next]] - [(n.dec current-idx) - (|> (list (if (n.= last-idx current-idx) - (` ("lux case tuple right" (~ (code;nat current-idx)))) - (` ("lux case tuple left" (~ (code;nat current-idx)))))) - (list/compose (path' outer-arity current-pattern)) - (list/compose next))]) - [last-idx (list popPS)] - (list;reverse membersP))] - tuple-path)) + [_ output] (list/fold (: (-> la;Pattern [Nat [Nat (List ls;Path)]] [Nat [Nat (List ls;Path)]]) + (function [current-pattern [current-idx num-locals' next]] + (let [[num-locals'' current-path] (path' arity num-locals' current-pattern)] + [(n.dec current-idx) + num-locals'' + (|> (list (if (n.= last-idx current-idx) + (` ("lux case tuple right" (~ (code;nat current-idx)))) + (` ("lux case tuple left" (~ (code;nat current-idx)))))) + (list/compose current-path) + (list/compose next))]))) + [last-idx num-locals (list popPS)] + (list;reverse membersP))] + output)) (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) - (|> (list (if (n.= (n.dec num-tags) tag) - (` ("lux case variant right" (~ (code;nat tag)))) - (` ("lux case variant left" (~ (code;nat tag)))))) - (list/compose (path' outer-arity memberP)) - (list& popPS)) + (let [[num-locals' member-path] (path' arity num-locals memberP)] + [num-locals' (|> (list (if (n.= (n.dec num-tags) tag) + (` ("lux case variant right" (~ (code;nat tag)))) + (` ("lux case variant left" (~ (code;nat tag)))))) + (list/compose member-path) + (list& popPS))]) (^code ("lux case bind" (~ [_ (#;Nat register)]))) - (list popPS - (` ("lux case bind" (~ (code;nat (if (functionS;nested? outer-arity) - (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register) - register)))))) + [(n.inc num-locals) + (list popPS + (` ("lux case bind" (~ (code;nat (if (functionS;nested? arity) + (n.+ (n.dec arity) register) + register))))))] _ - (list popPS pattern))) + [num-locals + (list popPS pattern)])) (def: (clean-unnecessary-pops paths) (-> (List ls;Path) (List ls;Path)) @@ -64,12 +71,14 @@ #;Nil paths)) -(def: #export (path outer-arity pattern body) - (-> ls;Arity la;Pattern ls;Synthesis ls;Path) - (|> (path' outer-arity pattern) clean-unnecessary-pops - (list/fold (function [pre post] - (` ("lux case seq" (~ pre) (~ post)))) - (` ("lux case exec" (~ body)))))) +(def: #export (path arity num-locals synthesize pattern bodyA) + (-> ls;Arity Nat (-> Nat la;Analysis ls;Synthesis) la;Pattern la;Analysis ls;Path) + (let [[num-locals' pieces] (path' arity num-locals pattern)] + (|> pieces + clean-unnecessary-pops + (list/fold (function [pre post] + (` ("lux case seq" (~ pre) (~ post)))) + (` ("lux case exec" (~ (synthesize num-locals' bodyA)))))))) (def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux index b9f5d56cc..aaa2cf2c7 100644 --- a/new-luxc/source/luxc/lang/synthesis/expression.lux +++ b/new-luxc/source/luxc/lang/synthesis/expression.lux @@ -59,33 +59,32 @@ (-> ls;Synthesis (List ls;Synthesis) ls;Synthesis) (` ("lux call" (~ funcS) (~@ argsS)))) -(def: (synthesize-case synthesize outer-arity inputA branchesA) - (-> (-> la;Analysis ls;Synthesis) - ls;Arity la;Analysis (List [la;Pattern la;Analysis]) +(def: (synthesize-case arity num-locals synthesize inputA branchesA) + (-> ls;Arity Nat (-> Nat la;Analysis ls;Synthesis) + la;Analysis (List [la;Pattern la;Analysis]) ls;Synthesis) - (let [inputS (synthesize inputA)] + (let [inputS (synthesize num-locals inputA)] (case (list;reverse branchesA) (^multi (^ (list [(^code ("lux case bind" (~ [_ (#;Nat input-register)]))) (^code ((~ [_ (#;Int var)])))])) (not (variableL;captured? var)) - (n.= input-register (int-to-nat var))) + (n.= input-register (variableL;local-register var))) inputS (^ (list [(^code ("lux case bind" (~ [_ (#;Nat register)]))) bodyA])) - (let$ (if (functionS;nested? outer-arity) - (|> register variableL;local (functionS;adjust-var outer-arity) variableL;local-register) + (let$ (if (functionS;nested? arity) + (n.+ (n.dec arity) register) register) inputS - (synthesize bodyA)) + (synthesize (n.inc num-locals) bodyA)) (^or (^ (list [(^code true) thenA] [(^code false) elseA])) (^ (list [(^code false) elseA] [(^code true) thenA]))) - (if$ inputS (synthesize thenA) (synthesize elseA)) + (if$ inputS (synthesize num-locals thenA) (synthesize num-locals elseA)) (#;Cons [lastP lastA] prevsPA) (let [transform-branch (: (-> la;Pattern la;Analysis ls;Path) - (function [pattern expr] - (caseS;path outer-arity pattern (synthesize expr)))) + (caseS;path arity num-locals synthesize)) pathS (list/fold caseS;weave (transform-branch lastP lastA) (list/map (product;uncurry transform-branch) prevsPA))] @@ -95,23 +94,20 @@ (undefined) ))) -(def: (synthesize-apply synthesize outer-arity num-locals exprA) - (-> (-> la;Analysis ls;Synthesis) ls;Arity Nat la;Analysis ls;Synthesis) +(def: (synthesize-apply synthesize num-locals exprA) + (-> (-> la;Analysis ls;Synthesis) Nat la;Analysis ls;Synthesis) (let [[funcA argsA] (functionS;unfold-apply exprA) funcS (synthesize funcA) argsS (list/map synthesize argsA)] (case funcS - (^multi (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat _arity)] [_ (#;Tuple _env)] _bodyS))]) + (^multi (^code ("lux function" (~ [_ (#;Nat _arity)]) [(~@ _env)] (~ _bodyS))) (and (n.= _arity (list;size argsS)) (not (loopS;contains-self-reference? _bodyS))) [(s;run _env (p;some s;int)) (#e;Success _env)]) - (let [register-offset (if (functionS;top? outer-arity) - num-locals - (|> outer-arity n.inc (n.+ num-locals)))] - (` ("lux loop" (~ (code;nat register-offset)) [(~@ argsS)] - (~ (loopS;adjust _env register-offset _bodyS))))) + (` ("lux loop" (~ (code;nat (n.inc num-locals))) [(~@ argsS)] + (~ (loopS;adjust _env num-locals _bodyS)))) - (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS' argsS'))]) + (^code ("lux call" (~ funcS') (~@ argsS'))) (call$ funcS' (list/compose argsS' argsS)) _ @@ -119,58 +115,59 @@ (def: #export (synthesize expressionA) (-> la;Analysis ls;Synthesis) - (loop [outer-arity +0 + (loop [arity +0 resolver init-resolver direct? false num-locals +0 expressionA expressionA] (case expressionA (^code [(~ _left) (~ _right)]) - (` [(~@ (list/map (recur outer-arity resolver false num-locals) (la;unfold-tuple expressionA)))]) + (` [(~@ (list/map (recur arity resolver false num-locals) + (la;unfold-tuple expressionA)))]) (^or (^code ("lux sum left" (~ _))) (^code ("lux sum right" (~ _)))) (let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))] - (variant$ tag last? (recur outer-arity resolver false num-locals value))) + (variant$ tag last? (recur arity resolver false num-locals value))) (^code ((~ [_ (#;Int var)]))) (if (variableL;local? var) - (if (functionS;nested? outer-arity) + (if (functionS;nested? arity) (if (variableL;self? var) - (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity)) + (call$ (var$ 0) (|> (list;n.range +1 (n.dec arity)) (list/map (|>. variableL;local code;int (~) () (`))))) - (var$ (functionS;adjust-var outer-arity var))) + (var$ (functionS;adjust-var arity var))) (var$ var)) (var$ (maybe;default var (dict;get var resolver)))) (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)]))) - (synthesize-case (recur outer-arity resolver false num-locals) outer-arity inputA branchesA) + (synthesize-case arity num-locals (recur arity resolver false) inputA branchesA) (^multi (^code ("lux function" [(~@ scope)] (~ bodyA))) [(s;run scope (p;some s;int)) (#e;Success raw-env)]) - (let [inner-arity (if direct? - (n.inc outer-arity) - +1) + (let [function-arity (if direct? + (n.inc arity) + +1) env (list/map (function [closure] (case (dict;get closure resolver) (#;Some resolved) (if (and (variableL;local? resolved) - (functionS;nested? outer-arity) - (|> resolved variableL;local-register (n.>= outer-arity))) - (functionS;adjust-var outer-arity resolved) + (functionS;nested? arity) + (|> resolved variableL;local-register (n.>= arity))) + (functionS;adjust-var arity resolved) resolved) #;None (if (and (variableL;local? closure) - (functionS;nested? outer-arity)) - (functionS;adjust-var outer-arity closure) + (functionS;nested? arity)) + (functionS;adjust-var arity closure) closure))) raw-env) env-vars (: (List Variable) (case raw-env #;Nil (list) _ (|> (list;size raw-env) n.dec (list;n.range +0) (list/map variableL;captured)))) - resolver' (if (and (functionS;nested? inner-arity) + resolver' (if (and (functionS;nested? function-arity) direct?) (list/fold (function [[from to] resolver'] (dict;put from to resolver')) @@ -180,19 +177,20 @@ (dict;put var var resolver')) init-resolver env-vars))] - (case (recur inner-arity resolver' true num-locals bodyA) - (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))]) - (let [arity (n.inc arity')] - (function$ arity env (prepare-body inner-arity arity bodyS'))) + (case (recur function-arity resolver' true function-arity bodyA) + (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat unmerged-arity)] env' bodyS'))]) + (let [merged-arity (n.inc unmerged-arity)] + (function$ merged-arity env + (prepare-body function-arity merged-arity bodyS'))) bodyS - (function$ +1 env (prepare-body inner-arity +1 bodyS)))) + (function$ +1 env (prepare-body function-arity +1 bodyS)))) (^code ("lux apply" (~@ _))) - (synthesize-apply (recur outer-arity resolver false num-locals) outer-arity num-locals expressionA) + (synthesize-apply (recur arity resolver false num-locals) num-locals expressionA) (^code ((~ [_ (#;Text name)]) (~@ args))) - (procedure$ name (list/map (recur outer-arity resolver false num-locals) args)) + (procedure$ name (list/map (recur arity resolver false num-locals) args)) _ expressionA))) diff --git a/new-luxc/source/luxc/lang/synthesis/loop.lux b/new-luxc/source/luxc/lang/synthesis/loop.lux index 86c37a3f0..ac72e69b2 100644 --- a/new-luxc/source/luxc/lang/synthesis/loop.lux +++ b/new-luxc/source/luxc/lang/synthesis/loop.lux @@ -108,7 +108,7 @@ exprS ))) -(def: #export (adjust env outer-offset exprS) +(def: #export (adjust env offset exprS) (-> (List Variable) Register ls;Synthesis ls;Synthesis) (let [resolve-captured (: (-> Variable Variable) (function [var] @@ -116,13 +116,13 @@ (|> env (list;nth idx) maybe;assume))))] (loop [exprS exprS] (case exprS - (^ [_ (#;Form (list [_ (#;Nat tag)] last? valueS))]) + (^code ((~ [_ (#;Nat tag)]) (~ last?) (~ valueS))) (` ((~ (code;nat tag)) (~ last?) (~ (recur valueS)))) - [_ (#;Tuple members)] - [_ (#;Tuple (list/map recur members))] + (^code [(~@ members)]) + (` [(~@ (list/map recur members))]) - (^ [_ (#;Form (list [_ (#;Text "lux case")] inputS pathS))]) + (^code ("lux case" (~ inputS) (~ pathS))) (` ("lux case" (~ (recur inputS)) (~ (let [adjust' recur] (loop [pathS pathS] @@ -133,22 +133,25 @@ (["lux case alt"] ["lux case seq"]) + (^code ("lux case bind" (~ [_ (#;Nat register)]))) + (` ("lux case bind" (~ (code;nat (n.+ offset register))))) + (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (` ("lux case exec" (~ (adjust' bodyS)))) _ pathS)))))) - (^ [_ (#;Form (list [_ (#;Text "lux function")] arity [_ (#;Tuple environment)] bodyS))]) + (^code ("lux function" (~ arity) [(~@ environment)] (~ bodyS))) (` ("lux function" (~ arity) - (~ [_ (#;Tuple (list/map (function [_var] - (case _var - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (` ((~ (code;int (resolve-captured var))))) - - _ - _var)) - environment))]) + [(~@ (list/map (function [_var] + (case _var + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (` ((~ (code;int (resolve-captured var))))) + + _ + _var)) + environment))] (~ (recur bodyS)))) (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) @@ -163,10 +166,10 @@ (^ [_ (#;Form (list [_ (#;Int var)]))]) (if (variableL;captured? var) (` ((~ (code;int (resolve-captured var))))) - (` ((~ (code;int (|> outer-offset nat-to-int (i.+ var))))))) + (` ((~ (code;int (|> offset nat-to-int (i.+ var))))))) (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS bodyS))]) - (` ("lux let" (~ (code;nat (n.+ outer-offset register))) + (` ("lux let" (~ (code;nat (n.+ offset register))) (~ (recur inputS)) (~ (recur bodyS)))) @@ -175,8 +178,8 @@ (~ (recur thenS)) (~ (recur elseS)))) - (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat inner-offset)] [_ (#;Tuple initsS)] bodyS))]) - (` ("lux loop" (~ (code;nat (n.+ outer-offset inner-offset))) + (^ [_ (#;Form (list [_ (#;Text "lux loop")] [_ (#;Nat loop-offset)] [_ (#;Tuple initsS)] bodyS))]) + (` ("lux loop" (~ (code;nat (n.+ offset loop-offset))) [(~@ (list/map recur initsS))] (~ (recur bodyS)))) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 33f74795a..fbecf2da5 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -7,10 +7,10 @@ (data ["e" error] [text "text/" Hash<Text>] text/format - (coll [list] + (coll [list "list/" Functor<List>] [dict])) [macro] - (lang [syntax] + (lang [syntax #+ Aliases] (type ["tc" check])) [host] [io #+ IO Process io] @@ -52,9 +52,12 @@ (wrap [annsI (:! Code annsV)]))) (def: (switch-compiler new-compiler) - (-> Compiler (Meta Unit)) + (-> Compiler (Meta Aliases)) (function [old-compiler] - (#e;Success [new-compiler []]))) + ((do macro;Monad<Meta> + [this macro;current-module] + (wrap (|> this (get@ #;module-aliases) (dict;from-list text;Hash<Text>) (: Aliases)))) + new-compiler))) (def: (ensure-valid-alias def-name annotations value) (-> Text Code Code (Meta Unit)) @@ -66,8 +69,8 @@ _ (&;throw Invalid-Alias def-name))) -(def: (translate translate-module code) - (-> (-> Text Compiler (Process Compiler)) Code (Meta Unit)) +(def: (translate translate-module aliases code) + (-> (-> Text Compiler (Process Compiler)) Aliases Code (Meta Aliases)) (case code (^code ((~ [_ (#;Symbol macro-name)]) (~@ args))) (do macro;Monad<Meta> @@ -76,15 +79,26 @@ (case ?macro (#;Some macro) (do @ - [expansion (function [compiler] - (case (macroL;expand macro args compiler) - (#e;Success [compiler' output]) - (#e;Success [compiler' output]) + [expansion (: (Meta (List Code)) + (function [compiler] + (case (macroL;expand macro args compiler) + (#e;Error error) + ((&;throw Macro-Expansion-Failed error) compiler) - (#e;Error error) - ((&;throw Macro-Expansion-Failed error) compiler))) - _ (monad;map @ (translate translate-module) expansion)] - (wrap [])) + output + output))) + expansion-aliases (monad;map @ (translate translate-module aliases) expansion)] + (if (dict;empty? aliases) + (loop [expansion-aliases expansion-aliases] + (case expansion-aliases + #;Nil + (wrap aliases) + + (#;Cons head tail) + (if (dict;empty? head) + (recur tail) + (wrap head)))) + (wrap aliases))) #;None (&;throw Unrecognized-Statement (%code code)))) @@ -100,7 +114,7 @@ [_ (ensure-valid-alias def-name annsV valueC) _ (&;with-scope (statementT;translate-def def-name Void id annsI annsV))] - (wrap [])) + (wrap aliases)) #;None (do @ @@ -114,10 +128,15 @@ (analyse valueC)))) valueT (&;with-type-env (tc;clean valueT)) + ## #let [_ (if (or (text/= "list/size" def-name)) + ## (log! (format "{" def-name "}\n" + ## " ANALYSIS: " (%code valueA) "\n" + ## "SYNTHESIS: " (%code (expressionS;synthesize valueA)))) + ## [])] valueI (expressionT;translate (expressionS;synthesize valueA)) _ (&;with-scope (statementT;translate-def def-name valueT valueI annsI annsV))] - (wrap [])))))) + (wrap aliases)))))) (^code ("lux module" (~ annsC))) (do macro;Monad<Meta> @@ -135,23 +154,24 @@ [[_ programA] (&;with-scope (&;with-type (type (io;IO Unit)) (analyse programC))) - programI (expressionT;translate (expressionS;synthesize programA))] - (statementT;translate-program program-args programI)) + programI (expressionT;translate (expressionS;synthesize programA)) + _ (statementT;translate-program program-args programI)] + (wrap aliases)) _ (&;throw Unrecognized-Statement (%code code)))) -(def: (exhaust action) - (All [a] (-> (Meta a) (Meta Unit))) +(def: (forgive-eof action) + (-> (Meta Unit) (Meta Unit)) (function [compiler] (case (action compiler) - (#e;Success [compiler' _]) - ((exhaust action) compiler') - (#e;Error error) (if (ex;match? syntax;End-Of-File error) (#e;Success [compiler []]) - (#e;Error error))))) + (#e;Error error)) + + output + output))) (def: prelude Text "lux") @@ -164,10 +184,10 @@ _ (moduleL;flag-compiled! module-name)] (wrap output))) -(def: (read current-module) - (-> Text (Meta Code)) +(def: (read current-module aliases) + (-> Text Aliases (Meta Code)) (function [compiler] - (case (syntax;read current-module (get@ #;source compiler)) + (case (syntax;read current-module aliases (get@ #;source compiler)) (#e;Error error) (#e;Error error) @@ -178,8 +198,7 @@ (def: (translate-module source-dirs target-dir module-name compiler) (-> (List File) File Text Compiler (Process Compiler)) (do io;Monad<Process> - [#let [_ (log! (format "{translate-module} " module-name))] - ## _ (&io;prepare-module target-dir module-name) + [## _ (&io;prepare-module target-dir module-name) [file-name file-content] (&io;read-module source-dirs module-name) #let [module-hash (text/hash file-content) translate-module (translate-module source-dirs target-dir)]] @@ -190,12 +209,15 @@ (with-active-compilation [module-name file-name file-content] - (exhaust - (do @ - [code (read module-name) - #let [[cursor _] code]] - (&;with-cursor cursor - (translate translate-module code)))))))] + (forgive-eof + (loop [aliases (: Aliases + (dict;new text;Hash<Text>))] + (do @ + [code (read module-name aliases) + #let [[cursor _] code] + aliases' (&;with-cursor cursor + (translate translate-module aliases code))] + (forgive-eof (recur aliases'))))))))] (wrap artifacts))) (#e;Success [compiler artifacts]) (do @ diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux index c30f61225..be8b828cd 100644 --- a/new-luxc/source/luxc/lang/translation/imports.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/imports.jvm.lux @@ -111,7 +111,6 @@ (do macro;Monad<Meta> [_ (moduleL;set-annotations annotations) current-module macro;current-module-name - #let [_ (log! (format "{translate-imports} " current-module))] imports (let [imports (|> (macro;get-tuple-ann (ident-for #;imports) annotations) (maybe;default (list)))] (case (s;run imports (p;some import)) diff --git a/new-luxc/source/luxc/lang/translation/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/loop.jvm.lux index f5830bf9e..77d43a0e5 100644 --- a/new-luxc/source/luxc/lang/translation/loop.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/loop.jvm.lux @@ -16,7 +16,18 @@ (translation [";T" common] [";T" runtime] [";T" reference]) - [";L" variable #+ Variable]))) + [";L" variable #+ Variable Register]))) + +(def: (constant? register changeS) + (-> Register ls;Synthesis Bool) + (case changeS + (^multi (^code ((~ [_ (#;Int var)]))) + (i.= (variableL;local register) + var)) + true + + _ + false)) (def: #export (translate-recur translate argsS) (-> (-> ls;Synthesis (Meta $;Inst)) @@ -24,23 +35,30 @@ (Meta $;Inst)) (do macro;Monad<Meta> [[@begin offset] hostL;anchor - argsI (monad;map @ (function [[register argS]] - (let [register' (|> register (n.+ offset))] - (: (Meta $;Inst) - (case argS - (^multi (^code ((~ [_ (#;Int var)]))) - (i.= (variableL;local register') - var)) - (wrap id) - - _ - (do @ - [argI (translate argS)] - (wrap (|>. argI - ($i;ASTORE register')))))))) - (list;zip2 (list;n.range +0 (n.dec (list;size argsS))) - argsS))] - (wrap (|>. ($i;fuse argsI) + #let [pairs (list;zip2 (list;n.range offset (|> (list;size argsS) n.dec (n.+ offset))) + argsS)] + ## It may look weird that first I compile the values separately, + ## and then I compile the stores/allocations. + ## It must be done that way in order to avoid a potential bug. + ## Let's say that you'll recur with 2 expressions: X and Y. + ## If Y depends on the value of X, and you don't compile values + ## and stores separately, then by the time Y is evaluated, it + ## will refer to the new value of X, instead of the old value, as + ## must be the case. + valuesI+ (monad;map @ (function [[register argS]] + (: (Meta $;Inst) + (if (constant? register argS) + (wrap id) + (translate argS)))) + pairs) + #let [storesI+ (list/map (function [[register argS]] + (: $;Inst + (if (constant? register argS) + id + ($i;ASTORE register)))) + (list;reverse pairs))]] + (wrap (|>. ($i;fuse valuesI+) + ($i;fuse storesI+) ($i;GOTO @begin))))) (def: #export (translate-loop translate offset initsS+ bodyS) @@ -50,12 +68,12 @@ (do macro;Monad<Meta> [@begin $i;make-label initsI+ (monad;map @ translate initsS+) - bodyI (hostL;with-anchor [@begin (n.inc offset)] + bodyI (hostL;with-anchor [@begin offset] (translate bodyS)) #let [initializationI (|> (list;enumerate initsI+) (list/map (function [[register initI]] (|>. initI - ($i;ASTORE (|> register n.inc (n.+ offset)))))) + ($i;ASTORE (n.+ offset register))))) $i;fuse)]] (wrap (|>. initializationI ($i;label @begin) 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 0e17f99a6..6c1b18932 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -267,65 +267,61 @@ $;Method ($t;method (list $t;long $t;long) (#;Some $t;int) (list))) -(do-template [<name> <const> <wrapper>] +(do-template [<name> <const> <type>] [(def: (<name> _) Nullary - (|>. <const> <wrapper>))] + (|>. <const> ($i;wrap <type>)))] - [nat//min ($i;long 0) ($i;wrap #$;Long)] - [nat//max ($i;long -1) ($i;wrap #$;Long)] + [nat//min ($i;long 0) #$;Long] + [nat//max ($i;long -1) #$;Long] - [int//min ($i;long Long.MIN_VALUE) ($i;wrap #$;Long)] - [int//max ($i;long Long.MAX_VALUE) ($i;wrap #$;Long)] + [int//min ($i;long Long.MIN_VALUE) #$;Long] + [int//max ($i;long Long.MAX_VALUE) #$;Long] - [frac//smallest ($i;double Double.MIN_VALUE) ($i;wrap #$;Double)] - [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) ($i;wrap #$;Double)] - [frac//max ($i;double Double.MAX_VALUE) ($i;wrap #$;Double)] - [frac//not-a-number ($i;double Double.NaN) ($i;wrap #$;Double)] - [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) ($i;wrap #$;Double)] - [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) ($i;wrap #$;Double)] - - [deg//min ($i;long 0) ($i;wrap #$;Long)] - [deg//max ($i;long -1) ($i;wrap #$;Long)] + [frac//smallest ($i;double Double.MIN_VALUE) #$;Double] + [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) #$;Double] + [frac//max ($i;double Double.MAX_VALUE) #$;Double] + [frac//not-a-number ($i;double Double.NaN) #$;Double] + [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) #$;Double] + [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) #$;Double] + + [deg//min ($i;long 0) #$;Long] + [deg//max ($i;long -1) #$;Long] ) -(do-template [<name> <unwrap> <wrap> <op>] +(do-template [<name> <type> <op>] [(def: (<name> [subjectI paramI]) Binary - (|>. subjectI <unwrap> - paramI <unwrap> + (|>. subjectI ($i;unwrap <type>) + paramI ($i;unwrap <type>) <op> - <wrap>))] + ($i;wrap <type>)))] - [int//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] - [int//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] - [int//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] - [int//div ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] - [int//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LREM] + [int//add #$;Long $i;LADD] + [int//sub #$;Long $i;LSUB] + [int//mul #$;Long $i;LMUL] + [int//div #$;Long $i;LDIV] + [int//rem #$;Long $i;LREM] - [nat//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] - [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] - [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] - [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] - [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] - - [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD] - [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB] - [frac//mul ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DMUL] - [frac//div ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DDIV] - [frac//rem ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DREM] - - [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD] - [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] - [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] - [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] - [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB] - [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL] - [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV] + [nat//add #$;Long $i;LADD] + [nat//sub #$;Long $i;LSUB] + [nat//mul #$;Long $i;LMUL] + [nat//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)] + [nat//rem #$;Long ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)] + + [frac//add #$;Double $i;DADD] + [frac//sub #$;Double $i;DSUB] + [frac//mul #$;Double $i;DMUL] + [frac//div #$;Double $i;DDIV] + [frac//rem #$;Double $i;DREM] + + [deg//add #$;Long $i;LADD] + [deg//sub #$;Long $i;LSUB] + [deg//mul #$;Long ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)] + [deg//div #$;Long ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)] + [deg//rem #$;Long $i;LSUB] + [deg//scale #$;Long $i;LMUL] + [deg//reciprocal #$;Long $i;LDIV] ) (do-template [<eq> <lt> <unwrap> <cmp>] @@ -382,11 +378,11 @@ ($i;INVOKEVIRTUAL <class> <method> ($t;method (list) (#;Some <outputT>) (list)) false) <post>))] - [text//size "java.lang.String" "length" lux-intI $t;int] - [text//hash "java.lang.Object" "hashCode" lux-intI $t;int] - [text//trim "java.lang.String" "trim" id $String] - [text//upper-case "java.lang.String" "toUpperCase" id $String] - [text//lower-case "java.lang.String" "toLowerCase" id $String] + [text//size "java.lang.String" "length" lux-intI $t;int] + [text//hash "java.lang.Object" "hashCode" lux-intI $t;int] + [text//trim "java.lang.String" "trim" id $String] + [text//upper "java.lang.String" "toUpperCase" id $String] + [text//lower "java.lang.String" "toLowerCase" id $String] ) (do-template [<name> <pre-subject> <pre-param> <op> <post>] @@ -676,18 +672,21 @@ (def: text-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "text =" (binary text//eq)) - (install "text <" (binary text//lt)) - (install "text concat" (binary text//concat)) - (install "text index" (trinary text//index)) - (install "text size" (unary text//size)) - (install "text hash" (unary text//hash)) - (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)) - )) + (<| (prefix "text") + (|> (dict;new text;Hash<Text>) + (install "=" (binary text//eq)) + (install "<" (binary text//lt)) + (install "concat" (binary text//concat)) + (install "index" (trinary text//index)) + (install "size" (unary text//size)) + (install "hash" (unary text//hash)) + (install "replace-once" (trinary text//replace-once)) + (install "replace-all" (trinary text//replace-all)) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + (install "upper" (unary text//upper)) + (install "lower" (unary text//lower)) + ))) (def: array-procs Bundle diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux index 87174b192..d2bb1645b 100644 --- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux @@ -198,7 +198,6 @@ div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)) upcastI ($i;INVOKESTATIC hostL;runtime-class "_toUnsignedBigInteger" upcast-method false) downcastI ($i;INVOKEVIRTUAL "java.math.BigInteger" "longValue" ($t;method (list) (#;Some $t;long) (list)) false)] - ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#215 (|>. ($d;method #$;Public $;staticM "_toUnsignedBigInteger" upcast-method (let [upcastI ($i;INVOKESTATIC "java.math.BigInteger" "valueOf" upcast-method false) discernI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGE @where))) @@ -220,14 +219,12 @@ ($i;LLOAD +0) upcastI $i;ARETURN)))) - ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java?av=f#1267 ($d;method #$;Public $;staticM "compare_nat" compare-nat-method (let [shiftI (|>. ($i;GETSTATIC "java.lang.Long" "MIN_VALUE" $t;long) $i;LADD)] (|>. ($i;LLOAD +0) shiftI ($i;LLOAD +2) shiftI $i;LCMP $i;IRETURN))) - ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1290 ($d;method #$;Public $;staticM "div_nat" div-method (let [is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLT @where))) is-subject-smallI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFGT @where))) @@ -257,7 +254,6 @@ ## Less than ($i;label @is-zero) ($i;long 0) $i;LRETURN)))) - ## http://grepcode.com/file/repository.grepcode.com/java/root/jdk/openjdk/8u40-b25/java/lang/Long.java#1323 ($d;method #$;Public $;staticM "rem_nat" div-method (let [is-subject-largeI (function [@where] (|>. ($i;LLOAD +0) ($i;long 0) $i;LCMP ($i;IFLE @where))) is-param-largeI (function [@where] (|>. ($i;LLOAD +2) ($i;long 0) $i;LCMP ($i;IFLE @where))) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 407e895a3..0dcc335a0 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1189,7 +1189,7 @@ (#Function Nat Code) (form$ (#Cons (tag$ ["lux" "Bound"]) (#Cons (nat$ idx) #Nil)))) -(def:'' (fold f init xs) +(def:'' (list/fold f init xs) #;Nil ## (All [a b] (-> (-> b a a) a (List b) a)) (#UnivQ #Nil (#UnivQ #Nil (#Function (#Function (#Bound +1) @@ -1203,13 +1203,13 @@ init (#Cons x xs') - (fold f (f x init) xs')})) + (list/fold f (f x init) xs')})) (def:'' (length list) #;Nil (#UnivQ #Nil (#Function ($' List (#Bound +1)) Nat)) - (fold (function'' [_ acc] ("lux nat +" +1 acc)) +0 list)) + (list/fold (function'' [_ acc] ("lux nat +" +1 acc)) +0 list)) (macro:' #export (All tokens) (#Cons [(tag$ ["lux" "doc"]) @@ -1232,14 +1232,14 @@ {(#Cons [_ (#Tuple args)] (#Cons body #Nil)) (parse-quantified-args args (function'' [names] - (let'' body' (fold ("lux check" (#Function Text (#Function Code Code)) - (function'' [name' body'] - (form$ (#Cons (tag$ ["lux" "UnivQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) - (update-bounds body')) #Nil)))))) - body - names) + (let'' body' (list/fold ("lux check" (#Function Text (#Function Code Code)) + (function'' [name' body'] + (form$ (#Cons (tag$ ["lux" "UnivQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) + (update-bounds body')) #Nil)))))) + body + names) (return (#Cons ("lux case" [(text/= "" self-name) names] {[true _] body' @@ -1283,14 +1283,14 @@ {(#Cons [_ (#Tuple args)] (#Cons body #Nil)) (parse-quantified-args args (function'' [names] - (let'' body' (fold ("lux check" (#Function Text (#Function Code Code)) - (function'' [name' body'] - (form$ (#Cons (tag$ ["lux" "ExQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) - (update-bounds body')) #Nil)))))) - body - names) + (let'' body' (list/fold ("lux check" (#Function Text (#Function Code Code)) + (function'' [name' body'] + (form$ (#Cons (tag$ ["lux" "ExQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound +1)] #Nil) + (update-bounds body')) #Nil)))))) + body + names) (return (#Cons ("lux case" [(text/= "" self-name) names] {[true _] body' @@ -1314,10 +1314,10 @@ (def:'' (reverse list) #;Nil (All [a] (#Function ($' List a) ($' List a))) - (fold ("lux check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) - (function'' [head tail] (#Cons head tail))) - #Nil - list)) + (list/fold ("lux check" (All [a] (#Function a (#Function ($' List a) ($' List a)))) + (function'' [head tail] (#Cons head tail))) + #Nil + list)) (macro:' #export (-> tokens) (#Cons [(tag$ ["lux" "doc"]) @@ -1328,10 +1328,10 @@ #;Nil) ("lux case" (reverse tokens) {(#Cons output inputs) - (return (#Cons (fold ("lux check" (#Function Code (#Function Code Code)) - (function'' [i o] (form$ (#Cons (tag$ ["lux" "Function"]) (#Cons i (#Cons o #Nil)))))) - output - inputs) + (return (#Cons (list/fold ("lux check" (#Function Code (#Function Code Code)) + (function'' [i o] (form$ (#Cons (tag$ ["lux" "Function"]) (#Cons i (#Cons o #Nil)))))) + output + inputs) #Nil)) _ @@ -1342,12 +1342,12 @@ (text$ "## List-construction macro. (list 1 2 3)")] #;Nil) - (return (#Cons (fold (function'' [head tail] - (form$ (#Cons (tag$ ["lux" "Cons"]) - (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) - #Nil)))) - (tag$ ["lux" "Nil"]) - (reverse xs)) + (return (#Cons (list/fold (function'' [head tail] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) + #Nil)))) + (tag$ ["lux" "Nil"]) + (reverse xs)) #Nil))) (macro:' #export (list& xs) @@ -1358,11 +1358,11 @@ #;Nil) ("lux case" (reverse xs) {(#Cons last init) - (return (list (fold (function'' [head tail] - (form$ (list (tag$ ["lux" "Cons"]) - (tuple$ (list head tail))))) - last - init))) + (return (list (list/fold (function'' [head tail] + (form$ (list (tag$ ["lux" "Cons"]) + (tuple$ (list head tail))))) + last + init))) _ (fail "Wrong syntax for list&")})) @@ -1380,9 +1380,9 @@ (return (list (tag$ ["lux" "Unit"]))) (#Cons last prevs) - (return (list (fold (function'' [left right] (form$ (list (tag$ ["lux" "Product"]) left right))) - last - prevs)))} + (return (list (list/fold (function'' [left right] (form$ (list (tag$ ["lux" "Product"]) left right))) + last + prevs)))} )) (macro:' #export (| tokens) @@ -1398,9 +1398,9 @@ (return (list (tag$ ["lux" "Void"]))) (#Cons last prevs) - (return (list (fold (function'' [left right] (form$ (list (tag$ ["lux" "Sum"]) left right))) - last - prevs)))} + (return (list (list/fold (function'' [left right] (form$ (list (tag$ ["lux" "Sum"]) left right))) + last + prevs)))} )) (macro:' (function' tokens) @@ -1420,13 +1420,13 @@ (return (list (form$ (list (text$ "lux function") (symbol$ ["" name]) harg - (fold (function'' [arg body'] - (form$ (list (text$ "lux function") - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))}) + (list/fold (function'' [arg body'] + (form$ (list (text$ "lux function") + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))}) _ (fail "Wrong syntax for function'")}))) @@ -1497,14 +1497,14 @@ (macro:' (let' tokens) ("lux case" tokens {(#Cons [[_ (#Tuple bindings)] (#Cons [body #Nil])]) - (return (list (fold ("lux check" (-> (& Code Code) Code - Code) - (function' [binding body] - ("lux case" binding - {[label value] - (form$ (list (text$ "lux case") value (record$ (list [label body]))))}))) - body - (reverse (as-pairs bindings))))) + (return (list (list/fold ("lux check" (-> (& Code Code) Code + Code) + (function' [binding body] + ("lux case" binding + {[label value] + (form$ (list (text$ "lux case") value (record$ (list [label body]))))}))) + body + (reverse (as-pairs bindings))))) _ (fail "Wrong syntax for let'")})) @@ -1522,16 +1522,6 @@ {true true false (any? p xs')})})) -(def:''' (spliced? token) - #;Nil - (-> Code Bool) - ("lux case" token - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [_ #Nil])]))] - true - - _ - false})) - (def:''' (wrap-meta content) #;Nil (-> Code Code) @@ -1592,7 +1582,7 @@ {(#Cons op tokens') ("lux case" tokens' {(#Cons first nexts) - (return (list (fold (_$_joiner op) first nexts))) + (return (list (list/fold (_$_joiner op) first nexts))) _ (fail "Wrong syntax for _$")}) @@ -1612,7 +1602,7 @@ {(#Cons op tokens') ("lux case" (reverse tokens') {(#Cons last prevs) - (return (list (fold (_$_joiner op) last prevs))) + (return (list (list/fold (_$_joiner op) last prevs))) _ (fail "Wrong syntax for $_")}) @@ -1672,19 +1662,19 @@ {(#Cons monad (#Cons [_ (#Tuple bindings)] (#Cons body #Nil))) (let' [g!wrap (symbol$ ["" "wrap"]) g!bind (symbol$ ["" " bind "]) - body' (fold ("lux check" (-> (& Code Code) Code Code) - (function' [binding body'] - (let' [[var value] binding] - ("lux case" var - {[_ (#Tag "" "let")] - (form$ (list (symbol$ ["lux" "let'"]) value body')) - - _ - (form$ (list g!bind - (form$ (list (text$ "lux function") (symbol$ ["" ""]) var body')) - value))})))) - body - (reverse (as-pairs bindings)))] + body' (list/fold ("lux check" (-> (& Code Code) Code Code) + (function' [binding body'] + (let' [[var value] binding] + ("lux case" var + {[_ (#Tag "" "let")] + (form$ (list (symbol$ ["lux" "let'"]) value body')) + + _ + (form$ (list g!bind + (form$ (list (text$ "lux function") (symbol$ ["" ""]) var body')) + value))})))) + body + (reverse (as-pairs bindings)))] (return (list (form$ (list (text$ "lux case") monad (record$ (list [(record$ (list [(tag$ ["lux" "wrap"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) @@ -1714,6 +1704,27 @@ (wrap (#Cons y ys))) }))) +(def:''' (monad/fold m f y xs) + #Nil + ## (All [m a b] + ## (-> (Monad m) (-> a b (m b)) b (List a) (m b))) + (All [m a b] + (-> ($' Monad m) + (-> a b ($' m b)) + b + ($' List a) + ($' m b))) + (let' [{#;wrap wrap #;bind _} m] + ("lux case" xs + {#Nil + (wrap y) + + (#Cons x xs') + (do m + [y' (f x y)] + (monad/fold m f y' xs')) + }))) + (macro:' #export (if tokens) (list [(tag$ ["lux" "doc"]) (text$ "Picks which expression to evaluate based on a boolean test value. @@ -1831,42 +1842,43 @@ #None (#Left ($_ text/compose "Unknown module: " module " @ " (ident/encode ident)))}))) -(def:''' (splice replace? untemplate tag elems) +(def:''' (splice replace? untemplate elems) #Nil - (-> Bool (-> Code ($' Meta Code)) Code ($' List Code) ($' Meta Code)) + (-> Bool (-> Code ($' Meta Code)) ($' List Code) ($' Meta Code)) ("lux case" replace? {true - ("lux case" (any? spliced? elems) - {true + ("lux case" (reverse elems) + {#Nil + (return (tag$ ["lux" "Nil"])) + + (#Cons lastI inits) (do Monad<Meta> - [elems' ("lux check" ($' Meta ($' List Code)) - (monad/map Monad<Meta> - ("lux check" (-> Code ($' Meta Code)) - (function' [elem] - ("lux case" elem - {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] - (wrap spliced) - - _ - (do Monad<Meta> - [=elem (untemplate elem)] - (wrap (form$ (list (text$ "lux check") - (form$ (list (tag$ ["lux" "Apply"]) (tuple$ (list (symbol$ ["lux" "Code"]) (symbol$ ["lux" "List"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))}))) - elems))] - (wrap (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$_"]) - (symbol$ ["lux" "splice-helper"]) - elems'))))))) + [lastO ("lux case" lastI + {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Monad<Meta> + [lastO (untemplate lastI)] + (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list lastO (tag$ ["lux" "Nil"])))))))})] + (monad/fold Monad<Meta> + (function' [leftI rightO] + ("lux case" leftI + {[_ (#Form (#Cons [[_ (#Symbol ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap (form$ (list (symbol$ ["lux" "splice-helper"]) + spliced + rightO))) - false - (do Monad<Meta> - [=elems (monad/map Monad<Meta> untemplate elems)] - (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))}) + _ + (do Monad<Meta> + [leftO (untemplate leftI)] + (wrap (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list leftO rightO))))))})) + lastO + inits))}) false (do Monad<Meta> [=elems (monad/map Monad<Meta> untemplate elems)] - (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))})) + (wrap (untemplate-list =elems)))})) (def:''' (untemplate replace? subst token) #Nil @@ -1918,9 +1930,6 @@ [false [_ (#Symbol [module name])]] (return (wrap-meta (form$ (list (tag$ ["lux" "Symbol"]) (tuple$ (list (text$ module) (text$ name))))))) - [_ [_ (#Tuple elems)]] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "Tuple"]) elems) - [true [_ (#Form (#Cons [[_ (#Symbol ["" "~"])] (#Cons [unquoted #Nil])]))]] (return unquoted) @@ -1929,9 +1938,15 @@ [_ [meta (#Form elems)]] (do Monad<Meta> - [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "Form"]) elems) - #let [[_ form'] output]] - (return [meta form'])) + [output (splice replace? (untemplate replace? subst) elems) + #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Form"]) output)))]] + (wrap [meta output'])) + + [_ [meta (#Tuple elems)]] + (do Monad<Meta> + [output (splice replace? (untemplate replace? subst) elems) + #let [[_ output'] (wrap-meta (form$ (list (tag$ ["lux" "Tuple"]) output)))]] + (wrap [meta output'])) [_ [_ (#Record fields)]] (do Monad<Meta> @@ -2041,19 +2056,19 @@ (map int/encode elems)))")]) ("lux case" tokens {(#Cons [init apps]) - (return (list (fold ("lux check" (-> Code Code Code) - (function' [app acc] - ("lux case" app - {[_ (#Tuple parts)] - (tuple$ (list/compose parts (list acc))) + (return (list (list/fold ("lux check" (-> Code Code Code) + (function' [app acc] + ("lux case" app + {[_ (#Tuple parts)] + (tuple$ (list/compose parts (list acc))) - [_ (#Form parts)] - (form$ (list/compose parts (list acc))) + [_ (#Form parts)] + (form$ (list/compose parts (list acc))) - _ - (` ((~ app) (~ acc)))}))) - init - apps))) + _ + (` ((~ app) (~ acc)))}))) + init + apps))) _ (fail "Wrong syntax for |>")})) @@ -2069,19 +2084,19 @@ (map int/encode elems)))")]) ("lux case" (reverse tokens) {(#Cons [init apps]) - (return (list (fold ("lux check" (-> Code Code Code) - (function' [app acc] - ("lux case" app - {[_ (#Tuple parts)] - (tuple$ (list/compose parts (list acc))) + (return (list (list/fold ("lux check" (-> Code Code Code) + (function' [app acc] + ("lux case" app + {[_ (#Tuple parts)] + (tuple$ (list/compose parts (list acc))) - [_ (#Form parts)] - (form$ (list/compose parts (list acc))) + [_ (#Form parts)] + (form$ (list/compose parts (list acc))) - _ - (` ((~ app) (~ acc)))}))) - init - apps))) + _ + (` ((~ app) (~ acc)))}))) + init + apps))) _ (fail "Wrong syntax for <|")})) @@ -2176,7 +2191,7 @@ #Nil (All [a] (-> (-> a Bool) ($' List a) Bool)) - (fold (function' [_2 _1] (if _1 (p _2) false)) true xs)) + (list/fold (function' [_2 _1] (if _1 (p _2) false)) true xs)) (macro:' #export (do-template tokens) (list [(tag$ ["lux" "doc"]) @@ -2341,11 +2356,11 @@ _ (let' [loop ("lux check" (-> Nat Text Text) (function' recur [input output] - (if ("lux nat =" input +0) - ("lux text concat" "+" output) - (recur ("lux nat /" input +10) - ("lux text concat" (digit-to-text ("lux nat %" input +10)) - output)))))] + (if (n.= +0 input) + (text/compose "+" output) + (recur (n./ +10 input) + (text/compose (|> input (n.% +10) digit-to-text) + output)))))] (loop value ""))})) (def:''' (int/abs value) @@ -2366,10 +2381,10 @@ (("lux check" (-> Int Text Text) (function' recur [input output] (if (i.= 0 input) - ("lux text concat" sign output) + (text/compose sign output) (recur (i./ 10 input) - ("lux text concat" (|> input (i.% 10) ("lux coerce" Nat) digit-to-text) - output))))) + (text/compose (|> input (i.% 10) ("lux coerce" Nat) digit-to-text) + output))))) (|> value (i./ 10) int/abs) (|> value (i.% 10) int/abs ("lux coerce" Nat) digit-to-text))))) @@ -2465,7 +2480,7 @@ #Nil (All [a] (-> ($' List ($' List a)) ($' List a))) - (fold list/compose #Nil (reverse xs))) + (list/fold list/compose #Nil (reverse xs))) (def:''' (interpose sep xs) #Nil @@ -2580,10 +2595,10 @@ (` (& (~@ (map walk-type members)))) [_ (#Form (#Cons type-fn args))] - (fold ("lux check" (-> Code Code Code) - (function' [arg type-fn] (` (#;Apply (~ arg) (~ type-fn))))) - (walk-type type-fn) - (map walk-type args)) + (list/fold ("lux check" (-> Code Code Code) + (function' [arg type-fn] (` (#;Apply (~ arg) (~ type-fn))))) + (walk-type type-fn) + (map walk-type args)) _ type})) @@ -2740,10 +2755,10 @@ ("lux case" (reverse tokens) {(#Cons value actions) (let' [dummy (symbol$ ["" ""])] - (return (list (fold ("lux check" (-> Code Code Code) - (function' [pre post] (` ("lux case" (~ pre) {(~ dummy) (~ post)})))) - value - actions)))) + (return (list (list/fold ("lux check" (-> Code Code Code) + (function' [pre post] (` ("lux case" (~ pre) {(~ dummy) (~ post)})))) + value + actions)))) _ (fail "Wrong syntax for exec")})) @@ -2835,21 +2850,21 @@ (map code-to-text) (interpose " ") reverse - (fold text/compose "")) ")") + (list/fold text/compose "")) ")") [_ (#Tuple xs)] ($_ text/compose "[" (|> xs (map code-to-text) (interpose " ") reverse - (fold text/compose "")) "]") + (list/fold text/compose "")) "]") [_ (#Record kvs)] ($_ text/compose "{" (|> kvs (map (function' [kv] ("lux case" kv {[k v] ($_ text/compose (code-to-text k) " " (code-to-text v))}))) (interpose " ") reverse - (fold text/compose "")) "}")} + (list/fold text/compose "")) "}")} )) (def:' (expander branches) @@ -2883,7 +2898,7 @@ (map code-to-text) (interpose " ") reverse - (fold text/compose ""))))})) + (list/fold text/compose ""))))})) (macro:' #export (case tokens) (list [(tag$ ["lux" "doc"]) @@ -2983,13 +2998,13 @@ (^ (list [_ (#Tuple bindings)] body)) (if (multiple? +2 (length bindings)) (|> bindings as-pairs reverse - (fold (: (-> [Code Code] Code Code) - (function' [lr body'] - (let' [[l r] lr] - (if (symbol? l) - (` ("lux case" (~ r) {(~ l) (~ body')})) - (` (case (~ r) (~ l) (~ body'))))))) - body) + (list/fold (: (-> [Code Code] Code Code) + (function' [lr body'] + (let' [[l r] lr] + (if (symbol? l) + (` ("lux case" (~ r) {(~ l) (~ body')})) + (` (case (~ r) (~ l) (~ body'))))))) + body) list return) (fail "let requires an even number of parts")) @@ -3019,14 +3034,14 @@ (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) - body+ (fold (: (-> Code Code Code) - (function' [arg body'] - (if (symbol? arg) - (` ("lux function" (~ g!blank) (~ arg) (~ body'))) - (` ("lux function" (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) - body - (reverse tail))] + body+ (list/fold (: (-> Code Code Code) + (function' [arg body'] + (if (symbol? arg) + (` ("lux function" (~ g!blank) (~ arg) (~ body'))) + (` ("lux function" (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail))] (return (list (if (symbol? head) (` ("lux function" (~ g!name) (~ head) (~ body+))) (` ("lux function" (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) @@ -3222,7 +3237,7 @@ (-> Code Code Code) (case addition [cursor (#;Record pairs)] - (fold meta-code-add base pairs) + (list/fold meta-code-add base pairs) _ base)) @@ -3360,10 +3375,10 @@ {#;doc <doc-msg>} (case (reverse tokens) (^ (list& last init)) - (return (list (fold (: (-> Code Code Code) - (function [pre post] (` <form>))) - last - init))) + (return (list (list/fold (: (-> Code Code Code) + (function [pre post] (` <form>))) + last + init))) _ (fail <message>)))] @@ -3704,7 +3719,7 @@ (def: (text/join parts) (-> (List Text) Text) - (|> parts reverse (fold text/compose ""))) + (|> parts reverse (list/fold text/compose ""))) (macro: #export (struct: tokens) {#;doc "## Definition of structures ala ML. @@ -3999,25 +4014,25 @@ _ false)))) - (fold (function [r l] (and l r)) true)) - (let [openings (fold (: (-> Code (List Openings) (List Openings)) - (function [part openings] - (case part - [_ (#Text prefix)] - (list& [prefix (list)] openings) - - [_ (#Symbol struct-name)] - (case openings - #Nil - (list ["" (list struct-name)]) - - (#Cons [prefix structs] openings') - (#Cons [prefix (#Cons struct-name structs)] openings')) - - _ - openings))) - (: (List Openings) (list)) - parts)] + (list/fold (function [r l] (and l r)) true)) + (let [openings (list/fold (: (-> Code (List Openings) (List Openings)) + (function [part openings] + (case part + [_ (#Text prefix)] + (list& [prefix (list)] openings) + + [_ (#Symbol struct-name)] + (case openings + #Nil + (list ["" (list struct-name)]) + + (#Cons [prefix structs] openings') + (#Cons [prefix (#Cons struct-name structs)] openings')) + + _ + openings))) + (: (List Openings) (list)) + parts)] (return [openings tokens'])) (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol).")) @@ -4035,25 +4050,25 @@ _ false)))) - (fold (function [r l] (and l r)) true)) - (let [openings (fold (: (-> Code (List Openings) (List Openings)) - (function [part openings] - (case part - [_ (#Text prefix)] - (list& [prefix (list)] openings) - - [_ (#Symbol struct-name)] - (case openings - #Nil - (list ["" (list struct-name)]) - - (#Cons [prefix structs] openings') - (#Cons [prefix (#Cons struct-name structs)] openings')) - - _ - openings))) - (: (List Openings) (list)) - parts)] + (list/fold (function [r l] (and l r)) true)) + (let [openings (list/fold (: (-> Code (List Openings) (List Openings)) + (function [part openings] + (case part + [_ (#Text prefix)] + (list& [prefix (list)] openings) + + [_ (#Symbol struct-name)] + (case openings + #Nil + (list ["" (list struct-name)]) + + (#Cons [prefix structs] openings') + (#Cons [prefix (#Cons struct-name structs)] openings')) + + _ + openings))) + (: (List Openings) (list)) + parts)] (return [openings (list)])) (fail "Expected all parts of opening form to be of either prefix (text) or struct (symbol)."))) @@ -4080,7 +4095,7 @@ [current-module current-module-name] (case (split-module module) (^ (list& "." parts)) - (return (|> (list& current-module parts) (interpose "/") reverse (fold text/compose ""))) + (return (|> (list& current-module parts) (interpose "/") reverse (list/fold text/compose ""))) parts (let [[ups parts'] (split-with (text/= "..") parts) @@ -4092,7 +4107,7 @@ (fail (text/compose "Cannot clean module: " module)) (#Some top-module) - (return (|> (list& top-module parts') (interpose "/") reverse (fold text/compose "")))) + (return (|> (list& top-module parts') (interpose "/") reverse (list/fold text/compose "")))) ))) )) @@ -4200,11 +4215,11 @@ (def: (is-member? cases name) (-> (List Text) Text Bool) - (let [output (fold (function [case prev] - (or prev - (text/= case name))) - false - cases)] + (let [output (list/fold (function [case prev] + (or prev + (text/= case name))) + false + cases)] output)) (def: (try-both f x1 x2) @@ -4351,7 +4366,7 @@ name _ - ($_ text/compose "(" name " " (|> params (map type/show) (interpose " ") reverse (fold text/compose "")) ")")) + ($_ text/compose "(" name " " (|> params (map type/show) (interpose " ") reverse (list/fold text/compose "")) ")")) #Void "Void" @@ -4360,13 +4375,13 @@ "Unit" (#Sum _) - ($_ text/compose "(| " (|> (flatten-variant type) (map type/show) (interpose " ") reverse (fold text/compose "")) ")") + ($_ text/compose "(| " (|> (flatten-variant type) (map type/show) (interpose " ") reverse (list/fold text/compose "")) ")") (#Product _) - ($_ text/compose "[" (|> (flatten-tuple type) (map type/show) (interpose " ") reverse (fold text/compose "")) "]") + ($_ text/compose "[" (|> (flatten-tuple type) (map type/show) (interpose " ") reverse (list/fold text/compose "")) "]") (#Function _) - ($_ text/compose "(-> " (|> (flatten-lambda type) (map type/show) (interpose " ") reverse (fold text/compose "")) ")") + ($_ text/compose "(-> " (|> (flatten-lambda type) (map type/show) (interpose " ") reverse (list/fold text/compose "")) ")") (#Bound id) (nat/encode id) @@ -4387,27 +4402,13 @@ (let [[func args] (flatten-app type)] ($_ text/compose "(" (type/show func) " " - (|> args (map type/show) (interpose " ") reverse (fold text/compose "")) + (|> args (map type/show) (interpose " ") reverse (list/fold text/compose "")) ")")) (#Named [prefix name] _) ($_ text/compose prefix ";" name) )) -(def: (foldM Monad<m> f init inputs) - (All [m o i] - (-> (Monad m) (-> i o (m o)) o (List i) (m o))) - (case inputs - #;Nil - (do Monad<m> - [] - (wrap init)) - - (#;Cons input inputs') - (do Monad<m> - [output (f input init)] - (foldM Monad<m> f output inputs')))) - (macro: #hidden (^open' tokens) (case tokens (^ (list [_ (#Symbol name)] [_ (#Text prefix)] body)) @@ -4427,20 +4428,20 @@ (symbol$ ["" (text/compose prefix t-name)])]) tags))] (do Monad<Meta> - [enhanced-target (foldM Monad<Meta> - (function [[[_ m-name] m-type] enhanced-target] - (do Monad<Meta> - [m-structure (resolve-type-tags m-type)] - (case m-structure - (#;Some m-tags&members) - (recur ["" (text/compose prefix m-name)] - m-tags&members - enhanced-target) - - #;None - (wrap enhanced-target)))) - target - (zip2 tags members))] + [enhanced-target (monad/fold Monad<Meta> + (function [[[_ m-name] m-type] enhanced-target] + (do Monad<Meta> + [m-structure (resolve-type-tags m-type)] + (case m-structure + (#;Some m-tags&members) + (recur ["" (text/compose prefix m-name)] + m-tags&members + enhanced-target) + + #;None + (wrap enhanced-target)))) + target + (zip2 tags members))] (wrap (` ("lux case" (~ (symbol$ source)) {(~ pattern) (~ enhanced-target)}))))))) name tags&members body)] (wrap (list full-body))))) @@ -4476,12 +4477,12 @@ (fail "cond requires an even number of arguments.") (case (reverse tokens) (^ (list& else branches')) - (return (list (fold (: (-> [Code Code] Code Code) - (function [branch else] - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) - else - (as-pairs branches')))) + (return (list (list/fold (: (-> [Code Code] Code Code) + (function [branch else] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) _ (fail "Wrong syntax for cond")))) @@ -4532,11 +4533,11 @@ (fail "get@ can only use records."))) (^ (list [_ (#Tuple slots)] record)) - (return (list (fold (: (-> Code Code Code) - (function [slot inner] - (` (;;get@ (~ slot) (~ inner))))) - record - slots))) + (return (list (list/fold (: (-> Code Code Code) + (function [slot inner] + (` (;;get@ (~ slot) (~ inner))))) + record + slots))) (^ (list selector)) (do Monad<Meta> @@ -4658,7 +4659,7 @@ "\n" (|> options (map code-to-text) (interpose " ") - (fold text/compose ""))))))) + (list/fold text/compose ""))))))) (def: (write-refer module-name [r-defs r-opens]) (-> Text Refer (Meta (List Code))) @@ -4865,17 +4866,17 @@ (function [_] (gensym "temp"))) slots) #let [pairs (zip2 slots bindings) - update-expr (fold (: (-> [Code Code] Code Code) - (function [[s b] v] - (` (;;set@ (~ s) (~ v) (~ b))))) - value - (reverse pairs)) - [_ accesses'] (fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))]) - (function [[new-slot new-binding] [old-record accesses']] - [(` (get@ (~ new-slot) (~ new-binding))) - (#;Cons (list new-binding old-record) accesses')])) - [record (: (List (List Code)) #;Nil)] - pairs) + update-expr (list/fold (: (-> [Code Code] Code Code) + (function [[s b] v] + (` (;;set@ (~ s) (~ v) (~ b))))) + value + (reverse pairs)) + [_ accesses'] (list/fold (: (-> [Code Code] [Code (List (List Code))] [Code (List (List Code))]) + (function [[new-slot new-binding] [old-record accesses']] + [(` (get@ (~ new-slot) (~ new-binding))) + (#;Cons (list new-binding old-record) accesses')])) + [record (: (List (List Code)) #;Nil)] + pairs) accesses (list/join (reverse accesses'))]] (wrap (list (` (let [(~@ accesses)] (~ update-expr))))))) @@ -5052,14 +5053,14 @@ (^template [<tag>] [[_ _ column] (<tag> parts)] - (fold n.min column (map find-baseline-column parts))) + (list/fold n.min column (map find-baseline-column parts))) ([#Form] [#Tuple]) [[_ _ column] (#Record pairs)] - (fold n.min column - (list/compose (map (. find-baseline-column first) pairs) - (map (. find-baseline-column second) pairs))) + (list/fold n.min column + (list/compose (map (. find-baseline-column first) pairs) + (map (. find-baseline-column second) pairs))) )) (type: Doc-Fragment @@ -5165,11 +5166,11 @@ (^template [<tag> <open> <close> <prep>] [group-cursor (<tag> parts)] - (let [[group-cursor' parts-text] (fold (function [part [last-cursor text-accum]] - (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)] - [part-cursor (text/compose text-accum part-text)])) - [(delim-update-cursor group-cursor) ""] - (<prep> parts))] + (let [[group-cursor' parts-text] (list/fold (function [part [last-cursor text-accum]] + (let [[part-cursor part-text] (doc-example->Text last-cursor baseline part)] + [part-cursor (text/compose text-accum part-text)])) + [(delim-update-cursor group-cursor) ""] + (<prep> parts))] [(delim-update-cursor group-cursor') ($_ text/compose (cursor-padding baseline prev-cursor group-cursor) <open> @@ -5565,15 +5566,15 @@ (def: (multi-level-case$ g!_ [[init-pattern levels] body]) (-> Code [Multi-Level-Case Code] (List Code)) - (let [inner-pattern-body (fold (function [[calculation pattern] success] - (` (case (~ calculation) - (~ pattern) - (~ success) - - (~ g!_) - #;None))) - (` (#;Some (~ body))) - (: (List [Code Code]) (reverse levels)))] + (let [inner-pattern-body (list/fold (function [[calculation pattern] success] + (` (case (~ calculation) + (~ pattern) + (~ success) + + (~ g!_) + #;None))) + (` (#;Some (~ body))) + (: (List [Code Code]) (reverse levels)))] (list init-pattern inner-pattern-body))) (macro: #export (^multi tokens) @@ -5973,7 +5974,7 @@ [ann (<tag> parts)] (do Monad<Meta> [=parts (monad/map Monad<Meta> label-code parts)] - (wrap [(fold list/compose (list) (map left =parts)) + (wrap [(list/fold list/compose (list) (map left =parts)) [ann (<tag> (map right =parts))]]))) ([#Form] [#Tuple]) @@ -5988,7 +5989,7 @@ [val-labels val-labelled] =val]] (wrap [(list/compose key-labels val-labels) [key-labelled val-labelled]]))) kvs)] - (wrap [(fold list/compose (list) (map left =kvs)) + (wrap [(list/fold list/compose (list) (map left =kvs)) [ann (#Record (map right =kvs))]])) _ diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 78cdbecce..75bcc52fd 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -20,7 +20,7 @@ (type: (Promise-State a) {#value (Maybe a) - #observers (List (-> a (IO Unit)))}) + #observers (List (-> a (IO Top)))}) (type: #export (Promise a) {#;doc "Represents values produced by asynchronous computations (unlike IO, which is synchronous)."} @@ -74,8 +74,8 @@ (wrap true)) (resolve value promise)))))) -(def: (await f promise) - (All [a] (-> (-> a (IO Unit)) (Promise a) Unit)) +(def: #export (await f promise) + (All [a] (-> (-> a (IO Top)) (Promise a) Top)) (let [old (io;run (atom;read promise))] (case (get@ #value old) (#;Some value) @@ -90,9 +90,7 @@ (struct: #export _ (F;Functor Promise) (def: (map f fa) (let [fb (promise ($ +1))] - (exec (await (function [a] (do Monad<IO> - [_ (resolve (f a) fb)] - (wrap []))) + (exec (await (function [a] (resolve (f a) fb)) fa) fb)))) @@ -106,9 +104,7 @@ (def: (apply ff fa) (let [fb (promise ($ +1))] (exec (await (function [f] - (io (await (function [a] (do Monad<IO> - [_ (resolve (f a) fb)] - (wrap []))) + (io (await (function [a] (resolve (f a) fb)) fa))) ff) fb)) @@ -120,10 +116,7 @@ (def: (join mma) (let [ma (promise ($ +0))] (exec (await (function [ma'] - (io (await (function [a'] - (do Monad<IO> - [_ (resolve a' ma)] - (wrap []))) + (io (await (function [a'] (resolve a' ma)) ma'))) mma) ma)))) @@ -142,10 +135,7 @@ (let [a|b (promise (Either ($ +0) ($ +1)))] (with-expansions [<sides> (do-template [<promise> <tag>] - [(await (function [value] - (do Monad<IO> - [_ (resolve (<tag> value) a|b)] - (wrap []))) + [(await (function [value] (resolve (<tag> value) a|b)) <promise>)] [left #;Left] @@ -158,19 +148,13 @@ {#;doc "Homogeneous alternative combinator."} (All [a] (-> (Promise a) (Promise a) (Promise a))) (let [left||right (promise ($ +0))] - (with-expansions - [<sides> (do-template [<promise>] - [(await [(function [value] - (do Monad<IO> - [_ (resolve value left||right)] - (wrap [])))] - <promise>)] + (`` (exec (~~ (do-template [<promise>] + [(await (function [value] (resolve value left||right)) + <promise>)] - [left] - [right] - )] - (exec <sides> - left||right)))) + [left] + [right])) + left||right)))) (def: #export (future computation) {#;doc "Runs an I/O computation on its own process and returns an Promise that will eventually host its result."} diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index 1fee00b7e..e29edc9a2 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -245,7 +245,14 @@ [inputs (follow pending-commits)] (exec (|> inputs (:! (frp;Channel [(STM Unit) (P;Promise Unit)])) - (frp/map process-commit)) + (P;await (function recur [?inputs] + (io (case ?inputs + #;Nil + [] + + (#;Cons head tail) + (exec (process-commit head) + (P;await recur tail))))))) (wrap []))) (wrap []))) ))) diff --git a/stdlib/source/lux/control/eq.lux b/stdlib/source/lux/control/eq.lux index 9e372bd58..d0f64e908 100644 --- a/stdlib/source/lux/control/eq.lux +++ b/stdlib/source/lux/control/eq.lux @@ -5,13 +5,13 @@ (: (-> a a Bool) =)) -(def: #export (pair left right) +(def: #export (product left right) (All [l r] (-> (Eq l) (Eq r) (Eq [l r]))) (struct (def: (= [a b] [x y]) (and (:: left = a x) (:: right = b y))))) -(def: #export (either left right) +(def: #export (sum left right) (All [l r] (-> (Eq l) (Eq r) (Eq (| l r)))) (struct (def: (= a|b x|y) (case [a|b x|y] diff --git a/stdlib/source/lux/data/coll/priority-queue.lux b/stdlib/source/lux/data/coll/priority-queue.lux index 879ace1e6..96ad71a6b 100644 --- a/stdlib/source/lux/data/coll/priority-queue.lux +++ b/stdlib/source/lux/data/coll/priority-queue.lux @@ -11,8 +11,8 @@ (type: #export (Queue a) (Maybe (F;Fingers Priority a))) -(def: max-priority Priority ("lux nat max-value")) -(def: min-priority Priority ("lux nat min-value")) +(def: max-priority Priority ("lux nat max")) +(def: min-priority Priority ("lux nat min")) (def: #export empty Queue diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index e9009102b..5b8e1946d 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -80,11 +80,10 @@ (def: * d.*) (def: / d./) (def: % d.%) - (def: (negate x) (d.- x ("lux deg max-value"))) + (def: (negate x) (d.- x ("lux deg max"))) (def: abs id) (def: (signum x) - ("lux deg max-value")) - ) + ("lux deg max"))) (do-template [<type> <order> <succ> <pred>] [(struct: #export _ (Enum <type>) @@ -94,8 +93,8 @@ [Nat Order<Nat> n.inc n.dec] [Int Order<Int> i.inc i.dec] - [Frac Order<Frac> (f.+ ("lux frac smallest-value")) (f.- ("lux frac smallest-value"))] - [Deg Order<Deg> (d.+ ("lux deg min-value")) (d.- ("lux deg min-value"))] + [Frac Order<Frac> (f.+ ("lux frac smallest")) (f.- ("lux frac smallest"))] + [Deg Order<Deg> (d.+ ("lux deg min")) (d.- ("lux deg min"))] ) (do-template [<type> <enum> <top> <bottom>] @@ -104,10 +103,10 @@ (def: top <top>) (def: bottom <bottom>))] - [ Nat Enum<Nat> ("lux nat max-value") ("lux nat min-value")] - [ Int Enum<Int> ("lux int max-value") ("lux int min-value")] - [Frac Enum<Frac> ("lux frac max-value") ("lux frac min-value")] - [ Deg Enum<Deg> ("lux deg max-value") ("lux deg min-value")] + [ Nat Enum<Nat> ("lux nat max") ("lux nat min")] + [ Int Enum<Int> ("lux int max") ("lux int min")] + [Frac Enum<Frac> ("lux frac max") ("lux frac min")] + [ Deg Enum<Deg> ("lux deg max") ("lux deg min")] ) (do-template [<name> <type> <identity> <compose>] @@ -193,7 +192,7 @@ (if (n.>= +2 input-size) (case ("lux text char" repr +0) (^ (#;Some (char "+"))) - (let [input ("lux text upper-case" repr)] + (let [input ("lux text upper" repr)] (loop [idx +1 output +0] (if (n.< input-size idx) @@ -244,7 +243,7 @@ _ 1) - input ("lux text upper-case" repr)] + input ("lux text upper" repr)] (loop [idx (if (i.= -1 sign) +1 +0) output 0] (if (n.< input-size idx) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index d0f1e6f15..0611e6e79 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -27,8 +27,8 @@ (-> Text Text) (<proc> input))] - [lower-case "lux text lower-case"] - [upper-case "lux text upper-case"] + [lower-case "lux text lower"] + [upper-case "lux text upper"] ) (def: #export (clip from to input) diff --git a/stdlib/source/lux/lang/syntax.lux b/stdlib/source/lux/lang/syntax.lux index 7bc8e8cca..ae20fd9b6 100644 --- a/stdlib/source/lux/lang/syntax.lux +++ b/stdlib/source/lux/lang/syntax.lux @@ -30,14 +30,17 @@ ["p" parser "p/" Monad<Parser>] ["ex" exception #+ exception:]) (data [bool] - [text] ["e" error] [number] [product] [maybe] + [text] (text ["l" lexer] format) - (coll [sequence #+ Sequence])))) + (coll [sequence #+ Sequence] + [dict #+ Dict])))) + +(type: #export Aliases (Dict Text Text)) (def: white-space Text "\t\v \r\f") (def: new-line Text "\n") @@ -521,8 +524,8 @@ (def: current-module-mark Text (format identifier-separator identifier-separator)) -(def: (ident^ current-module) - (-> Text (l;Lexer [Ident Nat])) +(def: (ident^ current-module aliases) + (-> Text Aliases (l;Lexer [Ident Nat])) ($_ p;either ## When an identifier starts with 2 marks, its module is ## taken to be the current-module being compiled at the moment. @@ -558,7 +561,8 @@ (p;either (do @ [_ (l;this identifier-separator) second-part ident-part^] - (wrap [[first-part second-part] + (wrap [[(|> aliases (dict;get first-part) (maybe;default first-part)) + second-part] ($_ n.+ (text;size first-part) +1 @@ -574,22 +578,22 @@ ## 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> current-module where) - (-> Text Cursor (l;Lexer [Cursor Code])) + [(def: #export (<name> current-module aliases where) + (-> Text Aliases 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^ current-module) +0] - [tag #;Tag (p;after (l;this "#") (ident^ current-module)) +1] + [symbol #;Symbol (ident^ current-module aliases) +0] + [tag #;Tag (p;after (l;this "#") (ident^ current-module aliases)) +1] ) (exception: #export End-Of-File) (exception: #export Unrecognized-Input) -(def: (ast current-module) - (-> Text Cursor (l;Lexer [Cursor Code])) +(def: (ast current-module aliases) + (-> Text Aliases Cursor (l;Lexer [Cursor Code])) (: (-> Cursor (l;Lexer [Cursor Code])) (function ast' [where] (do p;Monad<Parser> @@ -603,8 +607,8 @@ (frac where) (int where) (deg where) - (symbol current-module where) - (tag current-module where) + (symbol current-module aliases where) + (tag current-module aliases where) (text where) (do @ [end? l;end?] @@ -613,9 +617,9 @@ (p;fail (Unrecognized-Input current-module)))) ))))) -(def: #export (read current-module [where offset source]) - (-> Text Source (e;Error [Source Code])) - (case (p;run [offset source] (ast current-module where)) +(def: #export (read current-module aliases [where offset source]) + (-> Text Aliases Source (e;Error [Source Code])) + (case (p;run [offset source] (ast current-module aliases where)) (#e;Error error) (#e;Error error) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index e3cba7a31..fc392d49c 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -453,32 +453,11 @@ #;None (#e;Error ($_ text/compose "Unknown variable: " name)))))) -(def: #export (canonical name) - (-> Ident (Meta Ident)) - (case name - ["" _name] - (do Monad<Meta> - [this-module current-module-name] - (wrap [this-module _name])) - - [_module _name] - (do Monad<Meta> - [this-module-name current-module-name - this-module (find-module this-module-name)] - (case (list;find (|>. product;left (text/= _module)) - (get@ #;module-aliases this-module)) - (#;Some [alias real]) - (wrap [real _name]) - - _ - (wrap name))) - )) - (def: #export (find-def name) {#;doc "Looks-up a definition's whole data in the available modules (including the current one)."} (-> Ident (Meta Def)) (do Monad<Meta> - [name (canonical name)] + [name (normalize name)] (function [compiler] (case (: (Maybe Def) (do maybe;Monad<Maybe> diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index 22190bd93..addc7a33a 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -136,10 +136,10 @@ (|> x' (/ y) (* y) (= x')))) ))))] - ["Nat" r;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id] - ["Int" r;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id] - ["Frac" r;frac f.= f.+ f.- f.* f./ f.% f.> 0.0 1.0 1000000.0 %r id math;floor] - ["Deg" r;deg d.= d.+ d.- d.* d./ d.% d.> .0 ("lux deg max-value") ("lux deg max-value") %f id id] + ["Nat" r;nat n.= n.+ n.- n.* n./ n.% n.> +0 +1 +1000000 %n (n.% +1000) id] + ["Int" r;int i.= i.+ i.- i.* i./ i.% i.> 0 1 1000000 %i (i.% 1000) id] + ["Frac" r;frac f.= f.+ f.- f.* f./ f.% f.> 0.0 1.0 1000000.0 %r id math;floor] + ["Deg" r;deg d.= d.+ d.- d.* d./ d.% d.> .0 ("lux deg max") ("lux deg max") %f id id] ) (do-template [category rand-gen -> <- = <cap> %a %z] diff --git a/stdlib/test/test/lux/data/coll/dict.lux b/stdlib/test/test/lux/data/coll/dict.lux index 536ad8450..ddc1ddd2d 100644 --- a/stdlib/test/test/lux/data/coll/dict.lux +++ b/stdlib/test/test/lux/data/coll/dict.lux @@ -30,7 +30,7 @@ (not (&;empty? dict)))) (test "The functions 'entries', 'keys' and 'values' should be synchronized." - (:: (list;Eq<List> (eq;pair number;Eq<Nat> number;Eq<Nat>)) = + (:: (list;Eq<List> (eq;product number;Eq<Nat> number;Eq<Nat>)) = (&;entries dict) (list;zip2 (&;keys dict) (&;values dict)))) diff --git a/stdlib/test/test/lux/lang/syntax.lux b/stdlib/test/test/lux/lang/syntax.lux index 3eb9bfc02..4a7c16807 100644 --- a/stdlib/test/test/lux/lang/syntax.lux +++ b/stdlib/test/test/lux/lang/syntax.lux @@ -7,7 +7,8 @@ [text] (text format ["l" lexer]) - (coll [list])) + (coll [list] + [dict #+ Dict])) ["r" math/random "r/" Monad<Random>] (macro [code]) (lang ["&" syntax]) @@ -80,20 +81,23 @@ other code^] ($_ seq (test "Can parse Lux code." - (case (&;read "" [default-cursor +0 (code;to-text sample)]) + (case (&;read "" (dict;new text;Hash<Text>) + [default-cursor +0 (code;to-text sample)]) (#e;Error error) false (#e;Success [_ parsed]) (:: code;Eq<Code> = parsed sample))) (test "Can parse Lux multiple code nodes." - (case (&;read "" [default-cursor +0 (format (code;to-text sample) " " - (code;to-text other))]) + (case (&;read "" (dict;new text;Hash<Text>) + [default-cursor +0 (format (code;to-text sample) " " + (code;to-text other))]) (#e;Error error) false (#e;Success [remaining =sample]) - (case (&;read "" remaining) + (case (&;read "" (dict;new text;Hash<Text>) + remaining) (#e;Error error) false @@ -114,11 +118,12 @@ signed? r;bool #let [expected (|> numerator (f./ denominator) (f.* (if signed? -1.0 1.0)))]] (test "Can parse frac ratio syntax." - (case (&;read "" [default-cursor +0 - (format (if signed? "-" "") - (%i (frac-to-int numerator)) - "/" - (%i (frac-to-int denominator)))]) + (case (&;read "" (dict;new text;Hash<Text>) + [default-cursor +0 + (format (if signed? "-" "") + (%i (frac-to-int numerator)) + "/" + (%i (frac-to-int denominator)))]) (#e;Success [_ [_ (#;Frac actual)]]) (f.= expected actual) @@ -131,8 +136,9 @@ (do @ [expected (|> r;nat (:: @ map (n.% +1_000)))] (test "Can parse nat char syntax." - (case (&;read "" [default-cursor +0 - (format "#" (%t (text;from-code expected)) "")]) + (case (&;read "" (dict;new text;Hash<Text>) + [default-cursor +0 + (format "#" (%t (text;from-code expected)) "")]) (#e;Success [_ [_ (#;Nat actual)]]) (n.= expected actual) @@ -181,8 +187,9 @@ (let [bad-match (format (text;from-code x) "\n" (text;from-code y) "\n" (text;from-code z))] - (case (&;read "" [default-cursor +0 - (format "\"" bad-match "\"")]) + (case (&;read "" (dict;new text;Hash<Text>) + [default-cursor +0 + (format "\"" bad-match "\"")]) (#e;Error error) true @@ -195,9 +202,10 @@ good-output (format (text;from-code x) "\n" (text;from-code y) "\n" (text;from-code z))] - (case (&;read "" [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size)))) - +0 - (format "\"" good-input "\"")]) + (case (&;read "" (dict;new text;Hash<Text>) + [(|> default-cursor (update@ #;column (n.+ (n.dec offset-size)))) + +0 + (format "\"" good-input "\"")]) (#e;Error error) false @@ -206,25 +214,28 @@ parsed (code;text good-output))))) (test "Can handle comments." - (case (&;read "" [default-cursor +0 - (format comment (code;to-text sample))]) + (case (&;read "" (dict;new text;Hash<Text>) + [default-cursor +0 + (format comment (code;to-text sample))]) (#e;Error error) false (#e;Success [_ parsed]) (:: code;Eq<Code> = parsed sample))) (test "Will reject unbalanced multi-line comments." - (and (case (&;read "" [default-cursor +0 - (format "#(" "#(" unbalanced-comment ")#" - (code;to-text sample))]) + (and (case (&;read "" (dict;new text;Hash<Text>) + [default-cursor +0 + (format "#(" "#(" unbalanced-comment ")#" + (code;to-text sample))]) (#e;Error error) true (#e;Success [_ parsed]) false) - (case (&;read "" [default-cursor +0 - (format "#(" unbalanced-comment ")#" ")#" - (code;to-text sample))]) + (case (&;read "" (dict;new text;Hash<Text>) + [default-cursor +0 + (format "#(" unbalanced-comment ")#" ")#" + (code;to-text sample))]) (#e;Error error) true |