diff options
31 files changed, 1032 insertions, 247 deletions
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux index 1f351325e..88b3dd5d3 100644 --- a/new-luxc/source/luxc/generator/case.jvm.lux +++ b/new-luxc/source/luxc/generator/case.jvm.lux @@ -3,10 +3,10 @@ (lux (control [monad #+ do]) [macro "lux/" Monad<Lux>]) (luxc (lang ["ls" synthesis]) - (generator (host ["$" jvm] + (generator [expr] + (host ["$" jvm] (jvm ["$t" type] - ["$i" inst])) - [expr])) + ["$i" inst])))) [../runtime]) (def: $Object $;Type ($t;class "java.lang.Object" (list))) @@ -24,7 +24,7 @@ (def: peekI $;Inst (|>. $i;DUP - ($i;INVOKESTATIC ../runtime;runtime-name + ($i;INVOKESTATIC ../runtime;runtime-class "pm_peek" ($t;method (list ../runtime;$Stack) (#;Some $Object) @@ -33,7 +33,7 @@ (def: popI $;Inst - (|>. ($i;INVOKESTATIC ../runtime;runtime-name + (|>. ($i;INVOKESTATIC ../runtime;runtime-class "pm_pop" ($t;method (list ../runtime;$Stack) (#;Some ../runtime;$Stack) @@ -42,7 +42,7 @@ (def: pushI $;Inst - (|>. ($i;INVOKESTATIC ../runtime;runtime-name + (|>. ($i;INVOKESTATIC ../runtime;runtime-class "pm_push" ($t;method (list ../runtime;$Stack $Object) (#;Some ../runtime;$Stack) @@ -124,7 +124,7 @@ (|>. peekI ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) ($i;int (nat-to-int idx)) - ($i;INVOKESTATIC ../runtime;runtime-name + ($i;INVOKESTATIC ../runtime;runtime-class (if tail? "pm_right" "pm_left") ($t;method (list ../runtime;$Tuple $t;int) (#;Some $Object) @@ -151,7 +151,7 @@ ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) ($i;int (nat-to-int idx)) flagI - ($i;INVOKESTATIC ../runtime;runtime-name "pm_variant" + ($i;INVOKESTATIC ../runtime;runtime-class "pm_variant" ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) (#;Some ../runtime;$Datum) (list)) @@ -193,7 +193,7 @@ (wrap (|>. pathI ($i;label @else) $i;POP - ($i;INVOKESTATIC ../runtime;runtime-name + ($i;INVOKESTATIC ../runtime;runtime-class "pm_fail" ($t;method (list) #;None (list)) false) diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux index 095f41945..1f04f5798 100644 --- a/new-luxc/source/luxc/generator/common.jvm.lux +++ b/new-luxc/source/luxc/generator/common.jvm.lux @@ -1,17 +1,16 @@ (;module: - lux - (lux [io] + [lux #- function] + (lux (control ["ex" exception #+ exception:]) + [io] (concurrency ["A" atom]) (data ["R" result] - (coll ["d" dict]) - text/format) + (coll ["d" dict])) [host]) (luxc (generator (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst]))))) -## [Host] (host;import org.objectweb.asm.Opcodes (#static V1_6 int)) @@ -22,33 +21,69 @@ (host;import java.lang.ClassLoader (loadClass [String] (Class Object))) -## [Types] (type: #export Bytecode host;Byte-Array) (type: #export Class-Store (A;Atom (d;Dict Text Bytecode))) (type: #export Host {#loader ClassLoader - #store Class-Store}) + #store Class-Store + #function-class (Maybe Text)}) + +(exception: Unknown-Class) +(exception: Class-Already-Stored) +(exception: No-Function-Being-Compiled) (def: #export (store-class name byte-code) (-> Text Bytecode (Lux Unit)) - (function [compiler] + (;function [compiler] (let [store (|> (get@ #;host compiler) (:! Host) (get@ #store))] (if (d;contains? name (|> store A;get io;run)) - (#R;Error (format "Cannot store class that already exists: " name)) + (ex;throw Class-Already-Stored name) (#R;Success [compiler (io;run (A;update (d;put name byte-code) store))]) )))) (def: #export (load-class name) (-> Text (Lux (Class Object))) - (function [compiler] + (;function [compiler] (let [host (:! Host (get@ #;host compiler)) store (|> host (get@ #store) A;get io;run)] (if (d;contains? name store) (#R;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))]) - (#R;Error (format "Unknown class: " name)))))) + (ex;throw Unknown-Class name))))) + +(def: #export (with-function class expr) + (All [a] (-> Text (Lux a) (Lux a))) + (;function [compiler] + (let [host (:! Host (get@ #;host compiler)) + old-function-class (get@ #function-class host)] + (case (expr (set@ #;host + (:! Void (set@ #function-class + (#;Some class) + host)) + compiler)) + (#R;Success [compiler' output]) + (#R;Success [(update@ #;host + (|>. (:! Host) + (set@ #function-class old-function-class) + (:! Void)) + compiler') + output]) + + (#R;Error error) + (#R;Error error))))) + +(def: #export function + (Lux Text) + (;function [compiler] + (let [host (:! Host (get@ #;host compiler))] + (case (get@ #function-class host) + #;None + (ex;throw No-Function-Being-Compiled "") + + (#;Some function-class) + (#R;Success [compiler function-class]))))) (def: #export bytecode-version Int Opcodes.V1_6) diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux index e6650953f..818c03b66 100644 --- a/new-luxc/source/luxc/generator/eval.jvm.lux +++ b/new-luxc/source/luxc/generator/eval.jvm.lux @@ -71,10 +71,9 @@ (host;null) "java/lang/Object" (host;null)])) - ($d;field #$;Public {#$;staticF true #$;finalF true #$;transientF false #$;volatileF false} + ($d;field #$;Public $;staticF eval-field $Object) - ($d;method #$;Public - {#$;staticM true #$;finalM false #$;synchronizedM false} + ($d;method #$;Public ($_ $;++M $;staticM $;strictM) "<clinit>" ($t;method (list) #;None (list)) (|>. valueI diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux index 0bdebe555..6b6c68fde 100644 --- a/new-luxc/source/luxc/generator/expr.jvm.lux +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -1,16 +1,20 @@ (;module: lux (lux (control monad) + (data text/format) [macro #+ Monad<Lux> "Lux/" Monad<Lux>]) (luxc ["&" base] (lang ["ls" synthesis]) ["&;" analyser] ["&;" synthesizer] + (synthesizer [";S" function]) (generator ["&;" common] ["&;" primitive] ["&;" structure] ["&;" eval] ["&;" procedure] + ["&;" function] + ["&;" reference] (host ["$" jvm])))) (def: #export (generate synthesis) @@ -35,6 +39,17 @@ (#ls;Tuple members) (&structure;generate-tuple generate members) + (#ls;Variable var) + (if (functionS;captured? var) + (&reference;generate-captured var) + (&reference;generate-variable var)) + + (#ls;Function arity env body) + (&function;generate-function generate env arity body) + + (#ls;Call args function) + (&function;generate-call generate function args) + (#ls;Procedure name args) (&procedure;generate-procedure generate name args) diff --git a/new-luxc/source/luxc/generator/function.jvm.lux b/new-luxc/source/luxc/generator/function.jvm.lux new file mode 100644 index 000000000..135daf47e --- /dev/null +++ b/new-luxc/source/luxc/generator/function.jvm.lux @@ -0,0 +1,341 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data text/format + (coll [list "L/" Functor<List> Monoid<List>])) + [macro]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (synthesizer [function]) + (generator ["&;" common] + ["&;" runtime] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst]))))) + + +(def: arity-field Text "arity") +(def: $Object $;Type ($t;class "java.lang.Object" (list))) + +(do-template [<name> <prefix>] + [(def: #export (<name> idx) + (-> Nat Text) + (|> idx nat-to-int %i (format <prefix>)))] + + [captured "c"] + [partial "p"] + ) + +(def: (poly-arg? arity) + (-> ls;Arity Bool) + (n.> +1 arity)) + +(def: (reset-method class) + (-> Text $;Method) + ($t;method (list) (#;Some ($t;class class (list))) (list))) + +(def: (captured-args env) + (-> (List ls;Variable) (List $;Type)) + (list;repeat (list;size env) $Object)) + +(def: (init-method env arity) + (-> (List ls;Variable) ls;Arity $;Method) + (if (poly-arg? arity) + ($t;method (list;concat (list (captured-args env) + (list $t;int) + (list;repeat (n.dec arity) $Object))) + #;None + (list)) + ($t;method (captured-args env) #;None (list)))) + +(def: (implementation-method arity) + ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) + +(def: get-amount-of-partialsI + $;Inst + (|>. ($i;ALOAD +0) + ($i;GETFIELD &runtime;function-class &runtime;partials-field $t;int))) + +(def: (load-fieldI class field) + (-> Text Text $;Inst) + (|>. ($i;ALOAD +0) + ($i;GETFIELD class field $Object))) + +(def: (inputsI start amount) + (-> $;Register Nat $;Inst) + (|> (list;n.range start (n.+ start (n.dec amount))) + (L/map $i;ALOAD) + $i;fuse)) + +(def: (applysI start amount) + (-> $;Register Nat $;Inst) + (let [max-args (n.min amount &runtime;num-apply-variants) + later-applysI (if (n.> &runtime;num-apply-variants amount) + (applysI (n.+ &runtime;num-apply-variants start) (n.- &runtime;num-apply-variants amount)) + id)] + (|>. ($i;CHECKCAST &runtime;function-class) + (inputsI start max-args) + ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature max-args) false) + later-applysI))) + +(def: (inc-intI by) + (-> Nat $;Inst) + (|>. ($i;int (nat-to-int by)) + $i;IADD)) + +(def: (nullsI amount) + (-> Nat $;Inst) + (|> $i;NULL + (list;repeat amount) + $i;fuse)) + +(def: (with-captured env) + (-> (List ls;Variable) $;Def) + (|> (list;enumerate env) + (L/map (function [[env-idx env-source]] + ($d;field #$;Private $;finalF (captured env-idx) $Object))) + $d;fuse)) + +(def: (with-partial arity) + (-> ls;Arity $;Def) + (if (poly-arg? arity) + (|> (list;n.range +0 (n.- +2 arity)) + (L/map (function [idx] + ($d;field #$;Private $;finalF (partial idx) $Object))) + $d;fuse) + id)) + +(def: (instance class arity env) + (-> Text ls;Arity (List ls;Variable) $;Inst) + (let [captureI (|> env + (L/map (function [source] + (if (function;captured? source) + ($i;GETFIELD class (captured (function;captured-idx source)) $Object) + ($i;ALOAD (int-to-nat source))))) + $i;fuse) + argsI (if (poly-arg? arity) + (|> (nullsI (n.dec arity)) + (list ($i;int 0)) + $i;fuse) + id)] + (|>. ($i;NEW class) + $i;DUP + captureI + argsI + ($i;INVOKESPECIAL class "<init>" (init-method env arity) false)))) + +(def: (with-reset class arity env) + (-> Text ls;Arity (List ls;Variable) $;Def) + ($d;method #$;Public $;noneM "reset" (reset-method class) + (if (poly-arg? arity) + (let [env-size (list;size env) + captureI (|> (case env-size + +0 (list) + _ (list;n.range +0 (n.dec env-size))) + (L/map (function [source] + (|>. ($i;ALOAD +0) + ($i;GETFIELD class (captured source) $Object)))) + $i;fuse) + argsI (|> (nullsI (n.dec arity)) + (list ($i;int 0)) + $i;fuse)] + (|>. ($i;NEW class) + $i;DUP + captureI + argsI + ($i;INVOKESPECIAL class "<init>" (init-method env arity) false) + $i;ARETURN)) + (|>. ($i;ALOAD +0) + $i;ARETURN)))) + +(def: (with-implementation arity @begin bodyI) + (-> Nat $;Label $;Inst $;Def) + ($d;method #$;Public $;strictM "impl" (implementation-method arity) + (|>. ($i;label @begin) + bodyI + $i;ARETURN))) + +(def: function-init-method + $;Method + ($t;method (list $t;int) #;None (list))) + +(def: (function-init arity env-size) + (-> ls;Arity Nat $;Inst) + (if (n.= +1 arity) + (|>. ($i;int 0) + ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false)) + (|>. ($i;ILOAD (n.inc env-size)) + ($i;INVOKESPECIAL &runtime;function-class "<init>" function-init-method false)))) + +(def: (with-init class env arity) + (-> Text (List ls;Variable) ls;Arity $;Def) + (let [env-size (list;size env) + offset-partial (: (-> Nat Nat) + (|>. n.inc (n.+ env-size))) + store-capturedI (|> (case env-size + +0 (list) + _ (list;n.range +0 (n.dec env-size))) + (L/map (function [register] + (|>. ($i;ALOAD +0) + ($i;ALOAD (n.inc register)) + ($i;PUTFIELD class (captured register) $Object)))) + $i;fuse) + store-partialI (if (poly-arg? arity) + (|> (list;n.range +0 (n.- +2 arity)) + (L/map (function [idx] + (let [register (offset-partial idx)] + (|>. ($i;ALOAD +0) + ($i;ALOAD (n.inc register)) + ($i;PUTFIELD class (partial idx) $Object))))) + $i;fuse) + id)] + ($d;method #$;Public $;noneM "<init>" (init-method env arity) + (|>. ($i;ALOAD +0) + (function-init arity env-size) + store-capturedI + store-partialI + $i;RETURN)))) + +(def: (when test f) + (All [a] (-> Bool (-> a a) (-> a a))) + (function [value] + (if test + (f value) + value))) + +(def: (with-apply class env function-arity @begin bodyI apply-arity) + (-> Text (List ls;Variable) ls;Arity $;Label $;Inst ls;Arity + $;Def) + (let [num-partials (n.dec function-arity) + @default ($;new-label []) + @labels (L/map $;new-label (list;repeat num-partials [])) + arity-over-extent (|> (nat-to-int function-arity) (i.- (nat-to-int apply-arity))) + casesI (|> (L/append @labels (list @default)) + (list;zip2 (list;n.range +0 num-partials)) + (L/map (function [[stage @label]] + (let [load-partialsI (if (n.> +0 stage) + (|> (list;n.range +0 (n.dec stage)) + (L/map (|>. partial (load-fieldI class))) + $i;fuse) + id)] + (cond (i.= arity-over-extent (nat-to-int stage)) + (|>. ($i;label @label) + ($i;ALOAD +0) + (when (n.> +0 stage) + ($i;INVOKEVIRTUAL class "reset" (reset-method class) false)) + load-partialsI + (inputsI +1 apply-arity) + ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + $i;ARETURN) + + (i.> arity-over-extent (nat-to-int stage)) + (let [args-to-completion (|> function-arity (n.- stage)) + args-left (|> apply-arity (n.- args-to-completion))] + (|>. ($i;label @label) + ($i;ALOAD +0) + ($i;INVOKEVIRTUAL class "reset" (reset-method class) false) + load-partialsI + (inputsI +1 args-to-completion) + ($i;INVOKEVIRTUAL class "impl" (implementation-method function-arity) false) + (applysI (n.inc args-to-completion) args-left) + $i;ARETURN)) + + ## (i.< arity-over-extent (nat-to-int stage)) + (let [env-size (list;size env) + load-capturedI (|> (case env-size + +0 (list) + _ (list;n.range +0 (n.dec env-size))) + (L/map (|>. captured (load-fieldI class))) + $i;fuse)] + (|>. ($i;label @label) + ($i;NEW class) + $i;DUP + load-capturedI + get-amount-of-partialsI + (inc-intI apply-arity) + load-partialsI + (inputsI +1 apply-arity) + (nullsI (|> num-partials (n.- apply-arity) (n.- stage))) + ($i;INVOKESPECIAL class "<init>" (init-method env function-arity) false) + $i;ARETURN)) + )))) + $i;fuse)] + ($d;method #$;Public $;noneM &runtime;apply-method (&runtime;apply-signature apply-arity) + (|>. get-amount-of-partialsI + ($i;TABLESWITCH 0 (|> num-partials n.dec nat-to-int) + @default @labels) + casesI + ($i;INVOKESTATIC &runtime;runtime-class "apply_fail" ($t;method (list) #;None (list)) false) + $i;NULL + $i;ARETURN + )))) + +(def: #export (with-function generate class env arity body) + (-> (-> ls;Synthesis (Lux $;Inst)) + Text (List ls;Variable) ls;Arity ls;Synthesis + (Lux [$;Def $;Inst])) + (do macro;Monad<Lux> + [@begin $i;make-label + bodyI (&common;with-function class (generate body)) + #let [env-size (list;size env) + applyD (: $;Def + (if (poly-arg? arity) + (|> (n.min arity &runtime;num-apply-variants) + (list;n.range +1) + (L/map (with-apply class env arity @begin bodyI)) + (list& (with-implementation arity @begin bodyI)) + $d;fuse) + ($d;method #$;Public $;strictM &runtime;apply-method (&runtime;apply-signature +1) + (|>. ($i;label @begin) + bodyI + $i;ARETURN)))) + functionD (: $;Def + (|>. ($d;int-field #$;Public ($_ $;++F $;staticF $;finalF) arity-field (nat-to-int arity)) + (with-captured env) + (with-partial arity) + (with-init class env arity) + (with-reset class arity env) + applyD)) + instanceI (instance class arity env)]] + (wrap [functionD instanceI]))) + +(def: #export (generate-function generate env arity body) + (-> (-> ls;Synthesis (Lux $;Inst)) + (List ls;Variable) ls;Arity ls;Synthesis + (Lux $;Inst)) + (do macro;Monad<Lux> + [function-class (:: @ map %code (macro;gensym "function")) + [functionD instanceI] (with-function generate function-class env arity body) + _ (&common;store-class function-class + ($d;class #$;V1.6 #$;Public $;finalC + function-class (list) + ($;simple-class &runtime;function-class) (list) + functionD))] + (wrap instanceI))) + +(def: (segment size elems) + (All [a] (-> Nat (List a) (List (List a)))) + (let [[pre post] (list;split size elems)] + (if (list;empty? post) + (list pre) + (list& pre (segment size post))))) + +(def: #export (generate-call generate functionS argsS) + (-> (-> ls;Synthesis (Lux $;Inst)) + ls;Synthesis (List ls;Synthesis) + (Lux $;Inst)) + (do macro;Monad<Lux> + [functionI (generate functionS) + argsI (monad;map @ generate argsS) + #let [applyI (|> (segment &runtime;num-apply-variants argsI) + (L/map (function [chunkI+] + (|>. ($i;CHECKCAST &runtime;function-class) + ($i;fuse chunkI+) + ($i;INVOKEVIRTUAL &runtime;function-class &runtime;apply-method (&runtime;apply-signature (list;size chunkI+)) false)))) + $i;fuse)]] + (wrap (|>. functionI + applyI)))) diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux index 4b4b1d38e..149fbf123 100644 --- a/new-luxc/source/luxc/generator/host/jvm.lux +++ b/new-luxc/source/luxc/generator/host/jvm.lux @@ -117,10 +117,14 @@ ## Configs (config: Class-Config noneC ++C [finalC]) -(config: Method-Config noneM ++M [staticM finalM synchronizedM]) -(config: Field-Config noneF ++F [staticF finalF transientF volatileF]) +(config: Method-Config noneM ++M [finalM staticM synchronizedM strictM]) +(config: Field-Config noneF ++F [finalF staticF transientF volatileF]) ## Labels (def: #export new-label (-> Unit Label) org.objectweb.asm.Label.new) + +(def: #export (simple-class name) + (-> Text Class) + [name (list)]) diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux index bb1d2cd94..18cd4f945 100644 --- a/new-luxc/source/luxc/generator/host/jvm/def.lux +++ b/new-luxc/source/luxc/generator/host/jvm/def.lux @@ -50,6 +50,7 @@ (host;import org.objectweb.asm.ClassWriter (#static COMPUTE_MAXS int) + (#static COMPUTE_FRAMES int) (new [int]) (visit [int int String String String (Array String)] void) (visitEnd [] void) @@ -100,10 +101,10 @@ (def: (method-flags config) (-> $;Method-Config Int) ($_ i.+ - Opcodes.ACC_STRICT (if (get@ #$;staticM config) Opcodes.ACC_STATIC 0) (if (get@ #$;finalM config) Opcodes.ACC_FINAL 0) - (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0))) + (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0) + (if (get@ #$;strictM config) Opcodes.ACC_STRICT 0))) (def: (field-flags config) (-> $;Field-Config Int) @@ -145,12 +146,18 @@ (L/map (|>. class-to-type $t;signature)) (text;join-with ""))))) +(def: class-computes + Int + ($_ i.+ + ClassWriter.COMPUTE_MAXS + ClassWriter.COMPUTE_FRAMES)) + (do-template [<name> <flag>] [(def: #export (<name> version visibility config name parameters super interfaces definitions) (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) $;Class (List $;Class) $;Def host;Byte-Array) - (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (let [writer (|> (do-to (ClassWriter.new class-computes) (ClassWriter.visit [(version-flag version) ($_ i.+ Opcodes.ACC_SUPER @@ -177,7 +184,7 @@ definitions) (-> $;Version $;Visibility $;Class-Config Text (List $;Parameter) (List $;Class) $;Def host;Byte-Array) - (let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (let [writer (|> (do-to (ClassWriter.new class-computes) (ClassWriter.visit [(version-flag version) ($_ i.+ Opcodes.ACC_SUPER @@ -277,4 +284,4 @@ singleton (#;Cons head tail) - (. head (fuse tail)))) + (. (fuse tail) head))) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index 0f947925c..02027294a 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -353,4 +353,4 @@ singleton (#;Cons head tail) - (. head (fuse tail)))) + (. (fuse tail) head))) diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux index d04a91141..9f8afdbb2 100644 --- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux @@ -56,7 +56,7 @@ (def: $Object-Array $;Type ($t;array +1 $Object)) (def: $String $;Type ($t;class "java.lang.String" (list))) (def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list))) -(def: $Function $;Type ($t;class &runtime;function-name (list))) +(def: $Function $;Type ($t;class &runtime;function-class (list))) (def: (install name unnamed) (-> Text (-> Text Proc) @@ -135,8 +135,8 @@ (def: (lux//try riskyI) Unary (|>. riskyI - ($i;CHECKCAST &runtime;function-name) - ($i;INVOKESTATIC &runtime;runtime-name "try" try-method false))) + ($i;CHECKCAST &runtime;function-class) + ($i;INVOKESTATIC &runtime;runtime-class "try" try-method false))) ## [[Bits]] (do-template [<name> <op>] @@ -256,9 +256,9 @@ [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 &runtime;runtime-name "div_nat" nat-method false)] + ($i;INVOKESTATIC &runtime;runtime-class "div_nat" nat-method false)] [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-name "rem_nat" nat-method false)] + ($i;INVOKESTATIC &runtime;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] @@ -269,9 +269,9 @@ [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 &runtime;runtime-name "mul_deg" deg-method false)] + ($i;INVOKESTATIC &runtime;runtime-class "mul_deg" deg-method false)] [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long) - ($i;INVOKESTATIC &runtime;runtime-name "div_deg" deg-method false)] + ($i;INVOKESTATIC &runtime;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] @@ -289,10 +289,10 @@ [<eq> 0] [<lt> -1])] - [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)] + [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)] [int//eq int//lt ($i;unwrap #$;Long) $i;LCMP] [frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG] - [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "compare_nat" compare-nat-method false)] + [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "compare_nat" compare-nat-method false)] ) (do-template [<name> <prepare> <transform>] @@ -310,15 +310,15 @@ [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)] [frac//to-deg ($i;unwrap #$;Double) - (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-name "frac_to_deg" + (<| ($i;wrap #$;Long) ($i;INVOKESTATIC &runtime;runtime-class "frac_to_deg" ($t;method (list $t;double) (#;Some $t;long) (list)) false))] [frac//encode ($i;unwrap #$;Double) ($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)] [frac//decode ($i;CHECKCAST "java.lang.String") - ($i;INVOKESTATIC &runtime;runtime-name "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] + ($i;INVOKESTATIC &runtime;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)] [deg//to-frac ($i;unwrap #$;Long) - (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-name "deg_to_frac" + (<| ($i;wrap #$;Double) ($i;INVOKESTATIC &runtime;runtime-class "deg_to_frac" ($t;method (list $t;long) (#;Some $t;double) (list)) false))] ) @@ -358,7 +358,7 @@ ($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false) ($i;wrap #$;Boolean)] [text//char ($i;CHECKCAST "java.lang.String") jvm-intI - ($i;INVOKESTATIC &runtime;runtime-name "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) + ($i;INVOKESTATIC &runtime;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false) lux-intI] ) @@ -371,7 +371,7 @@ <op>))] [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI - ($i;INVOKESTATIC &runtime;runtime-name "text_clip" + ($i;INVOKESTATIC &runtime;runtime-class "text_clip" ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)] [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)] @@ -508,20 +508,20 @@ ## [[Processes]] (def: (process//concurrency-level []) Nullary - (|>. ($i;GETSTATIC &runtime;runtime-name "concurrency_level" $t;int) + (|>. ($i;GETSTATIC &runtime;runtime-class "concurrency_level" $t;int) lux-intI)) (def: (process//future procedureI) Unary - (|>. procedureI ($i;CHECKCAST &runtime;function-name) - ($i;INVOKESTATIC &runtime;runtime-name "future" + (|>. procedureI ($i;CHECKCAST &runtime;function-class) + ($i;INVOKESTATIC &runtime;runtime-class "future" ($t;method (list $Function) (#;Some $Object) (list)) false))) (def: (process//schedule [millisecondsI procedureI]) Binary (|>. millisecondsI ($i;unwrap #$;Long) - procedureI ($i;CHECKCAST &runtime;function-name) - ($i;INVOKESTATIC &runtime;runtime-name "schedule" + procedureI ($i;CHECKCAST &runtime;function-class) + ($i;INVOKESTATIC &runtime;runtime-class "schedule" ($t;method (list $t;long $Function) (#;Some $Object) (list)) false))) ## [Bundles] diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux new file mode 100644 index 000000000..28c936036 --- /dev/null +++ b/new-luxc/source/luxc/generator/reference.jvm.lux @@ -0,0 +1,26 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data text/format) + [macro "lux/" Monad<Lux>]) + (luxc (lang ["ls" synthesis]) + (generator [";G" common] + [";G" function] + (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst]))))) + +(def: $Object $;Type ($t;class "java.lang.Object" (list))) + +(def: #export (generate-captured variable) + (-> ls;Variable (Lux $;Inst)) + (do macro;Monad<Lux> + [function-class commonG;function] + (wrap (|>. ($i;ALOAD +0) + ($i;GETFIELD function-class + (|> variable i.inc (i.* -1) int-to-nat functionG;captured) + $Object))))) + +(def: #export (generate-variable variable) + (-> ls;Variable (Lux $;Inst)) + (lux/wrap ($i;ALOAD (int-to-nat variable)))) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index 68e18deaa..69f90cea0 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -2,7 +2,8 @@ lux (lux (control monad) (data ["R" result] - text/format) + text/format + (coll [list "L/" Functor<List>])) [math] [macro #+ Monad<Lux> "Lux/" Monad<Lux>] [host #+ do-to]) @@ -40,8 +41,8 @@ (visitEnd [] void) (toByteArray [] Byte-Array)) -(def: #export runtime-name Text "LuxRuntime") -(def: #export function-name Text "LuxFunction") +(def: #export runtime-class Text "LuxRuntime") +(def: #export function-class Text "LuxFunction") (def: #export unit Text "\u0000") (def: $Object $;Type ($t;class "java.lang.Object" (list))) @@ -54,7 +55,7 @@ (def: #export $Flag $;Type $Object) (def: #export $Datum $;Type $Object) -(def: logI +(def: #export logI $;Inst (let [outI ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list))) printI (function [method] ($i;INVOKEVIRTUAL "java.io.PrintStream" method ($t;method (list $Object) #;None (list)) false))] @@ -67,7 +68,7 @@ (def: variant-makeI $;Inst - ($i;INVOKESTATIC runtime-name "variant_make" variant-method false)) + ($i;INVOKESTATIC runtime-class "variant_make" variant-method false)) (def: #export someI $;Inst @@ -102,11 +103,11 @@ (def: nat-methods $;Def (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list)) - less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-name "compare_nat" compare-nat-method false) ($i;IFLT @where))) + less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-class "compare_nat" compare-nat-method false) ($i;IFLT @where))) $BigInteger ($t;class "java.math.BigInteger" (list)) upcast-method ($t;method (list $t;long) (#;Some $BigInteger) (list)) div-method ($t;method (list $t;long $t;long) (#;Some $t;long) (list)) - upcastI ($i;INVOKESTATIC runtime-name "_toUnsignedBigInteger" upcast-method false) + upcastI ($i;INVOKESTATIC 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 @@ -279,7 +280,7 @@ (let [subjectI ($i;LLOAD +0) paramI ($i;LLOAD +2) equal?I (function [@where] (|>. $i;LCMP ($i;IFEQ @where))) - count-leading-zerosI ($i;INVOKESTATIC runtime-name "count_leading_zeros" clz-method false) + count-leading-zerosI ($i;INVOKESTATIC runtime-class "count_leading_zeros" clz-method false) calc-max-shiftI (|>. subjectI count-leading-zerosI paramI count-leading-zerosI ($i;INVOKESTATIC "java.lang.Math" "min" ($t;method (list $t;int $t;int) (#;Some $t;int) (list)) false) @@ -323,6 +324,12 @@ ($i;string "Invalid expression for pattern-matching.") ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false) $i;ATHROW)) + ($d;method #$;Public $;staticM "apply_fail" ($t;method (list) #;None (list)) + (|>. ($i;NEW "java.lang.IllegalStateException") + $i;DUP + ($i;string "Error while applying function.") + ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false) + $i;ATHROW)) ($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list)) (|>. ($i;int 2) ($i;ANEWARRAY "java.lang.Object") @@ -439,15 +446,65 @@ $i;ARETURN))) ))) -(def: #export generate +(def: generate-runtime (Lux &common;Bytecode) (do Monad<Lux> [_ (wrap []) - #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list) + #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-class (list) ["java.lang.Object" (list)] (list) (|>. adt-methods nat-methods frac-methods deg-methods pm-methods))] - _ (&common;store-class runtime-name bytecode)] + _ (&common;store-class runtime-class bytecode)] (wrap bytecode))) + +(def: #export partials-field Text "partials") +(def: #export apply-method Text "apply") +(def: #export num-apply-variants Nat +8) + +(def: #export (apply-signature arity) + (-> ls;Arity $;Method) + ($t;method (list;repeat arity $Object) (#;Some $Object) (list))) + +(def: generate-function + (Lux &common;Bytecode) + (do Monad<Lux> + [_ (wrap []) + #let [applyI (|> (list;n.range +2 num-apply-variants) + (L/map (function [arity] + ($d;method #$;Public $;noneM apply-method (apply-signature arity) + (let [preI (|> (list;n.range +0 (n.dec arity)) + (L/map $i;ALOAD) + $i;fuse)] + (|>. preI + ($i;INVOKEVIRTUAL function-class apply-method (apply-signature (n.dec arity)) false) + ($i;CHECKCAST function-class) + ($i;ALOAD arity) + ($i;INVOKEVIRTUAL function-class apply-method (apply-signature +1) false) + $i;ARETURN))))) + (list& ($d;abstract-method #$;Public $;noneM apply-method (apply-signature +1)) + ## ($d;method #$;Public $;noneM apply-method (apply-signature +1) + ## (|>. $i;NULL + ## $i;ARETURN)) + ) + $d;fuse) + bytecode ($d;abstract #$;V1.6 #$;Public $;noneC function-class (list) ["java.lang.Object" (list)] (list) + (|>. ($d;field #$;Public $;finalF partials-field $t;int) + ($d;method #$;Public $;noneM "<init>" ($t;method (list $t;int) #;None (list)) + (|>. ($i;ALOAD +0) + ($i;INVOKESPECIAL "java.lang.Object" "<init>" ($t;method (list) #;None (list)) false) + ($i;ALOAD +0) + ($i;ILOAD +1) + ($i;PUTFIELD function-class partials-field $t;int) + $i;RETURN)) + applyI))] + _ (&common;store-class function-class bytecode)] + (wrap bytecode))) + +(def: #export generate + (Lux Unit) + (do Monad<Lux> + [_ generate-runtime + _ generate-function] + (wrap []))) diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux index 9adff1a55..a89f3083f 100644 --- a/new-luxc/source/luxc/generator/structure.jvm.lux +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -51,7 +51,7 @@ (wrap (|>. ($i;int (nat-to-int tag)) (flagI tail?) memberI - ($i;INVOKESTATIC ../runtime;runtime-name + ($i;INVOKESTATIC ../runtime;runtime-class "variant_make" ($t;method (list $t;int $Object $Object) (#;Some ($t;array +1 $Object)) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux index e22ab4fd1..75cfbec0c 100644 --- a/new-luxc/source/luxc/host.jvm.lux +++ b/new-luxc/source/luxc/host.jvm.lux @@ -78,9 +78,10 @@ #;None (error! (format "Class not found: " class-name)))))) -(def: #export (init-host _) - (-> Top &&common;Host) - (let [store (: &&common;Class-Store - (A;atom (d;new text;Hash<Text>)))] - {#&&common;loader (memory-class-loader store) - #&&common;store store})) +(def: #export init-host + (io;IO &&common;Host) + (io;io (let [store (: &&common;Class-Store + (A;atom (d;new text;Hash<Text>)))] + {#&&common;loader (memory-class-loader store) + #&&common;store store + #&&common;function-class #;None}))) diff --git a/new-luxc/source/luxc/lang/synthesis.lux b/new-luxc/source/luxc/lang/synthesis.lux index e8f186944..dab2d84e6 100644 --- a/new-luxc/source/luxc/lang/synthesis.lux +++ b/new-luxc/source/luxc/lang/synthesis.lux @@ -32,7 +32,7 @@ (#Tuple (List Synthesis)) (#Case Synthesis (Path' Synthesis)) (#Function Arity (List Variable) Synthesis) - (#Call Synthesis (List Synthesis)) + (#Call (List Synthesis) Synthesis) (#Recur (List Synthesis)) (#Procedure Text (List Synthesis)) (#Variable Variable) diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 9cfcc020e..7bee8fe58 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -54,9 +54,9 @@ (#;Local register) (if (&&function;nested? outer-arity) (if (n.= +0 register) - (<| (#ls;Call (#ls;Variable 0)) - (L/map (|>. &&function;to-local #ls;Variable)) - (list;n.range +1 (n.dec outer-arity))) + (#ls;Call (|> (list;n.range +1 (n.dec outer-arity)) + (L/map (|>. &&function;to-local #ls;Variable))) + (#ls;Variable 0)) (#ls;Variable (&&function;adjust-var outer-arity (&&function;to-local register)))) (#ls;Variable (&&function;to-local register))) @@ -136,11 +136,11 @@ (#ls;Loop register-offset argsS (&&loop;adjust _env register-offset _bodyS))) - (#ls;Call funcS' argsS') - (#ls;Call funcS' (L/append argsS' argsS)) + (#ls;Call argsS' funcS') + (#ls;Call (L/append argsS' argsS) funcS') _ - (#ls;Call funcS argsS))) + (#ls;Call argsS funcS))) (#la;Procedure name args) (#ls;Procedure name (L/map (recur +0 resolver num-locals) args)) diff --git a/new-luxc/source/luxc/synthesizer/loop.lux b/new-luxc/source/luxc/synthesizer/loop.lux index 06b1d1bb0..9f4d09a49 100644 --- a/new-luxc/source/luxc/synthesizer/loop.lux +++ b/new-luxc/source/luxc/synthesizer/loop.lux @@ -32,7 +32,7 @@ (#ls;Function arity environment bodyS) (list;any? &&function;self? environment) - (#ls;Call funcS argsS) + (#ls;Call argsS funcS) (or (contains-self-reference? funcS) (list;any? contains-self-reference? argsS)) @@ -81,11 +81,11 @@ _ pathS)))) - (^multi (#ls;Call (#ls;Variable 0) argsS) + (^multi (#ls;Call argsS (#ls;Variable 0)) (n.= arity (list;size argsS))) (#ls;Recur argsS) - (#ls;Call (#ls;Variable var) argsS) + (#ls;Call argsS (#ls;Variable var)) exprS (#ls;Let register inputS bodyS) @@ -136,8 +136,8 @@ (L/map resolve-captured scope) (recur bodyS)) - (#ls;Call funcS argsS) - (#ls;Call (recur funcS) (L/map recur argsS)) + (#ls;Call argsS funcS) + (#ls;Call (L/map recur argsS) (recur funcS)) (#ls;Recur argsS) (#ls;Recur (L/map recur argsS)) diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux index 161675075..7c1444e01 100644 --- a/new-luxc/test/test/luxc/common.lux +++ b/new-luxc/test/test/luxc/common.lux @@ -4,7 +4,8 @@ ["r" math/random "r/" Monad<Random>] (data ["R" result]) [macro] - (macro [code])) + (macro [code]) + [io]) (luxc ["&" base] [analyser] ["&;" host])) @@ -32,4 +33,4 @@ #;expected #;None #;seed +0 #;scope-type-vars (list) - #;host (:! Void (&host;init-host []))}) + #;host (:! Void (io;run &host;init-host))}) diff --git a/new-luxc/test/test/luxc/generator/function.lux b/new-luxc/test/test/luxc/generator/function.lux new file mode 100644 index 000000000..76ab600fe --- /dev/null +++ b/new-luxc/test/test/luxc/generator/function.lux @@ -0,0 +1,96 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data text/format + [product] + ["R" result] + [bool "B/" Eq<Bool>] + [text "T/" Eq<Text>] + (coll ["a" array] + [list "L/" Functor<List>] + ["S" set])) + ["r" math/random "r/" Monad<Random>] + [macro #+ Monad<Lux>] + (macro [code]) + [host] + test) + (luxc (lang ["ls" synthesis]) + [analyser] + [synthesizer] + (generator ["@;" expr] + ["@;" eval] + ["@;" runtime] + ["@;" common])) + (test/luxc common)) + +(def: arity-limit Nat +10) + +(def: arity + (r;Random ls;Arity) + (|> r;nat (r/map (|>. (n.% arity-limit) (n.max +1))))) + +(def: gen-function + (r;Random [ls;Arity Nat ls;Synthesis]) + (do r;Monad<Random> + [arity arity + arg (|> r;nat (:: @ map (n.% arity))) + #let [functionS (#ls;Function arity (list) (#ls;Variable (nat-to-int (n.inc arg))))]] + (wrap [arity arg functionS]))) + +(context: "Function." + [[arity arg functionS] gen-function + cut-off (|> r;nat (:: @ map (n.% arity))) + args (r;list arity r;nat) + #let [arg-value (assume (list;nth arg args)) + argsS (L/map (|>. #ls;Nat) args) + last-arg (n.dec arity) + cut-off (|> cut-off (n.min (n.dec last-arg)))]] + ($_ seq + (test "Can read arguments." + (|> (do Monad<Lux> + [runtime-bytecode @runtime;generate] + (@eval;eval (@expr;generate (#ls;Call argsS functionS)))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= arg-value (:! Nat valueG)) + + (#R;Error error) + false))) + (test "Can partially apply functions." + (or (n.= +1 arity) + (|> (do Monad<Lux> + [#let [partial-arity (n.inc cut-off) + preS (list;take partial-arity argsS) + postS (list;drop partial-arity argsS)] + runtime-bytecode @runtime;generate] + (@eval;eval (@expr;generate (|> functionS (#ls;Call preS) (#ls;Call postS))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= arg-value (:! Nat valueG)) + + (#R;Error error) + false)))) + (test "Can read environment." + (or (n.= +1 arity) + (|> (do Monad<Lux> + [#let [env (|> (list;n.range +0 cut-off) + (L/map (|>. n.inc nat-to-int))) + super-arity (n.inc cut-off) + arg-var (if (n.<= cut-off arg) + (|> arg n.inc nat-to-int (i.* -1)) + (|> arg n.inc (n.- super-arity) nat-to-int)) + sub-arity (|> arity (n.- super-arity)) + functionS (<| (#ls;Function super-arity (list)) + (#ls;Function sub-arity env) + (#ls;Variable arg-var))] + runtime-bytecode @runtime;generate] + (@eval;eval (@expr;generate (#ls;Call argsS functionS)))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= arg-value (:! Nat valueG)) + + (#R;Error error) + false)))) + )) diff --git a/new-luxc/test/test/luxc/synthesizer/function.lux b/new-luxc/test/test/luxc/synthesizer/function.lux index 7257307dc..6791eceb4 100644 --- a/new-luxc/test/test/luxc/synthesizer/function.lux +++ b/new-luxc/test/test/luxc/synthesizer/function.lux @@ -142,7 +142,7 @@ ($_ seq (test "Can synthesize function application." (|> (synthesizer;synthesize (la;apply argsA funcA)) - (case> (#ls;Call funcS argsS) + (case> (#ls;Call argsS funcS) (and (corresponds? funcA funcS) (list;every? (product;uncurry corresponds?) (list;zip2 argsA argsS))) diff --git a/new-luxc/test/test/luxc/synthesizer/loop.lux b/new-luxc/test/test/luxc/synthesizer/loop.lux index 45b86ede6..849df78d4 100644 --- a/new-luxc/test/test/luxc/synthesizer/loop.lux +++ b/new-luxc/test/test/luxc/synthesizer/loop.lux @@ -157,7 +157,7 @@ (and (n.= arity (list;size _inits)) (not (&&loop;contains-self-reference? _body))) - (#ls;Call (#ls;Function _arity _env _bodyS) argsS) + (#ls;Call argsS (#ls;Function _arity _env _bodyS)) (&&loop;contains-self-reference? _bodyS) _ diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index d07822069..30fab3878 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -21,11 +21,10 @@ (generator ["_;G" primitive] ["_;G" structure] ["_;G" case] + ["_;G" function] (procedure ["_;G" common])) )) - ## (luxc (generator ["_;G" function])) ) -## [Program] (program: args (test;run)) diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 641e8693d..6b29d7c42 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -5603,10 +5603,10 @@ (macro: #export (undefined tokens) {#;doc (doc "Meant to be used as a stand-in for functions with undefined implementations." "Undefined expressions will type-check against everything, so they make good dummy implementations." + "However, if an undefined expression is ever evaluated, it will raise a runtime error." (def: (square x) (-> Int Int) - (undefined)) - "If an undefined expression is ever evaluated, it will raise an error.")} + (undefined)))} (case tokens #;Nil (return (list (` (error! "Undefined behavior.")))) @@ -5761,3 +5761,10 @@ _ (#;Left "Wrong syntax for char"))) + +(def: #export (when test f) + (All [a] (-> Bool (-> a a) (-> a a))) + (function [value] + (if test + (f value) + value))) diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index 61a6ddbd0..cdb9cc457 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -1,4 +1,4 @@ -(;module: [lux #- if loop +(;module: [lux #- if loop when n.+ n.- n.* n./ n.% n.= n.< n.<= n.> n.>= i.+ i.- i.* i./ i.% i.= i.< i.<= i.> i.>= d.+ d.- d.* d./ d.% d.= d.< d.<= d.> d.>= diff --git a/stdlib/source/lux/data/coll/tree/parser.lux b/stdlib/source/lux/data/coll/tree/parser.lux new file mode 100644 index 000000000..203f55b16 --- /dev/null +++ b/stdlib/source/lux/data/coll/tree/parser.lux @@ -0,0 +1,50 @@ +(;module: + lux + (lux (control ["p" parser] + ["ex" exception #+ exception:]) + (data ["R" result])) + (.. ["T" rose] + ["Z" zipper])) + +(type: #export (Parser t a) + (p;Parser (Z;Zipper t) a)) + +(def: #export (run-zipper zipper parser) + (All [t a] (-> (Z;Zipper t) (Parser t a) (R;Result a))) + (case (p;run zipper parser) + (#R;Success [zipper output]) + (#R;Success output) + + (#R;Error error) + (#R;Error error))) + +(def: #export (run tree parser) + (All [t a] (-> (T;Tree t) (Parser t a) (R;Result a))) + (run-zipper (Z;zip tree) parser)) + +(def: #export value + (All [t] (Parser t t)) + (function [zipper] + (#R;Success [zipper (Z;value zipper)]))) + +(exception: #export Cannot-Move-Further) + +(do-template [<name> <direction>] + [(def: #export <name> + (All [t] (Parser t [])) + (function [zipper] + (let [next (<direction> zipper)] + (if (is zipper next) + (ex;throw Cannot-Move-Further "") + (#R;Success [next []])))))] + + [up Z;up] + [down Z;down] + [left Z;left] + [right Z;right] + [root Z;root] + [rightmost Z;rightmost] + [leftmost Z;leftmost] + [next Z;next] + [prev Z;prev] + ) diff --git a/stdlib/source/lux/data/coll/tree/zipper.lux b/stdlib/source/lux/data/coll/tree/zipper.lux index b217a0677..6b39178bc 100644 --- a/stdlib/source/lux/data/coll/tree/zipper.lux +++ b/stdlib/source/lux/data/coll/tree/zipper.lux @@ -21,24 +21,24 @@ #node (Tree a)}) ## [Values] -(def: #export (from-tree tree) +(def: #export (zip tree) (All [a] (-> (Tree a) (Zipper a))) {#parent #;None #lefts stack;empty #rights stack;empty #node tree}) -(def: #export (to-tree zipper) +(def: #export (unzip zipper) (All [a] (-> (Zipper a) (Tree a))) (get@ #node zipper)) (def: #export (value zipper) (All [a] (-> (Zipper a) a)) - (|> zipper (get@ #node) (get@ #rose;value))) + (|> zipper (get@ [#node #rose;value]))) (def: #export (children zipper) (All [a] (-> (Zipper a) (List (Tree a)))) - (|> zipper (get@ #node) (get@ #rose;children))) + (|> zipper (get@ [#node #rose;children]))) (def: #export (branch? zipper) (All [a] (-> (Zipper a) Bool)) @@ -48,9 +48,19 @@ (All [a] (-> (Zipper a) Bool)) (|> zipper branch? not)) -(def: #export (parent zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (get@ #parent zipper)) +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bool)) + (and (list;empty? (get@ #rights zipper)) + (list;empty? (children zipper)))) + +(def: #export (root? zipper) + (All [a] (-> (Zipper a) Bool)) + (case (get@ #parent zipper) + #;None + true + + _ + false)) (def: #export (down zipper) (All [a] (-> (Zipper a) (Zipper a))) @@ -108,6 +118,20 @@ [left leftmost #lefts #rights] ) +(do-template [<name> <h-side> <h-op> <v-op>] + [(def: #export (<name> zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ <h-side> zipper) + #;Nil + (<v-op> zipper) + + _ + (<h-op> zipper)))] + + [next #rights right down] + [prev #lefts left up] + ) + (def: #export (set value zipper) (All [a] (-> a (Zipper a) (Zipper a))) (set@ [#node #rose;value] value zipper)) @@ -169,34 +193,6 @@ [insert-right #rights] ) -(do-template [<name> <h-side> <h-op> <v-op>] - [(def: #export (<name> zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ <h-side> zipper) - #;Nil - (<v-op> zipper) - - _ - (<h-op> zipper)))] - - [next #rights right down] - [prev #lefts left up] - ) - -(def: #export (end? zipper) - (All [a] (-> (Zipper a) Bool)) - (and (list;empty? (get@ #rights zipper)) - (list;empty? (children zipper)))) - -(def: #export (root? zipper) - (All [a] (-> (Zipper a) Bool)) - (case (get@ #parent zipper) - #;None - true - - _ - false)) - (struct: #export _ (Functor Zipper) (def: (map f fa) {#parent (|> fa (get@ #parent) (M/map (map f))) @@ -211,7 +207,7 @@ ## (def: (split wa) ## (let [tree-splitter (function tree-splitter [tree] -## {#rose;value (from-tree tree) +## {#rose;value (zip tree) ## #rose;children (L/map tree-splitter ## (get@ #rose;children tree))})] ## {#parent (|> wa (get@ #parent) (M/map split)) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 4ff38380f..dc6074ef5 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -3,37 +3,28 @@ (lux (control monad [eq #+ Eq] codec - ["p" parser "p/" Monad<Parser>]) + ["p" parser "p/" Monad<Parser>] + ["ex" exception #+ exception:]) (data [text "text/" Eq<Text> Monoid<Text>] (text ["l" lexer]) [number] ["R" result] [product] [maybe "m/" Monad<Maybe>] - [ident "Ident/" Eq<Ident> Codec<Text,Ident>] + [ident "ident/" Eq<Ident> Codec<Text,Ident>] (coll [list "L/" Monad<List>] - ["d" dict] - (tree ["T" rose] - ["Z" zipper]))) + ["d" dict])) )) -## [Types] (type: #export Tag Ident) (type: #export Attrs (d;Dict Ident Text)) +(def: #export attrs Attrs (d;new ident;Hash<Ident>)) + (type: #export #rec XML (#Text Text) (#Node Tag Attrs (List XML))) -(def: #export (text value) - (-> Text XML) - (#Text value)) - -(def: #export (node tag attrs children) - (-> Tag Attrs (List XML) XML) - (#Node tag attrs children)) - -## [Parsing] (def: xml-standard-escape-char^ (l;Lexer Text) ($_ p;either @@ -119,9 +110,9 @@ (p;after (l;this "/")) (l;enclosed ["<" ">"]))] (p;assert ($_ text/append "Close tag does not match open tag.\n" - "Expected: " (Ident/encode expected) "\n" - " Actual: " (Ident/encode actual) "\n") - (Ident/= expected actual)))) + "Expected: " (ident/encode expected) "\n" + " Actual: " (ident/encode actual) "\n") + (ident/= expected actual)))) (def: comment^ (l;Lexer Text) @@ -163,12 +154,12 @@ attrs (spaced^ attrs^) #let [no-children^ (do p;Monad<Parser> [_ (l;this "/>")] - (wrap (node tag attrs (list)))) + (wrap (#Node tag attrs (list)))) with-children^ (do p;Monad<Parser> [_ (l;this ">") children (p;some node^) _ (close-tag^ tag)] - (wrap (node tag attrs children)))]] + (wrap (#Node tag attrs children)))]] (p;either no-children^ with-children^)))))) ## This is put outside of the call to "rec" because comments @@ -182,7 +173,6 @@ (-> Text (R;Result XML)) (l;run input xml^)) -## [Generation] (def: (sanitize-value input) (-> Text Text) (|> input @@ -231,7 +221,6 @@ (text;join-with "")) "</" tag ">"))))))) -## [Structs] (struct: #export _ (Codec Text XML) (def: encode write) (def: decode read)) @@ -244,7 +233,7 @@ [(#Node reference/tag reference/attrs reference/children) (#Node sample/tag sample/attrs sample/children)] - (and (Ident/= reference/tag sample/tag) + (and (ident/= reference/tag sample/tag) (:: (d;Eq<Dict> text;Eq<Text>) = reference/attrs sample/attrs) (n.= (list;size reference/children) (list;size sample/children)) @@ -253,3 +242,108 @@ _ false))) + +(type: #export (Reader a) + (p;Parser (List XML) a)) + +(exception: #export Empty-Input) +(exception: #export Unexpected-Input) +(exception: #export Unknown-Attribute) +(exception: #export Wrong-Tag) +(exception: #export Unconsumed-Inputs) + +(def: #export text + (Reader Text) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head tail) + (case head + (#Text value) + (#R;Success [tail value]) + + (#Node _) + (ex;throw Unexpected-Input ""))))) + +(def: #export (attr name) + (-> Ident (Reader Text)) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head _) + (case head + (#Text _) + (ex;throw Unexpected-Input "") + + (#Node tag attrs children) + (case (d;get name attrs) + #;None + (ex;throw Unknown-Attribute "") + + (#;Some value) + (#R;Success [docs value])))))) + +(def: (run' docs reader) + (All [a] (-> (List XML) (Reader a) (R;Result a))) + (case (p;run docs reader) + (#R;Success [remaining output]) + (if (list;empty? remaining) + (#R;Success output) + (ex;throw Unconsumed-Inputs (|> remaining + (L/map (:: Codec<Text,XML> encode)) + (text;join-with "\n\n")))) + + (#R;Error error) + (#R;Error error))) + +(def: #export (node tag) + (-> Ident (Reader Unit)) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head _) + (case head + (#Text _) + (ex;throw Unexpected-Input "") + + (#Node _tag _attrs _children) + (if (ident/= tag _tag) + (#R;Success [docs []]) + (ex;throw Wrong-Tag (ident/encode tag))))))) + +(def: #export (children reader) + (All [a] (-> (Reader a) (Reader a))) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head tail) + (case head + (#Text _) + (ex;throw Unexpected-Input "") + + (#Node _tag _attrs _children) + (do R;Monad<Result> + [output (run' _children reader)] + (wrap [tail output])))))) + +(def: #export ignore + (Reader Unit) + (function [docs] + (case docs + #;Nil + (ex;throw Empty-Input "") + + (#;Cons head tail) + (#R;Success [tail []])))) + +(def: #export (run document reader) + (All [a] (-> XML (Reader a) (R;Result a))) + (run' (list document) reader)) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 73c37d598..c2933ba85 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -99,45 +99,48 @@ (type: #rec Infix (#Const Code) (#Call (List Code)) - (#Infix Infix Code Infix)) - -(def: (infix^ _) - (-> Unit (Syntax Infix)) - ($_ p;alt - ($_ p;either - (p/map code;bool s;bool) - (p/map code;nat s;nat) - (p/map code;int s;int) - (p/map code;deg s;deg) - (p/map code;frac s;frac) - (p/map code;text s;text) - (p/map code;symbol s;symbol) - (p/map code;tag s;tag)) - (s;form (p;many s;any)) - (s;tuple (p;either (do p;Monad<Parser> - [_ (s;this (' #and)) - init-subject (infix^ []) - init-op s;any - init-param (infix^ []) - steps (p;some (p;seq s;any (infix^ [])))] - (wrap (product;right (L/fold (function [[op param] [subject [_subject _op _param]]] - [param [(#Infix _subject _op _param) - (` and) - (#Infix subject op param)]]) - [init-param [init-subject init-op init-param]] - steps)))) - (do p;Monad<Parser> - [_ (wrap []) - init-subject (infix^ []) - init-op s;any - init-param (infix^ []) - steps (p;some (p;seq s;any (infix^ [])))] - (wrap (L/fold (function [[op param] [_subject _op _param]] - [(#Infix _subject _op _param) op param]) - [init-subject init-op init-param] - steps))) - )) - )) + (#Unary Code Infix) + (#Binary Infix Code Infix)) + +(def: infix^ + (Syntax Infix) + (<| p;rec (function [infix^]) + ($_ p;alt + ($_ p;either + (p/map code;bool s;bool) + (p/map code;nat s;nat) + (p/map code;int s;int) + (p/map code;deg s;deg) + (p/map code;frac s;frac) + (p/map code;text s;text) + (p/map code;symbol s;symbol) + (p/map code;tag s;tag)) + (s;form (p;many s;any)) + (s;tuple (p;seq s;any infix^)) + (s;tuple ($_ p;either + (do p;Monad<Parser> + [_ (s;this (' #and)) + init-subject infix^ + init-op s;any + init-param infix^ + steps (p;some (p;seq s;any infix^))] + (wrap (product;right (L/fold (function [[op param] [subject [_subject _op _param]]] + [param [(#Binary _subject _op _param) + (` and) + (#Binary subject op param)]]) + [init-param [init-subject init-op init-param]] + steps)))) + (do p;Monad<Parser> + [init-subject infix^ + init-op s;any + init-param infix^ + steps (p;some (p;seq s;any infix^))] + (wrap (L/fold (function [[op param] [_subject _op _param]] + [(#Binary _subject _op _param) op param]) + [init-subject init-op init-param] + steps))) + )) + ))) (def: (infix-to-prefix infix) (-> Infix Code) @@ -147,15 +150,19 @@ (#Call parts) (code;form parts) + + (#Unary op subject) + (` ((~ op) (~ (infix-to-prefix subject)))) - (#Infix left op right) + (#Binary left op right) (` ((~ op) (~ (infix-to-prefix right)) (~ (infix-to-prefix left)))) )) -(syntax: #export (infix [expr (infix^ [])]) +(syntax: #export (infix [expr infix^]) {#;doc (doc "Infix math syntax." (infix [x i.* 10]) (infix [[x i.+ y] i.* [x i.- y]]) + (infix [sin [x i.+ y]]) (infix [[x n.< y] and [y n.< z]]) (infix [#and x n.< y n.< z]) (infix [(n.* +3 +9) gcd +450]) diff --git a/stdlib/test/test/lux/data/coll/tree/zipper.lux b/stdlib/test/test/lux/data/coll/tree/zipper.lux index b7936b140..9154459b9 100644 --- a/stdlib/test/test/lux/data/coll/tree/zipper.lux +++ b/stdlib/test/test/lux/data/coll/tree/zipper.lux @@ -3,23 +3,23 @@ (lux [io] (control [monad #+ do Monad] pipe) - (data (coll [list "List/" Fold<List> Functor<List>] + (data (coll [list "L/" Fold<List> Functor<List>] (tree ["&" zipper] [rose])) - [text "Text/" Monoid<Text>] + [text] text/format [number]) - ["R" math/random]) + ["r" math/random]) lux/test) (def: gen-tree - (R;Random (rose;Tree Nat)) - (R;rec (function [gen-tree] - (do R;Monad<Random> + (r;Random (rose;Tree Nat)) + (r;rec (function [gen-tree] + (do r;Monad<Random> ## Each branch can have, at most, 1 child. - [size (|> R;nat (:: @ map (n.% +2)))] - (R;seq R;nat - (R;list size gen-tree)))))) + [size (|> r;nat (:: @ map (n.% +2)))] + (r;seq r;nat + (r;list size gen-tree)))))) (def: (to-end zipper) (All [a] (-> (&;Zipper a) (&;Zipper a))) @@ -28,35 +28,34 @@ zipper (recur (&;next zipper))))) -(context: "Zippers" +(context: "Zippers." [sample gen-tree - new-val R;nat - pre-val R;nat - post-val R;nat - #let [(^open "Tree/") (rose;Eq<Tree> number;Eq<Nat>) - (^open "List/") (list;Eq<List> number;Eq<Nat>)]] + new-val r;nat + pre-val r;nat + post-val r;nat + #let [(^open "tree/") (rose;Eq<Tree> number;Eq<Nat>) + (^open "L/") (list;Eq<List> number;Eq<Nat>)]] ($_ seq (test "Trees can be converted to/from zippers." (|> sample - &;from-tree &;to-tree - (Tree/= sample))) + &;zip &;unzip + (tree/= sample))) (test "Creating a zipper gives you a root node." - (|> sample &;from-tree &;root?)) + (|> sample &;zip &;root?)) (test "Can move down inside branches. Can move up from lower nodes." - (let [zipper (&;from-tree sample)] + (let [zipper (&;zip sample)] (if (&;branch? zipper) (let [child (|> zipper &;down)] - (and (not (Tree/= sample (&;to-tree child))) - (|> child &;parent (default (undefined)) (is zipper)) + (and (not (tree/= sample (&;unzip child))) (|> child &;up (is zipper) not) (|> child &;root (is zipper) not))) (and (&;leaf? zipper) (|> zipper (&;prepend-child new-val) &;branch?))))) (test "Can prepend and append children." - (let [zipper (&;from-tree sample)] + (let [zipper (&;zip sample)] (if (&;branch? zipper) (let [mid-val (|> zipper &;down &;value) zipper (|> zipper @@ -71,7 +70,7 @@ true))) (test "Can insert children around a node (unless it's root)." - (let [zipper (&;from-tree sample)] + (let [zipper (&;zip sample)] (if (&;branch? zipper) (let [mid-val (|> zipper &;down &;value) zipper (|> zipper @@ -93,26 +92,26 @@ #;None true)))))) (test "Can set and update the value of a node." - (|> sample &;from-tree (&;set new-val) &;value (n.= new-val))) + (|> sample &;zip (&;set new-val) &;value (n.= new-val))) (test "Zipper traversal follows the outline of the tree depth-first." - (List/= (rose;flatten sample) - (loop [zipper (&;from-tree sample)] - (if (&;end? zipper) - (list (&;value zipper)) - (#;Cons (&;value zipper) - (recur (&;next zipper))))))) + (L/= (rose;flatten sample) + (loop [zipper (&;zip sample)] + (if (&;end? zipper) + (list (&;value zipper)) + (#;Cons (&;value zipper) + (recur (&;next zipper))))))) (test "Backwards zipper traversal yield reverse tree flatten." - (List/= (list;reverse (rose;flatten sample)) - (loop [zipper (to-end (&;from-tree sample))] - (if (&;root? zipper) - (list (&;value zipper)) - (#;Cons (&;value zipper) - (recur (&;prev zipper))))))) + (L/= (list;reverse (rose;flatten sample)) + (loop [zipper (to-end (&;zip sample))] + (if (&;root? zipper) + (list (&;value zipper)) + (#;Cons (&;value zipper) + (recur (&;prev zipper))))))) (test "Can remove nodes (except root nodes)." - (let [zipper (&;from-tree sample)] + (let [zipper (&;zip sample)] (if (&;branch? zipper) (and (|> zipper &;down &;root? not) (|> zipper &;down &;remove (case> #;None false diff --git a/stdlib/test/test/lux/data/format/xml.lux b/stdlib/test/test/lux/data/format/xml.lux index 1910caf3e..382659ab0 100644 --- a/stdlib/test/test/lux/data/format/xml.lux +++ b/stdlib/test/test/lux/data/format/xml.lux @@ -2,13 +2,15 @@ lux (lux [io] (control [monad #+ do Monad] + ["p" parser] pipe) - (data [text "Text/" Monoid<Text>] + (data [text "text/" Eq<Text>] text/format [ident] + ["R" result] (format ["&" xml]) (coll [dict] - [list])) + [list "L/" Functor<List>])) ["r" math/random "r/" Monad<Random>] test) ) @@ -52,7 +54,7 @@ (r;dict ident;Hash<Ident> size xml-identifier^ (xml-text^ +0 +10)) (r;list size gen-xml))))))) -(context: "XML" +(context: "XML." [sample gen-xml #let [(^open "&/") &;Eq<XML> (^open "&/") &;Codec<Text,XML>]] @@ -68,3 +70,44 @@ (#;Left error) false))) )) + +(context: "Parsing." + [text (xml-text^ +1 +10) + num-children (|> r;nat (:: @ map (n.% +5))) + children (r;list num-children (xml-text^ +1 +10)) + tag xml-identifier^ + attr xml-identifier^ + value (xml-text^ +1 +10) + #let [node (#&;Node tag + (dict;put attr value &;attrs) + (L/map (|>. #&;Text) children))]] + ($_ seq + (test "Can parse text." + (R;default false + (do R;Monad<Result> + [output (&;run (#&;Text text) + &;text)] + (wrap (text/= text output))))) + (test "Can parse attributes." + (R;default false + (do R;Monad<Result> + [output (|> (&;attr attr) + (p;before &;ignore) + (&;run node))] + (wrap (text/= value output))))) + (test "Can parse nodes." + (R;default false + (do R;Monad<Result> + [_ (|> (&;node tag) + (p;before &;ignore) + (&;run node))] + (wrap true)))) + (test "Can parse children." + (R;default false + (do R;Monad<Result> + [outputs (|> (&;children (p;some &;text)) + (&;run node))] + (wrap (:: (list;Eq<List> text;Eq<Text>) = + children + outputs))))) + )) diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux index 63a449965..701790886 100644 --- a/stdlib/test/test/lux/math.lux +++ b/stdlib/test/test/lux/math.lux @@ -8,7 +8,7 @@ [number "f/" Number<Frac>] (coll [list "List/" Fold<List> Functor<List>]) [product]) - ["R" math/random] + ["r" math/random] ["&" math]) lux/test) @@ -23,7 +23,7 @@ ## ## I won't be testing this, until I can figure out what's going on, or ## ## come up with my own implementation ## (context: "Trigonometry" -## [angle (|> R;frac (:: @ map (f.* &;tau)))] +## [angle (|> r;frac (:: @ map (f.* &;tau)))] ## ($_ seq ## (test "Sine and arc-sine are inverse functions." ## (|> angle &;sin &;asin (within? margin angle))) @@ -36,11 +36,11 @@ ## )) (context: "Roots" - [factor (|> R;nat (:: @ map (|>. (n.% +1000) + [factor (|> r;nat (:: @ map (|>. (n.% +1000) (n.max +1) nat-to-int int-to-frac))) - base (|> R;frac (:: @ map (f.* factor)))] + base (|> r;frac (:: @ map (f.* factor)))] ($_ seq (test "Square-root is inverse of square." (|> base (&;pow 2.0) &;root2 (f.= base))) @@ -50,7 +50,7 @@ )) (context: "Rounding" - [sample (|> R;frac (:: @ map (f.* 1000.0)))] + [sample (|> r;frac (:: @ map (f.* 1000.0)))] ($_ seq (test "The ceiling will be an integer value, and will be >= the original." (let [ceil'd (&;ceil sample)] @@ -71,12 +71,12 @@ )) (context: "Exponentials and logarithms" - [sample (|> R;frac (:: @ map (f.* 10.0)))] + [sample (|> r;frac (:: @ map (f.* 10.0)))] (test "Logarithm is the inverse of exponential." (|> sample &;exp &;log (within? 1.0e-15 sample)))) (context: "Greatest-Common-Divisor and Least-Common-Multiple" - [#let [gen-nat (|> R;nat (:: @ map (|>. (n.% +1000) (n.max +1))))] + [#let [gen-nat (|> r;nat (:: @ map (|>. (n.% +1000) (n.max +1))))] x gen-nat y gen-nat] ($_ (test "GCD" @@ -93,17 +93,24 @@ )) (context: "Infix syntax" - [x R;nat - y R;nat - z R;nat + [x r;nat + y r;nat + z r;nat + theta r;frac #let [top (|> x (n.max y) (n.max z)) bottom (|> x (n.min y) (n.min z))]] ($_ seq (test "Constant values don't change." - (n.= x (&;infix x))) + (n.= x + (&;infix x))) - (test "Can call infix functions." - (n.= (&;gcd y x) (&;infix [x &;gcd y]))) + (test "Can call binary functions." + (n.= (&;gcd y x) + (&;infix [x &;gcd y]))) + + (test "Can call unary functions." + (f.= (&;sin theta) + (&;infix [&;sin theta]))) (test "Can use regular syntax in the middle of infix code." (n.= (&;gcd +450 (n.* +3 +9)) diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index 598c488fd..62683aea5 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -52,10 +52,10 @@ ["_;" seq] ["_;" priority-queue] ["_;" stream] - (tree ["_;" rose] - ["_;" zipper]) - (ordered ["_o;" dict] - ["_o;" set])) + (tree ["tree_;" rose] + ["tree_;" zipper]) + (ordered ["ordered_;" dict] + ["ordered_;" set])) (text ["_;" format] ["_;" lexer] ["_;" regex])) @@ -85,7 +85,8 @@ [tainted] (format [context] [html] - [css])) + [css]) + (coll (tree ["tree_;" parser]))) [macro] (math [random]) (type [unit]) |