From e4bc4d0e2cd14a955530160c4fc7859e6c46874e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 3 Feb 2022 05:55:42 -0400 Subject: Fixes for the pure-Lux JVM compiler machinery. [Part 13 / Done!] --- documentation/bookmark/concurrency.md | 1 + lux-jvm/source/luxc/lang/directive/jvm.lux | 996 ++++++++++----------- lux-jvm/source/luxc/lang/translation/jvm.lux | 85 +- .../luxc/lang/translation/jvm/extension/host.lux | 4 +- .../source/luxc/lang/translation/jvm/function.lux | 7 +- .../source/luxc/lang/translation/jvm/program.lux | 50 +- .../source/luxc/lang/translation/jvm/runtime.lux | 87 +- lux-lua/source/program.lux | 2 +- stdlib/source/library/lux/math/number/i32.lux | 22 +- stdlib/source/library/lux/target/jvm/bytecode.lux | 9 +- .../library/lux/target/jvm/encoding/signed.lux | 13 +- .../tool/compiler/language/lux/phase/analysis.lux | 12 +- .../compiler/language/lux/phase/analysis/case.lux | 6 +- .../language/lux/phase/analysis/complex.lux | 424 +++++++++ .../language/lux/phase/analysis/structure.lux | 428 --------- .../language/lux/phase/extension/analysis/jvm.lux | 19 +- .../language/lux/phase/extension/analysis/lua.lux | 156 ++-- .../language/lux/phase/generation/lua/function.lux | 14 +- .../language/lux/phase/generation/lua/loop.lux | 7 +- .../language/lux/phase/generation/lua/runtime.lux | 7 +- .../lux/phase/generation/lua/structure.lux | 2 +- stdlib/source/test/lux.lux | 183 ++-- stdlib/source/test/lux/extension.lux | 15 +- stdlib/source/test/lux/target/lua.lux | 12 + stdlib/source/test/lux/tool.lux | 4 +- .../compiler/language/lux/analysis/inference.lux | 16 +- .../language/lux/phase/analysis/complex.lux | 650 ++++++++++++++ .../language/lux/phase/analysis/structure.lux | 311 ------- 28 files changed, 1955 insertions(+), 1587 deletions(-) create mode 100644 stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux delete mode 100644 stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux create mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux delete mode 100644 stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux diff --git a/documentation/bookmark/concurrency.md b/documentation/bookmark/concurrency.md index af7639a56..3ca0a1e51 100644 --- a/documentation/bookmark/concurrency.md +++ b/documentation/bookmark/concurrency.md @@ -1,5 +1,6 @@ # Reference +0. [The Upcoming Concurrency TS Version 2 for Low-Latency and Lockless Synchronization - CppCon 2021](https://www.youtube.com/watch?v=ZrQ7dk5OXJU) 0. [Concurrency Patterns - Rainer Grimm - CppCon 2021](https://www.youtube.com/watch?v=A3DQxZCtKqo) 0. [Fibers](https://github.com/wingo/fibers/wiki/Manual) 0. [OneFile - The world's first wait-free Software Transactional Memory](http://concurrencyfreaks.blogspot.com/2019/04/onefile-worlds-first-wait-free-software.html) diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux index 3960a3532..a3b28b710 100644 --- a/lux-jvm/source/luxc/lang/directive/jvm.lux +++ b/lux-jvm/source/luxc/lang/directive/jvm.lux @@ -56,7 +56,7 @@ ["[0]/" lux]]]]]] [meta [archive {"+" Archive} - ["[0]" artifact]] + ["[0]" unit]] ["[0]" cache "_" ["[1]" artifact]]]]]]] [/// @@ -69,520 +69,520 @@ [extension ["//G" host]]]]]) -(import: org/objectweb/asm/Label - ["[1]::[0]" - (new [])]) - -(def: (literal literal) - (-> /.Literal Inst) - (case literal - {/.#Boolean value} (_.boolean value) - {/.#Int value} (_.int value) - {/.#Long value} (_.long value) - {/.#Double value} (_.double value) - {/.#Char value} (_.char value) - {/.#String value} (_.string value))) - -(def: (constant instruction) - (-> /.Constant Inst) - (case instruction - {/.#BIPUSH constant} (_.BIPUSH constant) +... (import: org/objectweb/asm/Label +... ["[1]::[0]" +... (new [])]) + +... (def: (literal literal) +... (-> /.Literal Inst) +... (case literal +... {/.#Boolean value} (_.boolean value) +... {/.#Int value} (_.int value) +... {/.#Long value} (_.long value) +... {/.#Double value} (_.double value) +... {/.#Char value} (_.char value) +... {/.#String value} (_.string value))) + +... (def: (constant instruction) +... (-> /.Constant Inst) +... (case instruction +... {/.#BIPUSH constant} (_.BIPUSH constant) - {/.#SIPUSH constant} (_.SIPUSH constant) - - {/.#ICONST_M1} _.ICONST_M1 - {/.#ICONST_0} _.ICONST_0 - {/.#ICONST_1} _.ICONST_1 - {/.#ICONST_2} _.ICONST_2 - {/.#ICONST_3} _.ICONST_3 - {/.#ICONST_4} _.ICONST_4 - {/.#ICONST_5} _.ICONST_5 - - {/.#LCONST_0} _.LCONST_0 - {/.#LCONST_1} _.LCONST_1 +... {/.#SIPUSH constant} (_.SIPUSH constant) + +... {/.#ICONST_M1} _.ICONST_M1 +... {/.#ICONST_0} _.ICONST_0 +... {/.#ICONST_1} _.ICONST_1 +... {/.#ICONST_2} _.ICONST_2 +... {/.#ICONST_3} _.ICONST_3 +... {/.#ICONST_4} _.ICONST_4 +... {/.#ICONST_5} _.ICONST_5 + +... {/.#LCONST_0} _.LCONST_0 +... {/.#LCONST_1} _.LCONST_1 - {/.#FCONST_0} _.FCONST_0 - {/.#FCONST_1} _.FCONST_1 - {/.#FCONST_2} _.FCONST_2 +... {/.#FCONST_0} _.FCONST_0 +... {/.#FCONST_1} _.FCONST_1 +... {/.#FCONST_2} _.FCONST_2 - {/.#DCONST_0} _.DCONST_0 - {/.#DCONST_1} _.DCONST_1 +... {/.#DCONST_0} _.DCONST_0 +... {/.#DCONST_1} _.DCONST_1 - {/.#ACONST_NULL} _.NULL - - {/.#LDC literal} - (..literal literal) - )) - -(def: (int_arithmetic instruction) - (-> /.Int_Arithmetic Inst) - (case instruction - {/.#IADD} _.IADD - {/.#ISUB} _.ISUB - {/.#IMUL} _.IMUL - {/.#IDIV} _.IDIV - {/.#IREM} _.IREM - {/.#INEG} _.INEG)) - -(def: (long_arithmetic instruction) - (-> /.Long_Arithmetic Inst) - (case instruction - {/.#LADD} _.LADD - {/.#LSUB} _.LSUB - {/.#LMUL} _.LMUL - {/.#LDIV} _.LDIV - {/.#LREM} _.LREM - {/.#LNEG} _.LNEG)) - -(def: (float_arithmetic instruction) - (-> /.Float_Arithmetic Inst) - (case instruction - {/.#FADD} _.FADD - {/.#FSUB} _.FSUB - {/.#FMUL} _.FMUL - {/.#FDIV} _.FDIV - {/.#FREM} _.FREM - {/.#FNEG} _.FNEG)) - -(def: (double_arithmetic instruction) - (-> /.Double_Arithmetic Inst) - (case instruction - {/.#DADD} _.DADD - {/.#DSUB} _.DSUB - {/.#DMUL} _.DMUL - {/.#DDIV} _.DDIV - {/.#DREM} _.DREM - {/.#DNEG} _.DNEG)) - -(def: (arithmetic instruction) - (-> /.Arithmetic Inst) - (case instruction - {/.#Int_Arithmetic int_arithmetic} - (..int_arithmetic int_arithmetic) +... {/.#ACONST_NULL} _.NULL + +... {/.#LDC literal} +... (..literal literal) +... )) + +... (def: (int_arithmetic instruction) +... (-> /.Int_Arithmetic Inst) +... (case instruction +... {/.#IADD} _.IADD +... {/.#ISUB} _.ISUB +... {/.#IMUL} _.IMUL +... {/.#IDIV} _.IDIV +... {/.#IREM} _.IREM +... {/.#INEG} _.INEG)) + +... (def: (long_arithmetic instruction) +... (-> /.Long_Arithmetic Inst) +... (case instruction +... {/.#LADD} _.LADD +... {/.#LSUB} _.LSUB +... {/.#LMUL} _.LMUL +... {/.#LDIV} _.LDIV +... {/.#LREM} _.LREM +... {/.#LNEG} _.LNEG)) + +... (def: (float_arithmetic instruction) +... (-> /.Float_Arithmetic Inst) +... (case instruction +... {/.#FADD} _.FADD +... {/.#FSUB} _.FSUB +... {/.#FMUL} _.FMUL +... {/.#FDIV} _.FDIV +... {/.#FREM} _.FREM +... {/.#FNEG} _.FNEG)) + +... (def: (double_arithmetic instruction) +... (-> /.Double_Arithmetic Inst) +... (case instruction +... {/.#DADD} _.DADD +... {/.#DSUB} _.DSUB +... {/.#DMUL} _.DMUL +... {/.#DDIV} _.DDIV +... {/.#DREM} _.DREM +... {/.#DNEG} _.DNEG)) + +... (def: (arithmetic instruction) +... (-> /.Arithmetic Inst) +... (case instruction +... {/.#Int_Arithmetic int_arithmetic} +... (..int_arithmetic int_arithmetic) - {/.#Long_Arithmetic long_arithmetic} - (..long_arithmetic long_arithmetic) +... {/.#Long_Arithmetic long_arithmetic} +... (..long_arithmetic long_arithmetic) - {/.#Float_Arithmetic float_arithmetic} - (..float_arithmetic float_arithmetic) +... {/.#Float_Arithmetic float_arithmetic} +... (..float_arithmetic float_arithmetic) - {/.#Double_Arithmetic double_arithmetic} - (..double_arithmetic double_arithmetic))) - -(def: (int_bitwise instruction) - (-> /.Int_Bitwise Inst) - (case instruction - {/.#IOR} _.IOR - {/.#IXOR} _.IXOR - {/.#IAND} _.IAND - {/.#ISHL} _.ISHL - {/.#ISHR} _.ISHR - {/.#IUSHR} _.IUSHR)) - -(def: (long_bitwise instruction) - (-> /.Long_Bitwise Inst) - (case instruction - {/.#LOR} _.LOR - {/.#LXOR} _.LXOR - {/.#LAND} _.LAND - {/.#LSHL} _.LSHL - {/.#LSHR} _.LSHR - {/.#LUSHR} _.LUSHR)) - -(def: (bitwise instruction) - (-> /.Bitwise Inst) - (case instruction - {/.#Int_Bitwise int_bitwise} - (..int_bitwise int_bitwise) +... {/.#Double_Arithmetic double_arithmetic} +... (..double_arithmetic double_arithmetic))) + +... (def: (int_bitwise instruction) +... (-> /.Int_Bitwise Inst) +... (case instruction +... {/.#IOR} _.IOR +... {/.#IXOR} _.IXOR +... {/.#IAND} _.IAND +... {/.#ISHL} _.ISHL +... {/.#ISHR} _.ISHR +... {/.#IUSHR} _.IUSHR)) + +... (def: (long_bitwise instruction) +... (-> /.Long_Bitwise Inst) +... (case instruction +... {/.#LOR} _.LOR +... {/.#LXOR} _.LXOR +... {/.#LAND} _.LAND +... {/.#LSHL} _.LSHL +... {/.#LSHR} _.LSHR +... {/.#LUSHR} _.LUSHR)) + +... (def: (bitwise instruction) +... (-> /.Bitwise Inst) +... (case instruction +... {/.#Int_Bitwise int_bitwise} +... (..int_bitwise int_bitwise) - {/.#Long_Bitwise long_bitwise} - (..long_bitwise long_bitwise))) - -(def: (conversion instruction) - (-> /.Conversion Inst) - (case instruction - {/.#I2B} _.I2B - {/.#I2S} _.I2S - {/.#I2L} _.I2L - {/.#I2F} _.I2F - {/.#I2D} _.I2D - {/.#I2C} _.I2C - - {/.#L2I} _.L2I - {/.#L2F} _.L2F - {/.#L2D} _.L2D - - {/.#F2I} _.F2I - {/.#F2L} _.F2L - {/.#F2D} _.F2D +... {/.#Long_Bitwise long_bitwise} +... (..long_bitwise long_bitwise))) + +... (def: (conversion instruction) +... (-> /.Conversion Inst) +... (case instruction +... {/.#I2B} _.I2B +... {/.#I2S} _.I2S +... {/.#I2L} _.I2L +... {/.#I2F} _.I2F +... {/.#I2D} _.I2D +... {/.#I2C} _.I2C + +... {/.#L2I} _.L2I +... {/.#L2F} _.L2F +... {/.#L2D} _.L2D + +... {/.#F2I} _.F2I +... {/.#F2L} _.F2L +... {/.#F2D} _.F2D - {/.#D2I} _.D2I - {/.#D2L} _.D2L - {/.#D2F} _.D2F)) +... {/.#D2I} _.D2I +... {/.#D2L} _.D2L +... {/.#D2F} _.D2F)) -(def: (array instruction) - (-> /.Array Inst) - (case instruction - {/.#ARRAYLENGTH} _.ARRAYLENGTH +... (def: (array instruction) +... (-> /.Array Inst) +... (case instruction +... {/.#ARRAYLENGTH} _.ARRAYLENGTH - {/.#NEWARRAY type} (_.NEWARRAY type) - {/.#ANEWARRAY type} (_.ANEWARRAY type) +... {/.#NEWARRAY type} (_.NEWARRAY type) +... {/.#ANEWARRAY type} (_.ANEWARRAY type) - {/.#BALOAD} _.BALOAD - {/.#BASTORE} _.BASTORE +... {/.#BALOAD} _.BALOAD +... {/.#BASTORE} _.BASTORE - {/.#SALOAD} _.SALOAD - {/.#SASTORE} _.SASTORE +... {/.#SALOAD} _.SALOAD +... {/.#SASTORE} _.SASTORE - {/.#IALOAD} _.IALOAD - {/.#IASTORE} _.IASTORE +... {/.#IALOAD} _.IALOAD +... {/.#IASTORE} _.IASTORE - {/.#LALOAD} _.LALOAD - {/.#LASTORE} _.LASTORE +... {/.#LALOAD} _.LALOAD +... {/.#LASTORE} _.LASTORE - {/.#FALOAD} _.FALOAD - {/.#FASTORE} _.FASTORE +... {/.#FALOAD} _.FALOAD +... {/.#FASTORE} _.FASTORE - {/.#DALOAD} _.DALOAD - {/.#DASTORE} _.DASTORE +... {/.#DALOAD} _.DALOAD +... {/.#DASTORE} _.DASTORE - {/.#CALOAD} _.CALOAD - {/.#CASTORE} _.CASTORE - - {/.#AALOAD} _.AALOAD - {/.#AASTORE} _.AASTORE)) - -(def: (object instruction) - (-> /.Object Inst) - (case instruction - (^template [ ] - [{ class field_name field_type} - ( class field_name field_type)]) - ([/.#GETSTATIC _.GETSTATIC] - [/.#PUTSTATIC _.PUTSTATIC] - [/.#GETFIELD _.GETFIELD] - [/.#PUTFIELD _.PUTFIELD]) +... {/.#CALOAD} _.CALOAD +... {/.#CASTORE} _.CASTORE + +... {/.#AALOAD} _.AALOAD +... {/.#AASTORE} _.AASTORE)) + +... (def: (object instruction) +... (-> /.Object Inst) +... (case instruction +... (^template [ ] +... [{ class field_name field_type} +... ( class field_name field_type)]) +... ([/.#GETSTATIC _.GETSTATIC] +... [/.#PUTSTATIC _.PUTSTATIC] +... [/.#GETFIELD _.GETFIELD] +... [/.#PUTFIELD _.PUTFIELD]) - {/.#NEW type} (_.NEW type) +... {/.#NEW type} (_.NEW type) - {/.#INSTANCEOF type} (_.INSTANCEOF type) - {/.#CHECKCAST type} (_.CHECKCAST type) - - (^template [ ] - [{ class method_name method_type} - ( class method_name method_type)]) - ([/.#INVOKEINTERFACE _.INVOKEINTERFACE] - [/.#INVOKESPECIAL _.INVOKESPECIAL] - [/.#INVOKESTATIC _.INVOKESTATIC] - [/.#INVOKEVIRTUAL _.INVOKEVIRTUAL]) - )) - -(def: (local_int instruction) - (-> /.Local_Int Inst) - (case instruction - {/.#ILOAD register} (_.ILOAD register) - {/.#ISTORE register} (_.ISTORE register))) - -(def: (local_long instruction) - (-> /.Local_Long Inst) - (case instruction - {/.#LLOAD register} (_.LLOAD register) - {/.#LSTORE register} (_.LSTORE register))) - -(def: (local_float instruction) - (-> /.Local_Float Inst) - (case instruction - {/.#FLOAD register} (_.FLOAD register) - {/.#FSTORE register} (_.FSTORE register))) - -(def: (local_double instruction) - (-> /.Local_Double Inst) - (case instruction - {/.#DLOAD register} (_.DLOAD register) - {/.#DSTORE register} (_.DSTORE register))) - -(def: (local_object instruction) - (-> /.Local_Object Inst) - (case instruction - {/.#ALOAD register} (_.ALOAD register) - {/.#ASTORE register} (_.ASTORE register))) - -(def: (local instruction) - (-> /.Local Inst) - (case instruction - {/.#Local_Int instruction} (..local_int instruction) - {/.#IINC register} (_.IINC register) - {/.#Local_Long instruction} (..local_long instruction) - {/.#Local_Float instruction} (..local_float instruction) - {/.#Local_Double instruction} (..local_double instruction) - {/.#Local_Object instruction} (..local_object instruction))) - -(def: (stack instruction) - (-> /.Stack Inst) - (case instruction - {/.#DUP} _.DUP - {/.#DUP_X1} _.DUP_X1 - {/.#DUP_X2} _.DUP_X2 - {/.#DUP2} _.DUP2 - {/.#DUP2_X1} _.DUP2_X1 - {/.#DUP2_X2} _.DUP2_X2 - {/.#SWAP} _.SWAP - {/.#POP} _.POP - {/.#POP2} _.POP2)) - -(def: (comparison instruction) - (-> /.Comparison Inst) - (case instruction - {/.#LCMP} _.LCMP +... {/.#INSTANCEOF type} (_.INSTANCEOF type) +... {/.#CHECKCAST type} (_.CHECKCAST type) + +... (^template [ ] +... [{ class method_name method_type} +... ( class method_name method_type)]) +... ([/.#INVOKEINTERFACE _.INVOKEINTERFACE] +... [/.#INVOKESPECIAL _.INVOKESPECIAL] +... [/.#INVOKESTATIC _.INVOKESTATIC] +... [/.#INVOKEVIRTUAL _.INVOKEVIRTUAL]) +... )) + +... (def: (local_int instruction) +... (-> /.Local_Int Inst) +... (case instruction +... {/.#ILOAD register} (_.ILOAD register) +... {/.#ISTORE register} (_.ISTORE register))) + +... (def: (local_long instruction) +... (-> /.Local_Long Inst) +... (case instruction +... {/.#LLOAD register} (_.LLOAD register) +... {/.#LSTORE register} (_.LSTORE register))) + +... (def: (local_float instruction) +... (-> /.Local_Float Inst) +... (case instruction +... {/.#FLOAD register} (_.FLOAD register) +... {/.#FSTORE register} (_.FSTORE register))) + +... (def: (local_double instruction) +... (-> /.Local_Double Inst) +... (case instruction +... {/.#DLOAD register} (_.DLOAD register) +... {/.#DSTORE register} (_.DSTORE register))) + +... (def: (local_object instruction) +... (-> /.Local_Object Inst) +... (case instruction +... {/.#ALOAD register} (_.ALOAD register) +... {/.#ASTORE register} (_.ASTORE register))) + +... (def: (local instruction) +... (-> /.Local Inst) +... (case instruction +... {/.#Local_Int instruction} (..local_int instruction) +... {/.#IINC register} (_.IINC register) +... {/.#Local_Long instruction} (..local_long instruction) +... {/.#Local_Float instruction} (..local_float instruction) +... {/.#Local_Double instruction} (..local_double instruction) +... {/.#Local_Object instruction} (..local_object instruction))) + +... (def: (stack instruction) +... (-> /.Stack Inst) +... (case instruction +... {/.#DUP} _.DUP +... {/.#DUP_X1} _.DUP_X1 +... {/.#DUP_X2} _.DUP_X2 +... {/.#DUP2} _.DUP2 +... {/.#DUP2_X1} _.DUP2_X1 +... {/.#DUP2_X2} _.DUP2_X2 +... {/.#SWAP} _.SWAP +... {/.#POP} _.POP +... {/.#POP2} _.POP2)) + +... (def: (comparison instruction) +... (-> /.Comparison Inst) +... (case instruction +... {/.#LCMP} _.LCMP - {/.#FCMPG} _.FCMPG - {/.#FCMPL} _.FCMPL - - {/.#DCMPG} _.DCMPG - {/.#DCMPL} _.DCMPL)) - -(def: (branching instruction) - (-> (/.Branching org/objectweb/asm/Label) Inst) - (case instruction - {/.#IF_ICMPEQ label} (_.IF_ICMPEQ label) - {/.#IF_ICMPGE label} (_.IF_ICMPGE label) - {/.#IF_ICMPGT label} (_.IF_ICMPGT label) - {/.#IF_ICMPLE label} (_.IF_ICMPLE label) - {/.#IF_ICMPLT label} (_.IF_ICMPLT label) - {/.#IF_ICMPNE label} (_.IF_ICMPNE label) - {/.#IFEQ label} (_.IFEQ label) - {/.#IFGE label} (_.IFGE label) - {/.#IFGT label} (_.IFGT label) - {/.#IFLE label} (_.IFLE label) - {/.#IFLT label} (_.IFLT label) - {/.#IFNE label} (_.IFNE label) - - {/.#TABLESWITCH min max default labels} - (_.TABLESWITCH min max default labels) +... {/.#FCMPG} _.FCMPG +... {/.#FCMPL} _.FCMPL + +... {/.#DCMPG} _.DCMPG +... {/.#DCMPL} _.DCMPL)) + +... (def: (branching instruction) +... (-> (/.Branching org/objectweb/asm/Label) Inst) +... (case instruction +... {/.#IF_ICMPEQ label} (_.IF_ICMPEQ label) +... {/.#IF_ICMPGE label} (_.IF_ICMPGE label) +... {/.#IF_ICMPGT label} (_.IF_ICMPGT label) +... {/.#IF_ICMPLE label} (_.IF_ICMPLE label) +... {/.#IF_ICMPLT label} (_.IF_ICMPLT label) +... {/.#IF_ICMPNE label} (_.IF_ICMPNE label) +... {/.#IFEQ label} (_.IFEQ label) +... {/.#IFGE label} (_.IFGE label) +... {/.#IFGT label} (_.IFGT label) +... {/.#IFLE label} (_.IFLE label) +... {/.#IFLT label} (_.IFLT label) +... {/.#IFNE label} (_.IFNE label) + +... {/.#TABLESWITCH min max default labels} +... (_.TABLESWITCH min max default labels) - {/.#LOOKUPSWITCH default keys+labels} - (_.LOOKUPSWITCH default keys+labels) - - {/.#IF_ACMPEQ label} (_.IF_ACMPEQ label) - {/.#IF_ACMPNE label} (_.IF_ACMPNE label) - {/.#IFNONNULL label} (_.IFNONNULL label) - {/.#IFNULL label} (_.IFNULL label))) - -(def: (exception instruction) - (-> (/.Exception org/objectweb/asm/Label) Inst) - (case instruction - {/.#Try start end handler exception} (_.try start end handler exception) - {/.#ATHROW} _.ATHROW)) - -(def: (concurrency instruction) - (-> /.Concurrency Inst) - (case instruction - {/.#MONITORENTER} _.MONITORENTER - {/.#MONITOREXIT} _.MONITOREXIT)) - -(def: (return instruction) - (-> /.Return Inst) - (case instruction - {/.#RETURN} _.RETURN - {/.#IRETURN} _.IRETURN - {/.#LRETURN} _.LRETURN - {/.#FRETURN} _.FRETURN - {/.#DRETURN} _.DRETURN - {/.#ARETURN} _.ARETURN)) - -(def: (control instruction) - (-> (/.Control org/objectweb/asm/Label) Inst) - (case instruction - {/.#GOTO label} (_.GOTO label) - {/.#Branching instruction} (..branching instruction) - {/.#Exception instruction} (..exception instruction) - {/.#Concurrency instruction} (..concurrency instruction) - {/.#Return instruction} (..return instruction))) - -(def: (instruction instruction) - (-> (/.Instruction Inst org/objectweb/asm/Label) Inst) - (case instruction - {/.#NOP} _.NOP - {/.#Constant instruction} (..constant instruction) - {/.#Arithmetic instruction} (..arithmetic instruction) - {/.#Bitwise instruction} (..bitwise instruction) - {/.#Conversion instruction} (..conversion instruction) - {/.#Array instruction} (..array instruction) - {/.#Object instruction} (..object instruction) - {/.#Local instruction} (..local instruction) - {/.#Stack instruction} (..stack instruction) - {/.#Comparison instruction} (..comparison instruction) - {/.#Control instruction} (..control instruction) - {/.#Embedded embedded} embedded)) - -(type: Mapping - (Dictionary /.Label org/objectweb/asm/Label)) - -(type: (Re_labeler context) - (-> [Mapping (context /.Label)] - [Mapping (context org/objectweb/asm/Label)])) - -(def: (relabel [mapping label]) - (Re_labeler Identity) - (case (dictionary.value label mapping) - {.#Some label} - [mapping label] - - {.#None} - (let [label' (org/objectweb/asm/Label::new)] - [(dictionary.has label label' mapping) label']))) - -(def: (relabel_branching [mapping instruction]) - (Re_labeler /.Branching) - (case instruction - (^template [] - [{ label} - (let [[mapping label] (..relabel [mapping label])] - [mapping { label}])]) - ([/.#IF_ICMPEQ] [/.#IF_ICMPGE] [/.#IF_ICMPGT] [/.#IF_ICMPLE] [/.#IF_ICMPLT] [/.#IF_ICMPNE] - [/.#IFEQ] [/.#IFNE] [/.#IFGE] [/.#IFGT] [/.#IFLE] [/.#IFLT] - - [/.#IF_ACMPEQ] [/.#IF_ACMPNE] [/.#IFNONNULL] [/.#IFNULL]) - - {/.#TABLESWITCH min max default labels} - (let [[mapping default] (..relabel [mapping default]) - [mapping labels] (list#mix (function (_ input [mapping output]) - (let [[mapping input] (..relabel [mapping input])] - [mapping (list& input output)])) - [mapping (list)] labels)] - [mapping {/.#TABLESWITCH min max default (list.reversed labels)}]) +... {/.#LOOKUPSWITCH default keys+labels} +... (_.LOOKUPSWITCH default keys+labels) + +... {/.#IF_ACMPEQ label} (_.IF_ACMPEQ label) +... {/.#IF_ACMPNE label} (_.IF_ACMPNE label) +... {/.#IFNONNULL label} (_.IFNONNULL label) +... {/.#IFNULL label} (_.IFNULL label))) + +... (def: (exception instruction) +... (-> (/.Exception org/objectweb/asm/Label) Inst) +... (case instruction +... {/.#Try start end handler exception} (_.try start end handler exception) +... {/.#ATHROW} _.ATHROW)) + +... (def: (concurrency instruction) +... (-> /.Concurrency Inst) +... (case instruction +... {/.#MONITORENTER} _.MONITORENTER +... {/.#MONITOREXIT} _.MONITOREXIT)) + +... (def: (return instruction) +... (-> /.Return Inst) +... (case instruction +... {/.#RETURN} _.RETURN +... {/.#IRETURN} _.IRETURN +... {/.#LRETURN} _.LRETURN +... {/.#FRETURN} _.FRETURN +... {/.#DRETURN} _.DRETURN +... {/.#ARETURN} _.ARETURN)) + +... (def: (control instruction) +... (-> (/.Control org/objectweb/asm/Label) Inst) +... (case instruction +... {/.#GOTO label} (_.GOTO label) +... {/.#Branching instruction} (..branching instruction) +... {/.#Exception instruction} (..exception instruction) +... {/.#Concurrency instruction} (..concurrency instruction) +... {/.#Return instruction} (..return instruction))) + +... (def: (instruction instruction) +... (-> (/.Instruction Inst org/objectweb/asm/Label) Inst) +... (case instruction +... {/.#NOP} _.NOP +... {/.#Constant instruction} (..constant instruction) +... {/.#Arithmetic instruction} (..arithmetic instruction) +... {/.#Bitwise instruction} (..bitwise instruction) +... {/.#Conversion instruction} (..conversion instruction) +... {/.#Array instruction} (..array instruction) +... {/.#Object instruction} (..object instruction) +... {/.#Local instruction} (..local instruction) +... {/.#Stack instruction} (..stack instruction) +... {/.#Comparison instruction} (..comparison instruction) +... {/.#Control instruction} (..control instruction) +... {/.#Embedded embedded} embedded)) + +... (type: Mapping +... (Dictionary /.Label org/objectweb/asm/Label)) + +... (type: (Re_labeler context) +... (-> [Mapping (context /.Label)] +... [Mapping (context org/objectweb/asm/Label)])) + +... (def: (relabel [mapping label]) +... (Re_labeler Identity) +... (case (dictionary.value label mapping) +... {.#Some label} +... [mapping label] + +... {.#None} +... (let [label' (org/objectweb/asm/Label::new)] +... [(dictionary.has label label' mapping) label']))) + +... (def: (relabel_branching [mapping instruction]) +... (Re_labeler /.Branching) +... (case instruction +... (^template [] +... [{ label} +... (let [[mapping label] (..relabel [mapping label])] +... [mapping { label}])]) +... ([/.#IF_ICMPEQ] [/.#IF_ICMPGE] [/.#IF_ICMPGT] [/.#IF_ICMPLE] [/.#IF_ICMPLT] [/.#IF_ICMPNE] +... [/.#IFEQ] [/.#IFNE] [/.#IFGE] [/.#IFGT] [/.#IFLE] [/.#IFLT] + +... [/.#IF_ACMPEQ] [/.#IF_ACMPNE] [/.#IFNONNULL] [/.#IFNULL]) + +... {/.#TABLESWITCH min max default labels} +... (let [[mapping default] (..relabel [mapping default]) +... [mapping labels] (list#mix (function (_ input [mapping output]) +... (let [[mapping input] (..relabel [mapping input])] +... [mapping (list& input output)])) +... [mapping (list)] labels)] +... [mapping {/.#TABLESWITCH min max default (list.reversed labels)}]) - {/.#LOOKUPSWITCH default keys+labels} - (let [[mapping default] (..relabel [mapping default]) - [mapping keys+labels] (list#mix (function (_ [expected input] [mapping output]) - (let [[mapping input] (..relabel [mapping input])] - [mapping (list& [expected input] output)])) - [mapping (list)] keys+labels)] - [mapping {/.#LOOKUPSWITCH default (list.reversed keys+labels)}]) - )) - -(def: (relabel_exception [mapping instruction]) - (Re_labeler /.Exception) - (case instruction - {/.#Try start end handler exception} - (let [[mapping start] (..relabel [mapping start]) - [mapping end] (..relabel [mapping end]) - [mapping handler] (..relabel [mapping handler])] - [mapping {/.#Try start end handler exception}]) +... {/.#LOOKUPSWITCH default keys+labels} +... (let [[mapping default] (..relabel [mapping default]) +... [mapping keys+labels] (list#mix (function (_ [expected input] [mapping output]) +... (let [[mapping input] (..relabel [mapping input])] +... [mapping (list& [expected input] output)])) +... [mapping (list)] keys+labels)] +... [mapping {/.#LOOKUPSWITCH default (list.reversed keys+labels)}]) +... )) + +... (def: (relabel_exception [mapping instruction]) +... (Re_labeler /.Exception) +... (case instruction +... {/.#Try start end handler exception} +... (let [[mapping start] (..relabel [mapping start]) +... [mapping end] (..relabel [mapping end]) +... [mapping handler] (..relabel [mapping handler])] +... [mapping {/.#Try start end handler exception}]) - {/.#ATHROW} - [mapping {/.#ATHROW}] - )) - -(def: (relabel_control [mapping instruction]) - (Re_labeler /.Control) - (case instruction - (^template [ ] - [{ instruction} - (let [[mapping instruction] ( [mapping instruction])] - [mapping { instruction}])]) - ([/.#GOTO ..relabel] - [/.#Branching ..relabel_branching] - [/.#Exception ..relabel_exception]) - - (^template [] - [{ instruction} - [mapping { instruction}]]) - ([/.#Concurrency] [/.#Return]) - )) - -(def: (relabel_instruction [mapping instruction]) - (Re_labeler (/.Instruction Inst)) - (case instruction - {/.#Embedded embedded} - [mapping {/.#Embedded embedded}] - - {/.#NOP} - [mapping {/.#NOP}] - - (^template [] - [{ instruction} - [mapping { instruction}]]) - ([/.#Constant] - [/.#Arithmetic] - [/.#Bitwise] - [/.#Conversion] - [/.#Array] - [/.#Object] - [/.#Local] - [/.#Stack] - [/.#Comparison]) +... {/.#ATHROW} +... [mapping {/.#ATHROW}] +... )) + +... (def: (relabel_control [mapping instruction]) +... (Re_labeler /.Control) +... (case instruction +... (^template [ ] +... [{ instruction} +... (let [[mapping instruction] ( [mapping instruction])] +... [mapping { instruction}])]) +... ([/.#GOTO ..relabel] +... [/.#Branching ..relabel_branching] +... [/.#Exception ..relabel_exception]) + +... (^template [] +... [{ instruction} +... [mapping { instruction}]]) +... ([/.#Concurrency] [/.#Return]) +... )) + +... (def: (relabel_instruction [mapping instruction]) +... (Re_labeler (/.Instruction Inst)) +... (case instruction +... {/.#Embedded embedded} +... [mapping {/.#Embedded embedded}] + +... {/.#NOP} +... [mapping {/.#NOP}] + +... (^template [] +... [{ instruction} +... [mapping { instruction}]]) +... ([/.#Constant] +... [/.#Arithmetic] +... [/.#Bitwise] +... [/.#Conversion] +... [/.#Array] +... [/.#Object] +... [/.#Local] +... [/.#Stack] +... [/.#Comparison]) - {/.#Control instruction} - (let [[mapping instruction] (..relabel_control [mapping instruction])] - [mapping {/.#Control instruction}]))) - -(def: (relabel_bytecode [mapping bytecode]) - (Re_labeler (/.Bytecode Inst)) - (sequence#mix (function (_ input [mapping output]) - (let [[mapping input'] (..relabel_instruction [mapping input])] - [mapping (sequence.suffix input' output)])) - [mapping (sequence.sequence)] - bytecode)) - -(def: fresh - Mapping - (dictionary.empty nat.hash)) - -(def: bytecode - (-> (/.Bytecode Inst /.Label) jvm.Inst) - (|>> [..fresh] - ..relabel_bytecode - product.right - (sequence#each ..instruction) - sequence.list - _.fuse)) - -(with_expansions [ (as_is jvm.Anchor) - (as_is Inst) - (as_is jvm.Definition) - (as_is )] - (type: Handler' - ... (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) - (-> extension.Name - (phase.Phase [(extension.Bundle ) - (generation.State )] - Synthesis - ) - (phase.Phase [(extension.Bundle ) - (generation.State )] - (List Synthesis) - (/.Bytecode Inst /.Label))))) - -(def: (true_handler extender pseudo) - (-> jvm.Extender Any jvm.Handler) - (function (_ extension_name phase archive inputs) - (# phase.monad each - (|>> (:as (/.Bytecode Inst /.Label)) ..bytecode) - ((extender pseudo) extension_name phase archive inputs)))) - -(type: Phase (directive.Phase jvm.Anchor jvm.Inst jvm.Definition)) -(type: Operation (directive.Operation jvm.Anchor jvm.Inst jvm.Definition)) -(type: Handler (directive.Handler jvm.Anchor jvm.Inst jvm.Definition)) - -(def: (def::generation extender) - (-> jvm.Extender ..Handler) - (function (handler extension_name phase archive inputsC+) - (case inputsC+ - (^ (list nameC valueC)) - (do phase.monad - [[_ _ name] (lux/.evaluate! archive Text nameC) - [_ handlerV] (lux/.generator archive (:as Text name) ..Handler' valueC) - _ (|> handlerV - (..true_handler extender) - (extension.install extender (:as Text name)) - directive.lifted_generation) - _ (directive.lifted_generation - (generation.log! (format "Generation " (%.text (:as Text name)))))] - (in directive.no_requirements)) - - _ - (phase.except extension.invalid_syntax [extension_name %.code inputsC+])))) +... {/.#Control instruction} +... (let [[mapping instruction] (..relabel_control [mapping instruction])] +... [mapping {/.#Control instruction}]))) + +... (def: (relabel_bytecode [mapping bytecode]) +... (Re_labeler (/.Bytecode Inst)) +... (sequence#mix (function (_ input [mapping output]) +... (let [[mapping input'] (..relabel_instruction [mapping input])] +... [mapping (sequence.suffix input' output)])) +... [mapping (sequence.sequence)] +... bytecode)) + +... (def: fresh +... Mapping +... (dictionary.empty nat.hash)) + +... (def: bytecode +... (-> (/.Bytecode Inst /.Label) jvm.Inst) +... (|>> [..fresh] +... ..relabel_bytecode +... product.right +... (sequence#each ..instruction) +... sequence.list +... _.fuse)) + +... (with_expansions [ (as_is jvm.Anchor) +... (as_is Inst) +... (as_is jvm.Definition) +... (as_is )] +... (type: Handler' +... ... (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) +... (-> extension.Name +... (phase.Phase [(extension.Bundle ) +... (generation.State )] +... Synthesis +... ) +... (phase.Phase [(extension.Bundle ) +... (generation.State )] +... (List Synthesis) +... (/.Bytecode Inst /.Label))))) + +... (def: (true_handler extender pseudo) +... (-> jvm.Extender Any jvm.Handler) +... (function (_ extension_name phase archive inputs) +... (# phase.monad each +... (|>> (:as (/.Bytecode Inst /.Label)) ..bytecode) +... ((extender pseudo) extension_name phase archive inputs)))) + +... (type: Phase (directive.Phase jvm.Anchor jvm.Inst jvm.Definition)) +... (type: Operation (directive.Operation jvm.Anchor jvm.Inst jvm.Definition)) +... (type: Handler (directive.Handler jvm.Anchor jvm.Inst jvm.Definition)) + +... (def: (def::generation extender) +... (-> jvm.Extender ..Handler) +... (function (handler extension_name phase archive inputsC+) +... (case inputsC+ +... (^ (list nameC valueC)) +... (do phase.monad +... [[_ _ name] (lux/.evaluate! archive Text nameC) +... [_ handlerV] (lux/.generator archive (:as Text name) ..Handler' valueC) +... _ (|> handlerV +... (..true_handler extender) +... (extension.install extender (:as Text name)) +... directive.lifted_generation) +... _ (directive.lifted_generation +... (generation.log! (format "Generation " (%.text (:as Text name)))))] +... (in directive.no_requirements)) + +... _ +... (phase.except extension.invalid_syntax [extension_name %.code inputsC+])))) (def: .public (custom [parser handler]) (All (_ i) @@ -729,7 +729,7 @@ (def: (method_dependencies archive method) (-> Archive (Method Synthesis) (generation.Operation jvm.Anchor jvm.Inst jvm.Definition - (Set artifact.Dependency))) + (Set unit.ID))) (case method {#Constructor [privacy strict_floating_point? annotations variables exceptions self arguments constructor_arguments @@ -753,7 +753,7 @@ (cache.dependencies archive body) {#Abstract _} - (# phase.monad in artifact.no_dependencies))) + (# phase.monad in unit.none))) (def: constructor (Parser (Constructor Code)) @@ -1201,7 +1201,7 @@ (# ! each (|>> [typeJ]) (synthesise archive termA))) constructor_argumentsA) - bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})] + bodyS (synthesise archive {analysis.#Function (list) (//A.hidden_method_body (list.size arguments) bodyA)})] (in [privacy strict_floating_point? annotations method_tvars exceptions self arguments constructor_argumentsS (case bodyS @@ -1220,7 +1220,7 @@ synthesise directive.synthesis] (directive.lifted_synthesis (do ! - [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})] + [bodyS (synthesise archive {analysis.#Function (list) (//A.hidden_method_body (list.size arguments) bodyA)})] (in [[super_name super_tvars] method_name strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ (case bodyS @@ -1239,7 +1239,7 @@ synthesise directive.synthesis] (directive.lifted_synthesis (do ! - [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})] + [bodyS (synthesise archive {analysis.#Function (list) (//A.hidden_method_body (list.size arguments) bodyA)})] (in [name privacy final? strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ (case bodyS @@ -1258,7 +1258,7 @@ synthesise directive.synthesis] (directive.lifted_synthesis (do ! - [bodyS (synthesise archive {analysis.#Function (list) (//A.hide_method_body (list.size arguments) bodyA)})] + [bodyS (synthesise archive {analysis.#Function (list) (//A.hidden_method_body (list.size arguments) bodyA)})] (in [name privacy strict_floating_point? annotations method_tvars arguments returnJ exceptionsJ (case bodyS @@ -1507,7 +1507,7 @@ def.fuse))]]] (directive.lifted_generation (do ! - [artifact_id (generation.learn_custom class_name artifact.no_dependencies) + [artifact_id (generation.learn_custom class_name unit.none) _ (generation.execute! directive) _ (generation.save! artifact_id {.#Some class_name} directive) _ (generation.log! (format "JVM Interface " (%.text class_name)))] @@ -1516,6 +1516,6 @@ (def: .public (bundle class_loader extender) (-> java/lang/ClassLoader jvm.Extender (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition)) (|> bundle.empty - (dictionary.has "lux def generation" (..def::generation extender)) + ... (dictionary.has "lux def generation" (..def::generation extender)) (dictionary.has "jvm class" (..jvm::class class_loader)) (dictionary.has "jvm class interface" ..jvm::class::interface))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm.lux b/lux-jvm/source/luxc/lang/translation/jvm.lux index c2f7cea68..e2bd46f5d 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm.lux @@ -1,44 +1,45 @@ (.using - [library - [lux {"-" Definition} - ["[0]" ffi {"+" import: do_to object}] - [abstract - [monad {"+" do}]] - [control - pipe - ["[0]" maybe] - ["[0]" try {"+" Try}] - ["[0]" exception {"+" exception:}] - ["[0]" io {"+" IO io}] - [concurrency - ["[0]" atom {"+" Atom atom}]]] - [data - [binary {"+" Binary}] - ["[0]" product] - ["[0]" text ("[1]@[0]" hash) - ["%" format {"+" format}]] - [collection - ["[0]" array] - ["[0]" dictionary {"+" Dictionary}]]] - [target - [jvm - ["[0]" loader {"+" Library}] - ["[0]" type - ["[0]" descriptor]]]] - [tool - [compiler - [language - [lux - ["[0]" version] - ["[0]" generation]]] - [meta - [io {"+" lux_context}]]]]]] - [/// - [host - ["[0]" jvm {"+" Inst Definition Host State} - ["[0]" def] - ["[0]" inst]]]] - ) + [library + [lux {"-" Definition} + ["[0]" ffi {"+" import: do_to object}] + [abstract + [monad {"+" do}]] + [control + pipe + ["[0]" maybe] + ["[0]" try {"+" Try}] + ["[0]" exception {"+" exception:}] + ["[0]" io {"+" IO io}] + [concurrency + ["[0]" atom {"+" Atom atom}]]] + [data + [binary {"+" Binary}] + ["[0]" product] + ["[0]" text ("[1]@[0]" hash) + ["%" format {"+" format}]] + [collection + ["[0]" array] + ["[0]" dictionary {"+" Dictionary}]]] + [target + [jvm + ["[0]" loader {"+" Library}] + ["[0]" type + ["[0]" descriptor]]]] + [tool + [compiler + [language + [lux + ["[0]" version]]] + [meta + [io {"+" lux_context}] + [archive + ["[0]" unit]]]]]]] + [/// + [host + ["[0]" jvm {"+" Inst Definition Host State} + ["[0]" def] + ["[0]" inst]]]] + ) (import: java/lang/reflect/Field ["[1]::[0]" @@ -103,7 +104,7 @@ (text.replaced ..class_path_separator .module_separator)) (def: .public (class_name [module_id artifact_id]) - (-> generation.Context Text) + (-> unit.ID Text) (format lux_context ..class_path_separator (%.nat version.version) ..class_path_separator (%.nat module_id) @@ -146,7 +147,7 @@ (loader.load class_name loader)))) (def: (define! library loader context custom valueI) - (-> Library java/lang/ClassLoader generation.Context (Maybe Text) Inst (Try [Text Any Definition])) + (-> Library java/lang/ClassLoader unit.ID (Maybe Text) Inst (Try [Text Any Definition])) (do try.monad [[value definition] (evaluate! library loader (..class_name context) valueI)] (in [(maybe.else (..class_name context) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux index 28a5c34bc..ee6f243f2 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux @@ -40,7 +40,7 @@ ["[0]" variable {"+" Variable Register}]] [meta [archive {"+" Archive} - ["[0]" artifact]] + ["[0]" unit]] ["[0]" cache "_" ["[1]" artifact]]] [language @@ -1127,7 +1127,7 @@ (unwrap_primitive _.DRETURN type.double))))))) (def: (method_dependencies archive method) - (-> Archive (/.Overriden_Method Synthesis) (Operation (Set artifact.Dependency))) + (-> Archive (/.Overriden_Method Synthesis) (Operation (Set unit.ID))) (let [[_super _name _strict_fp? _annotations _t_vars _this _arguments _return _exceptions bodyS] method] diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux index 2eb1894da..6c0e29730 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/function.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux @@ -31,9 +31,10 @@ [lux [analysis {"+" Environment}] [synthesis {"+" Synthesis Abstraction Apply}] - ["[0]" generation {"+" Context}]]] + ["[0]" generation]]] [meta - [archive {"+" Archive}] + [archive {"+" Archive} + ["[0]" unit]] ["[0]" cache "_" ["[1]" artifact]]]]]]] [luxc @@ -306,7 +307,7 @@ (in [functionD instanceI])))) (def: .public (function' forced_context generate archive [env arity bodyS]) - (-> (Maybe Context) (Generator Abstraction)) + (-> (Maybe unit.ID) (Generator Abstraction)) (do [! phase.monad] [@begin _.make_label dependencies (cache.dependencies archive bodyS) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/program.lux b/lux-jvm/source/luxc/lang/translation/jvm/program.lux index 7e408ecc4..4efe0fd3d 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/program.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/program.lux @@ -1,32 +1,34 @@ (.using - [library - [lux "*" - [data - [text - ["%" format {"+" format}]]] - [target - [jvm - ["$t" type]]] - [tool - [compiler - [language - [lux - [generation {"+" Context}] - [program {"+" Program}]]]]]]] - [luxc - [lang - [host - ["_" jvm - ["$d" def] - ["$i" inst]]] - [translation - ["[0]" jvm - ["[0]" runtime]]]]]) + [library + [lux "*" + [data + [text + ["%" format {"+" format}]]] + [target + [jvm + ["$t" type]]] + [tool + [compiler + [language + [lux + [program {"+" Program}]]] + [meta + [archive + ["[0]" unit]]]]]]] + [luxc + [lang + [host + ["_" jvm + ["$d" def] + ["$i" inst]]] + [translation + ["[0]" jvm + ["[0]" runtime]]]]]) (def: ^Object ($t.class "java.lang.Object" (list))) (def: .public (program artifact_name context programI) - (-> (-> Context Text) (Program _.Inst _.Definition)) + (-> (-> unit.ID Text) (Program _.Inst _.Definition)) (let [nilI runtime.noneI num_inputsI (|>> ($i.ALOAD 0) $i.ARRAYLENGTH) --I (|>> ($i.int +1) $i.ISUB) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux index cec04d529..ee3e16ed8 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/runtime.lux @@ -1,45 +1,46 @@ (.using - [library - [lux {"-" Type Label Primitive try} - [abstract - [monad {"+" do}] - ["[0]" enum]] - [data - [binary {"+" Binary}] - ["[0]" product] - [text - ["%" format {"+" format}]] - [collection - ["[0]" list ("[1]@[0]" functor)] - ["[0]" sequence] - ["[0]" set]]] - ["[0]" math - [number - ["n" nat]]] - [target - [jvm - ["[0]" type {"+" Type} - ["[0]" category {"+" Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method}] - ["[0]" reflection]]]] - [tool - [compiler - [arity {"+" Arity}] - ["[0]" phase] - [language - [lux - ["[0]" synthesis] - ["[0]" generation]]] - [meta - [archive {"+" Output} - ["[0]" artifact] - ["[0]" registry {"+" Registry}]]]]]]] - [luxc - [lang - [host - ["$" jvm {"+" Label Inst Def Operation} - ["$d" def] - ["_" inst]]]]] - ["[0]" // {"+" ByteCode}]) + [library + [lux {"-" Type Label Primitive try} + [abstract + [monad {"+" do}] + ["[0]" enum]] + [data + [binary {"+" Binary}] + ["[0]" product] + [text + ["%" format {"+" format}]] + [collection + ["[0]" list ("[1]@[0]" functor)] + ["[0]" sequence] + ["[0]" set]]] + ["[0]" math + [number + ["n" nat]]] + [target + [jvm + ["[0]" type {"+" Type} + ["[0]" category {"+" Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method}] + ["[0]" reflection]]]] + [tool + [compiler + [arity {"+" Arity}] + ["[0]" phase] + [language + [lux + ["[0]" synthesis] + ["[0]" generation]]] + [meta + [archive {"+" Output} + ["[0]" artifact] + ["[0]" registry {"+" Registry}] + ["[0]" unit]]]]]]] + [luxc + [lang + [host + ["$" jvm {"+" Label Inst Def Operation} + ["$d" def] + ["_" inst]]]]] + ["[0]" // {"+" ByteCode}]) (def: $Text (type.class "java.lang.String" (list))) (def: .public $Lefts type.int) @@ -414,9 +415,9 @@ ... function_payload ..translate_function ] (in [(|> registry.empty - (registry.resource true artifact.no_dependencies) + (registry.resource true unit.none) product.right - ... (registry.resource true artifact.no_dependencies) + ... (registry.resource true unit.none) ... product.right ) (sequence.sequence runtime_payload diff --git a/lux-lua/source/program.lux b/lux-lua/source/program.lux index b588fa732..e0b399bcc 100644 --- a/lux-lua/source/program.lux +++ b/lux-lua/source/program.lux @@ -40,7 +40,7 @@ [language [lux [program {"+" Program}] - [generation {"+" Context Host}] + [generation {"+" Host}] [analysis [macro {"+" Expander}]] [phase diff --git a/stdlib/source/library/lux/math/number/i32.lux b/stdlib/source/library/lux/math/number/i32.lux index c08f261b1..e8967c412 100644 --- a/stdlib/source/library/lux/math/number/i32.lux +++ b/stdlib/source/library/lux/math/number/i32.lux @@ -1,16 +1,18 @@ (.using - [library - [lux {"-" i64} - [type {"+" :by_example}] - [abstract - [equivalence {"+" Equivalence}]] - [control - ["[0]" maybe]]]] - [// - ["[0]" i64 {"+" Sub}]]) + [library + [lux {"-" i64} + [type {"+" :by_example}] + [abstract + [equivalence {"+" Equivalence}]] + [control + ["[0]" maybe]]]] + [// + ["[0]" i64 {"+" Sub}]]) (def: sub - (maybe.trusted (i64.sub 32))) + ... TODO: Stop needing this coercion. + (:as (Sub (I64 (Primitive "#I32"))) + (maybe.trusted (i64.sub 32)))) (def: .public I32 Type diff --git a/stdlib/source/library/lux/target/jvm/bytecode.lux b/stdlib/source/library/lux/target/jvm/bytecode.lux index d7a29db73..17f2dd229 100644 --- a/stdlib/source/library/lux/target/jvm/bytecode.lux +++ b/stdlib/source/library/lux/target/jvm/bytecode.lux @@ -750,11 +750,10 @@ (do [! try.monad] [jump (# ! each //signed.value (/address.jump @from @to))] - (let [big? (n.> (//unsigned.value //unsigned.maximum/2) - (.nat (i.* (if (i.< +0 jump) - -1 - +1) - jump)))] + (let [big? (or (i.> (//signed.value //signed.maximum/2) + jump) + (i.< (//signed.value //signed.minimum/2) + jump))] (if big? (# ! each (|>> {.#Left}) (//signed.s4 jump)) (# ! each (|>> {.#Right}) (//signed.s2 jump)))))) diff --git a/stdlib/source/library/lux/target/jvm/encoding/signed.lux b/stdlib/source/library/lux/target/jvm/encoding/signed.lux index f4f664878..d33321b60 100644 --- a/stdlib/source/library/lux/target/jvm/encoding/signed.lux +++ b/stdlib/source/library/lux/target/jvm/encoding/signed.lux @@ -47,7 +47,7 @@ ["Value" (%.int value)] ["Scope (in bytes)" (%.nat scope)])) - (template [ <+> <->] + (template [ <+> <->] [(with_expansions [ (template.symbol [ "'"])] (abstract: Any) (type: .public (Signed ))) @@ -57,6 +57,11 @@ (def: .public (|> (n.* i64.bits_per_byte) -- i64.mask :abstraction)) + + (def: .public + + (let [it (:representation )] + (:abstraction (-- (i.- it +0))))) (def: .public (-> Int (Try )) @@ -81,9 +86,9 @@ [<-> i.-] )] - [1 S1 bytes/1 s1 maximum/1 +/1 -/1] - [2 S2 bytes/2 s2 maximum/2 +/2 -/2] - [4 S4 bytes/4 s4 maximum/4 +/4 -/4] + [1 S1 bytes/1 s1 maximum/1 minimum/1 +/1 -/1] + [2 S2 bytes/2 s2 maximum/2 minimum/2 +/2 -/2] + [4 S4 bytes/4 s4 maximum/4 minimum/4 +/4 -/4] ) (template [ ] diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux index d4f217dd0..657096c10 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux @@ -17,7 +17,7 @@ ["[0]" location]]]] ["[0]" / "_" ["[1][0]" simple] - ["[1][0]" structure] + ["[1][0]" complex] ["[1][0]" reference] ["[1][0]" case] ["[1][0]" function] @@ -60,22 +60,22 @@ values)}) (case values {.#Item value {.#End}} - (/structure.tagged_sum compile tag archive value) + (/complex.variant compile tag archive value) _ - (/structure.tagged_sum compile tag archive (` [(~+ values)]))) + (/complex.variant compile tag archive (` [(~+ values)]))) (^ {.#Variant (list& [_ {.#Nat lefts}] [_ {.#Bit right?}] values)}) (case values {.#Item value {.#End}} - (/structure.sum compile lefts right? archive value) + (/complex.sum compile lefts right? archive value) _ - (/structure.sum compile lefts right? archive (` [(~+ values)]))) + (/complex.sum compile lefts right? archive (` [(~+ values)]))) (^ {.#Tuple elems}) - (/structure.record archive compile elems) + (/complex.record compile archive elems) _ (else code'))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux index 2b99be974..3eab189d4 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux @@ -25,7 +25,7 @@ ["[1][0]" coverage {"+" Coverage}] ["/[1]" // "_" ["[1][0]" scope] - ["[1][0]" structure] + ["[1][0]" complex] ["/[1]" // "_" ["[1][0]" extension] [// @@ -247,11 +247,11 @@ [location {.#Tuple sub_patterns}] (/.with_location location (do [! ///.monad] - [record (//structure.normal sub_patterns) + [record (//complex.normal sub_patterns) record_size,members,recordT (: (Operation (Maybe [Nat (List Code) Type])) (.case record {.#Some record} - (//structure.order true record) + (//complex.order true record) {.#None} (in {.#None})))] diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux new file mode 100644 index 000000000..678a626da --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux @@ -0,0 +1,424 @@ +(.using + [library + [lux "*" + ["[0]" meta] + [abstract + ["[0]" monad {"+" do}]] + [control + ["[0]" maybe] + ["[0]" try] + ["[0]" exception {"+" exception:}] + ["[0]" state]] + [data + ["[0]" product] + ["[0]" text ("[1]#[0]" equivalence) + ["%" format {"+" format}]] + [collection + ["[0]" list ("[1]#[0]" monad)] + ["[0]" dictionary {"+" Dictionary}]]] + [macro + ["[0]" code]] + [math + [number + ["n" nat]]] + [meta + ["[0]" symbol]] + ["[0]" type + ["[0]" check]]]] + ["[0]" // "_" + ["[1][0]" simple] + ["/[1]" // "_" + ["[1][0]" extension] + [// + ["/" analysis {"+" Analysis Operation Phase} + ["[1][0]" complex {"+" Tag}] + ["[1][0]" type] + ["[1][0]" inference]] + [/// + ["[1]" phase ("[1]#[0]" monad)] + [meta + [archive {"+" Archive}]]]]]]) + +(exception: .public (not_a_quantified_type [type Type]) + (exception.report + ["Type" (%.type type)])) + +(template [] + [(exception: .public ( [type Type + members (List Code)]) + (exception.report + ["Type" (%.type type)] + ["Expression" (%.code (` [(~+ members)]))]))] + + [invalid_tuple_type] + [cannot_analyse_tuple] + ) + +(template [] + [(exception: .public ( [type Type + lefts Nat + right? Bit + code Code]) + (exception.report + ["Type" (%.type type)] + ["Lefts" (%.nat lefts)] + ["Right?" (%.bit right?)] + ["Expression" (%.code code)]))] + + [invalid_variant_type] + [cannot_analyse_variant] + [cannot_infer_sum] + ) + +(exception: .public (cannot_repeat_slot [key Symbol + record (List [Symbol Code])]) + (exception.report + ["Slot" (%.code (code.symbol key))] + ["Record" (%.code (code.tuple (|> record + (list#each (function (_ [keyI valC]) + (list (code.symbol keyI) valC))) + list#conjoint)))])) + +(exception: .public (slot_does_not_belong_to_record [key Symbol + type Type]) + (exception.report + ["Slot" (%.code (code.symbol key))] + ["Type" (%.type type)])) + +(exception: .public (record_size_mismatch [expected Nat + actual Nat + type Type + record (List [Symbol Code])]) + (exception.report + ["Expected" (%.nat expected)] + ["Actual" (%.nat actual)] + ["Type" (%.type type)] + ["Expression" (%.code (|> record + (list#each (function (_ [keyI valueC]) + (list (code.symbol keyI) valueC))) + list#conjoint + code.tuple))])) + +(def: .public (sum analyse lefts right? archive) + (-> Phase Nat Bit Phase) + (let [tag (/complex.tag right? lefts)] + (function (again valueC) + (do [! ///.monad] + [expectedT (///extension.lifted meta.expected_type) + expectedT' (/type.check (check.clean expectedT))] + (/.with_stack ..cannot_analyse_variant [expectedT' lefts right? valueC] + (case expectedT + {.#Sum _} + (|> (analyse archive valueC) + (# ! each (|>> [lefts right?] /.variant)) + (/type.expecting (|> expectedT + type.flat_variant + (list.item tag) + (maybe.else .Nothing)))) + + {.#Named name unnamedT} + (<| (/type.expecting unnamedT) + (again valueC)) + + {.#Var id} + (do ! + [?expectedT' (/type.check (check.peek id))] + (case ?expectedT' + {.#Some expectedT'} + (<| (/type.expecting expectedT') + (again valueC)) + + ... Cannot do inference when the tag is numeric. + ... This is because there is no way of knowing how many + ... cases the inferred sum type would have. + _ + (/.except ..cannot_infer_sum [expectedT lefts right? valueC]))) + + (^template [ ] + [{ _} + (do ! + [[@instance :instance:] (/type.check )] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (again valueC)))]) + ([.#UnivQ check.existential] + [.#ExQ check.var]) + + {.#Apply inputT funT} + (case funT + {.#Var funT_id} + (do ! + [?funT' (/type.check (check.peek funT_id))] + (case ?funT' + {.#Some funT'} + (<| (/type.expecting {.#Apply inputT funT'}) + (again valueC)) + + _ + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))) + + _ + (case (type.applied (list inputT) funT) + {.#Some outputT} + (<| (/type.expecting outputT) + (again valueC)) + + {.#None} + (/.except ..not_a_quantified_type [funT]))) + + _ + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))))))) + +(def: .public (variant analyse tag archive valueC) + (-> Phase Symbol Phase) + (do [! ///.monad] + [tag (///extension.lifted (meta.normal tag)) + [idx group variantT] (///extension.lifted (meta.tag tag)) + .let [case_size (list.size group) + [lefts right?] (/complex.choice case_size idx)] + expectedT (///extension.lifted meta.expected_type)] + (case expectedT + {.#Var _} + (do ! + [inferenceT (/inference.variant lefts right? variantT) + [inferredT valueA+] (/inference.general archive analyse inferenceT (list valueC))] + (in (/.variant [lefts right? (|> valueA+ list.head maybe.trusted)]))) + + _ + (..sum analyse lefts right? archive valueC)))) + +(def: (typed_product analyse expectedT archive members) + (-> Phase Type Archive (List Code) (Operation Analysis)) + (<| (let [! ///.monad]) + (# ! each (|>> /.tuple)) + (: (Operation (List Analysis))) + (loop [membersT+ (type.flat_tuple expectedT) + membersC+ members] + (case [membersT+ membersC+] + [{.#Item memberT {.#End}} {.#Item memberC {.#End}}] + (<| (# ! each (|>> list)) + (/type.expecting memberT) + (analyse archive memberC)) + + [{.#Item memberT {.#End}} _] + (<| (/type.expecting memberT) + (# ! each (|>> list) (analyse archive (code.tuple membersC+)))) + + [_ {.#Item memberC {.#End}}] + (<| (/type.expecting (type.tuple membersT+)) + (# ! each (|>> list) (analyse archive memberC))) + + [{.#Item memberT membersT+'} {.#Item memberC membersC+'}] + (do ! + [memberA (<| (/type.expecting memberT) + (analyse archive memberC)) + memberA+ (again membersT+' membersC+')] + (in {.#Item memberA memberA+})) + + _ + (/.except ..cannot_analyse_tuple [expectedT members]))))) + +(def: .public (product analyse archive membersC) + (-> Phase Archive (List Code) (Operation Analysis)) + (do [! ///.monad] + [expectedT (///extension.lifted meta.expected_type)] + (/.with_stack ..cannot_analyse_tuple [expectedT membersC] + (case expectedT + {.#Product _} + (..typed_product analyse expectedT archive membersC) + + {.#Named name unnamedT} + (<| (/type.expecting unnamedT) + (product analyse archive membersC)) + + {.#Var id} + (do ! + [?expectedT' (/type.check (check.peek id))] + (case ?expectedT' + {.#Some expectedT'} + (<| (/type.expecting expectedT') + (product analyse archive membersC)) + + _ + ... Must infer... + (do ! + [membersTA (monad.each ! (|>> (analyse archive) /type.inferring) + membersC) + _ (/type.check (check.check expectedT + (type.tuple (list#each product.left membersTA))))] + (in (/.tuple (list#each product.right membersTA)))))) + + (^template [ ] + [{ _} + (do ! + [[@instance :instance:] (/type.check )] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (product analyse archive membersC)))]) + ([.#UnivQ check.existential] + [.#ExQ check.var]) + + {.#Apply inputT funT} + (case funT + {.#Var funT_id} + (do ! + [?funT' (/type.check (check.peek funT_id))] + (case ?funT' + {.#Some funT'} + (<| (/type.expecting {.#Apply inputT funT'}) + (product analyse archive membersC)) + + _ + (/.except ..invalid_tuple_type [expectedT membersC]))) + + _ + (case (type.applied (list inputT) funT) + {.#Some outputT} + (<| (/type.expecting outputT) + (product analyse archive membersC)) + + {.#None} + (/.except ..not_a_quantified_type funT))) + + _ + (/.except ..invalid_tuple_type [expectedT membersC]) + )))) + +... There cannot be any ambiguity or improper syntax when analysing +... records, so they must be normalized for further analysis. +... Normalization just means that all the tags get resolved to their +... canonical form (with their corresponding module identified). +(def: .public (normal record) + (-> (List Code) (Operation (Maybe (List [Symbol Code])))) + (loop [input record + output (: (List [Symbol Code]) + {.#End})] + (case input + (^ (list& [_ {.#Symbol slotH}] valueH tail)) + (do ///.monad + [slotH (///extension.lifted (meta.normal slotH))] + (again tail {.#Item [slotH valueH] output})) + + {.#End} + (///#in {.#Some output}) + + _ + (///#in {.#None})))) + +(def: (local_binding? name) + (-> Text (Meta Bit)) + (# meta.monad each + (list.any? (list.any? (|>> product.left (text#= name)))) + meta.locals)) + +... Lux already possesses the means to analyse tuples, so +... re-implementing the same functionality for records makes no sense. +... Records, thus, get transformed into tuples by ordering the elements. +(def: (order' head_k record) + (-> Symbol (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) + (do [! ///.monad] + [slotH' (///extension.lifted + (do meta.monad + [head_k (meta.normal head_k)] + (meta.try (meta.slot head_k))))] + (case slotH' + {try.#Success [_ slot_set recordT]} + (do ! + [.let [size_record (list.size record) + size_ts (list.size slot_set)] + _ (if (n.= size_ts size_record) + (in []) + (/.except ..record_size_mismatch [size_ts size_record recordT record])) + .let [tuple_range (list.indices size_ts) + tag->idx (dictionary.of_list symbol.hash (list.zipped/2 slot_set tuple_range))] + idx->val (monad.mix ! + (function (_ [key val] idx->val) + (do ! + [key (///extension.lifted (meta.normal key))] + (case (dictionary.value key tag->idx) + {.#Some idx} + (if (dictionary.key? idx->val idx) + (/.except ..cannot_repeat_slot [key record]) + (in (dictionary.has idx val idx->val))) + + {.#None} + (/.except ..slot_does_not_belong_to_record [key recordT])))) + (: (Dictionary Nat Code) + (dictionary.empty n.hash)) + record) + .let [ordered_tuple (list#each (function (_ idx) + (maybe.trusted (dictionary.value idx idx->val))) + tuple_range)]] + (in {.#Some [size_ts ordered_tuple recordT]})) + + {try.#Failure error} + (in {.#None})))) + +(def: .public (order pattern_matching? record) + (-> Bit (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) + (case record + ... empty_record = empty_tuple = unit/any = [] + {.#End} + (///#in {.#Some [0 (list) .Any]}) + + {.#Item [head_k head_v] _} + (case head_k + ["" head_k'] + (if pattern_matching? + (///#in {.#None}) + (do ///.monad + [local_binding? (///extension.lifted + (..local_binding? head_k'))] + (if local_binding? + (in {.#None}) + (order' head_k record)))) + + _ + (order' head_k record)))) + +(def: .public (record analyse archive members) + (-> Phase Archive (List Code) (Operation Analysis)) + (case members + (^ (list)) + //simple.unit + + (^ (list singletonC)) + (analyse archive singletonC) + + (^ (list [_ {.#Symbol pseudo_slot}] singletonC)) + (do [! ///.monad] + [head_k (///extension.lifted (meta.normal pseudo_slot)) + slot (///extension.lifted (meta.try (meta.slot head_k)))] + (case slot + {try.#Success [_ slot_set recordT]} + (case (list.size slot_set) + 1 (analyse archive singletonC) + _ (..product analyse archive members)) + + _ + (..product analyse archive members))) + + _ + (do [! ///.monad] + [?members (normal members)] + (case ?members + {.#None} + (..product analyse archive members) + + {.#Some slots} + (do ! + [record_size,membersC,recordT (..order false slots)] + (case record_size,membersC,recordT + {.#None} + (..product analyse archive members) + + {.#Some [record_size membersC recordT]} + (do ! + [expectedT (///extension.lifted meta.expected_type)] + (case expectedT + {.#Var _} + (do ! + [inferenceT (/inference.record record_size recordT) + [inferredT membersA] (/inference.general archive analyse inferenceT membersC)] + (in (/.tuple membersA))) + + _ + (..product analyse archive membersC))))))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux deleted file mode 100644 index cdf65a6ad..000000000 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ /dev/null @@ -1,428 +0,0 @@ -(.using - [library - [lux "*" - ["[0]" meta] - [abstract - ["[0]" monad {"+" do}]] - [control - ["[0]" maybe] - ["[0]" try] - ["[0]" exception {"+" exception:}] - ["[0]" state]] - [data - ["[0]" product] - ["[0]" text ("[1]#[0]" equivalence) - ["%" format {"+" format}]] - [collection - ["[0]" list ("[1]#[0]" monad)] - ["[0]" dictionary {"+" Dictionary}]]] - [macro - ["[0]" code]] - [math - [number - ["n" nat]]] - [meta - ["[0]" symbol]] - ["[0]" type - ["[0]" check]]]] - ["[0]" // "_" - ["[1][0]" simple] - ["/[1]" // "_" - ["[1][0]" extension] - [// - ["/" analysis {"+" Analysis Operation Phase} - ["[1][0]" complex {"+" Tag}] - ["[1][0]" type] - ["[1][0]" inference]] - [/// - ["[1]" phase] - [meta - [archive {"+" Archive}]]]]]]) - -(template [] - [(exception: .public ( [type Type - members (List Code)]) - (exception.report - ["Type" (%.type type)] - ["Expression" (%.code (` [(~+ members)]))]))] - - [invalid_tuple_type] - [cannot_analyse_tuple] - ) - -(exception: .public (not_a_quantified_type [type Type]) - (exception.report - ["Type" (%.type type)])) - -(template [] - [(exception: .public ( [type Type - tag Tag - code Code]) - (exception.report - ["Type" (%.type type)] - ["Tag" (%.nat tag)] - ["Expression" (%.code code)]))] - - [invalid_variant_type] - [cannot_analyse_variant] - [cannot_infer_numeric_tag] - ) - -(template [] - [(exception: .public ( [key Symbol - record (List [Symbol Code])]) - (exception.report - ["Slot" (%.code (code.symbol key))] - ["Record" (%.code (code.tuple (|> record - (list#each (function (_ [keyI valC]) - (list (code.symbol keyI) valC))) - list#conjoint)))]))] - - [cannot_repeat_slot] - ) - -(exception: .public (slot_does_not_belong_to_record [key Symbol - type Type]) - (exception.report - ["Slot" (%.code (code.symbol key))] - ["Type" (%.type type)])) - -(exception: .public (record_size_mismatch [expected Nat - actual Nat - type Type - record (List [Symbol Code])]) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)] - ["Type" (%.type type)] - ["Expression" (%.code (|> record - (list#each (function (_ [keyI valueC]) - (list (code.symbol keyI) valueC))) - list#conjoint - code.tuple))])) - -(def: .public (sum analyse lefts right? archive) - (-> Phase Nat Bit Phase) - (let [tag (/complex.tag right? lefts)] - (function (again valueC) - (do [! ///.monad] - [expectedT (///extension.lifted meta.expected_type) - expectedT' (/type.check (check.clean expectedT))] - (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC] - (case expectedT - {.#Sum _} - (|> (analyse archive valueC) - (# ! each (|>> [lefts right?] /.variant)) - (/type.expecting (|> expectedT - type.flat_variant - (list.item tag) - (maybe.else .Nothing)))) - - {.#Named name unnamedT} - (<| (/type.expecting unnamedT) - (again valueC)) - - {.#Var id} - (do ! - [?expectedT' (/type.check (check.peek id))] - (case ?expectedT' - {.#Some expectedT'} - (<| (/type.expecting expectedT') - (again valueC)) - - ... Cannot do inference when the tag is numeric. - ... This is because there is no way of knowing how many - ... cases the inferred sum type would have. - _ - (/.except ..cannot_infer_numeric_tag [expectedT tag valueC]))) - - (^template [ ] - [{ _} - (do ! - [[instance_id instanceT] (/type.check )] - (<| (/type.expecting (maybe.trusted (type.applied (list instanceT) expectedT))) - (again valueC)))]) - ([.#UnivQ check.existential] - [.#ExQ check.var]) - - {.#Apply inputT funT} - (case funT - {.#Var funT_id} - (do ! - [?funT' (/type.check (check.peek funT_id))] - (case ?funT' - {.#Some funT'} - (<| (/type.expecting {.#Apply inputT funT'}) - (again valueC)) - - _ - (/.except ..invalid_variant_type [expectedT tag valueC]))) - - _ - (case (type.applied (list inputT) funT) - {.#Some outputT} - (<| (/type.expecting outputT) - (again valueC)) - - {.#None} - (/.except ..not_a_quantified_type funT))) - - _ - (/.except ..invalid_variant_type [expectedT tag valueC]))))))) - -(def: (typed_product archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) - (do [! ///.monad] - [expectedT (///extension.lifted meta.expected_type) - membersA+ (: (Operation (List Analysis)) - (loop [membersT+ (type.flat_tuple expectedT) - membersC+ members] - (case [membersT+ membersC+] - [{.#Item memberT {.#End}} {.#Item memberC {.#End}}] - (do ! - [memberA (<| (/type.expecting memberT) - (analyse archive memberC))] - (in (list memberA))) - - [{.#Item memberT {.#End}} _] - (<| (/type.expecting memberT) - (# ! each (|>> list) (analyse archive (code.tuple membersC+)))) - - [_ {.#Item memberC {.#End}}] - (<| (/type.expecting (type.tuple membersT+)) - (# ! each (|>> list) (analyse archive memberC))) - - [{.#Item memberT membersT+'} {.#Item memberC membersC+'}] - (do ! - [memberA (<| (/type.expecting memberT) - (analyse archive memberC)) - memberA+ (again membersT+' membersC+')] - (in {.#Item memberA memberA+})) - - _ - (/.except ..cannot_analyse_tuple [expectedT members]))))] - (in (/.tuple membersA+)))) - -(def: .public (product archive analyse membersC) - (-> Archive Phase (List Code) (Operation Analysis)) - (do [! ///.monad] - [expectedT (///extension.lifted meta.expected_type)] - (/.with_stack ..cannot_analyse_tuple [expectedT membersC] - (case expectedT - {.#Product _} - (..typed_product archive analyse membersC) - - {.#Named name unnamedT} - (<| (/type.expecting unnamedT) - (product archive analyse membersC)) - - {.#Var id} - (do ! - [?expectedT' (/type.check (check.peek id))] - (case ?expectedT' - {.#Some expectedT'} - (<| (/type.expecting expectedT') - (product archive analyse membersC)) - - _ - ... Must do inference... - (do ! - [membersTA (monad.each ! (|>> (analyse archive) /type.inferring) - membersC) - _ (/type.check (check.check expectedT - (type.tuple (list#each product.left membersTA))))] - (in (/.tuple (list#each product.right membersTA)))))) - - (^template [ ] - [{ _} - (do ! - [[instance_id instanceT] (/type.check )] - (<| (/type.expecting (maybe.trusted (type.applied (list instanceT) expectedT))) - (product archive analyse membersC)))]) - ([.#UnivQ check.existential] - [.#ExQ check.var]) - - {.#Apply inputT funT} - (case funT - {.#Var funT_id} - (do ! - [?funT' (/type.check (check.peek funT_id))] - (case ?funT' - {.#Some funT'} - (<| (/type.expecting {.#Apply inputT funT'}) - (product archive analyse membersC)) - - _ - (/.except ..invalid_tuple_type [expectedT membersC]))) - - _ - (case (type.applied (list inputT) funT) - {.#Some outputT} - (<| (/type.expecting outputT) - (product archive analyse membersC)) - - {.#None} - (/.except ..not_a_quantified_type funT))) - - _ - (/.except ..invalid_tuple_type [expectedT membersC]) - )))) - -(def: .public (tagged_sum analyse tag archive valueC) - (-> Phase Symbol Phase) - (do [! ///.monad] - [tag (///extension.lifted (meta.normal tag)) - [idx group variantT] (///extension.lifted (meta.tag tag)) - .let [case_size (list.size group) - [lefts right?] (/complex.choice case_size idx)] - expectedT (///extension.lifted meta.expected_type)] - (case expectedT - {.#Var _} - (do ! - [inferenceT (/inference.variant lefts right? variantT) - [inferredT valueA+] (/inference.general archive analyse inferenceT (list valueC))] - (in (/.variant [lefts right? (|> valueA+ list.head maybe.trusted)]))) - - _ - (..sum analyse lefts right? archive valueC)))) - -... There cannot be any ambiguity or improper syntax when analysing -... records, so they must be normalized for further analysis. -... Normalization just means that all the tags get resolved to their -... canonical form (with their corresponding module identified). -(def: .public (normal record) - (-> (List Code) (Operation (Maybe (List [Symbol Code])))) - (loop [input record - output (: (List [Symbol Code]) - {.#End})] - (case input - (^ (list& [_ {.#Symbol slotH}] valueH tail)) - (do ///.monad - [slotH (///extension.lifted (meta.normal slotH))] - (again tail {.#Item [slotH valueH] output})) - - {.#End} - (# ///.monad in {.#Some output}) - - _ - (# ///.monad in {.#None})))) - -(def: (local_binding? name) - (-> Text (Meta Bit)) - (# meta.monad each - (list.any? (list.any? (|>> product.left (text#= name)))) - meta.locals)) - -... Lux already possesses the means to analyse tuples, so -... re-implementing the same functionality for records makes no sense. -... Records, thus, get transformed into tuples by ordering the elements. -(def: (order' head_k record) - (-> Symbol (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) - (do [! ///.monad] - [slotH' (///extension.lifted - (do meta.monad - [head_k (meta.normal head_k)] - (meta.try (meta.slot head_k))))] - (case slotH' - {try.#Success [_ slot_set recordT]} - (do ! - [.let [size_record (list.size record) - size_ts (list.size slot_set)] - _ (if (n.= size_ts size_record) - (in []) - (/.except ..record_size_mismatch [size_ts size_record recordT record])) - .let [tuple_range (list.indices size_ts) - tag->idx (dictionary.of_list symbol.hash (list.zipped/2 slot_set tuple_range))] - idx->val (monad.mix ! - (function (_ [key val] idx->val) - (do ! - [key (///extension.lifted (meta.normal key))] - (case (dictionary.value key tag->idx) - {.#Some idx} - (if (dictionary.key? idx->val idx) - (/.except ..cannot_repeat_slot [key record]) - (in (dictionary.has idx val idx->val))) - - {.#None} - (/.except ..slot_does_not_belong_to_record [key recordT])))) - (: (Dictionary Nat Code) - (dictionary.empty n.hash)) - record) - .let [ordered_tuple (list#each (function (_ idx) - (maybe.trusted (dictionary.value idx idx->val))) - tuple_range)]] - (in {.#Some [size_ts ordered_tuple recordT]})) - - {try.#Failure error} - (in {.#None})))) - -(def: .public (order pattern_matching? record) - (-> Bit (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) - (case record - ... empty_record = empty_tuple = unit/any = [] - {.#End} - (# ///.monad in {.#Some [0 (list) Any]}) - - {.#Item [head_k head_v] _} - (case head_k - ["" head_k'] - (if pattern_matching? - (# ///.monad in {.#None}) - (do ///.monad - [local_binding? (///extension.lifted - (local_binding? head_k'))] - (if local_binding? - (order' head_k record) - (in {.#None})))) - - _ - (order' head_k record)))) - -(def: .public (record archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) - (case members - (^ (list)) - //simple.unit - - (^ (list singletonC)) - (analyse archive singletonC) - - (^ (list [_ {.#Symbol pseudo_slot}] singletonC)) - (do [! ///.monad] - [head_k (///extension.lifted (meta.normal pseudo_slot)) - slot (///extension.lifted (meta.try (meta.slot head_k)))] - (case slot - {try.#Success [_ slot_set recordT]} - (case (list.size slot_set) - 1 (analyse archive singletonC) - _ (..product archive analyse members)) - - _ - (..product archive analyse members))) - - _ - (do [! ///.monad] - [?members (normal members)] - (case ?members - {.#None} - (..product archive analyse members) - - {.#Some slots} - (do ! - [record_size,membersC,recordT (..order false slots)] - (case record_size,membersC,recordT - {.#None} - (..product archive analyse members) - - {.#Some [record_size membersC recordT]} - (do ! - [expectedT (///extension.lifted meta.expected_type)] - (case expectedT - {.#Var _} - (do ! - [inferenceT (/inference.record record_size recordT) - [inferredT membersA] (/inference.general archive analyse inferenceT membersC)] - (in (/.tuple membersA))) - - _ - (..product archive analyse membersC))))))))) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index 2b146414f..4d6c7e712 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -2180,19 +2180,18 @@ [[_ parameterT] check.existential] (in [parameterJ parameterT]))))) +(def: (matched? [sub sub_method subJT] [super super_method superJT]) + (-> [(Type Class) Text (Type Method)] [(Type Class) Text (Type Method)] Bit) + (and (# descriptor.equivalence = (jvm.descriptor super) (jvm.descriptor sub)) + (text#= super_method sub_method) + (jvm#= superJT subJT))) + (def: (mismatched_methods super_set sub_set) (-> (List [(Type Class) Text (Type Method)]) (List [(Type Class) Text (Type Method)]) (List [(Type Class) Text (Type Method)])) - (list.only (function (_ [sub sub_name subJT]) - (|> super_set - (list.only (function (_ [super super_name superJT]) - (and (jvm#= super sub) - (text#= super_name sub_name) - (jvm#= superJT subJT)))) - list.size - (n.= 1) - not)) + (list.only (function (_ sub) + (not (list.any? (matched? sub) super_set))) sub_set)) (exception: .public (class_parameter_mismatch [name Text @@ -2254,7 +2253,7 @@ methods) .let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods) invalid_overriden_methods (mismatched_methods available_methods overriden_methods)] - _ (phase.assertion ..missing_abstract_methods [required_abstract_methods missing_abstract_methods] + _ (phase.assertion ..missing_abstract_methods [required_abstract_methods overriden_methods] (list.empty? missing_abstract_methods)) _ (phase.assertion ..invalid_overriden_methods [available_methods invalid_overriden_methods] (list.empty? invalid_overriden_methods))] diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux index e6953ac59..7e286955e 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux @@ -1,32 +1,30 @@ (.using - [library - [lux "*" - ["[0]" ffi] - [abstract - ["[0]" monad {"+" do}]] - [control - ["<>" parser - ["<[0]>" code {"+" Parser}]]] - [data - [collection - ["[0]" array {"+" Array}] - ["[0]" dictionary] - ["[0]" list]]] - ["[0]" type - ["[0]" check]] - ["@" target - ["_" lua]]]] + [library + [lux "*" + ["[0]" ffi] + [abstract + ["[0]" monad {"+" do}]] + [control + ["<>" parser + ["<[0]>" code {"+" Parser}]]] + [data + [collection + ["[0]" array {"+" Array}] + ["[0]" dictionary] + ["[0]" list]]] + ["[0]" type + ["[0]" check]] + ["@" target + ["_" lua]]]] + [// + ["/" lux {"+" custom}] [// - ["/" lux {"+" custom}] - [// - ["[0]" bundle] - [// - ["[0]" analysis "_" - ["[1]/[0]" type]] - [// - ["[0]" analysis {"+" Analysis Operation Phase Handler Bundle}] - [/// - ["[0]" phase]]]]]]) + ["[0]" bundle] + [/// + ["[0]" analysis {"+" Analysis Operation Phase Handler Bundle} + ["[1]/[0]" type]] + [/// + ["[0]" phase]]]]]) (def: Nil (for [@.lua ffi.Nil] @@ -46,10 +44,10 @@ [.any (function (_ extension phase archive lengthC) (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] + [lengthA (analysis/type.expecting Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.check check.var) + _ (analysis/type.inference (type (Array varT)))] (in {analysis.#Extension extension (list lengthA)})))])) (def: array::length @@ -58,10 +56,10 @@ [.any (function (_ extension phase archive arrayC) (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] + [[var_id varT] (analysis/type.check check.var) + arrayA (analysis/type.expecting (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.inference Nat)] (in {analysis.#Extension extension (list arrayA)})))])) (def: array::read @@ -70,12 +68,12 @@ [(<>.and .any .any) (function (_ extension phase archive [indexC arrayC]) (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + [var_id varT] (analysis/type.check check.var) + arrayA (analysis/type.expecting (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.inference varT)] (in {analysis.#Extension extension (list indexA arrayA)})))])) (def: array::write @@ -84,14 +82,14 @@ [($_ <>.and .any .any .any) (function (_ extension phase archive [indexC valueC arrayC]) (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + [var_id varT] (analysis/type.check check.var) + valueA (analysis/type.expecting varT + (phase archive valueC)) + arrayA (analysis/type.expecting (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.inference (type (Array varT)))] (in {analysis.#Extension extension (list indexA valueA arrayA)})))])) (def: array::delete @@ -100,12 +98,12 @@ [($_ <>.and .any .any) (function (_ extension phase archive [indexC arrayC]) (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + [var_id varT] (analysis/type.check check.var) + arrayA (analysis/type.expecting (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.inference (type (Array varT)))] (in {analysis.#Extension extension (list indexA arrayA)})))])) (def: bundle::array @@ -125,9 +123,9 @@ [($_ <>.and .text .any) (function (_ extension phase archive [fieldC objectC]) (do phase.monad - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - _ (analysis/type.infer .Any)] + [objectA (analysis/type.expecting ..Object + (phase archive objectC)) + _ (analysis/type.inference .Any)] (in {analysis.#Extension extension (list (analysis.text fieldC) objectA)})))])) @@ -137,10 +135,10 @@ [($_ <>.and .text .any (<>.some .any)) (function (_ extension phase archive [methodC objectC inputsC]) (do [! phase.monad] - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - inputsA (monad.each ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] + [objectA (analysis/type.expecting ..Object + (phase archive objectC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference .Any)] (in {analysis.#Extension extension (list& (analysis.text methodC) objectA inputsA)})))])) @@ -162,9 +160,9 @@ [.any (function (_ extension phase archive inputC) (do [! phase.monad] - [inputA (analysis/type.with_type (type ) - (phase archive inputC)) - _ (analysis/type.infer (type ))] + [inputA (analysis/type.expecting (type ) + (phase archive inputC)) + _ (analysis/type.inference (type ))] (in {analysis.#Extension extension (list inputA)})))]))] [utf8::encode Text (array.Array (I64 Any))] @@ -185,7 +183,7 @@ [.text (function (_ extension phase archive name) (do phase.monad - [_ (analysis/type.infer Any)] + [_ (analysis/type.inference Any)] (in {analysis.#Extension extension (list (analysis.text name))})))])) (def: lua::apply @@ -194,10 +192,10 @@ [($_ <>.and .any (<>.some .any)) (function (_ extension phase archive [abstractionC inputsC]) (do [! phase.monad] - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.each ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] + [abstractionA (analysis/type.expecting ..Function + (phase archive abstractionC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference Any)] (in {analysis.#Extension extension (list& abstractionA inputsA)})))])) (def: lua::power @@ -206,11 +204,11 @@ [($_ <>.and .any .any) (function (_ extension phase archive [powerC baseC]) (do [! phase.monad] - [powerA (analysis/type.with_type Frac - (phase archive powerC)) - baseA (analysis/type.with_type Frac - (phase archive baseC)) - _ (analysis/type.infer Frac)] + [powerA (analysis/type.expecting Frac + (phase archive powerC)) + baseA (analysis/type.expecting Frac + (phase archive baseC)) + _ (analysis/type.inference Frac)] (in {analysis.#Extension extension (list powerA baseA)})))])) (def: lua::import @@ -219,7 +217,7 @@ [.text (function (_ extension phase archive name) (do phase.monad - [_ (analysis/type.infer ..Object)] + [_ (analysis/type.inference ..Object)] (in {analysis.#Extension extension (list (analysis.text name))})))])) (def: lua::function @@ -229,9 +227,9 @@ (function (_ extension phase archive [arity abstractionC]) (do phase.monad [.let [inputT (type.tuple (list.repeated arity Any))] - abstractionA (analysis/type.with_type (-> inputT Any) - (phase archive abstractionC)) - _ (analysis/type.infer ..Function)] + abstractionA (analysis/type.expecting (-> inputT Any) + (phase archive abstractionC)) + _ (analysis/type.inference ..Function)] (in {analysis.#Extension extension (list (analysis.nat arity) abstractionA)})))])) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux index b5899731b..e2ed832c1 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux @@ -20,20 +20,22 @@ ["/[1]" // "_" ["[1][0]" reference] ["//[1]" /// "_" - [analysis {"+" Abstraction Application Analysis}] + [analysis {"+" Abstraction Reification Analysis}] [synthesis {"+" Synthesis}] - ["[1][0]" generation {"+" Context}] + ["[1][0]" generation] ["//[1]" /// "_" [arity {"+" Arity}] ["[1][0]" phase ("[1]#[0]" monad)] [meta [archive - ["[0]" dependency]]] + ["[0]" unit]] + ["[0]" cache "_" + ["[1]" artifact]]] [reference [variable {"+" Register Variable}]]]]]]) (def: .public (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) + (Generator (Reification Synthesis)) (do [! ///////phase.monad] [functionO (expression archive functionS) argsO+ (monad.each ! (expression archive) argsS+)] @@ -63,13 +65,13 @@ (|>> ++ //case.register)) (def: (@scope function_name) - (-> Context Label) + (-> unit.ID Label) (_.label (format (///reference.artifact function_name) "_scope"))) (def: .public (function statement expression archive [environment arity bodyS]) (-> Phase! (Generator (Abstraction Synthesis))) (do [! ///////phase.monad] - [dependencies (dependency.dependencies archive bodyS) + [dependencies (cache.dependencies archive bodyS) [function_name body!] (/////generation.with_new_context archive dependencies (do ! [@scope (# ! each ..@scope diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux index 06135b240..59d88e612 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux @@ -26,8 +26,9 @@ ["//[1]" /// "_" ["[1][0]" phase] [meta - [archive {"+" Archive} - ["[0]" dependency]]] + [archive {"+" Archive}] + ["[0]" cache "_" + ["[1]" artifact]]] [reference [variable {"+" Register}]]]]]]) @@ -82,7 +83,7 @@ ... true loop _ (do [! ///////phase.monad] - [dependencies (dependency.dependencies archive bodyS) + [dependencies (cache.dependencies archive bodyS) [[artifact_module artifact_id] [initsO+ scope!]] (/////generation.with_new_context archive dependencies (scope! statement expression archive true [start initsS+ bodyS])) .let [@loop (_.var (///reference.artifact [artifact_module artifact_id])) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux index 40525dd00..794bc1fd7 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux @@ -36,7 +36,8 @@ [variable {"+" Register}]] [meta [archive {"+" Output Archive} - ["[0]" artifact {"+" Registry}]]]]]]) + ["[0]" registry {"+" Registry}] + ["[0]" unit]]]]]]) (template [ ] [(type: .public @@ -425,8 +426,8 @@ (do ///////phase.monad [_ (/////generation.execute! ..runtime) _ (/////generation.save! ..module_id {.#None} ..runtime)] - (in [(|> artifact.empty - (artifact.resource true artifact.no_dependencies) + (in [(|> registry.empty + (registry.resource true unit.none) product.right) (sequence.sequence [..module_id {.#None} diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux index 97784804e..80028d75e 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux @@ -11,7 +11,7 @@ ["///[1]" //// "_" ["[1][0]" synthesis {"+" Synthesis}] [analysis - [composite {"+" Variant Tuple}]] + [complex {"+" Variant Tuple}]] ["//[1]" /// "_" ["[1][0]" phase ("[1]#[0]" monad)]]]]) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 2b72f6dad..b859f456f 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -431,94 +431,97 @@ (n.= (..sum n/0 n/1 n/1) (..sum' n/0 n/1 n/1)))) (_.cover [/.using] - (with_expansions [ ("lux in-module" "library/lux" library/lux.refer) - (static.random code.text (random.ascii/lower 1)) - (static.random code.local_symbol (random.ascii/lower 1)) - (static.random code.text (random.ascii/lower 2)) - ' (template.symbol []) - (static.random code.text (random.ascii/lower 3)) - ' (template.symbol []) - (static.random code.text (random.ascii/lower 4)) - ' (template.symbol []) - (template.text [ "/" ]) - (template.text [// ']) - ' (template.symbol []) - <\\> (template.text [\\ ']) - <\\>' (template.symbol [<\\>]) - (template.text [ "/" ]) - (template.text [ "/" ]) - (template.text [ "/" "/" ]) - (template.text [ "#[0]"])] - (and (~~ (template [ ] - [(with_expansions [' (macro.final )] - (case (' [']) - (^code ) - true - - _ - false))] - - [(.using [']) - [("lux def module" [])]] - - [(.using [ ' "*"]) - [("lux def module" [[ ]]) - ( "*")]] - - [(.using [ ' {"+" }]) - [("lux def module" [[ ]]) - ( {"+" })]] - - [(.using [ ' {"-" }]) - [("lux def module" [[ ]]) - ( {"-" })]] - - [(.using [ ' "_"]) - [("lux def module" [])]] - - [(.using [' - [ ']]) - [("lux def module" [[ ]]) - ( )]] - - [(.using ["[0]" ' - ["[0]" ']]) - [("lux def module" [[ ] - [ ]]) - ( ) - ( )]] - - [(.using ["[0]" ' "_" - ["[1]" ']]) - [("lux def module" [[ ]]) - ( )]] - - [(.using ["[0]" ' "_" - ["[1]" ' "_" - ["[2]" ']]]) - [("lux def module" [[ ]]) - ( )]] - - [(.using [' - ["[0]" ' - ["[0]" ']]]) - [("lux def module" [[ ] - [ ]]) - ( ) - ( )]] - - [(.using ["[0]" ' - [' - ["[0]" <\\>']]]) - [("lux def module" [[ ] - [ <\\>]]) - ( ) - ( )]] - - [(.using ["[0]" ' ("[1]#[0]" )]) - [("lux def module" [[ ]]) - ( ( ))]] - ))))) + (`` (with_expansions [ ("lux in-module" "library/lux" library/lux.refer) + (static.random code.text (random.ascii/lower 1)) + (static.random code.local_symbol (random.ascii/lower 1)) + (static.random code.text (random.ascii/lower 2)) + ' (template.symbol []) + (static.random code.text (random.ascii/lower 3)) + ' (template.symbol []) + (static.random code.text (random.ascii/lower 4)) + ' (template.symbol []) + (template.text [ "/" ]) + (template.text [// ']) + ' (template.symbol []) + <\\> (template.text [\\ ']) + <\\>' (template.symbol [<\\>]) + (template.text [ "/" ]) + (template.text [ "/" ]) + (template.text [ "/" "/" ]) + (template.text [ "#[0]"])] + (and (~~ (template [ ] + [(with_expansions [' (macro.final )] + (let [scenario (: (-> Any Bit) + (function (_ _) + (case (' [']) + (^code ) + true + + _ + false)))] + (scenario [])))] + + [(.using [']) + [("lux def module" [])]] + + [(.using [ ' "*"]) + [("lux def module" [[ ]]) + ( "*")]] + + [(.using [ ' {"+" }]) + [("lux def module" [[ ]]) + ( {"+" })]] + + [(.using [ ' {"-" }]) + [("lux def module" [[ ]]) + ( {"-" })]] + + [(.using [ ' "_"]) + [("lux def module" [])]] + + [(.using [' + [ ']]) + [("lux def module" [[ ]]) + ( )]] + + [(.using ["[0]" ' + ["[0]" ']]) + [("lux def module" [[ ] + [ ]]) + ( ) + ( )]] + + [(.using ["[0]" ' "_" + ["[1]" ']]) + [("lux def module" [[ ]]) + ( )]] + + [(.using ["[0]" ' "_" + ["[1]" ' "_" + ["[2]" ']]]) + [("lux def module" [[ ]]) + ( )]] + + [(.using [' + ["[0]" ' + ["[0]" ']]]) + [("lux def module" [[ ] + [ ]]) + ( ) + ( )]] + + [(.using ["[0]" ' + [' + ["[0]" <\\>']]]) + [("lux def module" [[ ] + [ <\\>]]) + ( ) + ( )]] + + [(.using ["[0]" ' ("[1]#[0]" )]) + [("lux def module" [[ ]]) + ( ( ))]] + )))))) )))))) (/.type: for_type/variant @@ -1278,7 +1281,7 @@ (<| (_.covering /._) (`` (`` (_.in_parallel (list ..test|lux - + /abstract.test /control.test /data.test @@ -1288,7 +1291,7 @@ /locale.test /macro.test /math.test - + /meta.test /program.test /static.test diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index 63cb46691..4c923924b 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -9,8 +9,9 @@ ["[0]" ruby] ["[0]" php] ["[0]" scheme] - ["[0]" jvm - (~~ (.for ["JVM" (~~ (.as_is ["[0]" class] + ["[0]" jvm "_" + (~~ (.for ["JVM" (~~ (.as_is ["[1]" bytecode] + ["[0]" class] ["[0]" version] [encoding ["[0]" name]]))] @@ -113,9 +114,10 @@ (# ! each (|>> {synthesis.#Extension self}))))) (generation: (..generation self phase archive [pass_through .any]) - (for [@.jvm - (# phase.monad each (|>> {jvm.#Embedded} sequence.sequence) - (phase archive pass_through))] + (for [... @.jvm + ... (# phase.monad each (|>> {jvm.#Embedded} sequence.sequence) + ... (phase archive pass_through)) + ] (phase archive pass_through))) (analysis: (..dummy_generation self phase archive []) @@ -127,7 +129,8 @@ (generation: (..dummy_generation self phase archive []) (# phase.monad in (for [@.jvm - (sequence.sequence {jvm.#Constant {jvm.#LDC {jvm.#String self}}}) + (jvm.string self) + ... (sequence.sequence {jvm.#Constant {jvm.#LDC {jvm.#String self}}}) @.js (js.string self) @.python (python.unicode self) diff --git a/stdlib/source/test/lux/target/lua.lux b/stdlib/source/test/lux/target/lua.lux index 2558f41c8..0bee11310 100644 --- a/stdlib/source/test/lux/target/lua.lux +++ b/stdlib/source/test/lux/target/lua.lux @@ -584,6 +584,18 @@ (/.return $outcome))) (/.closure (list)) (/.apply (list))))) + (_.cover [/.error/2] + (expression (|>> (:as Frac) (f.= expected)) + (|> ($_ /.then + (/.let (list $verdict $outcome) (/.pcall/1 (/.closure (list) + ($_ /.then + (/.statement (/.error/2 (/.float expected) (/.int +2))) + (/.return (/.float dummy)))))) + (/.if $verdict + (/.return (/.float dummy)) + (/.return $outcome))) + (/.closure (list)) + (/.apply (list))))) ))) (def: test|function diff --git a/stdlib/source/test/lux/tool.lux b/stdlib/source/test/lux/tool.lux index 82e92e097..6fa62a7da 100644 --- a/stdlib/source/test/lux/tool.lux +++ b/stdlib/source/test/lux/tool.lux @@ -15,7 +15,8 @@ ["[1][0]" phase "_" ["[1]/[0]" extension] ["[1]/[0]" analysis "_" - ["[1]/[0]" simple]] + ["[1]/[0]" simple] + ["[1]/[0]" complex]] ... ["[1]/[0]" synthesis] ]]] ["[1][0]" meta "_" @@ -33,6 +34,7 @@ /meta/archive.test /phase/extension.test /phase/analysis/simple.test + /phase/analysis/complex.test ... /syntax.test ... /synthesis.test )) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux index 672a8f25a..1a5ece06a 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/analysis/inference.lux @@ -37,7 +37,7 @@ [phase ["[2][0]" analysis] ["[2][0]" extension - ["[1]/[0]"analysis "_" + ["[1]/[0]" analysis "_" ["[1]" lux]]]] [/// ["[2][0]" phase ("[1]#[0]" monad)] @@ -205,14 +205,14 @@ [type/0 term/0] ..simple_parameter [type/1 term/1] (random.only (|>> product.left (same? type/0) not) ..simple_parameter) - types/*,terms,* (random.list arity ..simple_parameter) + types/*,terms/* (random.list arity ..simple_parameter) tag (# ! each (n.% arity) random.nat) .let [[lefts right?] (//complex.choice arity tag)] arbitrary_right? random.bit] ($_ _.and (_.cover [/.variant] - (let [variantT (type.variant (list#each product.left types/*,terms,*)) - [tagT tagC] (|> types/*,terms,* + (let [variantT (type.variant (list#each product.left types/*,terms/*)) + [tagT tagC] (|> types/*,terms/* (list.item tag) (maybe.else [Any (' [])])) variant?' (: (-> Type (Maybe Type) Nat Bit Code Bit) @@ -295,7 +295,7 @@ existential_types_affect_dependent_cases! ))) (_.cover [/.not_a_variant] - (let [[tagT tagC] (|> types/*,terms,* + (let [[tagT tagC] (|> types/*,terms/* (list.item tag) (maybe.else [Any (' [])]))] (|> (/.variant lefts right? tagT) @@ -314,7 +314,7 @@ [type/0 term/0] ..simple_parameter [type/1 term/1] (random.only (|>> product.left (same? type/0) not) ..simple_parameter) - types/*,terms,* (random.list arity ..simple_parameter) + types/*,terms/* (random.list arity ..simple_parameter) .let [record? (: (-> Type (Maybe Type) Nat (List Code) Bit) (function (_ record expected arity terms) (|> (do /phase.monad @@ -335,8 +335,8 @@ (/phase#each product.right) (/phase.result state) (try.else false)))) - record (type.tuple (list#each product.left types/*,terms,*)) - terms (list#each product.right types/*,terms,*)]] + record (type.tuple (list#each product.left types/*,terms/*)) + terms (list#each product.right types/*,terms/*)]] ($_ _.and (_.cover [/.record] (let [can_infer_record! diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux new file mode 100644 index 000000000..89c341c2a --- /dev/null +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/complex.lux @@ -0,0 +1,650 @@ +(.using + [library + [lux "*" + ["_" test {"+" Test}] + [abstract + [monad {"+" do}]] + [control + [pipe {"+" case>}] + ["[0]" maybe ("[1]#[0]" functor)] + ["[0]" try {"+" Try} ("[1]#[0]" functor)] + ["[0]" exception {"+" Exception}]] + [data + ["[0]" product] + ["[0]" bit ("[1]#[0]" equivalence)] + ["[0]" text + ["%" format {"+" format}]] + [collection + ["[0]" list ("[1]#[0]" monad monoid)] + ["[0]" set]]] + [macro + ["[0]" code]] + [math + ["[0]" random {"+" Random} ("[1]#[0]" monad)] + [number + ["n" nat] + ["f" frac]]] + [meta + ["[0]" symbol + ["$[1]" \\test]]] + ["[0]" type ("[1]#[0]" equivalence) + ["[0]" check]]]] + [\\library + ["[0]" / + ["/[1]" // + [// + ["[1][0]" extension + ["[1]/[0]" analysis "_" + ["[1]" lux]]] + [// + ["[1][0]" analysis {"+" Analysis} + [evaluation {"+" Eval}] + ["[2][0]" macro] + ["[2][0]" type] + ["[2][0]" module] + ["[2][0]" complex]] + [/// + ["[1][0]" phase ("[1]#[0]" monad)] + [meta + ["[0]" archive]]]]]]]]) + +(def: (eval archive type term) + Eval + (//phase#in [])) + +(def: (expander macro inputs state) + //macro.Expander + {try.#Success ((.macro macro) inputs state)}) + +(def: random_state + (Random Lux) + (do random.monad + [version random.nat + host (random.ascii/lower 1)] + (in (//analysis.state (//analysis.info version host))))) + +(def: primitive + (Random Type) + (do random.monad + [name (random.ascii/lower 1)] + (in {.#Primitive name (list)}))) + +(def: analysis + //analysis.Phase + (//.phase ..expander)) + +(def: (failure? exception try) + (All (_ e a) (-> (Exception e) (Try a) Bit)) + (case try + {try.#Success _} + false + + {try.#Failure error} + (text.contains? (value@ exception.#label exception) error))) + +(def: simple_parameter + (Random [Type Code]) + (`` ($_ random.either + (~~ (template [ ] + [(random#each (|>> []) )] + + [.Bit random.bit code.bit] + [.Nat random.nat code.nat] + [.Int random.int code.int] + [.Rev random.rev code.rev] + [.Frac (random.only (|>> f.not_a_number? not) random.frac) code.frac] + [.Text (random.ascii/lower 1) code.text] + )) + ))) + +(def: (analysed? expected actual) + (-> Code Analysis Bit) + (case [expected actual] + (^ [[_ {.#Tuple (list)}] (//analysis.unit)]) + true + + (^ [[_ {.#Tuple expected}] (//analysis.tuple actual)]) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (analysed? expected actual)) + (list.zipped/2 expected actual))) + + (^template [ ] + [(^ [[_ { expected}] ( actual)]) + (same? expected actual)]) + ([.#Bit //analysis.bit] + [.#Nat //analysis.nat] + [.#Int //analysis.int] + [.#Rev //analysis.rev] + [.#Frac //analysis.frac] + [.#Text //analysis.text]) + + _ + false)) + +(def: test|sum + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + name ($symbol.random 1 1) + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + types/*,terms/* (random.list arity ..simple_parameter) + tag (# ! each (n.% arity) random.nat) + .let [[lefts right?] (//complex.choice arity tag) + [tagT tagC] (|> types/*,terms/* + (list.item tag) + (maybe.else [Any (' [])]))]] + ($_ _.and + (_.cover [/.sum] + (let [variantT (type.variant (list#each product.left types/*,terms/*)) + sum? (: (-> Type Nat Bit Code Bit) + (function (_ type lefts right? code) + (|> (do //phase.monad + [analysis (|> (/.sum ..analysis lefts right? archive.empty code) + (//type.expecting type))] + (in (case analysis + (^ (//analysis.variant [lefts' right?' analysis])) + (and (n.= lefts lefts') + (bit#= right? right?') + (..analysed? code analysis)) + + _ + false))) + (//module.with_module 0 (product.left name)) + (//phase#each product.right) + (//phase.result state) + (try.else false))))] + (and (sum? variantT lefts right? tagC) + (sum? {.#Named name variantT} lefts right? tagC) + (|> (do //phase.monad + [[@var varT] (//type.check check.var) + _ (//type.check (check.check varT variantT)) + analysis (|> (/.sum ..analysis lefts right? archive.empty tagC) + (//type.expecting varT))] + (in (case analysis + (^ (//analysis.variant [lefts' right?' it])) + (and (n.= lefts lefts') + (bit#= right? right?') + (..analysed? tagC it)) + + _ + false))) + (//module.with_module 0 (product.left name)) + (//phase#each product.right) + (//phase.result state) + (try.else false)) + (and (sum? (type (Maybe tagT)) 0 #0 (` [])) + (sum? (type (Maybe tagT)) 0 #1 tagC)) + (and (sum? (type (All (_ a) (Maybe a))) 0 #0 (` [])) + (not (sum? (type (All (_ a) (Maybe a))) 0 #1 tagC))) + (and (sum? (type (Ex (_ a) (Maybe a))) 0 #0 (` [])) + (sum? (type (Ex (_ a) (Maybe a))) 0 #1 tagC))))) + (_.for [/.cannot_analyse_variant] + (let [failure? (: (All (_ a) (-> (Exception a) (//analysis.Operation Any) Bit)) + (function (_ exception analysis) + (let [it (//phase.result state analysis)] + (and (..failure? /.cannot_analyse_variant it) + (..failure? exception it)))))] + ($_ _.and + (_.cover [/.invalid_variant_type] + (and (|> (/.sum ..analysis lefts right? archive.empty tagC) + (//type.expecting tagT) + (failure? /.invalid_variant_type)) + (|> (do //phase.monad + [[@var varT] (//type.check check.var)] + (|> (/.sum ..analysis lefts right? archive.empty tagC) + (//type.expecting (type (varT tagT))))) + (failure? /.invalid_variant_type)))) + (_.cover [/.cannot_infer_sum] + (|> (do //phase.monad + [[@var varT] (//type.check check.var)] + (|> (/.sum ..analysis lefts right? archive.empty tagC) + (//type.expecting varT))) + (failure? /.cannot_infer_sum))) + ))) + ))) + +(def: test|variant + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + name ($symbol.random 1 1) + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + types/*,terms/* (random.list arity ..simple_parameter) + tag (# ! each (n.% arity) random.nat) + .let [[lefts right?] (//complex.choice arity tag)] + tags (|> (random.ascii/lower 1) + (random.set text.hash arity) + (# ! each set.list)) + .let [module (product.left name) + sumT (type.variant (list#each product.left types/*,terms/*)) + variantT {.#Named name sumT} + [tagT tagC] (|> types/*,terms/* + (list.item tag) + (maybe.else [Any (' [])])) + tag (|> tags + (list.item tag) + (maybe.else ""))]] + ($_ _.and + ..test|sum + (_.cover [/.variant] + (let [expected_variant? (: (-> Symbol Bit) + (function (_ tag) + (|> (do //phase.monad + [_ (//module.declare_labels false tags false variantT) + analysis (|> (/.variant ..analysis tag archive.empty tagC) + (//type.expecting variantT))] + (in (case analysis + (^ (//analysis.variant [lefts' right?' analysis])) + (and (n.= lefts lefts') + (bit#= right? right?') + (..analysed? tagC analysis)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false)))) + inferred_variant? (: (-> Symbol Bit) + (function (_ tag) + (|> (do //phase.monad + [_ (//module.declare_labels false tags false variantT) + [actualT analysis] (|> (/.variant ..analysis tag archive.empty tagC) + //type.inferring)] + (in (case analysis + (^ (//analysis.variant [lefts' right?' analysis])) + (and (n.= lefts lefts') + (bit#= right? right?') + (..analysed? tagC analysis) + (type#= variantT actualT)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false))))] + (and (expected_variant? [module tag]) + (expected_variant? ["" tag]) + (inferred_variant? [module tag]) + (inferred_variant? ["" tag]) + + ... TODO: Test what happens when tags are shadowed by local bindings. + ))) + ))) + +(type: (Triple a) + [a a a]) + +(def: test|product + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + name ($symbol.random 1 1) + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + types/*,terms/* (random.list arity ..simple_parameter) + [type/0 term/0] ..simple_parameter + [type/1 term/1] ..simple_parameter + [type/2 term/2] ..simple_parameter + .let [module (product.left name) + productT (type.tuple (list#each product.left types/*,terms/*)) + expected (list#each product.right types/*,terms/*)]] + ($_ _.and + (_.cover [/.product] + (let [product? (: (-> Type (List Code) Bit) + (function (_ type expected) + (|> (do //phase.monad + [analysis (|> expected + (/.product ..analysis archive.empty) + (//type.expecting type))] + (in (case analysis + (^ (//analysis.tuple actual)) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (..analysed? expected actual)) + (list.zipped/2 expected actual))) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false))))] + (and (product? productT expected) + (product? {.#Named name productT} expected) + (product? (type (Ex (_ a) [a a])) (list term/0 term/0)) + (not (product? (type (All (_ a) [a a])) (list term/0 term/0))) + (product? (type (Triple type/0)) (list term/0 term/0 term/0)) + (|> (do //phase.monad + [[@var varT] (//type.check check.var) + _ (//type.check (check.check varT productT)) + analysis (|> expected + (/.product ..analysis archive.empty) + (//type.expecting varT))] + (in (case analysis + (^ (//analysis.tuple actual)) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (..analysed? expected actual)) + (list.zipped/2 expected actual))) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false)) + (|> (do //phase.monad + [[:inferred: analysis] (|> expected + (/.product ..analysis archive.empty) + //type.inferring)] + (in (case analysis + (^ (//analysis.tuple actual)) + (and (n.= (list.size expected) + (list.size actual)) + (list.every? (function (_ [expected actual]) + (..analysed? expected actual)) + (list.zipped/2 expected actual)) + (type#= productT :inferred:)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false)) + (|> (do [! //phase.monad] + [[@var varT] (//type.check check.var) + [:inferred: analysis] (//type.inferring + (do ! + [_ (//type.inference (Tuple type/0 type/1 varT))] + (/.product ..analysis archive.empty + (list term/0 term/1 term/2 term/2 term/2))))] + (in (case analysis + (^ (//analysis.tuple (list analysis/0 analysis/1 (//analysis.tuple (list analysis/2 analysis/3 analysis/4))))) + (and (type#= (Tuple type/0 type/1 type/2 type/2 type/2) + :inferred:) + (..analysed? term/0 analysis/0) + (..analysed? term/1 analysis/1) + (..analysed? term/2 analysis/2) + (..analysed? term/2 analysis/3) + (..analysed? term/2 analysis/4)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false)) + (|> (do [! //phase.monad] + [analysis (|> (list term/0 term/1 (code.tuple (list term/2 term/2 term/2))) + (/.product ..analysis archive.empty) + (//type.expecting (Tuple type/0 type/1 type/2 type/2 type/2)))] + (in (case analysis + (^ (//analysis.tuple (list analysis/0 analysis/1 (//analysis.tuple (list analysis/2 analysis/3 analysis/4))))) + (and (..analysed? term/0 analysis/0) + (..analysed? term/1 analysis/1) + (..analysed? term/2 analysis/2) + (..analysed? term/2 analysis/3) + (..analysed? term/2 analysis/4)) + + _ + false))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (try.else false))))) + (_.for [/.cannot_analyse_tuple] + (_.cover [/.invalid_tuple_type] + (let [failure? (: (All (_ a) (-> (Exception a) (//analysis.Operation Any) Bit)) + (function (_ exception operation) + (let [it (//phase.result state operation)] + (and (..failure? /.cannot_analyse_tuple it) + (..failure? exception it)))))] + (and (|> expected + (/.product ..analysis archive.empty) + (//type.expecting (|> types/*,terms/* + list.head + (maybe#each product.left) + (maybe.else .Any))) + (failure? /.invalid_tuple_type)) + (|> (do //phase.monad + [[@var varT] (//type.check check.var)] + (|> expected + (/.product ..analysis archive.empty) + (//type.expecting (type (varT type/0))))) + (failure? /.invalid_tuple_type)))))) + ))) + +(def: test|record + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + name ($symbol.random 1 1) + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + slice (# ! each (|>> (n.% (-- arity)) ++) random.nat) + [type/0 term/0] ..simple_parameter + slot/0 (random.ascii/lower 1) + types/*,terms/* (random.list arity ..simple_parameter) + slots/0 (|> (random.ascii/lower 1) + (random.set text.hash arity)) + slots/1 (|> (random.ascii/lower 1) + (random.only (|>> (set.member? slots/0) not)) + (random.set text.hash arity)) + .let [slots/0 (set.list slots/0) + slots/1 (set.list slots/1) + module (product.left name) + :record: {.#Named name (type.tuple (list#each product.left types/*,terms/*))} + tuple (list#each product.right types/*,terms/*) + local_record (|> tuple + (list.zipped/2 (list#each (|>> [""] code.symbol) slots/0)) + (list#each (function (_ [slot value]) + (list slot value))) + list#conjoint) + global_record (|> tuple + (list.zipped/2 (list#each (|>> [module] code.symbol) slots/0)) + (list#each (function (_ [slot value]) + (list slot value))) + list#conjoint) + expected_record (list.zipped/2 (list#each (|>> [module]) slots/0) + tuple) + head_slot/0 (|> slots/0 list.head maybe.trusted) + head_term/0 (|> types/*,terms/* list.head maybe.trusted product.right) + head_slot/1 (|> slots/1 list.head maybe.trusted) + slots/01 (case slots/1 + {.#Item _ tail} + {.#Item head_slot/0 tail} + + _ + slots/0)]] + ($_ _.and + (_.cover [/.normal] + (let [normal? (: (-> (List [Symbol Code]) (List Code) Bit) + (function (_ expected input) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (/.normal input)) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (case> {try.#Success {.#Some actual}} + (let [(^open "list#[0]") (list.equivalence (product.equivalence symbol.equivalence code.equivalence))] + (list#= expected (list.reversed actual))) + + _ + false))))] + (and (normal? (list) (list)) + (normal? expected_record global_record) + (normal? expected_record local_record) + (|> (/.normal tuple) + (//phase.result state) + (case> {try.#Success {.#None}} + true + + _ + false))))) + (_.cover [/.order] + (let [local_record (list.zipped/2 (list#each (|>> [""]) slots/0) tuple) + global_record (list.zipped/2 (list#each (|>> [module]) slots/0) tuple) + ordered? (: (-> Bit (List [Symbol Code]) Bit) + (function (_ pattern_matching? input) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (/.order pattern_matching? input)) + //analysis.with_scope + (//module.with_module 0 module) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (case> {try.#Success {.#Some [actual_arity actual_tuple actual_type]}} + (and (n.= arity actual_arity) + (# code.equivalence = (code.tuple tuple) (code.tuple actual_tuple)) + (type#= :record: actual_type)) + + _ + false)))) + unit? (: (-> Bit Bit) + (function (_ pattern_matching?) + (|> (/.order false (list)) + (//phase.result state) + (case> (^ {try.#Success {.#Some [0 (list) actual_type]}}) + (same? .Any actual_type) + + _ + false))))] + (and (ordered? false global_record) + (ordered? false (list.reversed global_record)) + (ordered? false local_record) + (ordered? false (list.reversed local_record)) + + (ordered? true global_record) + (ordered? true (list.reversed global_record)) + (not (ordered? true local_record)) + (not (ordered? true (list.reversed local_record))) + + (unit? false) + (unit? true) + + ... TODO: Test what happens when slots are shadowed by local bindings. + ))) + (_.cover [/.cannot_repeat_slot] + (let [repeated? (: (-> Bit Bit) + (function (_ pattern_matching?) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (/.order pattern_matching? (list.repeated arity [[module head_slot/0] head_term/0]))) + (//module.with_module 0 module) + (//phase#each product.right) + (//phase.result state) + (..failure? /.cannot_repeat_slot))))] + (and (repeated? false) + (repeated? true)))) + (_.cover [/.record_size_mismatch] + (let [local_record (list.zipped/2 (list#each (|>> [""]) slots/0) tuple) + global_record (list.zipped/2 (list#each (|>> [module]) slots/0) tuple) + mismatched? (: (-> Bit (List [Symbol Code]) Bit) + (function (_ pattern_matching? input) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (/.order pattern_matching? input)) + //analysis.with_scope + (//module.with_module 0 module) + (//phase.result state) + (..failure? /.record_size_mismatch))))] + (and (mismatched? false (list.first slice local_record)) + (mismatched? false (list#composite local_record (list.first slice local_record))) + + (mismatched? false (list.first slice global_record)) + (mismatched? true (list.first slice global_record)) + (mismatched? false (list#composite global_record (list.first slice global_record))) + (mismatched? true (list#composite global_record (list.first slice global_record)))))) + (_.cover [/.slot_does_not_belong_to_record] + (let [local_record (list.zipped/2 (list#each (|>> [""]) slots/01) tuple) + global_record (list.zipped/2 (list#each (|>> [module]) slots/01) tuple) + mismatched? (: (-> Bit (List [Symbol Code]) Bit) + (function (_ pattern_matching? input) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:) + _ (//module.declare_labels true slots/1 false :record:)] + (/.order pattern_matching? input)) + //analysis.with_scope + (//module.with_module 0 module) + (//phase.result state) + (..failure? /.slot_does_not_belong_to_record))))] + (and (mismatched? false local_record) + + (mismatched? false global_record) + (mismatched? true global_record)))) + (_.cover [/.record] + (let [record? (: (-> Type (List Text) (List Code) Code Bit) + (function (_ type slots tuple expected) + (|> (do //phase.monad + [_ (//module.declare_labels true slots false type)] + (/.record ..analysis archive.empty tuple)) + (//type.expecting type) + //analysis.with_scope + (//module.with_module 0 module) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try#each (analysed? expected)) + (try.else false)))) + inferred? (: (-> (List Code) Bit) + (function (_ record) + (|> (do //phase.monad + [_ (//module.declare_labels true slots/0 false :record:)] + (//type.inferring + (/.record ..analysis archive.empty record))) + //analysis.with_scope + (//module.with_module 0 module) + (//phase#each (|>> product.right product.right)) + (//phase.result state) + (try#each (function (_ [actual_type actual_term]) + (and (same? :record: actual_type) + (analysed? (code.tuple tuple) actual_term)))) + (try.else false))))] + (and (record? {.#Named name .Any} (list) (list) (' [])) + (record? {.#Named name type/0} (list) (list term/0) term/0) + (record? {.#Named name type/0} (list slot/0) (list term/0) term/0) + (record? :record: slots/0 tuple (code.tuple tuple)) + (record? :record: slots/0 local_record (code.tuple tuple)) + (record? :record: slots/0 global_record (code.tuple tuple)) + (inferred? local_record) + (inferred? global_record)))) + ))) + +(def: .public test + (<| (_.covering /._) + (do [! random.monad] + [lux ..random_state + .let [state [//extension.#bundle (//extension/analysis.bundle ..eval) + //extension.#state lux]] + arity (# ! each (|>> (n.% 5) (n.+ 2)) random.nat) + types/*,terms/* (random.list arity ..simple_parameter) + [type/0 term/0] ..simple_parameter + [type/1 term/1] ..simple_parameter + tag (# ! each (n.% arity) random.nat) + .let [[lefts right?] (//complex.choice arity tag)]] + ($_ _.and + ..test|sum + ..test|variant + ..test|product + ..test|record + (_.cover [/.not_a_quantified_type] + (and (|> (/.sum ..analysis lefts right? archive.empty term/0) + (//type.expecting (type (type/0 type/1))) + (//phase.result state) + (..failure? /.not_a_quantified_type)) + (|> types/*,terms/* + (list#each product.right) + (/.product ..analysis archive.empty) + (//type.expecting (type (type/0 type/1))) + (//phase.result state) + (..failure? /.not_a_quantified_type)))) + )))) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux deleted file mode 100644 index 7521d7878..000000000 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ /dev/null @@ -1,311 +0,0 @@ -(.using - [lux "*" - [abstract - ["[0]" monad {"+" do}]] - [data - ["%" text/format {"+" format}]] - ["r" math/random {"+" Random}] - ["_" test {"+" Test}] - [control - pipe - ["[0]" maybe] - ["[0]" try]] - [data - ["[0]" bit ("[1]#[0]" equivalence)] - ["[0]" product] - ["[0]" text] - [number - ["n" nat]] - [collection - ["[0]" list ("[1]#[0]" functor)] - ["[0]" set]]] - ["[0]" type - ["[0]" check]] - [macro - ["[0]" code]] - [meta - ["[0]" symbol]]] - [// - ["_[0]" primitive]] - [\\ - ["[0]" / - ["/[1]" // - ["[1][0]" module] - ["[1][0]" type] - ["/[1]" // "_" - ["/[1]" // - ["[1][0]" analysis {"+" Analysis Variant Tag Operation}] - [/// - ["[0]" phase] - [meta - ["[0]" archive]]]]]]]]) - -(template [ ] - [(def: .public - (All (_ a) (-> (Operation a) Bit)) - (|>> (phase.result _primitive.state) - (case> {try.#Success _} - - - _ - )))] - - [check_succeeds true false] - [check_fails false true] - ) - -(def: (check_sum' tag size variant) - (-> Tag Nat (Variant Analysis) Bit) - (let [expected//right? (n.= (-- size) tag) - expected//lefts (if expected//right? - (-- tag) - tag) - actual//right? (value@ ////analysis.#right? variant) - actual//lefts (value@ ////analysis.#lefts variant)] - (and (n.= expected//lefts - actual//lefts) - (bit#= expected//right? - actual//right?)))) - -(def: (check_sum type tag size analysis) - (-> Type Tag Nat (Operation Analysis) Bit) - (|> analysis - (//type.with_type type) - (phase.result _primitive.state) - (case> (^ {try.#Success (////analysis.variant variant)}) - (check_sum' tag size variant) - - _ - false))) - -(def: (with_tags module tags type) - (All (_ a) (-> Text (List //module.Tag) Type (Operation a) (Operation [Module a]))) - (|>> (do phase.monad - [_ (//module.declare_tags tags false type)]) - (//module.with_module 0 module))) - -(def: (check_variant module tags expectedT variantT tag analysis) - (-> Text (List //module.Tag) Type Type Tag (Operation Analysis) Bit) - (|> analysis - (with_tags module tags variantT) - (//type.with_type expectedT) - (phase.result _primitive.state) - (case> (^ {try.#Success [_ (////analysis.variant variant)]}) - (check_sum' tag (list.size tags) variant) - - _ - false))) - -(def: (correct_size? size) - (-> Nat (-> Analysis Bit)) - (|>> (case> (^ (////analysis.tuple elems)) - (|> elems - list.size - (n.= size)) - - _ - false))) - -(def: (check_record module tags expectedT recordT size analysis) - (-> Text (List //module.Tag) Type Type Nat (Operation Analysis) Bit) - (|> analysis - (with_tags module tags recordT) - (//type.with_type expectedT) - (phase.result _primitive.state) - (case> {try.#Success [_ productA]} - (correct_size? size productA) - - _ - false))) - -(def: sum - (do [! r.monad] - [size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - choice (|> r.nat (# ! each (n.% size))) - primitives (r.list size _primitive.primitive) - +choice (|> r.nat (# ! each (n.% (++ size)))) - [_ +valueC] _primitive.primitive - .let [variantT (type.variant (list#each product.left primitives)) - [valueT valueC] (maybe.trusted (list.item choice primitives)) - +size (++ size) - +primitives (list.together (list (list.first choice primitives) - (list [{.#Parameter 1} +valueC]) - (list.after choice primitives))) - [+valueT +valueC] (maybe.trusted (list.item +choice +primitives)) - +variantT (type.variant (list#each product.left +primitives))]] - (<| (_.context (%.symbol (symbol /.sum))) - ($_ _.and - (_.test "Can analyse." - (check_sum variantT choice size - (/.sum _primitive.phase choice archive.empty valueC))) - (_.test "Can analyse through bound type-vars." - (|> (do phase.monad - [[_ varT] (//type.with_env check.var) - _ (//type.with_env - (check.check varT variantT))] - (//type.with_type varT - (/.sum _primitive.phase choice archive.empty valueC))) - (phase.result _primitive.state) - (case> (^ {try.#Success (////analysis.variant variant)}) - (check_sum' choice size variant) - - _ - false))) - (_.test "Cannot analyse through unbound type-vars." - (|> (do phase.monad - [[_ varT] (//type.with_env check.var)] - (//type.with_type varT - (/.sum _primitive.phase choice archive.empty valueC))) - check_fails)) - (_.test "Can analyse through existential quantification." - (|> (//type.with_type (type.ex_q 1 +variantT) - (/.sum _primitive.phase +choice archive.empty +valueC)) - check_succeeds)) - (_.test "Can analyse through universal quantification." - (let [check_outcome (if (not (n.= choice +choice)) - check_succeeds - check_fails)] - (|> (//type.with_type (type.univ_q 1 +variantT) - (/.sum _primitive.phase +choice archive.empty +valueC)) - check_outcome))) - )))) - -(def: product - (do [! r.monad] - [size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - primitives (r.list size _primitive.primitive) - choice (|> r.nat (# ! each (n.% size))) - [_ +valueC] _primitive.primitive - .let [tupleT (type.tuple (list#each product.left primitives)) - [singletonT singletonC] (|> primitives (list.item choice) maybe.trusted) - +primitives (list.together (list (list.first choice primitives) - (list [{.#Parameter 1} +valueC]) - (list.after choice primitives))) - +tupleT (type.tuple (list#each product.left +primitives))]] - (<| (_.context (%.symbol (symbol /.product))) - ($_ _.and - (_.test "Can analyse." - (|> (//type.with_type tupleT - (/.product archive.empty _primitive.phase (list#each product.right primitives))) - (phase.result _primitive.state) - (case> {try.#Success tupleA} - (correct_size? size tupleA) - - _ - false))) - (_.test "Can infer." - (|> (//type.with_inference - (/.product archive.empty _primitive.phase (list#each product.right primitives))) - (phase.result _primitive.state) - (case> {try.#Success [_type tupleA]} - (and (check.subsumes? tupleT _type) - (correct_size? size tupleA)) - - _ - false))) - (_.test "Can analyse singleton." - (|> (//type.with_type singletonT - (_primitive.phase archive.empty (` [(~ singletonC)]))) - check_succeeds)) - (_.test "Can analyse through bound type-vars." - (|> (do phase.monad - [[_ varT] (//type.with_env check.var) - _ (//type.with_env - (check.check varT (type.tuple (list#each product.left primitives))))] - (//type.with_type varT - (/.product archive.empty _primitive.phase (list#each product.right primitives)))) - (phase.result _primitive.state) - (case> {try.#Success tupleA} - (correct_size? size tupleA) - - _ - false))) - (_.test "Can analyse through existential quantification." - (|> (//type.with_type (type.ex_q 1 +tupleT) - (/.product archive.empty _primitive.phase (list#each product.right +primitives))) - check_succeeds)) - (_.test "Cannot analyse through universal quantification." - (|> (//type.with_type (type.univ_q 1 +tupleT) - (/.product archive.empty _primitive.phase (list#each product.right +primitives))) - check_fails)) - )))) - -(def: variant - (do [! r.monad] - [size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - tags (|> (r.set text.hash size (r.unicode 5)) (# ! each set.list)) - choice (|> r.nat (# ! each (n.% size))) - other_choice (|> r.nat (# ! each (n.% size)) (r.only (|>> (n.= choice) not))) - primitives (r.list size _primitive.primitive) - module_name (r.unicode 5) - type_name (r.unicode 5) - .let [with_name (|>> {.#Named [module_name type_name]}) - varT {.#Parameter 1} - primitivesT (list#each product.left primitives) - [choiceT choiceC] (maybe.trusted (list.item choice primitives)) - [other_choiceT other_choiceC] (maybe.trusted (list.item other_choice primitives)) - monoT (type.variant primitivesT) - polyT (|> (type.variant (list.together (list (list.first choice primitivesT) - (list varT) - (list.after (++ choice) primitivesT)))) - (type.univ_q 1)) - choice_tag (maybe.trusted (list.item choice tags)) - other_choice_tag (maybe.trusted (list.item other_choice tags))]] - (<| (_.context (%.symbol (symbol /.tagged_sum))) - ($_ _.and - (_.test "Can infer." - (|> (/.tagged_sum _primitive.phase [module_name choice_tag] archive.empty choiceC) - (check_variant module_name tags - monoT (with_name monoT) - choice))) - (_.test "Inference retains universal quantification when type-vars are not bound." - (|> (/.tagged_sum _primitive.phase [module_name other_choice_tag] archive.empty other_choiceC) - (check_variant module_name tags - polyT (with_name polyT) - other_choice))) - (_.test "Can specialize." - (|> (//type.with_type monoT - (/.tagged_sum _primitive.phase [module_name other_choice_tag] archive.empty other_choiceC)) - (check_variant module_name tags - monoT (with_name polyT) - other_choice))) - (_.test "Specialization when type-vars get bound." - (|> (/.tagged_sum _primitive.phase [module_name choice_tag] archive.empty choiceC) - (check_variant module_name tags - monoT (with_name polyT) - choice))) - )))) - -(def: record - (do [! r.monad] - [size (|> r.nat (# ! each (|>> (n.% 10) (n.max 2)))) - tags (|> (r.set text.hash size (r.unicode 5)) (# ! each set.list)) - primitives (r.list size _primitive.primitive) - module_name (r.unicode 5) - type_name (r.unicode 5) - choice (|> r.nat (# ! each (n.% size))) - .let [varT {.#Parameter 1} - tagsC (list#each (|>> [module_name] code.tag) tags) - primitivesT (list#each product.left primitives) - primitivesC (list#each product.right primitives) - monoT {.#Named [module_name type_name] (type.tuple primitivesT)} - recordC (list.zipped/2 tagsC primitivesC) - polyT (|> (type.tuple (list.together (list (list.first choice primitivesT) - (list varT) - (list.after (++ choice) primitivesT)))) - (type.univ_q 1) - {.#Named [module_name type_name]})]] - (<| (_.context (%.symbol (symbol /.record))) - (_.test "Can infer." - (|> (/.record archive.empty _primitive.phase recordC) - (check_record module_name tags monoT monoT size)))))) - -(def: .public test - Test - (<| (_.context (symbol.module (symbol /._))) - ($_ _.and - ..sum - ..product - ..variant - ..record - ))) -- cgit v1.2.3