diff options
21 files changed, 451 insertions, 333 deletions
diff --git a/luxc/src/lux/analyser/proc/common.clj b/luxc/src/lux/analyser/proc/common.clj index 1dce02b2c..7031a9135 100644 --- a/luxc/src/lux/analyser/proc/common.clj +++ b/luxc/src/lux/analyser/proc/common.clj @@ -289,7 +289,7 @@ ^:private analyse-nat-to-int &type/Nat &type/Int ["nat" "to-int"] ^:private analyse-int-to-nat &type/Int &type/Nat ["int" "to-nat"] - ^:private analyse-nat-to-char &type/Nat &type/Text ["nat" "to-char"] + ^:private analyse-nat-char &type/Nat &type/Text ["nat" "char"] ^:private analyse-int-to-frac &type/Int &type/Frac ["int" "to-frac"] ^:private analyse-frac-to-int &type/Frac &type/Int ["frac" "to-int"] @@ -365,18 +365,6 @@ (do-template [<name> <proc>] (defn <name> [analyse exo-type ?values] - (|do [:let [(&/$Nil) ?values] - _ (&type/check exo-type &type/Frac) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["math" <proc>]) (&/|list) (&/|list))))))) - - ^:private analyse-math-e "e" - ^:private analyse-math-pi "pi" - ) - -(do-template [<name> <proc>] - (defn <name> [analyse exo-type ?values] (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] =input (&&/analyse-1 analyse &type/Frac ?input) _ (&type/check exo-type &type/Frac) @@ -426,7 +414,7 @@ (return (&/|list (&&/|meta exo-type _cursor (&&/$proc (&/T ["atom" "new"]) (&/|list =init) (&/|list))))))))) -(defn ^:private analyse-atom-get [analyse exo-type ?values] +(defn ^:private analyse-atom-read [analyse exo-type ?values] (&type/with-var (fn [$var] (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values] @@ -434,7 +422,7 @@ _ (&type/check exo-type $var) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&&/$proc (&/T ["atom" "get"]) (&/|list =atom) (&/|list))))))))) + (&&/$proc (&/T ["atom" "read"]) (&/|list =atom) (&/|list))))))))) (defn ^:private analyse-atom-compare-and-swap [analyse exo-type ?values] (&type/with-var @@ -519,7 +507,7 @@ "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) + "lux nat char" (analyse-nat-char analyse exo-type ?values) "lux int +" (analyse-int-add analyse exo-type ?values) "lux int -" (analyse-int-sub analyse exo-type ?values) @@ -564,8 +552,6 @@ "lux frac to-deg" (analyse-frac-to-deg analyse exo-type ?values) "lux frac to-int" (analyse-frac-to-int analyse exo-type ?values) - "lux math e" (analyse-math-e analyse exo-type ?values) - "lux math pi" (analyse-math-pi analyse exo-type ?values) "lux math cos" (analyse-math-cos analyse exo-type ?values) "lux math sin" (analyse-math-sin analyse exo-type ?values) "lux math tan" (analyse-math-tan analyse exo-type ?values) @@ -586,7 +572,7 @@ "lux math pow" (analyse-math-pow analyse exo-type ?values) "lux atom new" (analyse-atom-new analyse exo-type ?values) - "lux atom get" (analyse-atom-get analyse exo-type ?values) + "lux atom read" (analyse-atom-read analyse exo-type ?values) "lux atom compare-and-swap" (analyse-atom-compare-and-swap analyse exo-type ?values) "lux process concurrency-level" (analyse-process-concurrency-level analyse exo-type ?values) diff --git a/luxc/src/lux/compiler/jvm/proc/common.clj b/luxc/src/lux/compiler/jvm/proc/common.clj index 3c948e8bc..bead93256 100644 --- a/luxc/src/lux/compiler/jvm/proc/common.clj +++ b/luxc/src/lux/compiler/jvm/proc/common.clj @@ -415,7 +415,7 @@ ^:private compile-frac-to-deg "java.lang.Double" "frac-to-deg" "(D)J" &&/unwrap-double &&/wrap-long ) -(defn ^:private compile-nat-to-char [compile ?values special-args] +(defn ^:private compile-nat-char [compile ?values special-args] (|do [:let [(&/$Cons ?x (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?x) @@ -667,19 +667,6 @@ &&/wrap-long)]] (return nil))) -(do-template [<name> <field>] - (defn <name> [compile ?values special-args] - (|do [:let [(&/$Nil) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Math" <field> "D") - &&/wrap-double)]] - (return nil))) - - ^:private compile-math-e "E" - ^:private compile-math-pi "PI" - ) - (do-template [<name> <method>] (defn <name> [compile ?values special-args] (|do [:let [(&/$Cons ?input (&/$Nil)) ?values] @@ -749,7 +736,7 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/util/concurrent/atomic/AtomicReference" "<init>" "(Ljava/lang/Object;)V"))]] (return nil))) -(defn ^:private compile-atom-get [compile ?values special-args] +(defn ^:private compile-atom-read [compile ?values special-args] (|do [:let [(&/$Cons ?atom (&/$Nil)) ?values] ^MethodVisitor *writer* &/get-writer _ (compile ?atom) @@ -865,7 +852,7 @@ "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) + "char" (compile-nat-char compile ?values special-args) ) "deg" @@ -922,8 +909,6 @@ "math" (case proc - "e" (compile-math-e compile ?values special-args) - "pi" (compile-math-pi compile ?values special-args) "cos" (compile-math-cos compile ?values special-args) "sin" (compile-math-sin compile ?values special-args) "tan" (compile-math-tan compile ?values special-args) @@ -947,7 +932,7 @@ "atom" (case proc "new" (compile-atom-new compile ?values special-args) - "get" (compile-atom-get compile ?values special-args) + "read" (compile-atom-read compile ?values special-args) "compare-and-swap" (compile-atom-compare-and-swap 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 5d4c592aa..949e18a26 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -35,6 +35,15 @@ (format " Type: " (%type type) "\n" "Pattern: " (%code pattern))) +(def: (re-quantify envs baseT) + (-> (List (List Type)) Type Type) + (case envs + #;Nil + baseT + + (#;Cons head tail) + (re-quantify tail (#;UnivQ head baseT)))) + ## Type-checking on the input value is done during the analysis of a ## "case" expression, to ensure that the patterns being used make ## sense for the type of the input value. @@ -44,52 +53,74 @@ ## type-check the input with respect to the patterns. (def: (simplify-case-type caseT) (-> Type (Meta Type)) - (case caseT - (#;Var id) - (do macro;Monad<Meta> - [?caseT' (&;with-type-env - (tc;read id))] - (case ?caseT' - (#;Some caseT') - (simplify-case-type caseT') + (loop [envs (: (List (List Type)) + (list)) + caseT caseT] + (case caseT + (#;Var id) + (do macro;Monad<Meta> + [?caseT' (&;with-type-env + (tc;read id))] + (case ?caseT' + (#;Some caseT') + (recur envs caseT') - _ - (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + _ + (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) - (#;Named name unnamedT) - (simplify-case-type unnamedT) + (#;Named name unnamedT) + (recur envs unnamedT) - (^or (#;UnivQ _) (#;ExQ _)) - (do macro;Monad<Meta> - [[ex-id exT] (&;with-type-env - tc;existential)] - (simplify-case-type (maybe;assume (type;apply (list exT) caseT)))) + (#;UnivQ env unquantifiedT) + (recur (#;Cons env envs) unquantifiedT) - (#;Apply inputT funcT) - (case funcT - (#;Var funcT-id) + ## (^template [<tag> <instancer>] + ## (<tag> _) + ## (do macro;Monad<Meta> + ## [[_ instanceT] (&;with-type-env + ## <instancer>)] + ## (recur (maybe;assume (type;apply (list instanceT) caseT))))) + ## ([#;UnivQ tc;var] + ## [#;ExQ tc;existential]) + + (#;ExQ _) (do macro;Monad<Meta> - [funcT' (&;with-type-env - (do tc;Monad<Check> - [?funct' (tc;read funcT-id)] - (case ?funct' - (#;Some funct') - (wrap funct') + [[ex-id exT] (&;with-type-env + tc;existential)] + (recur envs (maybe;assume (type;apply (list exT) caseT)))) - _ - (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))] - (simplify-case-type (#;Apply inputT funcT'))) + (#;Apply inputT funcT) + (case funcT + (#;Var funcT-id) + (do macro;Monad<Meta> + [funcT' (&;with-type-env + (do tc;Monad<Check> + [?funct' (tc;read funcT-id)] + (case ?funct' + (#;Some funct') + (wrap funct') - _ - (case (type;apply (list inputT) funcT) - (#;Some outputT) - (:: macro;Monad<Meta> wrap outputT) + _ + (tc;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))))] + (recur envs (#;Apply inputT funcT'))) - #;None - (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + _ + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (recur envs outputT) - _ - (:: macro;Monad<Meta> wrap caseT))) + #;None + (&;throw Cannot-Simplify-Type-For-Pattern-Matching (%type caseT)))) + + (#;Product _) + (|> caseT + type;flatten-tuple + (list/map (re-quantify envs)) + type;tuple + (:: macro;Monad<Meta> wrap)) + + _ + (:: macro;Monad<Meta> wrap (re-quantify envs caseT))))) ## This function handles several concerns at once, but it must be that ## way because those concerns are interleaved when doing diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/new-luxc/source/luxc/lang/analysis/inference.lux index c6f0323f7..e89ab2e1e 100644 --- a/new-luxc/source/luxc/lang/analysis/inference.lux +++ b/new-luxc/source/luxc/lang/analysis/inference.lux @@ -132,9 +132,9 @@ )) ## Turns a record type into the kind of function type suitable for inference. -(def: #export (record type) +(def: #export (record inferT) (-> Type (Meta Type)) - (case type + (case inferT (#;Named name unnamedT) (record unnamedT) @@ -146,17 +146,25 @@ ([#;UnivQ] [#;ExQ]) + (#;Apply inputT funcT) + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (record outputT) + + #;None + (&;throw Invalid-Type-Application (%type inferT))) + (#;Product _) - (macro/wrap (type;function (type;flatten-tuple type) type)) + (macro/wrap (type;function (type;flatten-tuple inferT) inferT)) _ - (&;throw Not-A-Record-Type (%type type)))) + (&;throw Not-A-Record-Type (%type inferT)))) ## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant tag expected-size type) +(def: #export (variant tag expected-size inferT) (-> Nat Nat Type (Meta Type)) (loop [depth +0 - currentT type] + currentT inferT] (case currentT (#;Named name unnamedT) (do macro;Monad<Meta> @@ -182,12 +190,12 @@ (#;Some caseT) (macro/wrap (if (n.= +0 depth) (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)] (type;function (list (replace! caseT)) (replace! currentT))))) #;None - (&common;variant-out-of-bounds-error type expected-size tag)) + (&common;variant-out-of-bounds-error inferT expected-size tag)) (n.< expected-size actual-size) (&;throw Smaller-Variant-Than-Expected @@ -198,12 +206,20 @@ (let [caseT (type;variant (list;drop boundary cases))] (macro/wrap (if (n.= +0 depth) (type;function (list caseT) currentT) - (let [replace! (replace-bound (|> depth n.dec (n.* +2)) type)] + (let [replace! (replace-bound (|> depth n.dec (n.* +2)) inferT)] (type;function (list (replace! caseT)) (replace! currentT)))))) ## else - (&common;variant-out-of-bounds-error type expected-size tag))) + (&common;variant-out-of-bounds-error inferT expected-size tag))) + + (#;Apply inputT funcT) + (case (type;apply (list inputT) funcT) + (#;Some outputT) + (variant tag expected-size outputT) + + #;None + (&;throw Invalid-Type-Application (%type inferT))) _ - (&;throw Not-A-Variant-Type (%type type))))) + (&;throw Not-A-Variant-Type (%type inferT))))) diff --git a/new-luxc/source/luxc/lang/analysis/procedure/common.lux b/new-luxc/source/luxc/lang/analysis/procedure/common.lux index 489414c2a..f5afca5bf 100644 --- a/new-luxc/source/luxc/lang/analysis/procedure/common.lux +++ b/new-luxc/source/luxc/lang/analysis/procedure/common.lux @@ -172,7 +172,7 @@ (|> (dict;new text;Hash<Text>) (install "log" (unary Text Unit)) (install "error" (unary Text Bottom)) - (install "exit" (unary Nat Bottom)) + (install "exit" (unary Int Bottom)) (install "current-time" (nullary Int))))) (def: bit-procs @@ -202,7 +202,7 @@ (install "min" (nullary Nat)) (install "max" (nullary Nat)) (install "to-int" (unary Nat Int)) - (install "to-text" (unary Nat Text))))) + (install "char" (unary Nat Text))))) (def: int-procs Bundle @@ -277,28 +277,28 @@ (install "lower" (unary Text Text)) ))) -(def: (array-get proc) +(def: (array//get proc) (-> Text Proc) (function [analyse eval args] (do macro;Monad<Meta> [[var-id varT] (&;with-type-env tc;var)] - ((binary Nat (type (Array varT)) varT proc) + ((binary (type (Array varT)) Nat (type (Maybe varT)) proc) analyse eval args)))) -(def: (array-put proc) +(def: (array//put proc) (-> Text Proc) (function [analyse eval args] (do macro;Monad<Meta> [[var-id varT] (&;with-type-env tc;var)] - ((trinary Nat varT (type (Array varT)) (type (Array varT)) proc) + ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc) analyse eval args)))) -(def: (array-remove proc) +(def: (array//remove proc) (-> Text Proc) (function [analyse eval args] (do macro;Monad<Meta> [[var-id varT] (&;with-type-env tc;var)] - ((binary Nat (type (Array varT)) (type (Array varT)) proc) + ((binary (type (Array varT)) Nat (type (Array varT)) proc) analyse eval args)))) (def: array-procs @@ -306,9 +306,9 @@ (<| (prefix "array") (|> (dict;new text;Hash<Text>) (install "new" (unary Nat Array)) - (install "get" array-get) - (install "put" array-put) - (install "remove" array-remove) + (install "get" array//get) + (install "put" array//put) + (install "remove" array//remove) (install "size" (unary (type (Ex [a] (Array a))) Nat)) ))) @@ -359,12 +359,12 @@ ((unary (type (Atom varT)) varT proc) analyse eval args)))) -(def: (atom-compare-and-swap proc) +(def: (atom//compare-and-swap proc) (-> Text Proc) (function [analyse eval args] (do macro;Monad<Meta> [[var-id varT] (&;with-type-env tc;var)] - ((trinary varT varT (type (Atom varT)) Bool proc) + ((trinary (type (Atom varT)) varT varT Bool proc) analyse eval args)))) (def: atom-procs @@ -373,7 +373,7 @@ (|> (dict;new text;Hash<Text>) (install "new" atom-new) (install "read" atom-read) - (install "compare-and-swap" atom-compare-and-swap) + (install "compare-and-swap" atom//compare-and-swap) ))) (def: process-procs diff --git a/new-luxc/source/luxc/lang/synthesis/loop.lux b/new-luxc/source/luxc/lang/synthesis/loop.lux index ac72e69b2..a5da743d5 100644 --- a/new-luxc/source/luxc/lang/synthesis/loop.lux +++ b/new-luxc/source/luxc/lang/synthesis/loop.lux @@ -152,7 +152,7 @@ _ _var)) environment))] - (~ (recur bodyS)))) + (~ bodyS))) (^ [_ (#;Form (list& [_ (#;Text "lux call")] funcS argsS))]) (` ("lux call" (~ (recur funcS)) (~@ (list/map recur argsS)))) @@ -160,15 +160,7 @@ (^ [_ (#;Form (list& [_ (#;Text "lux recur")] argsS))]) (` ("lux recur" (~@ (list/map recur argsS)))) - (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) - (` ((~ (code;text procedure)) (~@ (list/map recur argsS)))) - - (^ [_ (#;Form (list [_ (#;Int var)]))]) - (if (variableL;captured? var) - (` ((~ (code;int (resolve-captured var))))) - (` ((~ (code;int (|> offset nat-to-int (i.+ var))))))) - - (^ [_ (#;Form (list [_ (#;Text "lux let")] [_ (#;Nat register)] inputS bodyS))]) + (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ bodyS))) (` ("lux let" (~ (code;nat (n.+ offset register))) (~ (recur inputS)) (~ (recur bodyS)))) @@ -183,6 +175,14 @@ [(~@ (list/map recur initsS))] (~ (recur bodyS)))) + (^ [_ (#;Form (list [_ (#;Int var)]))]) + (if (variableL;captured? var) + (` ((~ (code;int (resolve-captured var))))) + (` ((~ (code;int (|> offset nat-to-int (i.+ var))))))) + + (^ [_ (#;Form (list& [_ (#;Text procedure)] argsS))]) + (` ((~ (code;text procedure)) (~@ (list/map recur argsS)))) + _ exprS )))) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index fbecf2da5..80484b7e8 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -128,8 +128,9 @@ (analyse valueC)))) valueT (&;with-type-env (tc;clean valueT)) - ## #let [_ (if (or (text/= "list/size" def-name)) + ## #let [_ (if (or (text/= "string~" def-name)) ## (log! (format "{" def-name "}\n" + ## " TYPE: " (%type valueT) "\n" ## " ANALYSIS: " (%code valueA) "\n" ## "SYNTHESIS: " (%code (expressionS;synthesize valueA)))) ## [])] 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 6c1b18932..01f2a33c7 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -224,7 +224,7 @@ ## [[Arrays]] (def: (array//new lengthI) Unary - (|>. lengthI jvm-intI ($i;ANEWARRAY ($t;descriptor $Object)))) + (|>. lengthI jvm-intI ($i;ANEWARRAY ($t;binary-name "java.lang.Object")))) (def: (array//get [arrayI idxI]) Binary @@ -348,9 +348,8 @@ (|>. inputI <prepare> <transform>))] [nat//to-int id id] - [nat//to-char ($i;unwrap #$;Long) - (<| ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false) - $i;I2C $i;L2I)] + [nat//char ($i;unwrap #$;Long) + ((|>. $i;L2I $i;I2C ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false)))] [int//to-nat id id] [int//to-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)] @@ -397,7 +396,7 @@ ($i;wrap #$;Boolean)] [text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false) - (predicateI $i;IF_ICMPEQ)] + (<| (predicateI $i;IF_ICMPEQ) ($i;int -1))] [text//concat ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false) id] @@ -563,7 +562,8 @@ ## [[Processes]] (def: (process//concurrency-level []) Nullary - (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int) + (|>. ($i;INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t;method (list) (#;Some ($t;class "java.lang.Runtime" (list))) (list)) false) + ($i;INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t;method (list) (#;Some $t;int) (list)) false) lux-intI)) (def: (process//future procedureI) @@ -593,82 +593,87 @@ (def: bit-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "bit count" (unary bit//count)) - (install "bit and" (binary bit//and)) - (install "bit or" (binary bit//or)) - (install "bit xor" (binary bit//xor)) - (install "bit shift-left" (binary bit//shift-left)) - (install "bit unsigned-shift-right" (binary bit//unsigned-shift-right)) - (install "bit shift-right" (binary bit//shift-right)) - )) + (<| (prefix "bit") + (|> (dict;new text;Hash<Text>) + (install "count" (unary bit//count)) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "shift-left" (binary bit//shift-left)) + (install "unsigned-shift-right" (binary bit//unsigned-shift-right)) + (install "shift-right" (binary bit//shift-right)) + ))) (def: nat-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "nat +" (binary nat//add)) - (install "nat -" (binary nat//sub)) - (install "nat *" (binary nat//mul)) - (install "nat /" (binary nat//div)) - (install "nat %" (binary nat//rem)) - (install "nat =" (binary nat//eq)) - (install "nat <" (binary nat//lt)) - (install "nat min" (nullary nat//min)) - (install "nat max" (nullary nat//max)) - (install "nat to-int" (unary nat//to-int)) - (install "nat to-char" (unary nat//to-char)))) + (<| (prefix "nat") + (|> (dict;new text;Hash<Text>) + (install "+" (binary nat//add)) + (install "-" (binary nat//sub)) + (install "*" (binary nat//mul)) + (install "/" (binary nat//div)) + (install "%" (binary nat//rem)) + (install "=" (binary nat//eq)) + (install "<" (binary nat//lt)) + (install "min" (nullary nat//min)) + (install "max" (nullary nat//max)) + (install "to-int" (unary nat//to-int)) + (install "char" (unary nat//char))))) (def: int-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "int +" (binary int//add)) - (install "int -" (binary int//sub)) - (install "int *" (binary int//mul)) - (install "int /" (binary int//div)) - (install "int %" (binary int//rem)) - (install "int =" (binary int//eq)) - (install "int <" (binary int//lt)) - (install "int min" (nullary int//min)) - (install "int max" (nullary int//max)) - (install "int to-nat" (unary int//to-nat)) - (install "int to-frac" (unary int//to-frac)))) + (<| (prefix "int") + (|> (dict;new text;Hash<Text>) + (install "+" (binary int//add)) + (install "-" (binary int//sub)) + (install "*" (binary int//mul)) + (install "/" (binary int//div)) + (install "%" (binary int//rem)) + (install "=" (binary int//eq)) + (install "<" (binary int//lt)) + (install "min" (nullary int//min)) + (install "max" (nullary int//max)) + (install "to-nat" (unary int//to-nat)) + (install "to-frac" (unary int//to-frac))))) (def: deg-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "deg +" (binary deg//add)) - (install "deg -" (binary deg//sub)) - (install "deg *" (binary deg//mul)) - (install "deg /" (binary deg//div)) - (install "deg %" (binary deg//rem)) - (install "deg =" (binary deg//eq)) - (install "deg <" (binary deg//lt)) - (install "deg scale" (binary deg//scale)) - (install "deg reciprocal" (binary deg//reciprocal)) - (install "deg min" (nullary deg//min)) - (install "deg max" (nullary deg//max)) - (install "deg to-frac" (unary deg//to-frac)))) + (<| (prefix "deg") + (|> (dict;new text;Hash<Text>) + (install "+" (binary deg//add)) + (install "-" (binary deg//sub)) + (install "*" (binary deg//mul)) + (install "/" (binary deg//div)) + (install "%" (binary deg//rem)) + (install "=" (binary deg//eq)) + (install "<" (binary deg//lt)) + (install "scale" (binary deg//scale)) + (install "reciprocal" (binary deg//reciprocal)) + (install "min" (nullary deg//min)) + (install "max" (nullary deg//max)) + (install "to-frac" (unary deg//to-frac))))) (def: frac-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "frac +" (binary frac//add)) - (install "frac -" (binary frac//sub)) - (install "frac *" (binary frac//mul)) - (install "frac /" (binary frac//div)) - (install "frac %" (binary frac//rem)) - (install "frac =" (binary frac//eq)) - (install "frac <" (binary frac//lt)) - (install "frac smallest" (nullary frac//smallest)) - (install "frac min" (nullary frac//min)) - (install "frac max" (nullary frac//max)) - (install "frac not-a-number" (nullary frac//not-a-number)) - (install "frac positive-infinity" (nullary frac//positive-infinity)) - (install "frac negative-infinity" (nullary frac//negative-infinity)) - (install "frac to-deg" (unary frac//to-deg)) - (install "frac to-int" (unary frac//to-int)) - (install "frac encode" (unary frac//encode)) - (install "frac decode" (unary frac//decode)))) + (<| (prefix "frac") + (|> (dict;new text;Hash<Text>) + (install "+" (binary frac//add)) + (install "-" (binary frac//sub)) + (install "*" (binary frac//mul)) + (install "/" (binary frac//div)) + (install "%" (binary frac//rem)) + (install "=" (binary frac//eq)) + (install "<" (binary frac//lt)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "not-a-number" (nullary frac//not-a-number)) + (install "positive-infinity" (nullary frac//positive-infinity)) + (install "negative-infinity" (nullary frac//negative-infinity)) + (install "to-deg" (unary frac//to-deg)) + (install "to-int" (unary frac//to-int)) + (install "encode" (unary frac//encode)) + (install "decode" (unary frac//decode))))) (def: text-procs Bundle @@ -690,59 +695,64 @@ (def: array-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "array new" (unary array//new)) - (install "array get" (binary array//get)) - (install "array put" (trinary array//put)) - (install "array remove" (binary array//remove)) - (install "array size" (unary array//size)) - )) + (<| (prefix "array") + (|> (dict;new text;Hash<Text>) + (install "new" (unary array//new)) + (install "get" (binary array//get)) + (install "put" (trinary array//put)) + (install "remove" (binary array//remove)) + (install "size" (unary array//size)) + ))) (def: math-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "math cos" (unary math//cos)) - (install "math sin" (unary math//sin)) - (install "math tan" (unary math//tan)) - (install "math acos" (unary math//acos)) - (install "math asin" (unary math//asin)) - (install "math atan" (unary math//atan)) - (install "math cosh" (unary math//cosh)) - (install "math sinh" (unary math//sinh)) - (install "math tanh" (unary math//tanh)) - (install "math exp" (unary math//exp)) - (install "math log" (unary math//log)) - (install "math root2" (unary math//root2)) - (install "math root3" (unary math//root3)) - (install "math ceil" (unary math//ceil)) - (install "math floor" (unary math//floor)) - (install "math round" (unary math//round)) - (install "math atan2" (binary math//atan2)) - (install "math pow" (binary math//pow)) - )) + (<| (prefix "math") + (|> (dict;new text;Hash<Text>) + (install "cos" (unary math//cos)) + (install "sin" (unary math//sin)) + (install "tan" (unary math//tan)) + (install "acos" (unary math//acos)) + (install "asin" (unary math//asin)) + (install "atan" (unary math//atan)) + (install "cosh" (unary math//cosh)) + (install "sinh" (unary math//sinh)) + (install "tanh" (unary math//tanh)) + (install "exp" (unary math//exp)) + (install "log" (unary math//log)) + (install "root2" (unary math//root2)) + (install "root3" (unary math//root3)) + (install "ceil" (unary math//ceil)) + (install "floor" (unary math//floor)) + (install "round" (unary math//round)) + (install "atan2" (binary math//atan2)) + (install "pow" (binary math//pow)) + ))) (def: io-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "io log" (unary io//log)) - (install "io error" (unary io//error)) - (install "io exit" (unary io//exit)) - (install "io current-time" (nullary io//current-time)))) + (<| (prefix "io") + (|> (dict;new text;Hash<Text>) + (install "log" (unary io//log)) + (install "error" (unary io//error)) + (install "exit" (unary io//exit)) + (install "current-time" (nullary io//current-time))))) (def: atom-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "atom new" (unary atom//new)) - (install "atom read" (unary atom//read)) - (install "atom compare-and-swap" (trinary atom//compare-and-swap)))) + (<| (prefix "atom") + (|> (dict;new text;Hash<Text>) + (install "new" (unary atom//new)) + (install "read" (unary atom//read)) + (install "compare-and-swap" (trinary atom//compare-and-swap))))) (def: process-procs Bundle - (|> (dict;new text;Hash<Text>) - (install "process concurrency-level" (nullary process//concurrency-level)) - (install "process future" (unary process//future)) - (install "process schedule" (binary process//schedule)) - )) + (<| (prefix "process") + (|> (dict;new text;Hash<Text>) + (install "concurrency-level" (nullary process//concurrency-level)) + (install "future" (unary process//future)) + (install "schedule" (binary process//schedule)) + ))) (def: #export procedures Bundle diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux index 2837d6177..f2e1cc14e 100644 --- a/stdlib/source/lux/concurrency/atom.lux +++ b/stdlib/source/lux/concurrency/atom.lux @@ -13,7 +13,7 @@ (def: #export (read atom) (All [a] (-> (Atom a) (IO a))) - (io ("lux atom get" atom))) + (io ("lux atom read" atom))) (def: #export (compare-and-swap current new atom) {#;doc "Only mutates an atom if you can present it's current value. @@ -29,7 +29,7 @@ The retries will be done with the new values of the atom, as they show up."} (All [a] (-> (-> a a) (Atom a) (IO Unit))) - (io (let [old ("lux atom get" atom)] + (io (let [old ("lux atom read" atom)] (if ("lux atom compare-and-swap" atom old (f old)) [] (io;run (update f atom)))))) diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 75bcc52fd..9baaded11 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -89,7 +89,9 @@ (struct: #export _ (F;Functor Promise) (def: (map f fa) - (let [fb (promise ($ +1))] + (let [fb (promise ($ +1)) + ## fb (promise' #;None) + ] (exec (await (function [a] (resolve (f a) fb)) fa) fb)))) @@ -102,7 +104,9 @@ #observers (list)})) (def: (apply ff fa) - (let [fb (promise ($ +1))] + (let [fb (promise ($ +1)) + ## fb (promise' #;None) + ] (exec (await (function [f] (io (await (function [a] (resolve (f a) fb)) fa))) @@ -114,7 +118,9 @@ (def: applicative Applicative<Promise>) (def: (join mma) - (let [ma (promise ($ +0))] + (let [ma (promise ($ +0)) + ## ma (promise' #;None) + ] (exec (await (function [ma'] (io (await (function [a'] (resolve a' ma)) ma'))) @@ -132,7 +138,9 @@ (def: #export (alt left right) {#;doc "Heterogeneous alternative combinator."} (All [a b] (-> (Promise a) (Promise b) (Promise (| a b)))) - (let [a|b (promise (Either ($ +0) ($ +1)))] + (let [a|b (promise (| ($ +0) ($ +1))) + ## a|b (promise' #;None) + ] (with-expansions [<sides> (do-template [<promise> <tag>] [(await (function [value] (resolve (<tag> value) a|b)) @@ -147,7 +155,9 @@ (def: #export (either left right) {#;doc "Homogeneous alternative combinator."} (All [a] (-> (Promise a) (Promise a) (Promise a))) - (let [left||right (promise ($ +0))] + (let [left||right (promise ($ +0)) + ## left||right (promise' #;None) + ] (`` (exec (~~ (do-template [<promise>] [(await (function [value] (resolve value left||right)) <promise>)] @@ -159,7 +169,9 @@ (def: #export (future computation) {#;doc "Runs an I/O computation on its own process and returns an Promise that will eventually host its result."} (All [a] (-> (IO a) (Promise a))) - (let [!out (promise ($ +0))] + (let [!out (promise ($ +0)) + ## !out (promise' #;None) + ] (exec ("lux process future" (io (io;run (resolve (io;run computation) !out)))) !out))) diff --git a/stdlib/source/lux/control/applicative.lux b/stdlib/source/lux/control/applicative.lux index 187950aa9..d2b505941 100644 --- a/stdlib/source/lux/control/applicative.lux +++ b/stdlib/source/lux/control/applicative.lux @@ -1,10 +1,10 @@ (;module: lux - (.. ["F" functor])) + (.. [functor #+ Functor])) (sig: #export (Applicative f) {#;doc "Applicative functors."} - (: (F;Functor f) + (: (Functor f) functor) (: (All [a] (-> a (f a))) @@ -16,15 +16,20 @@ (struct: #export (compose Applicative<F> Applicative<G>) {#;doc "Applicative functor composition."} (All [F G] (-> (Applicative F) (Applicative G) (Applicative (All [a] (F (G a)))))) - (def: functor (F;compose (get@ #functor Applicative<F>) - (get@ #functor Applicative<G>))) + + (def: functor (functor;compose (get@ #functor Applicative<F>) + (get@ #functor Applicative<G>))) (def: wrap (|>. (:: Applicative<G> wrap) (:: Applicative<F> wrap))) (def: (apply fgf fgx) + ## (let [fgf' (:: Applicative<F> apply + ## (:: Applicative<F> wrap (:: Applicative<G> apply)) + ## fgf)] + ## (:: Applicative<F> apply fgf' fgx)) (let [applyF (:: Applicative<F> apply) applyG (:: Applicative<G> apply)] ($_ applyF (:: Applicative<F> wrap applyG) fgf - fgx))) - ) + fgx)) + )) diff --git a/stdlib/source/lux/data/coll/array.lux b/stdlib/source/lux/data/coll/array.lux index 2dbf07803..c697e5681 100644 --- a/stdlib/source/lux/data/coll/array.lux +++ b/stdlib/source/lux/data/coll/array.lux @@ -78,7 +78,19 @@ xs' (delete idx xs'))))) xs - (list;indices (size xs)))) + (list;indices (size xs))) + ## (list/fold (function [idx xs'] + ## (case (read idx xs) + ## #;None + ## xs' + + ## (#;Some x) + ## (if (p x) + ## xs' + ## (delete idx xs')))) + ## xs + ## (list;indices (size xs))) + ) (def: #export (find p xs) (All [a] @@ -195,7 +207,17 @@ (#;Some x) (write idx (f x) mb)))) (new arr-size) - (list;n.range +0 (n.dec arr-size))))))) + (list;n.range +0 (n.dec arr-size))) + ## (list/fold (function [idx mb] + ## (case (read idx ma) + ## #;None + ## mb + + ## (#;Some x) + ## (write idx (f x) mb))) + ## (new arr-size) + ## (list;n.range +0 (n.dec arr-size))) + )))) (struct: #export _ (Fold Array) (def: (fold f init xs) diff --git a/stdlib/source/lux/data/coll/dict.lux b/stdlib/source/lux/data/coll/dict.lux index d5528dc09..cee6a83fc 100644 --- a/stdlib/source/lux/data/coll/dict.lux +++ b/stdlib/source/lux/data/coll/dict.lux @@ -120,7 +120,8 @@ (def: (insert! idx value old-array) (All [a] (-> Index a (Array a) (Array a))) (let [old-size (array;size old-array)] - (|> (: (Array ($ +0)) + (|> ## (array;new (n.inc old-size)) + (: (Array ($ +0)) (array;new (n.inc old-size))) (array;copy idx +0 old-array +0) (array;write idx value) @@ -233,8 +234,10 @@ (array;write insertion-idx (#;Left sub-node) base)]]) ))) [+0 [clean-bitmap + ## (array;new (n.dec h-size)) (: (Base ($ +0) ($ +1)) - (array;new (n.dec h-size)))]] + (array;new (n.dec h-size))) + ]] (list;indices (array;size h-array))))) ## When #Base nodes grow too large, they're promoted to #Hierarchy to @@ -264,8 +267,10 @@ (undefined))] default)) [+0 + ## (array;new hierarchy-nodes-size) (: (Array (Node ($ +0) ($ +1))) - (array;new hierarchy-nodes-size))] + (array;new hierarchy-nodes-size)) + ] hierarchy-indices))) ## All empty nodes look the same (a #Base node with clean bitmap is @@ -287,13 +292,20 @@ ## a sub-node. If impossible, I introduced a new singleton sub-node. (#Hierarchy _size hierarchy) (let [idx (level-index level hash) + ## [_size' sub-node] (case (array;read idx hierarchy) + ## (#;Some sub-node) + ## [_size sub-node] + + ## _ + ## [(n.inc _size) empty]) [_size' sub-node] (: [Nat (Node ($ +0) ($ +1))] (case (array;read idx hierarchy) (#;Some sub-node) [_size sub-node] _ - [(n.inc _size) empty]))] + [(n.inc _size) empty])) + ] (#Hierarchy _size' (update! idx (put' (level-up level) hash key val Hash<k> sub-node) hierarchy))) @@ -327,7 +339,8 @@ ## the same, a new ## #Collisions node ## is added. - (#Collisions hash (|> (: (Array [($ +0) ($ +1)]) + (#Collisions hash (|> ## (array;new +2) + (: (Array [($ +0) ($ +1)]) (array;new +2)) (array;write +0 [key' val']) (array;write +1 [key val]))) @@ -373,7 +386,8 @@ ## If the hashes are not equal, I create a new #Base node that ## contains the old #Collisions node, plus the new KV-pair. (|> (#Base (bit-position level _hash) - (|> (: (Base ($ +0) ($ +1)) + (|> ## (array;new +1) + (: (Base ($ +0) ($ +1)) (array;new +1)) (array;write +0 (#;Left node)))) (put' level hash key val Hash<k>))) diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux index 4d4090835..d7bbe0161 100644 --- a/stdlib/source/lux/data/coll/list.lux +++ b/stdlib/source/lux/data/coll/list.lux @@ -483,7 +483,9 @@ (do Monad<M> [lMla MlMla lla (: (($ +0) (List (List ($ +1)))) - (M;seq @ lMla))] + (M;seq @ lMla)) + ## lla (M;seq @ lMla) + ] (wrap (concat lla))))) (def: #export (lift Monad<M>) diff --git a/stdlib/source/lux/data/coll/sequence.lux b/stdlib/source/lux/data/coll/sequence.lux index f85558c5e..f76c824a7 100644 --- a/stdlib/source/lux/data/coll/sequence.lux +++ b/stdlib/source/lux/data/coll/sequence.lux @@ -74,14 +74,16 @@ (All [a] (-> Level (Base a) (Node a))) (if (n.= +0 level) (#Base tail) - (|> (: (Hierarchy ($ +0)) + (|> ## (new-hierarchy []) + (: (Hierarchy ($ +0)) (new-hierarchy [])) (array;write +0 (new-path (level-down level) tail)) #Hierarchy))) (def: (new-tail singleton) (All [a] (-> a (Base a))) - (|> (: (Base ($ +0)) + (|> ## (array;new +1) + (: (Base ($ +0)) (array;new +1)) (array;write +0 singleton))) @@ -110,7 +112,8 @@ (def: (expand-tail val tail) (All [a] (-> a (Base a) (Base a))) (let [tail-size (array;size tail)] - (|> (: (Base ($ +0)) + (|> ## (array;new (n.inc tail-size)) + (: (Base ($ +0)) (array;new (n.inc tail-size))) (array;copy tail-size +0 tail +0) (array;write tail-size val) @@ -208,7 +211,8 @@ ## If so, a brand-new root must be established, that is ## 1-level taller. (|> vec - (set@ #root (|> (: (Hierarchy ($ +0)) + (set@ #root (|> ## (new-hierarchy []) + (: (Hierarchy ($ +0)) (new-hierarchy [])) (array;write +0 (#Hierarchy (get@ #root vec))) (array;write +1 (new-path (get@ #level vec) (get@ #tail vec))))) @@ -259,8 +263,10 @@ (n.< vec-size idx)) (if (n.>= (tail-off vec-size) idx) (|> vec + ## (update@ #tail (|>. array;clone (array;write (branch-idx idx) val))) (update@ #tail (: (-> (Base ($ +0)) (Base ($ +0))) - (|>. array;clone (array;write (branch-idx idx) val))))) + (|>. array;clone (array;write (branch-idx idx) val)))) + ) (|> vec (update@ #root (put' (get@ #level vec) idx val)))) vec))) @@ -294,7 +300,26 @@ (maybe;assume (do maybe;Monad<Maybe> [new-tail (base-for (n.- +2 vec-size) vec) - #let [[level' root'] (: [Level (Hierarchy ($ +0))] + #let [## [level' root'] (let [init-level (get@ #level vec)] + ## (loop [level init-level + ## root (maybe;default (new-hierarchy []) + ## (pop-tail vec-size init-level (get@ #root vec))) + ## ## root (: (Hierarchy ($ +0)) + ## ## (maybe;default (new-hierarchy []) + ## ## (pop-tail vec-size init-level (get@ #root vec)))) + ## ] + ## (if (n.> branching-exponent level) + ## (case [(array;read +1 root) (array;read +0 root)] + ## [#;None (#;Some (#Hierarchy sub-node))] + ## (recur (level-down level) sub-node) + + ## ## [#;None (#;Some (#Base _))] + ## ## (undefined) + + ## _ + ## [level root]) + ## [level root]))) + [level' root'] (: [Level (Hierarchy ($ +0))] (let [init-level (get@ #level vec)] (loop [level init-level root (: (Hierarchy ($ +0)) @@ -310,7 +335,8 @@ _ [level root]) - [level root]))))]] + [level root])))) + ]] (wrap (|> vec (update@ #size n.dec) (set@ #level level') @@ -326,6 +352,7 @@ (def: #export (from-list list) (All [a] (-> (List a) (Sequence a))) (list/fold add + ## empty (: (Sequence ($ +0)) empty) list)) @@ -353,7 +380,9 @@ [(#Hierarchy h1) (#Hierarchy h2)] (:: (array;Eq<Array> (Eq<Node> Eq<a>)) = h1 h2) - ))) + + _ + false))) (struct: #export (Eq<Sequence> Eq<a>) (All [a] (-> (Eq a) (Eq (Sequence a)))) (def: (= v1 v2) diff --git a/stdlib/source/lux/data/number.lux b/stdlib/source/lux/data/number.lux index 5b8e1946d..446e1e152 100644 --- a/stdlib/source/lux/data/number.lux +++ b/stdlib/source/lux/data/number.lux @@ -8,7 +8,7 @@ enum interval codec) - (data ["E" error] + (data ["e" error] [maybe] [bit]))) @@ -162,10 +162,10 @@ (def: (decode input) (case (<decoder> [input]) (#;Some value) - (#E;Success value) + (#e;Success value) #;None - (#E;Error <error>))))] + (#e;Error <error>))))] [Frac "lux frac encode" "lux frac decode" "Could not decode Frac"] ) @@ -199,16 +199,16 @@ (let [digit (maybe;assume (get-char input idx))] (case ("lux text index" <char-set> digit +0) #;None - (#E;Error ("lux text concat" <error> repr)) + (#e;Error ("lux text concat" <error> repr)) (#;Some index) (recur (n.inc idx) (|> output (n.* <base>) (n.+ index))))) - (#E;Success output)))) + (#e;Success output)))) _ - (#E;Error ("lux text concat" <error> repr))) - (#E;Error ("lux text concat" <error> repr))))))] + (#e;Error ("lux text concat" <error> repr))) + (#e;Error ("lux text concat" <error> repr))))))] [Binary@Codec<Text,Nat> +2 "01" "Invalid binary syntax for Nat: "] [Octal@Codec<Text,Nat> +8 "01234567" "Invalid octal syntax for Nat: "] @@ -250,13 +250,13 @@ (let [digit (maybe;assume (get-char input idx))] (case ("lux text index" <char-set> digit +0) #;None - (#E;Error <error>) + (#e;Error <error>) (#;Some index) (recur (n.inc idx) (|> output (i.* <base>) (i.+ (:! Int index)))))) - (#E;Success (i.* sign output))))) - (#E;Error <error>)))))] + (#e;Success (i.* sign output))))) + (#e;Error <error>)))))] [Binary@Codec<Text,Int> 2 "01" "Invalid binary syntax for Int: "] [Octal@Codec<Text,Int> 8 "01234567" "Invalid octal syntax for Int: "] @@ -289,12 +289,12 @@ (case ("lux text char" repr +0) (^multi (^ (#;Some (char "."))) [(:: <nat> decode ("lux text concat" "+" (de-prefix repr))) - (#;Some output)]) - (#E;Success (:! Deg output)) + (#e;Success output)]) + (#e;Success (:! Deg output)) _ - (#E;Error ("lux text concat" <error> repr))) - (#E;Error ("lux text concat" <error> repr))))))] + (#e;Error ("lux text concat" <error> repr))) + (#e;Error ("lux text concat" <error> repr))))))] [Binary@Codec<Text,Deg> Binary@Codec<Text,Nat> +1 "Invalid binary syntax: "] [Octal@Codec<Text,Deg> Octal@Codec<Text,Nat> +3 "Invalid octal syntax: "] @@ -327,7 +327,7 @@ decimal-part (maybe;assume ("lux text clip" repr (n.inc split-index) ("lux text size" repr)))] (case [(:: <int> decode whole-part) (:: <int> decode decimal-part)] - (^multi [(#;Some whole) (#;Some decimal)] + (^multi [(#e;Success whole) (#e;Success decimal)] (i.>= 0 decimal)) (let [sign (if (i.< 0 whole) -1.0 @@ -340,19 +340,19 @@ (f.* <base> output)))) adjusted-decimal (|> decimal int-to-frac (f./ div-power)) dec-deg (case (:: Hex@Codec<Text,Deg> decode ("lux text concat" "." decimal-part)) - (#E;Success dec-deg) + (#e;Success dec-deg) dec-deg - (#E;Error error) + (#e;Error error) (error! error))] - (#E;Success (f.+ (int-to-frac whole) + (#e;Success (f.+ (int-to-frac whole) (f.* sign adjusted-decimal)))) _ - (#E;Error ("lux text concat" <error> repr)))) + (#e;Error ("lux text concat" <error> repr)))) _ - (#E;Error ("lux text concat" <error> repr)))))] + (#e;Error ("lux text concat" <error> repr)))))] [Binary@Codec<Text,Frac> Binary@Codec<Text,Int> 2.0 "01" "Invalid binary syntax: "] ) @@ -524,14 +524,14 @@ ("lux text concat" (<to> whole-part)) ("lux text concat" (if (f.= -1.0 sign) "-" "")))] (case (:: Binary@Codec<Text,Frac> decode as-binary) - (#E;Error _) - (#E;Error ("lux text concat" <error> repr)) + (#e;Error _) + (#e;Error ("lux text concat" <error> repr)) output output)) _ - (#E;Error ("lux text concat" <error> repr))))))] + (#e;Error ("lux text concat" <error> repr))))))] [Octal@Codec<Text,Frac> "Invalid octaladecimal syntax: " binary-to-octal octal-to-binary] [Hex@Codec<Text,Frac> "Invalid hexadecimal syntax: " binary-to-hex hex-to-binary] @@ -543,26 +543,26 @@ (case tokens (#;Cons [meta (#;Text repr)] #;Nil) (case (:: <nat> decode repr) - (#E;Success value) - (#E;Success [state (list [meta (#;Nat value)])]) + (#e;Success value) + (#e;Success [state (list [meta (#;Nat value)])]) - (^multi (#E;Error _) - [(:: <int> decode repr) (#E;Success value)]) - (#E;Success [state (list [meta (#;Int value)])]) + (^multi (#e;Error _) + [(:: <int> decode repr) (#e;Success value)]) + (#e;Success [state (list [meta (#;Int value)])]) - (^multi (#E;Error _) - [(:: <deg> decode repr) (#E;Success value)]) - (#E;Success [state (list [meta (#;Deg value)])]) + (^multi (#e;Error _) + [(:: <deg> decode repr) (#e;Success value)]) + (#e;Success [state (list [meta (#;Deg value)])]) - (^multi (#E;Error _) - [(:: <frac> decode repr) (#E;Success value)]) - (#E;Success [state (list [meta (#;Frac value)])]) + (^multi (#e;Error _) + [(:: <frac> decode repr) (#e;Success value)]) + (#e;Success [state (list [meta (#;Frac value)])]) _ - (#E;Error <error>)) + (#e;Error <error>)) _ - (#E;Error <error>)))] + (#e;Error <error>)))] [bin Binary@Codec<Text,Nat> Binary@Codec<Text,Int> Binary@Codec<Text,Deg> Binary@Codec<Text,Frac> "Invalid binary syntax." @@ -757,11 +757,11 @@ (recur (digits-sub! power digits) (n.inc idx) (bit;set (n.- idx (n.dec bit;width)) output)))) - (#E;Success (:! Deg output)))) + (#e;Success (:! Deg output)))) #;None - (#E;Error ("lux text concat" "Wrong syntax for Deg: " input))) - (#E;Error ("lux text concat" "Wrong syntax for Deg: " input)))) + (#e;Error ("lux text concat" "Wrong syntax for Deg: " input))) + (#e;Error ("lux text concat" "Wrong syntax for Deg: " input)))) )) (def: (log2 input) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 0611e6e79..fe57508cc 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -20,7 +20,12 @@ (def: #export (contains? sub text) (-> Text Text Bool) - ("lux text contains?" text sub)) + (case ("lux text index" text sub +0) + (#;Some _) + true + + _ + false)) (do-template [<name> <proc>] [(def: #export (<name> input) @@ -213,7 +218,7 @@ (def: #export (from-code code) (-> Nat Text) - ("lux nat to-char" code)) + ("lux nat char" code)) (def: #export (space? char) {#;doc "Checks whether the character is white-space."} diff --git a/stdlib/source/lux/lang/type.lux b/stdlib/source/lux/lang/type.lux index 974561605..d4a3d7d1b 100644 --- a/stdlib/source/lux/lang/type.lux +++ b/stdlib/source/lux/lang/type.lux @@ -30,7 +30,7 @@ (<tag> env def) _ - type)) + (<tag> (list/map (beta-reduce env) old-env) def))) ([#;UnivQ] [#;ExQ]) diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index 917b7e094..0f2777ed8 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -228,15 +228,16 @@ (with-brackets (spaced (list/map constructor-arg$ constructor-args))) (with-brackets (spaced (list/map (method-def$ id) methods))))))] (wrap (list (` ((~ (code;text def-code)))))))))} - (let [[exported? tokens] (case tokens - (^ (list& [_ (#;Tag ["" "hidden"])] tokens')) - [(#;Some #;Left) tokens'] + (let [[exported? tokens] (: [(Maybe (Either Unit Unit)) (List Code)] + (case tokens + (^ (list& [_ (#;Tag ["" "hidden"])] tokens')) + [(#;Some #;Left) tokens'] - (^ (list& [_ (#;Tag ["" "export"])] tokens')) - [(#;Some #;Right) tokens'] + (^ (list& [_ (#;Tag ["" "export"])] tokens')) + [(#;Some #;Right) tokens'] - _ - [#;None tokens]) + _ + [#;None tokens])) ?parts (: (Maybe [Text (List Code) Code Code]) (case tokens (^ (list [_ (#;Form (list& [_ (#;Symbol ["" name])] args))] @@ -270,10 +271,10 @@ #let [g!state (code;symbol ["" "*compiler*"]) error-msg (code;text (text/compose "Wrong syntax for " name)) export-ast (: (List Code) (case exported? - (#;Some #E;Error) + (#;Some #;Left) (list (' #hidden)) - (#;Some #E;Success) + (#;Some #;Right) (list (' #export)) _ diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index d1671537d..700bc9919 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -9,20 +9,17 @@ [code]))) ## [Values] -(do-template [<name> <value>] +(do-template [<name> <value> <doc>] [(def: #export <name> + {#;doc <doc>} Frac - (<value>))] + <value>)] - [e "lux math e"] - [pi "lux math pi"] + [e 2.7182818284590452354 "The base of the natural logarithm."] + [pi 3.14159265358979323846 "The ratio of a circle's circumference to its diameter."] + [tau 6.28318530717958647692 "The ratio of a circle's circumference to its radius."] ) -(def: #export tau - {#;doc "The same as 2*PI."} - Frac - 6.28318530717958647692) - (do-template [<name> <method>] [(def: #export (<name> input) (-> Frac Frac) diff --git a/stdlib/source/lux/type/opaque.lux b/stdlib/source/lux/type/opaque.lux index 3b50fcbc2..636acd6e2 100644 --- a/stdlib/source/lux/type/opaque.lux +++ b/stdlib/source/lux/type/opaque.lux @@ -68,28 +68,30 @@ this-module (|> this-module (update@ #;defs (put down-cast (: Def [Macro macro-anns - (function [tokens] - (case tokens - (^ (list value)) - (wrap (list (` ((: (All [(~@ type-varsC)] - (-> (~ representation-declaration) (~ opaque-declaration))) - (|>. :!!)) - (~ value))))) - - _ - (macro;fail ($_ text/compose "Wrong syntax for " down-cast))))]))) + (: Macro + (function [tokens] + (case tokens + (^ (list value)) + (wrap (list (` ((: (All [(~@ type-varsC)] + (-> (~ representation-declaration) (~ opaque-declaration))) + (|>. :!!)) + (~ value))))) + + _ + (macro;fail ($_ text/compose "Wrong syntax for " down-cast)))))]))) (update@ #;defs (put up-cast (: Def [Macro macro-anns - (function [tokens] - (case tokens - (^ (list value)) - (wrap (list (` ((: (All [(~@ type-varsC)] - (-> (~ opaque-declaration) (~ representation-declaration))) - (|>. :!!)) - (~ value))))) - - _ - (macro;fail ($_ text/compose "Wrong syntax for " up-cast))))]))))]] + (: Macro + (function [tokens] + (case tokens + (^ (list value)) + (wrap (list (` ((: (All [(~@ type-varsC)] + (-> (~ opaque-declaration) (~ representation-declaration))) + (|>. :!!)) + (~ value))))) + + _ + (macro;fail ($_ text/compose "Wrong syntax for " up-cast)))))]))))]] (function [compiler] (#E;Success [(update@ #;modules (put this-module-name this-module) compiler) []])))) |