diff options
Diffstat (limited to 'new-luxc')
| -rw-r--r-- | new-luxc/source/luxc/generator/case.jvm.lux | 214 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm/inst.lux | 49 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/runtime.jvm.lux | 177 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/structure.jvm.lux | 2 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/analyser/case.lux | 22 | ||||
| -rw-r--r-- | new-luxc/test/test/luxc/generator/case.lux | 102 | ||||
| -rw-r--r-- | new-luxc/test/tests.lux | 1 |
7 files changed, 525 insertions, 42 deletions
diff --git a/new-luxc/source/luxc/generator/case.jvm.lux b/new-luxc/source/luxc/generator/case.jvm.lux new file mode 100644 index 000000000..1f351325e --- /dev/null +++ b/new-luxc/source/luxc/generator/case.jvm.lux @@ -0,0 +1,214 @@ +(;module: + lux + (lux (control [monad #+ do]) + [macro "lux/" Monad<Lux>]) + (luxc (lang ["ls" synthesis]) + (generator (host ["$" jvm] + (jvm ["$t" type] + ["$i" inst])) + [expr])) + [../runtime]) + +(def: $Object $;Type ($t;class "java.lang.Object" (list))) + +(def: (pop-altI stack-depth) + (-> Nat $;Inst) + (case stack-depth + +0 id + +1 $i;POP + +2 $i;POP2 + _ ## (n.> +2) + (|>. $i;POP2 + (pop-altI (n.- +2 stack-depth))))) + +(def: peekI + $;Inst + (|>. $i;DUP + ($i;INVOKESTATIC ../runtime;runtime-name + "pm_peek" + ($t;method (list ../runtime;$Stack) + (#;Some $Object) + (list)) + false))) + +(def: popI + $;Inst + (|>. ($i;INVOKESTATIC ../runtime;runtime-name + "pm_pop" + ($t;method (list ../runtime;$Stack) + (#;Some ../runtime;$Stack) + (list)) + false))) + +(def: pushI + $;Inst + (|>. ($i;INVOKESTATIC ../runtime;runtime-name + "pm_push" + ($t;method (list ../runtime;$Stack $Object) + (#;Some ../runtime;$Stack) + (list)) + false))) + +(def: (generate-pattern' stack-depth @else @end path) + (-> Nat $;Label $;Label ls;Path (Lux $;Inst)) + (case path + (#ls;ExecP bodyS) + (do macro;Monad<Lux> + [bodyI (expr;generate bodyS)] + (wrap (|>. (pop-altI stack-depth) + bodyI + ($i;GOTO @end)))) + + #ls;UnitP + (lux/wrap popI) + + (#ls;BindP register) + (lux/wrap (|>. peekI + ($i;ASTORE register) + popI)) + + (#ls;BoolP value) + (lux/wrap (let [jumpI (if value $i;IFEQ $i;IFNE)] + (|>. peekI + ($i;unwrap #$;Boolean) + (jumpI @else)))) + + (^template [<tag> <prep>] + (<tag> value) + (lux/wrap (|>. peekI + ($i;unwrap #$;Long) + ($i;long (|> value <prep>)) + $i;LCMP + ($i;IFNE @else)))) + ([#ls;NatP (:! Int)] + [#ls;IntP (: Int)] + [#ls;DegP (:! Int)]) + + (#ls;FracP value) + (lux/wrap (|>. peekI + ($i;unwrap #$;Double) + ($i;double value) + $i;DCMPL + ($i;IFNE @else))) + + (#ls;TextP value) + (lux/wrap (|>. peekI + ($i;string value) + ($i;INVOKEVIRTUAL "java.lang.Object" + "equals" + ($t;method (list $Object) + (#;Some $t;boolean) + (list)) + false) + ($i;IFEQ @else))) + + (#ls;TupleP idx subP) + (do macro;Monad<Lux> + [subI (generate-pattern' stack-depth @else @end subP) + #let [[idx tail?] (case idx + (#;Left idx) + [idx false] + + (#;Right idx) + [idx true])]] + (wrap (case idx + +0 + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int 0) + $i;AALOAD + pushI + subI) + + _ + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Tuple)) + ($i;int (nat-to-int idx)) + ($i;INVOKESTATIC ../runtime;runtime-name + (if tail? "pm_right" "pm_left") + ($t;method (list ../runtime;$Tuple $t;int) + (#;Some $Object) + (list)) + false) + pushI + subI)))) + + (#ls;VariantP idx subP) + (do macro;Monad<Lux> + [subI (generate-pattern' stack-depth @else @end subP) + #let [[idx last?] (case idx + (#;Left idx) + [idx false] + + (#;Right idx) + [idx true]) + flagI (if last? + ($i;string "") + $i;NULL)]] + (wrap (<| $i;with-label (function [@success]) + $i;with-label (function [@fail]) + (|>. peekI + ($i;CHECKCAST ($t;descriptor ../runtime;$Variant)) + ($i;int (nat-to-int idx)) + flagI + ($i;INVOKESTATIC ../runtime;runtime-name "pm_variant" + ($t;method (list ../runtime;$Variant ../runtime;$Tag ../runtime;$Flag) + (#;Some ../runtime;$Datum) + (list)) + false) + $i;DUP + ($i;IFNULL @fail) + ($i;GOTO @success) + ($i;label @fail) + $i;POP + ($i;GOTO @else) + ($i;label @success) + pushI + subI)))) + + (#ls;SeqP leftP rightP) + (do macro;Monad<Lux> + [leftI (generate-pattern' stack-depth @else @end leftP) + rightI (generate-pattern' stack-depth @else @end rightP)] + (wrap (|>. leftI + rightI))) + + (#ls;AltP leftP rightP) + (do macro;Monad<Lux> + [@alt-else $i;make-label + leftI (generate-pattern' (n.inc stack-depth) @alt-else @end leftP) + rightI (generate-pattern' stack-depth @else @end rightP)] + (wrap (|>. $i;DUP + leftI + ($i;label @alt-else) + $i;POP + rightI))) + )) + +(def: (generate-pattern path @end) + (-> ls;Path $;Label (Lux $;Inst)) + (do macro;Monad<Lux> + [@else $i;make-label + pathI (generate-pattern' +1 @else @end path)] + (wrap (|>. pathI + ($i;label @else) + $i;POP + ($i;INVOKESTATIC ../runtime;runtime-name + "pm_fail" + ($t;method (list) #;None (list)) + false) + $i;NULL + ($i;GOTO @end))))) + +(def: #export (generate valueS path) + (-> ls;Synthesis ls;Path (Lux $;Inst)) + (do macro;Monad<Lux> + [@end $i;make-label + valueI (expr;generate valueS) + pathI (generate-pattern path @end)] + (wrap (|>. valueI + $i;NULL + $i;SWAP + pushI + pathI + ($i;label @end))))) diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux index 6085ff72b..0f947925c 100644 --- a/new-luxc/source/luxc/generator/host/jvm/inst.lux +++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux @@ -3,6 +3,7 @@ (lux (control monad ["p" parser]) (data text/format + ["R" result] (coll [list "L/" Functor<List>])) [host #+ do-to] [macro] @@ -25,14 +26,16 @@ <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2 POP POP2 SWAP) - <jump> (declare IF_ICMPEQ IF_ACMPEQ IFNULL - IFEQ IFLT IFLE IFGT IFGE + <jump> (declare IF_ICMPEQ IF_ICMPGT IF_ICMPLT IF_ACMPEQ IFNULL + IFEQ IFNE IFLT IFLE IFGT IFGE GOTO) <var> (declare ILOAD LLOAD DLOAD ALOAD - ISTORE LSTORE) + ISTORE LSTORE ASTORE) <arithmethic> (declare IADD ISUB - LADD LSUB LMUL LDIV LREM LCMP - DADD DSUB DMUL DDIV DREM DCMPG) + LADD LSUB LMUL LDIV LREM + LCMP + DADD DSUB DMUL DDIV DREM + DCMPG DCMPL) <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)] (host;import org.objectweb.asm.Opcodes <primitive> @@ -101,9 +104,16 @@ (visitMethodInsn [int String String String boolean] void) (visitLabel [Label] void) (visitJumpInsn [int Label] void) - (visitTryCatchBlock [Label Label Label String] void)) + (visitTryCatchBlock [Label Label Label String] void) + (visitTableSwitchInsn [int int Label (Array Label)] void) + ) ## [Insts] +(def: #export make-label + (Lux Label) + (function [compiler] + (#R;Success [compiler (Label.new [])]))) + (def: #export (with-label action) (-> (-> Label $;Inst) $;Inst) (action (Label.new []))) @@ -149,10 +159,12 @@ [IADD] [ISUB] ## Long arithmethic - [LADD] [LSUB] [LMUL] [LDIV] [LREM] [LCMP] + [LADD] [LSUB] [LMUL] [LDIV] [LREM] + [LCMP] ## Double arithmetic - [DADD] [DSUB] [DMUL] [DDIV] [DREM] [DCMPG] + [DADD] [DSUB] [DMUL] [DDIV] [DREM] + [DCMPG] [DCMPL] ## Conversions [I2L] [L2I] [L2D] [D2L] [I2C] @@ -175,7 +187,7 @@ (MethodVisitor.visitVarInsn [(prefix <name>) (nat-to-int register)]))))] [ILOAD] [LLOAD] [DLOAD] [ALOAD] - [ISTORE] [LSTORE] + [ISTORE] [LSTORE] [ASTORE] ) (do-template [<name> <inst>] @@ -237,11 +249,26 @@ (do-to visitor (MethodVisitor.visitJumpInsn [(prefix <name>) @where]))))] - [IF_ICMPEQ] [IF_ACMPEQ] [IFNULL] - [IFEQ] [IFLT] [IFLE] [IFGT] [IFGE] + [IF_ICMPEQ] [IF_ICMPGT] [IF_ICMPLT] [IF_ACMPEQ] [IFNULL] + [IFEQ] [IFNE] [IFLT] [IFLE] [IFGT] [IFGE] [GOTO] ) +(def: #export (TABLESWITCH min max default labels) + (-> Int Int $;Label (List $;Label) $;Inst) + (function [visitor] + (let [num-labels (list;size labels) + labels-array (host;array Label num-labels) + _ (loop [idx +0] + (if (n.< num-labels idx) + (exec (host;array-write idx + (assume (list;nth idx labels)) + labels-array) + (recur (n.inc idx))) + []))] + (do-to visitor + (MethodVisitor.visitTableSwitchInsn [min max default labels-array]))))) + (def: #export (try @from @to @handler exception) (-> $;Label $;Label $;Label Text $;Inst) (function [visitor] diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index e094334c0..68e18deaa 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -47,6 +47,12 @@ (def: $Object $;Type ($t;class "java.lang.Object" (list))) (def: $Object-Array $;Type ($t;array +1 $Object)) (def: $String $;Type ($t;class "java.lang.String" (list))) +(def: #export $Stack $;Type ($t;array +1 $Object)) +(def: #export $Tuple $;Type ($t;array +1 $Object)) +(def: #export $Variant $;Type ($t;array +1 $Object)) +(def: #export $Tag $;Type $t;int) +(def: #export $Flag $;Type $Object) +(def: #export $Datum $;Type $Object) (def: logI $;Inst @@ -55,41 +61,45 @@ (|>. outI ($i;string "LOG: ") (printI "print") outI $i;SWAP (printI "println")))) -(def: sum-method +(def: variant-method $;Method ($t;method (list $t;int $Object $Object) (#;Some $Object-Array) (list))) +(def: variant-makeI + $;Inst + ($i;INVOKESTATIC runtime-name "variant_make" variant-method false)) + (def: #export someI $;Inst (|>. ($i;int 1) ($i;string "") $i;DUP2_X1 $i;POP2 - ($i;INVOKESTATIC runtime-name "sum_make" sum-method false))) + variant-makeI)) (def: #export noneI $;Inst (|>. ($i;int 0) $i;NULL ($i;string unit) - ($i;INVOKESTATIC runtime-name "sum_make" sum-method false))) + variant-makeI)) -(def: add-adt-methods +(def: adt-methods $;Def - (let [store-tag (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE) - store-flag (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE) - store-value (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)] - (|>. ($d;method #$;Public $;staticM "sum_make" + (let [store-tagI (|>. $i;DUP ($i;int 0) ($i;ILOAD +0) ($i;wrap #$;Int) $i;AASTORE) + store-flagI (|>. $i;DUP ($i;int 1) ($i;ALOAD +1) $i;AASTORE) + store-valueI (|>. $i;DUP ($i;int 2) ($i;ALOAD +2) $i;AASTORE)] + (|>. ($d;method #$;Public $;staticM "variant_make" ($t;method (list $t;int $Object $Object) - (#;Some ($t;array +1 $Object)) + (#;Some $Variant) (list)) (|>. ($i;array $Object +3) - store-tag - store-flag - store-value + store-tagI + store-flagI + store-valueI $i;ARETURN))))) -(def: add-nat-methods +(def: nat-methods $;Def (let [compare-nat-method ($t;method (list $t;long $t;long) (#;Some $t;int) (list)) less-thanI (function [@where] (|>. ($i;INVOKESTATIC runtime-name "compare_nat" compare-nat-method false) ($i;IFLT @where))) @@ -183,7 +193,7 @@ (def: frac-shiftI $;Inst ($i;double (math;pow 32.0 2.0))) -(def: add-frac-methods +(def: frac-methods $;Def (|>. ($d;method #$;Public $;staticM "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) (<| $i;with-label (function [@from]) @@ -229,7 +239,7 @@ (def: deg-method $;Method ($t;method (list $t;long $t;long) (#;Some $t;long) (list))) (def: clz-method $;Method ($t;method (list $t;long) (#;Some $t;int) (list))) -(def: add-deg-methods +(def: deg-methods $;Def (let [## "And" mask corresponding to -1 (FFFF...), on the low 32 bits. low-half (|>. ($i;int -1) $i;I2L $i;LAND) @@ -301,14 +311,143 @@ $i;DRETURN))) ))) +(def: pm-methods + $;Def + (let [tuple-sizeI (|>. ($i;ALOAD +0) $i;ARRAYLENGTH) + tuple-elemI (|>. ($i;ALOAD +0) ($i;ILOAD +1) $i;AALOAD) + expected-last-sizeI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD) + tuple-tailI (|>. ($i;ALOAD +0) tuple-sizeI ($i;int 1) $i;ISUB $i;AALOAD ($i;CHECKCAST ($t;descriptor $Tuple)))] + (|>. ($d;method #$;Public $;staticM "pm_fail" ($t;method (list) #;None (list)) + (|>. ($i;NEW "java.lang.IllegalStateException") + $i;DUP + ($i;string "Invalid expression for pattern-matching.") + ($i;INVOKESPECIAL "java.lang.IllegalStateException" "<init>" ($t;method (list $String) #;None (list)) false) + $i;ATHROW)) + ($d;method #$;Public $;staticM "pm_push" ($t;method (list $Stack $Object) (#;Some $Stack) (list)) + (|>. ($i;int 2) + ($i;ANEWARRAY "java.lang.Object") + $i;DUP + ($i;int 0) + ($i;ALOAD +0) + $i;AASTORE + $i;DUP + ($i;int 1) + ($i;ALOAD +1) + $i;AASTORE + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_pop" ($t;method (list $Stack) (#;Some $Stack) (list)) + (|>. ($i;ALOAD +0) + ($i;int 0) + $i;AALOAD + ($i;CHECKCAST ($t;descriptor $Stack)) + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_peek" ($t;method (list $Stack) (#;Some $Object) (list)) + (|>. ($i;ALOAD +0) + ($i;int 1) + $i;AALOAD + $i;ARETURN)) + ($d;method #$;Public $;staticM "pm_variant" ($t;method (list $Stack $t;int $Object) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@just-return]) + $i;with-label (function [@then]) + $i;with-label (function [@further]) + $i;with-label (function [@shorten]) + $i;with-label (function [@wrong]) + (let [variant-partI (: (-> Nat $;Inst) + (function [idx] + (|>. ($i;int (nat-to-int idx)) $i;AALOAD))) + tagI (: $;Inst + (|>. (variant-partI +0) ($i;unwrap #$;Int))) + flagI (variant-partI +1) + datumI (variant-partI +2) + shortenI (|>. ($i;ALOAD +0) tagI ## Get tag + ($i;ILOAD +1) $i;ISUB ## Shorten tag + ($i;ALOAD +0) flagI ## Get flag + ($i;ALOAD +0) datumI ## Get value + variant-makeI ## Build sum + $i;ARETURN) + update-tagI (|>. $i;ISUB ($i;ISTORE +1)) + update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0)) + wrongI (|>. $i;NULL $i;ARETURN) + return-datumI (|>. ($i;ALOAD +0) datumI $i;ARETURN)]) + (|>. ($i;label @begin) + ($i;ILOAD +1) ## tag + ($i;ALOAD +0) tagI ## tag, sumT + $i;DUP2 ($i;IF_ICMPEQ @then) + $i;DUP2 ($i;IF_ICMPGT @further) + $i;DUP2 ($i;IF_ICMPLT @shorten) + ## $i;POP2 + wrongI + ($i;label @then) ## tag, sumT + ($i;ALOAD +2) ## tag, sumT, wants-last? + ($i;ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? + ($i;IF_ACMPEQ @just-return) ## tag, sumT + ($i;label @further) ## tag, sumT + ($i;ALOAD +0) flagI ## tag, sumT, last? + ($i;IFNULL @wrong) ## tag, sumT + update-tagI + update-variantI + ($i;GOTO @begin) + ($i;label @just-return) ## tag, sumT + ## $i;POP2 + return-datumI + ($i;label @shorten) ## tag, sumT + ($i;ALOAD +2) ($i;IFNULL @wrong) + ## $i;POP2 + shortenI + ($i;label @wrong) ## tag, sumT + ## $i;POP2 + wrongI))) + ($d;method #$;Public $;staticM "pm_left" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@not-recursive]) + (let [updated-idxI (|>. $i;SWAP $i;ISUB)]) + (|>. ($i;label @begin) + tuple-sizeI + expected-last-sizeI + $i;DUP2 ($i;IF_ICMPGT @not-recursive) + ## Recursive + updated-idxI ($i;ISTORE +1) + tuple-tailI ($i;ASTORE +0) + ($i;GOTO @begin) + ($i;label @not-recursive) + ## $i;POP2 + tuple-elemI + $i;ARETURN))) + ($d;method #$;Public $;staticM "pm_right" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) + (<| $i;with-label (function [@begin]) + $i;with-label (function [@tail]) + $i;with-label (function [@slice]) + (let [updated-idxI (|>. ($i;ILOAD +1) ($i;int 1) $i;IADD tuple-sizeI $i;ISUB) + sliceI (|>. ($i;ALOAD +0) ($i;ILOAD +1) tuple-sizeI + ($i;INVOKESTATIC "java.util.Arrays" "copyOfRange" ($t;method (list $Object-Array $t;int $t;int) (#;Some $Object-Array) (list)) false))]) + (|>. ($i;label @begin) + tuple-sizeI + expected-last-sizeI + $i;DUP2 ($i;IF_ICMPEQ @tail) + ($i;IF_ICMPGT @slice) + ## Must recurse + tuple-tailI ($i;ASTORE +0) + updated-idxI ($i;ISTORE +1) + ($i;GOTO @begin) + ($i;label @slice) + sliceI + $i;ARETURN + ($i;label @tail) + ## $i;POP2 + tuple-elemI + $i;ARETURN))) + ))) + (def: #export generate (Lux &common;Bytecode) (do Monad<Lux> [_ (wrap []) #let [bytecode ($d;class #$;V1.6 #$;Public $;finalC runtime-name (list) ["java.lang.Object" (list)] (list) - (|>. add-adt-methods - add-nat-methods - add-frac-methods - add-deg-methods))] + (|>. adt-methods + nat-methods + frac-methods + deg-methods + pm-methods))] _ (&common;store-class runtime-name bytecode)] (wrap bytecode))) diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux index 64848546f..9adff1a55 100644 --- a/new-luxc/source/luxc/generator/structure.jvm.lux +++ b/new-luxc/source/luxc/generator/structure.jvm.lux @@ -52,7 +52,7 @@ (flagI tail?) memberI ($i;INVOKESTATIC ../runtime;runtime-name - "sum_make" + "variant_make" ($t;method (list $t;int $Object $Object) (#;Some ($t;array +1 $Object)) (list)) diff --git a/new-luxc/test/test/luxc/analyser/case.lux b/new-luxc/test/test/luxc/analyser/case.lux index 3c05f5dad..983dff6f5 100644 --- a/new-luxc/test/test/luxc/analyser/case.lux +++ b/new-luxc/test/test/luxc/analyser/case.lux @@ -40,7 +40,7 @@ head head+] (wrap (#;Cons head tail+))))) -(def: (exhaustive-branches-for allow-literals? variantTC inputC) +(def: #export (exhaustive-branches allow-literals? variantTC inputC) (-> Bool (List [Code Code]) Code (r;Random (List Code))) (case inputC [_ (#;Bool _)] @@ -54,7 +54,7 @@ (case ?sample (#;Some sample) (do @ - [else (exhaustive-branches-for allow-literals? variantTC inputC)] + [else (exhaustive-branches allow-literals? variantTC inputC)] (wrap (list& (<wrapper> sample) else))) #;None @@ -74,7 +74,7 @@ [_ (#;Tuple members)] (do r;Monad<Random> - [member-wise-patterns (monad;map @ (exhaustive-branches-for allow-literals? variantTC) members)] + [member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) members)] (wrap (|> member-wise-patterns exhaustive-weaving (L/map code;tuple)))) @@ -83,7 +83,7 @@ (do r;Monad<Random> [#let [ks (L/map product;left kvs) vs (L/map product;right kvs)] - member-wise-patterns (monad;map @ (exhaustive-branches-for allow-literals? variantTC) vs)] + member-wise-patterns (monad;map @ (exhaustive-branches allow-literals? variantTC) vs)] (wrap (|> member-wise-patterns exhaustive-weaving (L/map (|>. (list;zip2 ks) code;record))))) @@ -93,7 +93,7 @@ [bundles (monad;map @ (function [[_tag _code]] (do @ - [v-branches (exhaustive-branches-for allow-literals? variantTC _code)] + [v-branches (exhaustive-branches allow-literals? variantTC _code)] (wrap (L/map (function [pattern] (` ((~ _tag) (~ pattern)))) v-branches)))) variantTC)] @@ -103,10 +103,10 @@ (r/wrap (list)) )) -(def: (gen-input variant-tags record-tags primitivesC) +(def: #export (input variant-tags record-tags primitivesC) (-> (List Code) (List Code) (List Code) (r;Random Code)) (r;rec - (function [gen-input] + (function [input] ($_ r;either (r/map product;right gen-primitive) (do r;Monad<Random> @@ -116,7 +116,7 @@ (wrap (` ((~ choiceT) (~ choiceC))))) (do r;Monad<Random> [size (|> r;nat (:: @ map (n.% +3))) - elems (r;list size gen-input)] + elems (r;list size input)] (wrap (code;tuple elems))) (r/wrap (code;record (list;zip2 record-tags primitivesC))) )))) @@ -141,12 +141,12 @@ variant-tags+ (L/map (|>. [module-name] code;tag) variant-tags) record-tags+ (L/map (|>. [module-name] code;tag) record-tags) variantTC (list;zip2 variant-tags+ primitivesC)] - inputC (gen-input variant-tags+ record-tags+ primitivesC) + inputC (input variant-tags+ record-tags+ primitivesC) [outputT outputC] gen-primitive [heterogeneousT heterogeneousC] (|> gen-primitive (r;filter (|>. product;left (tc;checks? outputT) not))) - exhaustive-patterns (exhaustive-branches-for true variantTC inputC) - redundant-patterns (exhaustive-branches-for false variantTC inputC) + exhaustive-patterns (exhaustive-branches true variantTC inputC) + redundant-patterns (exhaustive-branches false variantTC inputC) redundancy-idx (|> r;nat (:: @ map (n.% (list;size redundant-patterns)))) heterogeneous-idx (|> r;nat (:: @ map (n.% (list;size exhaustive-patterns)))) #let [exhaustive-branchesC (L/map (branch outputC) diff --git a/new-luxc/test/test/luxc/generator/case.lux b/new-luxc/test/test/luxc/generator/case.lux new file mode 100644 index 000000000..9e6dbf928 --- /dev/null +++ b/new-luxc/test/test/luxc/generator/case.lux @@ -0,0 +1,102 @@ +(;module: + lux + (lux [io] + (control [monad #+ do] + pipe) + (data text/format + [product] + ["R" result] + [bool "B/" Eq<Bool>] + [text "T/" Eq<Text>] + (coll ["a" array] + [list "L/" Functor<List>] + ["S" set])) + ["r" math/random "r/" Monad<Random>] + [macro #+ Monad<Lux>] + (macro [code]) + [host] + test) + (luxc (lang ["ls" synthesis]) + [analyser] + [synthesizer] + (generator ["@" case] + ["@;" eval] + ["@;" runtime] + ["@;" common])) + (test/luxc common)) + +(def: struct-limit Nat +10) + +(def: (tail? size idx) + (-> Nat Nat Bool) + (n.= (n.dec size) idx)) + +(def: gen-case + (r;Random [ls;Synthesis ls;Path]) + (<| r;rec (function [gen-case]) + (with-expansions [<simple> (do-template [<gen> <synth> <path>] + [(do r;Monad<Random> + [value <gen>] + (wrap [(<synth> value) (<path> value)]))] + + [r;bool #ls;Bool #ls;BoolP] + [r;nat #ls;Nat #ls;NatP] + [r;int #ls;Int #ls;IntP] + [r;deg #ls;Deg #ls;DegP] + [r;frac #ls;Frac #ls;FracP] + [(r;text +5) #ls;Text #ls;TextP])] + ($_ r;either + (r/wrap [#ls;Unit #ls;UnitP]) + <simple> + (do r;Monad<Random> + [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2)))) + idx (|> r;nat (:: @ map (n.% size))) + [subS subP] gen-case + #let [dummyS (list;repeat (n.dec size) #ls;Unit) + caseS (#ls;Tuple (list;concat (list (list;take idx dummyS) + (list subS) + (list;drop idx dummyS)))) + caseP (#ls;TupleP (if (tail? idx idx) + (#;Right idx) + (#;Left idx)) + subP)]] + (wrap [caseS caseP])) + (do r;Monad<Random> + [size (|> r;nat (:: @ map (|>. (n.% struct-limit) (n.max +2)))) + idx (|> r;nat (:: @ map (n.% size))) + [subS subP] gen-case + #let [caseS (#ls;Variant idx (tail? idx idx) subS) + caseP (#ls;VariantP (if (tail? idx idx) + (#;Right idx) + (#;Left idx)) + subP)]] + (wrap [caseS caseP])) + )))) + +(context: "Pattern-matching." + [[valueS path] gen-case + to-bind r;nat] + ($_ seq + (test "Can generate pattern-matching." + (|> (do Monad<Lux> + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate valueS + (#ls;AltP (#ls;SeqP path (#ls;ExecP (#ls;Bool true))) + (#ls;SeqP (#ls;BindP +0) (#ls;ExecP (#ls;Bool false))))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (:! Bool valueG) + + _ + false))) + (test "Can bind values." + (|> (do Monad<Lux> + [runtime-bytecode @runtime;generate] + (@eval;eval (@;generate (#ls;Nat to-bind) + (#ls;SeqP (#ls;BindP +1) (#ls;ExecP (#ls;Variable 1)))))) + (macro;run (init-compiler [])) + (case> (#R;Success valueG) + (n.= to-bind (:! Nat valueG)) + + _ + false))))) diff --git a/new-luxc/test/tests.lux b/new-luxc/test/tests.lux index 06f3e940e..d07822069 100644 --- a/new-luxc/test/tests.lux +++ b/new-luxc/test/tests.lux @@ -20,6 +20,7 @@ ["_;S" loop]) (generator ["_;G" primitive] ["_;G" structure] + ["_;G" case] (procedure ["_;G" common])) )) ## (luxc (generator ["_;G" function])) |