aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2017-11-21 16:09:07 -0400
committerEduardo Julian2017-11-21 16:09:07 -0400
commite37e3713e080606930a5f8442f03dabc4c26a7f9 (patch)
treead772c1801af0d01dc105bccf85703f13b127e50
parent3eabc421e559e7e2f903e06eb6b47a2ee0cd25b9 (diff)
- Fixed some bugs.
- Some small refactoring.
Diffstat (limited to '')
-rw-r--r--luxc/src/lux/analyser/proc/common.clj44
-rw-r--r--luxc/src/lux/compiler/js/proc/common.clj44
-rw-r--r--luxc/src/lux/compiler/jvm/proc/common.clj44
-rw-r--r--new-luxc/source/luxc/lang/analysis/case.lux2
-rw-r--r--new-luxc/source/luxc/lang/analysis/expression.lux15
-rw-r--r--new-luxc/source/luxc/lang/analysis/function.lux6
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure/common.lux2
-rw-r--r--new-luxc/source/luxc/lang/analysis/reference.lux3
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux61
-rw-r--r--new-luxc/source/luxc/lang/synthesis/case.lux69
-rw-r--r--new-luxc/source/luxc/lang/synthesis/expression.lux84
-rw-r--r--new-luxc/source/luxc/lang/synthesis/loop.lux39
-rw-r--r--new-luxc/source/luxc/lang/translation.lux92
-rw-r--r--new-luxc/source/luxc/lang/translation/imports.jvm.lux1
-rw-r--r--new-luxc/source/luxc/lang/translation/loop.jvm.lux58
-rw-r--r--new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux127
-rw-r--r--new-luxc/source/luxc/lang/translation/runtime.jvm.lux4
-rw-r--r--stdlib/source/lux.lux609
-rw-r--r--stdlib/source/lux/concurrency/promise.lux42
-rw-r--r--stdlib/source/lux/concurrency/stm.lux9
-rw-r--r--stdlib/source/lux/control/eq.lux4
-rw-r--r--stdlib/source/lux/data/coll/priority-queue.lux4
-rw-r--r--stdlib/source/lux/data/number.lux21
-rw-r--r--stdlib/source/lux/data/text.lux4
-rw-r--r--stdlib/source/lux/lang/syntax.lux36
-rw-r--r--stdlib/source/lux/macro.lux23
-rw-r--r--stdlib/test/test/lux.lux8
-rw-r--r--stdlib/test/test/lux/data/coll/dict.lux2
-rw-r--r--stdlib/test/test/lux/lang/syntax.lux61
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