diff options
27 files changed, 1629 insertions, 1261 deletions
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 [<tag> <inst>] - [{<tag> class field_name field_type} - (<inst> 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 [<tag> <inst>] +... [{<tag> class field_name field_type} +... (<inst> 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 [<tag> <inst>] - [{<tag> class method_name method_type} - (<inst> 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 [<tag> <inst>] +... [{<tag> class method_name method_type} +... (<inst> 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 [<tag>] - [{<tag> label} - (let [[mapping label] (..relabel [mapping label])] - [mapping {<tag> 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 [<tag>] +... [{<tag> label} +... (let [[mapping label] (..relabel [mapping label])] +... [mapping {<tag> 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 [<tag> <relabel>] - [{<tag> instruction} - (let [[mapping instruction] (<relabel> [mapping instruction])] - [mapping {<tag> instruction}])]) - ([/.#GOTO ..relabel] - [/.#Branching ..relabel_branching] - [/.#Exception ..relabel_exception]) - - (^template [<tag>] - [{<tag> instruction} - [mapping {<tag> instruction}]]) - ([/.#Concurrency] [/.#Return]) - )) - -(def: (relabel_instruction [mapping instruction]) - (Re_labeler (/.Instruction Inst)) - (case instruction - {/.#Embedded embedded} - [mapping {/.#Embedded embedded}] - - {/.#NOP} - [mapping {/.#NOP}] - - (^template [<tag>] - [{<tag> instruction} - [mapping {<tag> instruction}]]) - ([/.#Constant] - [/.#Arithmetic] - [/.#Bitwise] - [/.#Conversion] - [/.#Array] - [/.#Object] - [/.#Local] - [/.#Stack] - [/.#Comparison]) +... {/.#ATHROW} +... [mapping {/.#ATHROW}] +... )) + +... (def: (relabel_control [mapping instruction]) +... (Re_labeler /.Control) +... (case instruction +... (^template [<tag> <relabel>] +... [{<tag> instruction} +... (let [[mapping instruction] (<relabel> [mapping instruction])] +... [mapping {<tag> instruction}])]) +... ([/.#GOTO ..relabel] +... [/.#Branching ..relabel_branching] +... [/.#Exception ..relabel_exception]) + +... (^template [<tag>] +... [{<tag> instruction} +... [mapping {<tag> instruction}]]) +... ([/.#Concurrency] [/.#Return]) +... )) + +... (def: (relabel_instruction [mapping instruction]) +... (Re_labeler (/.Instruction Inst)) +... (case instruction +... {/.#Embedded embedded} +... [mapping {/.#Embedded embedded}] + +... {/.#NOP} +... [mapping {/.#NOP}] + +... (^template [<tag>] +... [{<tag> instruction} +... [mapping {<tag> 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 [<anchor> (as_is jvm.Anchor) - <expression> (as_is Inst) - <directive> (as_is jvm.Definition) - <type_vars> (as_is <anchor> <expression> <directive>)] - (type: Handler' - ... (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) - (-> extension.Name - (phase.Phase [(extension.Bundle <type_vars>) - (generation.State <type_vars>)] - Synthesis - <expression>) - (phase.Phase [(extension.Bundle <type_vars>) - (generation.State <type_vars>)] - (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 [<anchor> (as_is jvm.Anchor) +... <expression> (as_is Inst) +... <directive> (as_is jvm.Definition) +... <type_vars> (as_is <anchor> <expression> <directive>)] +... (type: Handler' +... ... (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) +... (-> extension.Name +... (phase.Phase [(extension.Bundle <type_vars>) +... (generation.State <type_vars>)] +... Synthesis +... <expression>) +... (phase.Phase [(extension.Bundle <type_vars>) +... (generation.State <type_vars>)] +... (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 [<bytes> <name> <size> <constructor> <maximum> <+> <->] + (template [<bytes> <name> <size> <constructor> <maximum> <minimum> <+> <->] [(with_expansions [<raw> (template.symbol [<name> "'"])] (abstract: <raw> Any) (type: .public <name> (Signed <raw>))) @@ -57,6 +57,11 @@ (def: .public <maximum> <name> (|> <bytes> (n.* i64.bits_per_byte) -- i64.mask :abstraction)) + + (def: .public <minimum> + <name> + (let [it (:representation <maximum>)] + (:abstraction (-- (i.- it +0))))) (def: .public <constructor> (-> Int (Try <name>)) @@ -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 [<name> <from> <to>] 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/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux index cdf65a6ad..678a626da 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/complex.lux @@ -35,10 +35,14 @@ ["[1][0]" type] ["[1][0]" inference]] [/// - ["[1]" phase] + ["[1]" phase ("[1]#[0]" monad)] [meta [archive {"+" Archive}]]]]]]) +(exception: .public (not_a_quantified_type [type Type]) + (exception.report + ["Type" (%.type type)])) + (template [<name>] [(exception: .public (<name> [type Type members (List Code)]) @@ -50,36 +54,30 @@ [cannot_analyse_tuple] ) -(exception: .public (not_a_quantified_type [type Type]) - (exception.report - ["Type" (%.type type)])) - (template [<name>] [(exception: .public (<name> [type Type - tag Tag + lefts Nat + right? Bit code Code]) (exception.report ["Type" (%.type type)] - ["Tag" (%.nat tag)] + ["Lefts" (%.nat lefts)] + ["Right?" (%.bit right?)] ["Expression" (%.code code)]))] [invalid_variant_type] [cannot_analyse_variant] - [cannot_infer_numeric_tag] + [cannot_infer_sum] ) -(template [<name>] - [(exception: .public (<name> [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 (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]) @@ -108,7 +106,7 @@ (do [! ///.monad] [expectedT (///extension.lifted meta.expected_type) expectedT' (/type.check (check.clean expectedT))] - (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC] + (/.with_stack ..cannot_analyse_variant [expectedT' lefts right? valueC] (case expectedT {.#Sum _} (|> (analyse archive valueC) @@ -134,13 +132,13 @@ ... 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]))) + (/.except ..cannot_infer_sum [expectedT lefts right? valueC]))) (^template [<tag> <instancer>] [{<tag> _} (do ! - [[instance_id instanceT] (/type.check <instancer>)] - (<| (/type.expecting (maybe.trusted (type.applied (list instanceT) expectedT))) + [[@instance :instance:] (/type.check <instancer>)] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) (again valueC)))]) ([.#UnivQ check.existential] [.#ExQ check.var]) @@ -156,7 +154,7 @@ (again valueC)) _ - (/.except ..invalid_variant_type [expectedT tag valueC]))) + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))) _ (case (type.applied (list inputT) funT) @@ -165,56 +163,72 @@ (again valueC)) {.#None} - (/.except ..not_a_quantified_type funT))) + (/.except ..not_a_quantified_type [funT]))) _ - (/.except ..invalid_variant_type [expectedT tag valueC]))))))) + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))))))) -(def: (typed_product archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) +(def: .public (variant analyse tag archive valueC) + (-> Phase Symbol Phase) (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)) + [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 archive analyse membersC) + (..typed_product analyse expectedT archive membersC) {.#Named name unnamedT} (<| (/type.expecting unnamedT) - (product archive analyse membersC)) + (product analyse archive membersC)) {.#Var id} (do ! @@ -222,10 +236,10 @@ (case ?expectedT' {.#Some expectedT'} (<| (/type.expecting expectedT') - (product archive analyse membersC)) + (product analyse archive membersC)) _ - ... Must do inference... + ... Must infer... (do ! [membersTA (monad.each ! (|>> (analyse archive) /type.inferring) membersC) @@ -236,9 +250,9 @@ (^template [<tag> <instancer>] [{<tag> _} (do ! - [[instance_id instanceT] (/type.check <instancer>)] - (<| (/type.expecting (maybe.trusted (type.applied (list instanceT) expectedT))) - (product archive analyse membersC)))]) + [[@instance :instance:] (/type.check <instancer>)] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (product analyse archive membersC)))]) ([.#UnivQ check.existential] [.#ExQ check.var]) @@ -250,7 +264,7 @@ (case ?funT' {.#Some funT'} (<| (/type.expecting {.#Apply inputT funT'}) - (product archive analyse membersC)) + (product analyse archive membersC)) _ (/.except ..invalid_tuple_type [expectedT membersC]))) @@ -259,7 +273,7 @@ (case (type.applied (list inputT) funT) {.#Some outputT} (<| (/type.expecting outputT) - (product archive analyse membersC)) + (product analyse archive membersC)) {.#None} (/.except ..not_a_quantified_type funT))) @@ -268,24 +282,6 @@ (/.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 @@ -302,10 +298,10 @@ (again tail {.#Item [slotH valueH] output})) {.#End} - (# ///.monad in {.#Some output}) + (///#in {.#Some output}) _ - (# ///.monad in {.#None})))) + (///#in {.#None})))) (def: (local_binding? name) (-> Text (Meta Bit)) @@ -361,25 +357,25 @@ (case record ... empty_record = empty_tuple = unit/any = [] {.#End} - (# ///.monad in {.#Some [0 (list) Any]}) + (///#in {.#Some [0 (list) .Any]}) {.#Item [head_k head_v] _} (case head_k ["" head_k'] (if pattern_matching? - (# ///.monad in {.#None}) + (///#in {.#None}) (do ///.monad [local_binding? (///extension.lifted - (local_binding? head_k'))] + (..local_binding? head_k'))] (if local_binding? - (order' head_k record) - (in {.#None})))) + (in {.#None}) + (order' head_k record)))) _ (order' head_k record)))) -(def: .public (record archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) +(def: .public (record analyse archive members) + (-> Phase Archive (List Code) (Operation Analysis)) (case members (^ (list)) //simple.unit @@ -395,24 +391,24 @@ {try.#Success [_ slot_set recordT]} (case (list.size slot_set) 1 (analyse archive singletonC) - _ (..product archive analyse members)) + _ (..product analyse archive members)) _ - (..product archive analyse members))) + (..product analyse archive members))) _ (do [! ///.monad] [?members (normal members)] (case ?members {.#None} - (..product archive analyse members) + (..product analyse archive members) {.#Some slots} (do ! [record_size,membersC,recordT (..order false slots)] (case record_size,membersC,recordT {.#None} - (..product archive analyse members) + (..product analyse archive members) {.#Some [record_size membersC recordT]} (do ! @@ -425,4 +421,4 @@ (in (/.tuple membersA))) _ - (..product archive analyse membersC))))))))) + (..product analyse archive 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 @@ [<code>.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 @@ [<code>.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 <code>.any <code>.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 <code>.any <code>.any <code>.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 <code>.any <code>.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 <code>.text <code>.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 <code>.text <code>.any (<>.some <code>.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 @@ [<code>.any (function (_ extension phase archive inputC) (do [! phase.monad] - [inputA (analysis/type.with_type (type <fromT>) - (phase archive inputC)) - _ (analysis/type.infer (type <toT>))] + [inputA (analysis/type.expecting (type <fromT>) + (phase archive inputC)) + _ (analysis/type.inference (type <toT>))] (in {analysis.#Extension extension (list inputA)})))]))] [utf8::encode Text (array.Array (I64 Any))] @@ -185,7 +183,7 @@ [<code>.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 <code>.any (<>.some <code>.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 <code>.any <code>.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 @@ [<code>.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 [<name> <base>] [(type: .public <name> @@ -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 [<referral> ("lux in-module" "library/lux" library/lux.refer) - <alias> (static.random code.text (random.ascii/lower 1)) - <definition> (static.random code.local_symbol (random.ascii/lower 1)) - <module/0> (static.random code.text (random.ascii/lower 2)) - <module/0>' (template.symbol [<module/0>]) - <module/1> (static.random code.text (random.ascii/lower 3)) - <module/1>' (template.symbol [<module/1>]) - <module/2> (static.random code.text (random.ascii/lower 4)) - <module/2>' (template.symbol [<module/2>]) - <m0/1> (template.text [<module/0> "/" <module/1>]) - <//> (template.text [// <module/2>']) - <//>' (template.symbol [<//>]) - <\\> (template.text [\\ <module/2>']) - <\\>' (template.symbol [<\\>]) - <m0/2> (template.text [<module/0> "/" <module/2>]) - <m2/1> (template.text [<module/2> "/" <module/1>]) - <m0/1/2> (template.text [<module/0> "/" <module/1> "/" <module/2>]) - <open/0> (template.text [<module/0> "#[0]"])] - (and (~~ (template [<input> <pattern>] - [(with_expansions [<input>' (macro.final <input>)] - (case (' [<input>']) - (^code <pattern>) - true - - _ - false))] - - [(.using [<module/0>']) - [("lux def module" [])]] - - [(.using [<alias> <module/0>' "*"]) - [("lux def module" [[<module/0> <alias>]]) - (<referral> <module/0> "*")]] - - [(.using [<alias> <module/0>' {"+" <definition>}]) - [("lux def module" [[<module/0> <alias>]]) - (<referral> <module/0> {"+" <definition>})]] - - [(.using [<alias> <module/0>' {"-" <definition>}]) - [("lux def module" [[<module/0> <alias>]]) - (<referral> <module/0> {"-" <definition>})]] - - [(.using [<alias> <module/0>' "_"]) - [("lux def module" [])]] - - [(.using [<module/0>' - [<alias> <module/1>']]) - [("lux def module" [[<m0/1> <alias>]]) - (<referral> <m0/1>)]] - - [(.using ["[0]" <module/0>' - ["[0]" <module/1>']]) - [("lux def module" [[<module/0> <module/0>] - [<m0/1> <module/1>]]) - (<referral> <module/0>) - (<referral> <m0/1>)]] - - [(.using ["[0]" <module/0>' "_" - ["[1]" <module/1>']]) - [("lux def module" [[<m0/1> <module/0>]]) - (<referral> <m0/1>)]] - - [(.using ["[0]" <module/0>' "_" - ["[1]" <module/1>' "_" - ["[2]" <module/2>']]]) - [("lux def module" [[<m0/1/2> <module/0>]]) - (<referral> <m0/1/2>)]] - - [(.using [<module/0>' - ["[0]" <module/1>' - ["[0]" <//>']]]) - [("lux def module" [[<m0/1> <module/1>] - [<m0/2> <//>]]) - (<referral> <m0/1>) - (<referral> <m0/2>)]] - - [(.using ["[0]" <module/0>' - [<module/1>' - ["[0]" <\\>']]]) - [("lux def module" [[<module/0> <module/0>] - [<m2/1> <\\>]]) - (<referral> <module/0>) - (<referral> <m2/1>)]] - - [(.using ["[0]" <module/0>' ("[1]#[0]" <definition>)]) - [("lux def module" [[<module/0> <module/0>]]) - (<referral> <module/0> (<open/0> <definition>))]] - ))))) + (`` (with_expansions [<referral> ("lux in-module" "library/lux" library/lux.refer) + <alias> (static.random code.text (random.ascii/lower 1)) + <definition> (static.random code.local_symbol (random.ascii/lower 1)) + <module/0> (static.random code.text (random.ascii/lower 2)) + <module/0>' (template.symbol [<module/0>]) + <module/1> (static.random code.text (random.ascii/lower 3)) + <module/1>' (template.symbol [<module/1>]) + <module/2> (static.random code.text (random.ascii/lower 4)) + <module/2>' (template.symbol [<module/2>]) + <m0/1> (template.text [<module/0> "/" <module/1>]) + <//> (template.text [// <module/2>']) + <//>' (template.symbol [<//>]) + <\\> (template.text [\\ <module/2>']) + <\\>' (template.symbol [<\\>]) + <m0/2> (template.text [<module/0> "/" <module/2>]) + <m2/1> (template.text [<module/2> "/" <module/1>]) + <m0/1/2> (template.text [<module/0> "/" <module/1> "/" <module/2>]) + <open/0> (template.text [<module/0> "#[0]"])] + (and (~~ (template [<input> <pattern>] + [(with_expansions [<input>' (macro.final <input>)] + (let [scenario (: (-> Any Bit) + (function (_ _) + (case (' [<input>']) + (^code <pattern>) + true + + _ + false)))] + (scenario [])))] + + [(.using [<module/0>']) + [("lux def module" [])]] + + [(.using [<alias> <module/0>' "*"]) + [("lux def module" [[<module/0> <alias>]]) + (<referral> <module/0> "*")]] + + [(.using [<alias> <module/0>' {"+" <definition>}]) + [("lux def module" [[<module/0> <alias>]]) + (<referral> <module/0> {"+" <definition>})]] + + [(.using [<alias> <module/0>' {"-" <definition>}]) + [("lux def module" [[<module/0> <alias>]]) + (<referral> <module/0> {"-" <definition>})]] + + [(.using [<alias> <module/0>' "_"]) + [("lux def module" [])]] + + [(.using [<module/0>' + [<alias> <module/1>']]) + [("lux def module" [[<m0/1> <alias>]]) + (<referral> <m0/1>)]] + + [(.using ["[0]" <module/0>' + ["[0]" <module/1>']]) + [("lux def module" [[<module/0> <module/0>] + [<m0/1> <module/1>]]) + (<referral> <module/0>) + (<referral> <m0/1>)]] + + [(.using ["[0]" <module/0>' "_" + ["[1]" <module/1>']]) + [("lux def module" [[<m0/1> <module/0>]]) + (<referral> <m0/1>)]] + + [(.using ["[0]" <module/0>' "_" + ["[1]" <module/1>' "_" + ["[2]" <module/2>']]]) + [("lux def module" [[<m0/1/2> <module/0>]]) + (<referral> <m0/1/2>)]] + + [(.using [<module/0>' + ["[0]" <module/1>' + ["[0]" <//>']]]) + [("lux def module" [[<m0/1> <module/1>] + [<m0/2> <//>]]) + (<referral> <m0/1>) + (<referral> <m0/2>)]] + + [(.using ["[0]" <module/0>' + [<module/1>' + ["[0]" <\\>']]]) + [("lux def module" [[<module/0> <module/0>] + [<m2/1> <\\>]]) + (<referral> <module/0>) + (<referral> <m2/1>)]] + + [(.using ["[0]" <module/0>' ("[1]#[0]" <definition>)]) + [("lux def module" [[<module/0> <module/0>]]) + (<referral> <module/0> (<open/0> <definition>))]] + )))))) )))))) (/.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 <synthesis>.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 [<type> <random> <code>] + [(random#each (|>> <code> [<type>]) <random>)] + + [.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>] + [(^ [[_ {<expected> expected}] (<actual> 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 [<name> <on_success> <on_error>] - [(def: .public <name> - (All (_ a) (-> (Operation a) Bit)) - (|>> (phase.result _primitive.state) - (case> {try.#Success _} - <on_success> - - _ - <on_error>)))] - - [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 - ))) |