diff options
Diffstat (limited to '')
25 files changed, 861 insertions, 273 deletions
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index abd154190..bf9368abe 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -22,6 +22,8 @@ #Eval #REPL) +(def: #export compiler-version Text "0.6.0") + (def: #export (fail message) (All [a] (-> Text (Lux a))) (do Monad<Lux> @@ -32,6 +34,12 @@ (macro;fail (format "@ " location "\n" message)))) +(def: #export (assert message test) + (-> Text Bool (Lux Unit)) + (if test + (:: Monad<Lux> wrap []) + (fail message))) + (def: #export (with-expected-type expected action) (All [a] (-> Type (Lux a) (Lux a))) (function [compiler] diff --git a/new-luxc/source/luxc/compiler/common.jvm.lux b/new-luxc/source/luxc/compiler/common.jvm.lux deleted file mode 100644 index bd5487ef6..000000000 --- a/new-luxc/source/luxc/compiler/common.jvm.lux +++ /dev/null @@ -1,65 +0,0 @@ -(;module: - lux - (lux (concurrency ["A" atom]) - (data ["R" result] - (coll ["D" dict])) - [macro] - [host #+ jvm-import])) - -## [Host] -(jvm-import org.objectweb.asm.MethodVisitor - (visitLdcInsn [Object] void)) - -(jvm-import java.lang.ClassLoader) - -## [Types] -(type: #export Compiled - Unit) - -(type: #export Blob host;Byte-Array) - -(type: #export Class-Store (A;Atom (D;Dict Text Blob))) - -(type: #export Host - {#visitor (Maybe MethodVisitor) - #loader ClassLoader - #store Class-Store}) - -(def: #export unit-value Text "\u0000unit\u0000") - -(def: (visitor::get compiler) - (-> Compiler (Maybe MethodVisitor)) - (|> (get@ #;host compiler) - (:! Host) - (get@ #visitor))) - -(def: (visitor::put ?visitor compiler) - (-> (Maybe MethodVisitor) Compiler Compiler) - (update@ #;host - (function [host] - (|> host - (:! Host) - (set@ #visitor ?visitor) - (:! Void))) - compiler)) - -(def: #export get-visitor - (Lux MethodVisitor) - (function [compiler] - (case (visitor::get compiler) - #;None - (#R;Error "No visitor has been set.") - - (#;Some visitor) - (#R;Success [compiler visitor])))) - -(def: #export (with-visitor visitor body) - (All [a] (-> MethodVisitor (Lux a) (Lux a))) - (function [compiler] - (case (macro;run' (visitor::put (#;Some visitor) compiler) body) - (#R;Error error) - (#R;Error error) - - (#R;Success [compiler' output]) - (#R;Success [(visitor::put (visitor::get compiler) compiler') - output])))) diff --git a/new-luxc/source/luxc/compiler/expr.jvm.lux b/new-luxc/source/luxc/compiler/expr.jvm.lux deleted file mode 100644 index b2e4923c4..000000000 --- a/new-luxc/source/luxc/compiler/expr.jvm.lux +++ /dev/null @@ -1,62 +0,0 @@ -(;module: - lux - (lux (control monad) - (data text/format) - [macro #+ Monad<Lux> "Lux/" Monad<Lux>] - [host #+ jvm-import]) - (luxc ["&" base] - (lang ["la" analysis] - ["ls" synthesis]) - ["&;" analyser] - ["&;" synthesizer] - (compiler ["&;" common]))) - -(jvm-import #long java.lang.Object) - -(jvm-import org.objectweb.asm.Opcodes) - -(jvm-import org.objectweb.asm.MethodVisitor - (visitLdcInsn [Object] void)) - -(def: unit-value Text "\u0000unit\u0000") - -(def: (compiler-literal value) - (-> Top (Lux &common;Compiled)) - (do Monad<Lux> - [visitor &common;get-visitor - #let [_ (MethodVisitor.visitLdcInsn [(:! java.lang.Object value)])]] - (wrap []))) - -(def: (compile-synthesis synthesis) - (-> ls;Synthesis (Lux &common;Compiled)) - (case synthesis - #ls;Unit - (compiler-literal &common;unit-value) - - (^template [<tag>] - (<tag> value) - (compiler-literal value)) - ([#ls;Bool] - [#ls;Nat] - [#ls;Int] - [#ls;Deg] - [#ls;Real] - [#ls;Char] - [#ls;Text]) - - _ - (macro;fail "Unrecognized synthesis."))) - -(def: (eval type code) - &;Eval - (undefined)) - -(def: analyse - &;Analyser - (&analyser;analyser eval)) - -(def: #export (compile input) - (-> Code (Lux &common;Compiled)) - (do Monad<Lux> - [analysis (analyse input)] - (compile-synthesis (&synthesizer;synthesize analysis)))) diff --git a/new-luxc/source/luxc/compiler/runtime.jvm.lux b/new-luxc/source/luxc/compiler/runtime.jvm.lux deleted file mode 100644 index 16e072194..000000000 --- a/new-luxc/source/luxc/compiler/runtime.jvm.lux +++ /dev/null @@ -1,11 +0,0 @@ -(;module: - lux - (lux (control monad) - (concurrency ["P" promise "P/" Monad<Promise>]) - (data text/format - ["R" result])) - (luxc ["&" base])) - -(def: #export (compile-runtime compiler) - (-> Compiler (P;Promise (R;Result Compiler))) - (P/wrap (#R;Success compiler))) diff --git a/new-luxc/source/luxc/compiler.lux b/new-luxc/source/luxc/generator.lux index 55fe3c738..d095023ff 100644 --- a/new-luxc/source/luxc/compiler.lux +++ b/new-luxc/source/luxc/generator.lux @@ -15,6 +15,7 @@ ["&;" io] ["&;" module] ["&;" parser] + ["&;" host] (compiler ["&&;" runtime] ["&&;" statement] ["&&;" common]) @@ -109,69 +110,6 @@ (jvm-import org.objectweb.asm.MethodVisitor) -(jvm-import java.lang.reflect.AccessibleObject - (setAccessible [boolean] void)) - -(jvm-import java.lang.reflect.Method - (invoke [Object (Array Object)] #try Object)) - -(jvm-import (java.lang.Class a) - (getDeclaredMethod [String (Array (Class Object))] #try Method)) - -(jvm-import java.lang.Object - (getClass [] (Class Object))) - -(jvm-import java.lang.Integer - (#static TYPE (Class Integer))) - -(jvm-import java.lang.ClassLoader) - -(def: ClassLoader::defineClass - Method - (case (Class.getDeclaredMethod ["defineClass" - (|> (array (Class Object) +4) - (array-store +0 (:! (Class Object) (class-for String))) - (array-store +1 (Object.getClass [] (array byte +0))) - (array-store +2 (:! (Class Object) Integer.TYPE)) - (array-store +3 (:! (Class Object) Integer.TYPE)))] - (class-for java.lang.ClassLoader)) - (#R;Success method) - (do-to method - (AccessibleObject.setAccessible [true])) - - (#R;Error error) - (error! error))) - -(def: (memory-class-loader store) - (-> &&common;Class-Store ClassLoader) - (object ClassLoader [] - [] - (ClassLoader (findClass [class-name String]) void - (case (|> store A;get io;run (D;get class-name)) - (#;Some bytecode) - (case (Method.invoke [(:! Object _jvm_this) - (array;from-list (list (:! Object class-name) - (:! Object bytecode) - (:! Object (l2i 0)) - (:! Object (l2i (nat-to-int (array-length bytecode))))))] - ClassLoader::defineClass) - (#R;Success output) - [] - - (#R;Error error) - (error! error)) - - _ - (error! (format "Unknown class: " class-name)))))) - -(def: (init-host _) - (-> Top &&common;Host) - (let [store (: &&common;Class-Store - (A;atom (D;new text;Hash<Text>)))] - {#&&common;visitor #;None - #&&common;loader (memory-class-loader store) - #&&common;store store})) - (def: init-cursor Cursor ["" +0 +0]) (def: init-type-context @@ -180,11 +118,9 @@ #;var-counter +0 #;var-bindings (list)}) -(def: compiler-version Text "0.6.0") - (def: init-compiler-info Compiler-Info - {#;compiler-version compiler-version + {#;compiler-version &;compiler-version #;compiler-mode #;Build}) (def: (init-compiler host) @@ -214,7 +150,7 @@ (def: #export (compile-program program target sources) (-> &;Path &;Path (List &;Path) (P;Promise Unit)) (do P;Monad<Promise> - [#let [compiler (init-compiler (init-host []))] + [#let [compiler (init-compiler (&host;init-host []))] compiler (or-crash! (&&runtime;compile-runtime compiler)) compiler (or-crash! (compile-module sources prelude compiler)) compiler (or-crash! (compile-module sources program compiler)) diff --git a/new-luxc/source/luxc/compiler/base.jvm.lux b/new-luxc/source/luxc/generator/base.jvm.lux index 01a97aec4..01a97aec4 100644 --- a/new-luxc/source/luxc/compiler/base.jvm.lux +++ b/new-luxc/source/luxc/generator/base.jvm.lux diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux new file mode 100644 index 000000000..e5d3552c4 --- /dev/null +++ b/new-luxc/source/luxc/generator/common.jvm.lux @@ -0,0 +1,130 @@ +(;module: + lux + (lux [io] + (concurrency ["A" atom]) + (data ["R" result] + (coll ["d" dict]) + text/format) + [macro #+ Monad<Lux>] + [host #+ jvm-import do-to])) + +## [Host] +(jvm-import org.objectweb.asm.Opcodes + (#static V1_6 int) + (#static CHECKCAST int) + (#static INVOKESTATIC int) + (#static INVOKEVIRTUAL int)) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitLdcInsn [Object] void) + (visitTypeInsn [int String] void) + (visitMethodInsn [int String String String boolean] void)) + +(jvm-import java.lang.Object + (toString [] String)) + +(jvm-import (java.lang.Class a)) + +(jvm-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 + {#visitor (Maybe MethodVisitor) + #loader ClassLoader + #store Class-Store}) + +(def: #export unit Text "\u0000") + +(def: (visitor::get compiler) + (-> Compiler (Maybe MethodVisitor)) + (|> (get@ #;host compiler) + (:! Host) + (get@ #visitor))) + +(def: (visitor::put ?visitor compiler) + (-> (Maybe MethodVisitor) Compiler Compiler) + (update@ #;host + (function [host] + (|> host + (:! Host) + (set@ #visitor ?visitor) + (:! Void))) + compiler)) + +(def: #export get-visitor + (Lux MethodVisitor) + (function [compiler] + (case (visitor::get compiler) + #;None + (#R;Error "No visitor has been set.") + + (#;Some visitor) + (#R;Success [compiler visitor])))) + +(def: #export (with-visitor visitor body) + (All [a] (-> MethodVisitor (Lux a) (Lux a))) + (function [compiler] + (case (macro;run' (visitor::put (#;Some visitor) compiler) body) + (#R;Error error) + (#R;Error error) + + (#R;Success [compiler' output]) + (#R;Success [(visitor::put (visitor::get compiler) compiler') + output])))) + +(def: #export (store-class name byte-code) + (-> Text Bytecode (Lux Unit)) + (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)) + (#R;Success [compiler (io;run (A;update (d;put name byte-code) store))]) + )))) + +(def: #export (load-class name) + (-> Text (Lux (Class Object))) + (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)))))) + + +(do-template [<wrap> <unwrap> <class> <unwrap-method> <prim> <dup>] + [(def: #export (<wrap> writer) + (-> MethodVisitor MethodVisitor) + (do-to writer + (MethodVisitor.visitMethodInsn [Opcodes.INVOKESTATIC + <class> "valueOf" (format "(" <prim> ")" "L" <class> ";") + false]))) + (def: #export (<unwrap> writer) + (-> MethodVisitor MethodVisitor) + (do-to writer + (MethodVisitor.visitTypeInsn [Opcodes.CHECKCAST <class>]) + (MethodVisitor.visitMethodInsn [Opcodes.INVOKEVIRTUAL + <class> <unwrap-method> (format "()" <prim>) + false])))] + + [wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes.DUP_X1] + [wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes.DUP_X1] + [wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes.DUP_X1] + [wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes.DUP_X1] + [wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes.DUP_X2] + [wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes.DUP_X1] + [wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes.DUP_X2] + [wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes.DUP_X1] + ) + +(type: #export Flags Int) +(type: #export Descriptor Text) + +(def: #export bytecode-version Flags Opcodes.V1_6) +(def: #export runtime-class-name Text "LuxRT") diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux new file mode 100644 index 000000000..5fcf0b288 --- /dev/null +++ b/new-luxc/source/luxc/generator/eval.jvm.lux @@ -0,0 +1,89 @@ +(;module: + lux + (lux (control monad) + (data ["R" result] + text/format) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import do-to]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (generator ["&;" common]))) + +(jvm-import java.lang.Object) +(jvm-import java.lang.String) + +(jvm-import java.lang.reflect.Field + (get [Object] Object)) + +(jvm-import (java.lang.Class a) + (getField [String] Field)) + +(jvm-import org.objectweb.asm.Opcodes + (#static ACC_PUBLIC int) + (#static ACC_SUPER int) + (#static ACC_FINAL int) + (#static ACC_STATIC int) + (#static PUTSTATIC int) + (#static RETURN int) + (#static V1_6 int) + ) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitCode [] void) + (visitEnd [] void) + (visitLdcInsn [Object] void) + (visitFieldInsn [int String String String] void) + (visitInsn [int] void) + (visitMaxs [int int] void)) + +(jvm-import org.objectweb.asm.FieldVisitor + (visitEnd [] void)) + +(jvm-import org.objectweb.asm.ClassWriter + (#static COMPUTE_MAXS int) + (new [int]) + (visit [int int String String String (Array String)] void) + (visitEnd [] void) + (visitField [int String String String Object] FieldVisitor) + (visitMethod [int String String String (Array String)] MethodVisitor) + (toByteArray [] Byte-Array)) + +(def: (make-field flags name descriptor writer) + (-> &common;Flags Text &common;Descriptor ClassWriter FieldVisitor) + (do-to (ClassWriter.visitField [flags name descriptor (host;null) (host;null)] writer) + (FieldVisitor.visitEnd []))) + +(def: eval-field-name Text "_value") +(def: eval-field-desc Text "Ljava/lang/Object;") + +(def: #export (eval generator) + (-> (Lux Unit) (Lux Top)) + (do Monad<Lux> + [class-name (:: @ map %code (macro;gensym "eval")) + #let [writer (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (ClassWriter.visit [&common;bytecode-version + (i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_SUPER) + class-name + (host;null) + "java/lang/Object" + (host;null)])) + value-field (make-field ($_ i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_STATIC Opcodes.ACC_FINAL) + eval-field-name eval-field-desc + writer) + visitor (do-to (ClassWriter.visitMethod [Opcodes.ACC_STATIC "<clinit>" "()V" (host;null) (host;null)] writer) + (MethodVisitor.visitCode []))] + _ (&common;with-visitor visitor generator) + #let [_ (do-to visitor + (MethodVisitor.visitFieldInsn [Opcodes.PUTSTATIC class-name eval-field-name eval-field-desc]) + (MethodVisitor.visitInsn [Opcodes.RETURN]) + (MethodVisitor.visitMaxs [0 0]) + (MethodVisitor.visitEnd [])) + bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))] + _ (&common;store-class class-name bytecode) + class (&common;load-class class-name)] + (wrap (|> class + (Class.getField [eval-field-name]) + (Field.get (host;null)))))) diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux new file mode 100644 index 000000000..4b038378a --- /dev/null +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -0,0 +1,55 @@ +(;module: + lux + (lux (control monad) + (data text/format) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (generator ["&;" common] + ["&;" primitive] + ["&;" structure]))) + +(def: #export (generate synthesis) + (-> ls;Synthesis (Lux Unit)) + (case synthesis + #ls;Unit + &primitive;generate-unit + + (^template [<tag> <generator>] + (<tag> value) + (<generator> value)) + ([#ls;Bool &primitive;generate-bool] + [#ls;Nat &primitive;generate-nat] + [#ls;Int &primitive;generate-int] + [#ls;Deg &primitive;generate-deg] + [#ls;Real &primitive;generate-real] + [#ls;Char &primitive;generate-char] + [#ls;Text &primitive;generate-text]) + + (#ls;Variant tag tail? member) + (&structure;generate-variant generate tag tail? member) + + (#ls;Tuple members) + (&structure;generate-tuple generate members) + + _ + (macro;fail "Unrecognized synthesis."))) + +## (def: (eval type code) +## &;Eval +## (undefined)) + +## (def: analyse +## &;Analyser +## (&analyser;analyser eval)) + +## (def: #export (generate input) +## (-> Code (Lux Unit)) +## (do Monad<Lux> +## [analysis (analyse input) +## #let [synthesis (&synthesizer;synthesize analysis)]] +## (generate-synthesis synthesis))) diff --git a/new-luxc/source/luxc/generator/primitive.jvm.lux b/new-luxc/source/luxc/generator/primitive.jvm.lux new file mode 100644 index 000000000..2c879dd48 --- /dev/null +++ b/new-luxc/source/luxc/generator/primitive.jvm.lux @@ -0,0 +1,44 @@ +(;module: + lux + (lux (control monad) + (data text/format) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (generator ["&;" common]))) + +(jvm-import #long java.lang.Object) + +(jvm-import org.objectweb.asm.Opcodes) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitLdcInsn [Object] void)) + +(def: #export generate-unit + (Lux Unit) + (do Monad<Lux> + [visitor &common;get-visitor + #let [_ (MethodVisitor.visitLdcInsn [(:! java.lang.Object &common;unit)] visitor)]] + (wrap []))) + +(do-template [<name> <type> <wrap>] + [(def: #export (<name> value) + (-> <type> (Lux Unit)) + (do Monad<Lux> + [visitor &common;get-visitor + #let [_ (MethodVisitor.visitLdcInsn [(:! java.lang.Object value)] visitor) + _ (<wrap> visitor)]] + (wrap [])))] + + [generate-bool Bool &common;wrap-boolean] + [generate-nat Nat &common;wrap-long] + [generate-int Int &common;wrap-long] + [generate-deg Deg &common;wrap-long] + [generate-real Real &common;wrap-double] + [generate-char Char &common;wrap-char] + [generate-text Text id] + ) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux new file mode 100644 index 000000000..e8831d005 --- /dev/null +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -0,0 +1,126 @@ +(;module: + lux + (lux (control monad) + (data ["R" result] + text/format) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import do-to]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (generator ["&;" common]))) + +(jvm-import java.lang.Object) +(jvm-import java.lang.String) + +(jvm-import java.lang.reflect.Field + (get [Object] #try Object)) + +(jvm-import (java.lang.Class a) + (getField [String] Field)) + +(type: Flags Int) +(type: Descriptor Text) + +(jvm-import org.objectweb.asm.Opcodes + (#static ACC_PUBLIC int) + (#static ACC_SUPER int) + (#static ACC_FINAL int) + (#static ACC_STATIC int) + (#static DUP int) + (#static PUTSTATIC int) + (#static ILOAD int) + (#static ALOAD int) + (#static ANEWARRAY int) + (#static AASTORE int) + (#static RETURN int) + (#static ARETURN int) + (#static V1_6 int) + ) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitCode [] void) + (visitEnd [] void) + (visitInsn [int] void) + (visitLdcInsn [Object] void) + (visitFieldInsn [int String String String] void) + (visitVarInsn [int int] void) + (visitTypeInsn [int String] void) + (visitMaxs [int int] void)) + +(jvm-import org.objectweb.asm.FieldVisitor + (visitEnd [] void)) + +(jvm-import org.objectweb.asm.ClassWriter + (#static COMPUTE_MAXS int) + (new [int]) + (visit [int int String String String (Array String)] void) + (visitEnd [] void) + (visitField [int String String String Object] FieldVisitor) + (visitMethod [int String String String (Array String)] MethodVisitor) + (toByteArray [] Byte-Array)) + +(def: (generate-adt-methods writer) + (-> ClassWriter ClassWriter) + (let [## I commented-out some parts because a null-check was + ## done to ensure variants were never created with null + ## values (this would interfere later with + ## pattern-matching). + ## Since Lux itself does not have null values as part of + ## the language, the burden of ensuring non-nulls was + ## shifted to library code dealing with host-interop, to + ## ensure variant-making was as fast as possible. + ## The null-checking code was left as comments in case I + ## ever change my mind. + _ (let [## $is-null (new Label) + visitor (ClassWriter.visitMethod [(i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_STATIC) + "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" + (host;null) (host;null)] + writer) + _ (do-to visitor + (MethodVisitor.visitCode []) + ## (MethodVisitor.visitVarInsn [Opcodes.ALOAD 2]) + ## (MethodVisitor.visitJumpInsn [Opcodes.IFNULL $is-null]) + (MethodVisitor.visitLdcInsn [(host;l2i 3)]) + (MethodVisitor.visitTypeInsn [Opcodes.ANEWARRAY "java/lang/Object"]) + (MethodVisitor.visitInsn [Opcodes.DUP]) + (MethodVisitor.visitLdcInsn [(host;l2i 0)]) + (MethodVisitor.visitVarInsn [Opcodes.ILOAD 0])) + _ (&common;wrap-int visitor) + _ (do-to visitor + (MethodVisitor.visitInsn [Opcodes.AASTORE]) + (MethodVisitor.visitInsn [Opcodes.DUP]) + (MethodVisitor.visitLdcInsn [(host;l2i 1)]) + (MethodVisitor.visitVarInsn [Opcodes.ALOAD 1]) + (MethodVisitor.visitInsn [Opcodes.AASTORE]) + (MethodVisitor.visitInsn [Opcodes.DUP]) + (MethodVisitor.visitLdcInsn [(host;l2i 2)]) + (MethodVisitor.visitVarInsn [Opcodes.ALOAD 2]) + (MethodVisitor.visitInsn [Opcodes.AASTORE]) + (MethodVisitor.visitInsn [Opcodes.ARETURN]) + ## (MethodVisitor.visitLabel [$is-null]) + ## (MethodVisitor.visitTypeInsn [Opcodes.NEW "java/lang/IllegalStateException"]) + ## (MethodVisitor.visitInsn [Opcodes.DUP]) + ## (MethodVisitor.visitLdcInsn ["Cannot create variant for null pointer"]) + ## (MethodVisitor.visitMethodInsn [Opcodes.INVOKESPECIAL "java/lang/IllegalStateException" "<init>" "(Ljava/lang/String;)V"]) + ## (MethodVisitor.visitInsn [Opcodes.ATHROW]) + (MethodVisitor.visitMaxs [0 0]) + (MethodVisitor.visitEnd []))] + [])] + writer)) + +(def: #export generate + (Lux &common;Bytecode) + (do Monad<Lux> + [_ (wrap []) + #let [writer (|> (do-to (ClassWriter.new ClassWriter.COMPUTE_MAXS) + (ClassWriter.visit [&common;bytecode-version + ($_ i.+ Opcodes.ACC_PUBLIC Opcodes.ACC_FINAL Opcodes.ACC_SUPER) + &common;runtime-class-name (host;null) + "java/lang/Object" (host;null)])) + generate-adt-methods) + bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))] + _ (&common;store-class &common;runtime-class-name bytecode)] + (wrap bytecode))) diff --git a/new-luxc/source/luxc/compiler/statement.jvm.lux b/new-luxc/source/luxc/generator/statement.jvm.lux index 96263181f..96263181f 100644 --- a/new-luxc/source/luxc/compiler/statement.jvm.lux +++ b/new-luxc/source/luxc/generator/statement.jvm.lux diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux new file mode 100644 index 000000000..1584cb170 --- /dev/null +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -0,0 +1,70 @@ +(;module: + lux + (lux (control monad) + (data text/format + (coll [list])) + [macro #+ Monad<Lux> "Lux/" Monad<Lux>] + [host #+ jvm-import do-to]) + (luxc ["&" base] + (lang ["la" analysis] + ["ls" synthesis]) + ["&;" analyser] + ["&;" synthesizer] + (generator ["&;" common]))) + +(jvm-import #long java.lang.Object) + +(jvm-import org.objectweb.asm.Opcodes + (#static ANEWARRAY int) + (#static DUP int) + (#static AASTORE int) + (#static ACONST_NULL int) + (#static INVOKESTATIC int)) + +(jvm-import org.objectweb.asm.MethodVisitor + (visitInsn [int] void) + (visitLdcInsn [Object] void) + (visitTypeInsn [int String] void) + (visitMethodInsn [int String String String boolean] void)) + +(def: #export (generate-tuple generate members) + (-> (-> ls;Synthesis (Lux Unit)) (List ls;Synthesis) (Lux Unit)) + (do Monad<Lux> + [#let [size (list;size members)] + _ (&;assert "Cannot generate tuples with less than 2 elements." + (n.>= +2 size)) + visitor &common;get-visitor + #let [_ (do-to visitor + (MethodVisitor.visitLdcInsn [(|> size nat-to-int host;l2i (:! java.lang.Object))]) + (MethodVisitor.visitTypeInsn [Opcodes.ANEWARRAY "java/lang/Object"]))] + _ (mapM @ (function [[idx member]] + (do @ + [#let [_ (do-to visitor + (MethodVisitor.visitInsn [Opcodes.DUP]) + (MethodVisitor.visitLdcInsn [(|> idx nat-to-int host;l2i (:! java.lang.Object))]))] + _ (generate member) + #let [_ (MethodVisitor.visitInsn [Opcodes.AASTORE] visitor)]] + (wrap []))) + (list;enumerate members))] + (wrap []))) + +(def: (generate-variant-flag tail? visitor) + (-> Bool MethodVisitor MethodVisitor) + (if tail? + (do-to visitor (MethodVisitor.visitLdcInsn [(:! java.lang.Object "")])) + (do-to visitor (MethodVisitor.visitInsn [Opcodes.ACONST_NULL])))) + +(def: #export (generate-variant generate tag tail? member) + (-> (-> ls;Synthesis (Lux Unit)) Nat Bool ls;Synthesis (Lux Unit)) + (do Monad<Lux> + [visitor &common;get-visitor + #let [_ (do-to visitor + (MethodVisitor.visitLdcInsn [(|> tag nat-to-int host;l2i (:! java.lang.Object))])) + _ (generate-variant-flag tail? visitor)] + _ (generate member) + #let [_ (do-to visitor + (MethodVisitor.visitMethodInsn [Opcodes.INVOKESTATIC + &common;runtime-class-name + "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" + false]))]] + (wrap []))) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux new file mode 100644 index 000000000..c46e1cf1f --- /dev/null +++ b/new-luxc/source/luxc/host.jvm.lux @@ -0,0 +1,86 @@ +(;module: + lux + (lux (control monad) + (concurrency ["A" atom]) + (data ["R" result] + [text] + text/format + (coll ["d" dict] + [array #+ Array])) + [macro #+ Monad<Lux>] + host + [io]) + (luxc ["&" base] + (generator ["&&;" common]) + )) + +(jvm-import java.lang.reflect.AccessibleObject + (setAccessible [boolean] void)) + +(jvm-import java.lang.reflect.Method + (invoke [Object (Array Object)] #try Object)) + +(jvm-import (java.lang.Class a) + (getDeclaredMethod [String (Array (Class Object))] #try Method)) + +(jvm-import java.lang.Object + (getClass [] (Class Object))) + +(jvm-import java.lang.Integer + (#static TYPE (Class Integer))) + +(jvm-import java.lang.ClassLoader) + +(def: ClassLoader::defineClass + Method + (case (Class.getDeclaredMethod ["defineClass" + (|> (array (Class Object) +4) + (array-store +0 (:! (Class Object) (class-for String))) + (array-store +1 (Object.getClass [] (array byte +0))) + (array-store +2 (:! (Class Object) Integer.TYPE)) + (array-store +3 (:! (Class Object) Integer.TYPE)))] + (class-for java.lang.ClassLoader)) + (#R;Success method) + (do-to method + (AccessibleObject.setAccessible [true])) + + (#R;Error error) + (error! error))) + +(def: (define-class class-name byte-code loader) + (-> Text &&common;Bytecode ClassLoader (R;Result Object)) + (Method.invoke [loader + (array;from-list (list (:! Object class-name) + (:! Object byte-code) + (:! Object (l2i 0)) + (:! Object (l2i (nat-to-int (array-length byte-code))))))] + ClassLoader::defineClass)) + +(def: (fetch-byte-code class-name store) + (-> Text &&common;Class-Store &&common;Bytecode) + (|> store A;get io;run (d;get class-name) assume)) + +(def: (assume!! input) + (All [a] (-> (R;Result a) a)) + (case input + (#R;Success output) + output + + (#R;Error error) + (error! error))) + +(def: (memory-class-loader store) + (-> &&common;Class-Store ClassLoader) + (object ClassLoader [] + [] + (ClassLoader (findClass [class-name String]) Class + (:!! (assume!! (define-class class-name (fetch-byte-code class-name store) (:! ClassLoader _jvm_this)))) + ))) + +(def: #export (init-host _) + (-> Top &&common;Host) + (let [store (: &&common;Class-Store + (A;atom (d;new text;Hash<Text>)))] + {#&&common;visitor #;None + #&&common;loader (memory-class-loader store) + #&&common;store store})) diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux index 218ebc0cd..3fe67b7a3 100644 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -22,7 +22,8 @@ (analyser ["@" case] ["@;" common]) ["@;" module]) - (.. common)) + (.. common) + (test/luxc common)) (def: (total-weaving branchings) (-> (List (List Code)) (List (List Code))) diff --git a/new-luxc/test/test/luxc/analyser/common.lux b/new-luxc/test/test/luxc/analyser/common.lux index 5e8f73fd1..9a17fbb45 100644 --- a/new-luxc/test/test/luxc/analyser/common.lux +++ b/new-luxc/test/test/luxc/analyser/common.lux @@ -6,33 +6,8 @@ [macro] (macro [code])) (luxc ["&" base] - [analyser])) - -(def: compiler-version Text "0.6.0") - -(def: init-compiler-info - Compiler-Info - {#;compiler-version compiler-version - #;compiler-mode #;Build}) - -(def: init-type-context - Type-Context - {#;ex-counter +0 - #;var-counter +0 - #;var-bindings (list)}) - -(def: #export init-compiler - Compiler - {#;info init-compiler-info - #;source [dummy-cursor ""] - #;cursor dummy-cursor - #;modules (list) - #;scopes (list) - #;type-context init-type-context - #;expected #;None - #;seed +0 - #;scope-type-vars (list) - #;host (:! Void [])}) + [analyser]) + (test/luxc common)) (def: gen-unit (r;Random Code) @@ -65,7 +40,7 @@ [(def: #export (<name> analysis) (All [a] (-> (Lux a) Bool)) (|> analysis - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) <on-success> diff --git a/new-luxc/test/test/luxc/analyser/function.lux b/new-luxc/test/test/luxc/analyser/function.lux index fe435ebf9..4957bfe06 100644 --- a/new-luxc/test/test/luxc/analyser/function.lux +++ b/new-luxc/test/test/luxc/analyser/function.lux @@ -21,7 +21,8 @@ (analyser ["@" function] ["@;" common]) ["@;" module]) - (.. common)) + (.. common) + (test/luxc common)) (def: (check-type expectedT result) (-> Type (R;Result [Type la;Analysis]) Bool) @@ -54,7 +55,7 @@ (def: (check-apply expectedT num-args analysis) (-> Type Nat (Lux [Type la;Analysis]) Bool) (|> analysis - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success [applyT applyA]) (let [[funcA argsA] (flatten-apply applyA)] (and (Type/= expectedT applyT) @@ -72,36 +73,36 @@ (assert "Can analyse function." (|> (&;with-expected-type (type (All [a] (-> a outputT))) (@;analyse-function analyse func-name arg-name outputC)) - (macro;run init-compiler) + (macro;run (init-compiler [])) succeeds?)) (assert "Generic functions can always be specialized." (and (|> (&;with-expected-type (-> inputT outputT) (@;analyse-function analyse func-name arg-name outputC)) - (macro;run init-compiler) + (macro;run (init-compiler [])) succeeds?) (|> (&;with-expected-type (-> inputT inputT) (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) - (macro;run init-compiler) + (macro;run (init-compiler [])) succeeds?))) (assert "Can infer function (constant output and unused input)." (|> (@common;with-unknown-type (@;analyse-function analyse func-name arg-name outputC)) - (macro;run init-compiler) + (macro;run (init-compiler [])) (check-type (type (All [a] (-> a outputT)))))) (assert "Can infer function (output = input)." (|> (@common;with-unknown-type (@;analyse-function analyse func-name arg-name (code;symbol ["" arg-name]))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (check-type (type (All [a] (-> a a)))))) (assert "The function's name is bound to the function's type." (|> (&;with-expected-type (type (Rec self (-> inputT self))) (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (macro;run init-compiler) + (macro;run (init-compiler [])) succeeds?)) (assert "Can infer recursive types for functions." (|> (@common;with-unknown-type (@;analyse-function analyse func-name arg-name (code;symbol ["" func-name]))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (check-type (type (Rec self (All [a] (-> a self))))))) )) diff --git a/new-luxc/test/test/luxc/analyser/primitive.lux b/new-luxc/test/test/luxc/analyser/primitive.lux index 11a10088b..5e4e318a5 100644 --- a/new-luxc/test/test/luxc/analyser/primitive.lux +++ b/new-luxc/test/test/luxc/analyser/primitive.lux @@ -24,7 +24,8 @@ [analyser] (analyser ["@" primitive] ["@;" common])) - (.. common)) + (.. common) + (test/luxc common)) (test: "Primitives" [%bool% r;bool @@ -39,7 +40,7 @@ [(assert (format "Can analyse " <desc> ".") (|> (@common;with-unknown-type (<analyser> <value>)) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success [_type (<tag> value)]) (and (Type/= <type> _type) (is <value> value)) diff --git a/new-luxc/test/test/luxc/analyser/procedure/common.lux b/new-luxc/test/test/luxc/analyser/procedure/common.lux index dc4459734..9ebcf6880 100644 --- a/new-luxc/test/test/luxc/analyser/procedure/common.lux +++ b/new-luxc/test/test/luxc/analyser/procedure/common.lux @@ -20,14 +20,15 @@ [analyser] (analyser ["@" procedure] ["@;" common])) - (../.. common)) + (../.. common) + (test/luxc common)) (do-template [<name> <success> <failure>] [(def: (<name> procedure params output-type) (-> Text (List Code) Type Bool) (|> (&;with-expected-type output-type (@;analyse-procedure analyse procedure params)) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) <success> @@ -247,7 +248,7 @@ (@;analyse-procedure analyse "array get" (list idxC (code;symbol ["" var-name])))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) true @@ -261,7 +262,7 @@ (list idxC elemC (code;symbol ["" var-name])))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) true @@ -274,7 +275,7 @@ (@;analyse-procedure analyse "array remove" (list idxC (code;symbol ["" var-name])))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) true @@ -286,7 +287,7 @@ (&;with-expected-type Nat (@;analyse-procedure analyse "array size" (list (code;symbol ["" var-name])))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) true @@ -342,7 +343,7 @@ (&;with-expected-type elemT (@;analyse-procedure analyse "atom read" (list (code;symbol ["" var-name])))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) true @@ -356,7 +357,7 @@ (list elemC elemC (code;symbol ["" var-name])))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) true diff --git a/new-luxc/test/test/luxc/analyser/reference.lux b/new-luxc/test/test/luxc/analyser/reference.lux index 2acec2cad..5e277b2a6 100644 --- a/new-luxc/test/test/luxc/analyser/reference.lux +++ b/new-luxc/test/test/luxc/analyser/reference.lux @@ -14,7 +14,8 @@ [analyser] (analyser ["@" reference] ["@;" common])) - (.. common)) + (.. common) + (test/luxc common)) (test: "References" [[ref-type _] gen-primitive @@ -27,7 +28,7 @@ (&env;with-local [var-name ref-type] (@common;with-unknown-type (@;analyse-reference ["" var-name])))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success [_type (#~;Relative idx)]) (Type/= ref-type _type) @@ -40,7 +41,7 @@ [ref-type (list) (:! Void [])])] (@common;with-unknown-type (@;analyse-reference [module-name var-name]))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success [_type (#~;Absolute idx)]) (Type/= ref-type _type) diff --git a/new-luxc/test/test/luxc/analyser/structure.lux b/new-luxc/test/test/luxc/analyser/structure.lux index 801f61616..597388aa2 100644 --- a/new-luxc/test/test/luxc/analyser/structure.lux +++ b/new-luxc/test/test/luxc/analyser/structure.lux @@ -22,7 +22,8 @@ (analyser ["@" structure] ["@;" common]) ["@;" module]) - (.. common)) + (.. common) + (test/luxc common)) (def: (flatten-tuple analysis) (-> la;Analysis (List la;Analysis)) @@ -73,7 +74,7 @@ (|> (&;with-scope (&;with-expected-type variantT (@;analyse-sum analyse choice valueC))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (^multi (#R;Success [_ sumA]) [(flatten-variant sumA) (#;Some [tag last? valueA])]) @@ -91,7 +92,7 @@ (TC;check varT variantT))] (&;with-expected-type varT (@;analyse-sum analyse choice valueC)))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (^multi (#R;Success [_ sumA]) [(flatten-variant sumA) (#;Some [tag last? valueA])]) @@ -106,7 +107,7 @@ (function [[var-id varT]] (&;with-expected-type varT (@;analyse-sum analyse choice valueC))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) false @@ -116,7 +117,7 @@ (|> (&;with-scope (&;with-expected-type (type;ex-q +1 +variantT) (@;analyse-sum analyse +choice +valueC))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) true @@ -126,7 +127,7 @@ (|> (&;with-scope (&;with-expected-type (type;univ-q +1 +variantT) (@;analyse-sum analyse +choice +valueC))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) (not (n.= choice +choice)) @@ -148,7 +149,7 @@ (assert "Can analyse product." (|> (&;with-expected-type (type;tuple (L/map product;left primitives)) (@;analyse-product analyse (L/map product;right primitives))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success tupleA) (n.= size (list;size (flatten-tuple tupleA))) @@ -157,7 +158,7 @@ (assert "Can infer product." (|> (@common;with-unknown-type (@;analyse-product analyse (L/map product;right primitives))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success [_type tupleA]) (and (Type/= (type;tuple (L/map product;left primitives)) _type) @@ -168,7 +169,7 @@ (assert "Can analyse pseudo-product (singleton tuple)" (|> (&;with-expected-type singletonT (analyse (` [(~ singletonC)]))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success singletonA) true @@ -183,7 +184,7 @@ (TC;check varT (type;tuple (L/map product;left primitives))))] (&;with-expected-type varT (@;analyse-product analyse (L/map product;right primitives))))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success [_ tupleA]) (n.= size (list;size (flatten-tuple tupleA))) @@ -193,7 +194,7 @@ (|> (&;with-scope (&;with-expected-type (type;ex-q +1 +tupleT) (@;analyse-product analyse (L/map product;right +primitives)))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) true @@ -203,7 +204,7 @@ (|> (&;with-scope (&;with-expected-type (type;univ-q +1 +tupleT) (@;analyse-product analyse (L/map product;right +primitives)))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (#R;Success _) false @@ -214,7 +215,7 @@ (def: (check-variant-inference variantT choice size analysis) (-> Type Nat Nat (Lux [Module Scope Type la;Analysis]) Bool) (|> analysis - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (^multi (#R;Success [_ _ sumT sumA]) [(flatten-variant sumA) (#;Some [tag last? valueA])]) @@ -228,7 +229,7 @@ (def: (check-record-inference tupleT size analysis) (-> Type Nat (Lux [Module Scope Type la;Analysis]) Bool) (|> analysis - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (^multi (#R;Success [_ _ productT productA]) [(flatten-tuple productA) membersA]) @@ -291,7 +292,7 @@ (&;with-scope (&;with-expected-type variantT (@;analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (^multi (#R;Success [_ _ sumA]) [(flatten-variant sumA) (#;Some [tag last? valueA])]) @@ -345,7 +346,7 @@ (&;with-scope (&;with-expected-type tupleT (@;analyse-record analyse recordC))))) - (macro;run init-compiler) + (macro;run (init-compiler [])) (case> (^multi (#R;Success [_ _ productA]) [(flatten-tuple productA) membersA]) diff --git a/new-luxc/test/test/luxc/common.lux b/new-luxc/test/test/luxc/common.lux new file mode 100644 index 000000000..6892274e4 --- /dev/null +++ b/new-luxc/test/test/luxc/common.lux @@ -0,0 +1,34 @@ +(;module: + lux + (lux (control pipe) + ["r" math/random "r/" Monad<Random>] + (data ["R" result]) + [macro] + (macro [code])) + (luxc ["&" base] + [analyser] + ["&;" host])) + +(def: init-compiler-info + Compiler-Info + {#;compiler-version &;compiler-version + #;compiler-mode #;Build}) + +(def: init-type-context + Type-Context + {#;ex-counter +0 + #;var-counter +0 + #;var-bindings (list)}) + +(def: #export (init-compiler _) + (-> Top Compiler) + {#;info init-compiler-info + #;source [dummy-cursor ""] + #;cursor dummy-cursor + #;modules (list) + #;scopes (list) + #;type-context init-type-context + #;expected #;None + #;seed +0 + #;scope-type-vars (list) + #;host (:! Void (&host;init-host []))}) diff --git a/new-luxc/test/test/luxc/generator/primitive.lux b/new-luxc/test/test/luxc/generator/primitive.lux new file mode 100644 index 000000000..a64712e86 --- /dev/null +++ b/new-luxc/test/test/luxc/generator/primitive.lux @@ -0,0 +1,58 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data text/format + ["R" result] + [bool "B/" Eq<Bool>] + [char "C/" Eq<Char>] + [text "T/" Eq<Text>]) + ["r" math/random "R/" Monad<Random>] + [macro] + test) + (luxc (lang ["ls" synthesis]) + [analyser] + [synthesizer] + (generator ["@" expr] + ["@;" eval] + ["@;" common])) + (test/luxc common)) + +(test: "Primitives." + [%bool% r;bool + %nat% r;nat + %int% r;int + %deg% r;deg + %real% r;real + %char% r;char + %text% (r;text +5)] + (with-expansions + [<tests> (do-template [<desc> <type> <synthesis> <sample> <test>] + [(assert (format "Can generate " <desc> ".") + (|> (@eval;eval (@;generate (<synthesis> <sample>))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (<test> <sample> (:! <type> valueG)) + + _ + false)))] + + ["bool" Bool #ls;Bool %bool% B/=] + ["nat" Nat #ls;Nat %nat% n.=] + ["int" Int #ls;Int %int% i.=] + ["deg" Deg #ls;Deg %deg% d.=] + ["real" Real #ls;Real %real% r.=] + ["char" Char #ls;Char %char% C/=] + ["text" Text #ls;Text %text% T/=])] + ($_ seq + (assert "Can generate unit." + (|> (@eval;eval (@;generate #ls;Unit)) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (is @common;unit (:! Text valueG)) + + _ + false))) + <tests> + ))) diff --git a/new-luxc/test/test/luxc/generator/structure.lux b/new-luxc/test/test/luxc/generator/structure.lux new file mode 100644 index 000000000..ddf4f0afc --- /dev/null +++ b/new-luxc/test/test/luxc/generator/structure.lux @@ -0,0 +1,105 @@ +(;module: + lux + (lux [io] + (control monad + pipe) + (data text/format + ["R" result] + [bool "B/" Eq<Bool>] + [char "C/" Eq<Char>] + [text "T/" Eq<Text>] + (coll ["a" array] + [list])) + ["r" math/random "r/" Monad<Random>] + [macro #+ Monad<Lux>] + [host #+ jvm-import] + test) + (luxc (lang ["ls" synthesis]) + [analyser] + [synthesizer] + (generator ["@" expr] + ["@;" eval] + ["@;" runtime] + ["@;" common])) + (test/luxc common)) + +(jvm-import java.lang.Integer) + +(def: gen-primitive + (r;Random ls;Synthesis) + (r;either (r;either (r;either (r/wrap #ls;Unit) + (r/map (|>. #ls;Bool) r;bool)) + (r;either (r/map (|>. #ls;Nat) r;nat) + (r/map (|>. #ls;Int) r;int))) + (r;either (r;either (r/map (|>. #ls;Deg) r;deg) + (r/map (|>. #ls;Real) r;real)) + (r;either (r/map (|>. #ls;Char) r;char) + (r/map (|>. #ls;Text) (r;text +5)))))) + +(def: (corresponds? [prediction sample]) + (-> [ls;Synthesis Top] Bool) + (case prediction + #ls;Unit + (is @common;unit (:! Text sample)) + + (^template [<tag> <type> <test>] + (<tag> prediction') + (case (host;try (<test> prediction' (:! <type> sample))) + (#R;Success result) + result + + (#R;Error error) + false)) + ([#ls;Bool Bool B/=] + [#ls;Nat Nat n.=] + [#ls;Int Int i.=] + [#ls;Deg Deg d.=] + [#ls;Real Real r.=] + [#ls;Char Char C/=] + [#ls;Text Text T/=]) + + _ + false + )) + +(test: "Tuples." + [size (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + members (r;list size gen-primitive)] + (assert "Can generate tuple." + (|> (@eval;eval (@;generate (#ls;Tuple members))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (let [valueG (:! (a;Array Top) valueG)] + (and (n.= size (a;size valueG)) + (list;every? corresponds? (list;zip2 members (a;to-list valueG))))) + + _ + false)))) + +(test: "Variants." + [num-tags (|> r;nat (:: @ map (|>. (n.% +10) (n.max +2)))) + tag (|> r;nat (:: @ map (n.% num-tags))) + #let [last? (n.= (n.dec num-tags) tag)] + member gen-primitive] + (assert "Can generate variant." + (|> (do Monad<Lux> + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate (#ls;Variant tag last? member)))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (let [valueG (:! (a;Array Top) valueG)] + (and (n.= +3 (a;size valueG)) + (let [_tag (:! Integer (assume (a;get +0 valueG))) + _last? (a;get +1 valueG) + _value (:! Top (assume (a;get +2 valueG)))] + (and (n.= tag (|> _tag host;i2l int-to-nat)) + (case _last? + (#;Some _last?') + (and last? (T/= "" (:! Text _last?'))) + + #;None + (not last?)) + (corresponds? [member _value]))))) + + _ + false)))) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 30a8ec522..92644ff48 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -14,9 +14,13 @@ (procedure ["_;A" common])) (synthesizer ["_;S" primitive] ["_;S" structure] + ## ["_;S" case] + (case ["_;S" special]) ["_;S" function] ["_;S" procedure] - ["_;S" loop])))) + ["_;S" loop]) + (generator ["_;G" primitive] + ["_;G" structure])))) ## [Program] (program: args |