diff options
11 files changed, 222 insertions, 340 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux index e11187787..ac7ab3b83 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux @@ -57,9 +57,8 @@ (list)) #0))) -(def: (path' translate stack-depth @else @end path) - (-> (-> Synthesis (Operation Inst)) - Nat Label Label Path (Operation Inst)) +(def: (path' phase stack-depth @else @end path) + (-> Phase Nat Label Label Path (Operation Inst)) (.case path #synthesis.Pop (operation/wrap popI) @@ -101,15 +100,39 @@ (#synthesis.Then bodyS) (do phase.Monad<Operation> - [bodyI (translate bodyS)] + [bodyI (phase bodyS)] (wrap (|>> (pop-altI stack-depth) bodyI (_.GOTO @end)))) - (^template [<pattern> <method>] + (^template [<pattern> <flag> <prepare>] (^ (<pattern> idx)) - (operation/wrap (.case idx + (operation/wrap (<| _.with-label (function (_ @success)) + _.with-label (function (_ @fail)) + (|>> peekI + (_.CHECKCAST ($t.descriptor runtime.$Variant)) + (_.int (.int (<prepare> idx))) + <flag> + (_.INVOKESTATIC //.runtime-class "pm_variant" + ($t.method (list runtime.$Variant runtime.$Tag runtime.$Flag) + (#.Some runtime.$Datum) + (list)) + #0) + _.DUP + (_.IFNULL @fail) + (_.GOTO @success) + (_.label @fail) + _.POP + (_.GOTO @else) + (_.label @success) + pushI)))) + ([synthesis.side/left _.NULL .id] + [synthesis.side/right (_.string "") .inc]) + + (^template [<pattern> <method> <prepare>] + (^ (<pattern> idx)) + (operation/wrap (.case (<prepare> idx) 0 (|>> peekI (_.CHECKCAST ($t.descriptor runtime.$Tuple)) @@ -128,39 +151,14 @@ (list)) #0) pushI)))) - ([synthesis.member/left "pm_left"] - [synthesis.member/right "pm_right"]) - - (^template [<pattern> <flag> <mod>] - (^ (<pattern> idx)) - (.let [idx (<mod> idx)] - (operation/wrap (<| _.with-label (function (_ @success)) - _.with-label (function (_ @fail)) - (|>> peekI - (_.CHECKCAST ($t.descriptor runtime.$Variant)) - (_.int (.int idx)) - <flag> - (_.INVOKESTATIC //.runtime-class "pm_variant" - ($t.method (list runtime.$Variant runtime.$Tag runtime.$Flag) - (#.Some runtime.$Datum) - (list)) - #0) - _.DUP - (_.IFNULL @fail) - (_.GOTO @success) - (_.label @fail) - _.POP - (_.GOTO @else) - (_.label @success) - pushI))))) - ([synthesis.side/left _.NULL .id] - [synthesis.side/right (_.string "") .inc]) + ([synthesis.member/left "pm_left" id] + [synthesis.member/right "pm_right" inc]) (#synthesis.Alt leftP rightP) (do phase.Monad<Operation> [@alt-else _.make-label - leftI (path' translate (inc stack-depth) @alt-else @end leftP) - rightI (path' translate stack-depth @else @end rightP)] + leftI (path' phase (inc stack-depth) @alt-else @end leftP) + rightI (path' phase stack-depth @else @end rightP)] (wrap (|>> _.DUP leftI (_.label @alt-else) @@ -169,17 +167,17 @@ (#synthesis.Seq leftP rightP) (do phase.Monad<Operation> - [leftI (path' translate stack-depth @else @end leftP) - rightI (path' translate stack-depth @else @end rightP)] + [leftI (path' phase stack-depth @else @end leftP) + rightI (path' phase stack-depth @else @end rightP)] (wrap (|>> leftI rightI))) )) -(def: (path translate path @end) +(def: (path phase path @end) (-> Phase Path Label (Operation Inst)) (do phase.Monad<Operation> [@else _.make-label - pathI (..path' translate 1 @else @end path)] + pathI (..path' phase 1 @else @end path)] (wrap (|>> pathI (_.label @else) _.POP @@ -190,12 +188,12 @@ _.NULL (_.GOTO @end))))) -(def: #export (if translate testS thenS elseS) +(def: #export (if phase testS thenS elseS) (-> Phase Synthesis Synthesis Synthesis (Operation Inst)) (do phase.Monad<Operation> - [testI (translate testS) - thenI (translate thenS) - elseI (translate elseS)] + [testI (phase testS) + thenI (phase thenS) + elseI (phase elseS)] (wrap (<| _.with-label (function (_ @else)) _.with-label (function (_ @end)) (|>> testI @@ -207,21 +205,21 @@ elseI (_.label @end)))))) -(def: #export (let translate inputS register exprS) +(def: #export (let phase inputS register exprS) (-> Phase Synthesis Nat Synthesis (Operation Inst)) (do phase.Monad<Operation> - [inputI (translate inputS) - exprI (translate exprS)] + [inputI (phase inputS) + exprI (phase exprS)] (wrap (|>> inputI (_.ASTORE register) exprI)))) -(def: #export (case translate valueS path) +(def: #export (case phase valueS path) (-> Phase Synthesis Path (Operation Inst)) (do phase.Monad<Operation> [@end _.make-label - valueI (translate valueS) - pathI (..path translate path @end)] + valueI (phase valueS) + pathI (..path phase path @end)] (wrap (|>> _.NULL valueI pushI diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux index c92ab1026..20c31bd5d 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -106,59 +106,8 @@ Def (let [store-tagI (|>> _.DUP (_.int +0) (_.ILOAD 0) (_.wrap #$.Int) _.AASTORE) store-flagI (|>> _.DUP (_.int +1) (_.ALOAD 1) _.AASTORE) - store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE) - force-textMT ($t.method (list $Object) (#.Some $String) (list))] - (|>> ($d.method #$.Public $.staticM "force_text" force-textMT - (<| _.with-label (function (_ @is-null)) - _.with-label (function (_ @normal-object)) - _.with-label (function (_ @array-loop)) - _.with-label (function (_ @within-bounds)) - _.with-label (function (_ @is-first)) - _.with-label (function (_ @elem-end)) - _.with-label (function (_ @fold-end)) - (let [on-normal-objectI (|>> (_.ALOAD 0) - (_.INVOKEVIRTUAL "java.lang.Object" "toString" ($t.method (list) (#.Some $String) (list)) #0)) - on-null-objectI (_.string "NULL") - arrayI (|>> (_.ALOAD 0) - (_.CHECKCAST ($t.descriptor $Object-Array))) - recurseI (_.INVOKESTATIC //.runtime-class "force_text" force-textMT #0) - force-elemI (|>> _.DUP arrayI _.SWAP _.AALOAD recurseI) - swap2 (|>> _.DUP2_X2 ## X,Y => Y,X,Y - _.POP2 ## Y,X,Y => Y,X - ) - add-spacingI (|>> (_.string ", ") _.SWAP string-concatI) - merge-with-totalI (|>> _.DUP_X2 _.POP ## TSIP => TPSI - swap2 ## TPSI => SITP - string-concatI ## SITP => SIT - _.DUP_X2 _.POP ## SIT => TSI - ) - foldI (|>> _.DUP ## TSI => TSII - (_.IFEQ @is-first) ## TSI - force-elemI add-spacingI merge-with-totalI (_.GOTO @elem-end) - (_.label @is-first) ## TSI - force-elemI merge-with-totalI - (_.label @elem-end) ## TSI - ) - inc-idxI (|>> (_.int +1) _.IADD) - on-array-objectI (|>> (_.string "[") ## T - arrayI _.ARRAYLENGTH ## TS - (_.int +0) ## TSI - (_.label @array-loop) ## TSI - _.DUP2 - (_.IF_ICMPGT @within-bounds) ## TSI - _.POP2 (_.string "]") string-concatI (_.GOTO @fold-end) - (_.label @within-bounds) - foldI inc-idxI (_.GOTO @array-loop) - (_.label @fold-end))]) - (|>> (_.ALOAD 0) - (_.IFNULL @is-null) - (_.ALOAD 0) - (_.INSTANCEOF ($t.descriptor $Object-Array)) - (_.IFEQ @normal-object) - on-array-objectI _.ARETURN - (_.label @normal-object) on-normal-objectI _.ARETURN - (_.label @is-null) on-null-objectI _.ARETURN))) - ($d.method #$.Public $.staticM "variant_make" + store-valueI (|>> _.DUP (_.int +2) (_.ALOAD 2) _.AASTORE)] + (|>> ($d.method #$.Public $.staticM "variant_make" ($t.method (list $t.int $Object $Object) (#.Some $Variant) (list)) @@ -169,10 +118,6 @@ store-valueI _.ARETURN))))) -(def: #export force-textI - Inst - (_.INVOKESTATIC //.runtime-class "force_text" ($t.method (list $Object) (#.Some $String) (list)) #0)) - (def: frac-shiftI Inst (_.double (math.pow +32.0 +2.0))) (def: frac-methods diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 9bf515bdb..e5a992052 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -827,27 +827,27 @@ ("lux check" Macro ([_ tokens] ({(#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil)) - (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier "" "")) + (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" ""])) (#Cons arg #Nil)))) (#Cons ({#Nil body _ - (_ann (#Form (#Cons (_ann (#Identifier "lux" "function''")) + (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"])) (#Cons (_ann (#Tuple args')) (#Cons body #Nil)))))} args') #Nil)))) #Nil)) - (#Cons [_ (#Identifier "" self)] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))) - (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier "" self)) + (#Cons [_ (#Identifier ["" self])] (#Cons [_ (#Tuple (#Cons arg args'))] (#Cons body #Nil))) + (return (#Cons (_ann (#Form (#Cons (_ann (#Tuple (#Cons (_ann (#Identifier ["" self])) (#Cons arg #Nil)))) (#Cons ({#Nil body _ - (_ann (#Form (#Cons (_ann (#Identifier "lux" "function''")) + (_ann (#Form (#Cons (_ann (#Identifier ["lux" "function''"])) (#Cons (_ann (#Tuple args')) (#Cons body #Nil)))))} args') diff --git a/stdlib/source/lux/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux index 19ef64af2..7663f6950 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis.lux @@ -25,9 +25,16 @@ (type: #export Tag Nat) +(type: #export (Variant a) + {#lefts Nat + #right? Bit + #value a}) + +(type: #export (Tuple a) (List a)) + (type: #export (Composite a) - (#Sum (Either a a)) - (#Product [a a])) + (#Variant (Variant a)) + (#Tuple (Tuple a))) (type: #export #rec Pattern (#Simple Primitive) @@ -90,13 +97,6 @@ [text Text #Text] ) -(type: #export (Variant a) - {#lefts Nat - #right? Bit - #value a}) - -(type: #export (Tuple a) (List a)) - (type: #export Arity Nat) (type: #export (Abstraction c) [Environment Arity c]) @@ -112,92 +112,10 @@ (#..Function (list)) (#..Apply value))) -(do-template [<name> <type> <structure> <prep-value>] - [(def: #export (<name> size tag value) - (-> Nat Tag <type> <type>) - (let [left (function.constant (|>> #.Left #Sum <structure>)) - right (|>> #.Right #Sum <structure>)] - (if (last? size tag) - (list/fold left - (right value) - (list.indices (dec tag))) - (list/fold left - (case value - (<structure> (#Sum _)) - (<prep-value> value) - - _ - value) - (list.indices (inc tag))))))] - - [sum-analysis Analysis #Structure ..no-op] - [sum-pattern Pattern #Complex id] - ) - -(do-template [<name> <type> <primitive> <structure>] - [(def: #export (<name> members) - (-> (Tuple <type>) <type>) - (case (list.reverse members) - #.Nil - (<primitive> #Unit) - - (#.Cons singleton #.Nil) - singleton - - (#.Cons last prevs) - (list/fold (function (_ left right) (<structure> (#Product left right))) - last prevs)))] - - [product-analysis Analysis #Primitive #Structure] - [product-pattern Pattern #Simple #Complex] - ) - (def: #export (apply [func args]) (-> (Application Analysis) Analysis) (list/fold (function (_ arg func) (#Apply arg func)) func args)) -(do-template [<name> <type> <tag>] - [(def: #export (<name> value) - (-> <type> (Tuple <type>)) - (case value - (<tag> (#Product left right)) - (#.Cons left (<name> right)) - - _ - (list value)))] - - [tuple Analysis #Structure] - [tuple-pattern Pattern #Complex] - ) - -(do-template [<name> <type> <tag>] - [(def: #export (<name> value) - (-> <type> (Maybe (Variant <type>))) - (loop [lefts 0 - variantA value] - (case variantA - (<tag> (#Sum (#.Left valueA))) - (case valueA - (<tag> (#Sum _)) - (recur (inc lefts) valueA) - - _ - (#.Some {#lefts lefts - #right? #0 - #value valueA})) - - (<tag> (#Sum (#.Right valueA))) - (#.Some {#lefts lefts - #right? #1 - #value valueA}) - - _ - #.None)))] - - [variant Analysis #Structure] - [variant-pattern Pattern #Complex] - ) - (def: #export (application analysis) (-> Analysis (Application Analysis)) (case analysis @@ -208,6 +126,26 @@ _ [analysis (list)])) +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #Complex + <tag> + content))] + + [pattern/variant #..Variant] + [pattern/tuple #..Tuple] + ) + +(do-template [<name> <tag>] + [(template: #export (<name> content) + (.<| #..Structure + <tag> + content))] + + [variant #..Variant] + [tuple #..Tuple] + ) + (template: #export (pattern/unit) (#..Simple #..Unit)) @@ -223,6 +161,9 @@ [pattern/text #..Text] ) +(template: #export (pattern/bind register) + (#..Bind register)) + (def: #export (with-source-code source action) (All [a] (-> Source (Operation a) (Operation a))) (function (_ [bundle state]) @@ -314,13 +255,11 @@ (#Structure structure) (case structure - (#Sum _) - (let [[lefts right? value] (maybe.assume (..variant analysis))] - (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")")) + (#Variant [lefts right? value]) + (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")") - (#Product _) - (|> analysis - ..tuple + (#Tuple members) + (|> members (list/map %analysis) (text.join-with " ") (text.enclose ["[" "]"]))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case.lux b/stdlib/source/lux/compiler/default/phase/analysis/case.lux index 5b5b2038c..0d3536db3 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/case.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/case.lux @@ -208,7 +208,7 @@ [nextA next] (wrap [(list) nextA])) (list.reverse matches))] - (wrap [(//.product-pattern memberP+) + (wrap [(//.pattern/tuple memberP+) thenA]))) _ @@ -246,8 +246,12 @@ (type.variant (list.drop (dec num-cases) flat-sum)) (` [(~+ values)]) next) - (analyse-pattern #.None caseT (` [(~+ values)]) next))] - (wrap [(//.sum-pattern num-cases idx testP) + (analyse-pattern #.None caseT (` [(~+ values)]) next)) + #let [right? (n/= (dec num-cases) idx) + lefts (if right? + (dec idx) + idx)]] + (wrap [(//.pattern/variant [lefts right? testP]) nextA])) _ diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux index df09bb0ec..6b2f307ac 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux @@ -17,30 +17,13 @@ ["." //// ("operation/." Monad<Operation>)] ["." /// (#+ Pattern Variant Operation)]) +(exception: #export (invalid-tuple-pattern) + "Tuple size must be >= 2") + (def: cases (-> (Maybe Nat) Nat) (|>> (maybe.default 0))) -(def: (variant sum-side) - (-> (Either Pattern Pattern) (Variant Pattern)) - (loop [lefts 0 - variantP sum-side] - (case variantP - (#.Left valueP) - (case valueP - (#///.Complex (#///.Sum value-side)) - (recur (inc lefts) value-side) - - _ - {#///.lefts lefts - #///.right? #0 - #///.value valueP}) - - (#.Right valueP) - {#///.lefts lefts - #///.right? #1 - #///.value valueP}))) - ## The coverage of a pattern-matching expression summarizes how well ## all the possible values of an input are being covered by the ## different patterns involved. @@ -96,31 +79,39 @@ ## Tuple patterns can be exhaustive if there is exhaustiveness for all of ## their sub-patterns. - (#///.Complex (#///.Product [left right])) - (do ////.Monad<Operation> - [left (determine left) - right (determine right)] - (case right - (#Exhaustive _) - (wrap left) - - _ - (wrap (#Seq left right)))) - - (#///.Complex (#///.Sum sum-side)) - (let [[variant-lefts variant-right? variant-value] (variant sum-side)] - ## Variant patterns can be shown to be exhaustive if all the possible - ## cases are handled exhaustively. + (#///.Complex (#///.Tuple membersP+)) + (case (list.reverse membersP+) + (^or #.Nil (#.Cons _ #.Nil)) + (////.throw invalid-tuple-pattern []) + + (#.Cons lastP prevsP+) (do ////.Monad<Operation> - [value-coverage (determine variant-value) - #let [variant-idx (if variant-right? - (inc variant-lefts) - variant-lefts)]] - (wrap (#Variant (if variant-right? - (#.Some variant-idx) - #.None) - (|> (dict.new number.Hash<Nat>) - (dict.put variant-idx value-coverage)))))))) + [lastC (determine lastP)] + (monad.fold ////.Monad<Operation> + (function (_ leftP rightC) + (do ////.Monad<Operation> + [leftC (determine leftP)] + (case rightC + #Exhaustive + (wrap leftC) + + _ + (wrap (#Seq leftC rightC))))) + lastC prevsP+))) + + ## Variant patterns can be shown to be exhaustive if all the possible + ## cases are handled exhaustively. + (#///.Complex (#///.Variant [lefts right? value])) + (do ////.Monad<Operation> + [value-coverage (determine value) + #let [idx (if right? + (inc lefts) + lefts)]] + (wrap (#Variant (if right? + (#.Some idx) + #.None) + (|> (dict.new number.Hash<Nat>) + (dict.put idx value-coverage))))))) (def: (xor left right) (-> Bit Bit Bit) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/structure.lux b/stdlib/source/lux/compiler/default/phase/analysis/structure.lux index 1ef523c76..3988349e0 100644 --- a/stdlib/source/lux/compiler/default/phase/analysis/structure.lux +++ b/stdlib/source/lux/compiler/default/phase/analysis/structure.lux @@ -2,12 +2,14 @@ [lux #* [control ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] + ["ex" exception (#+ exception:)] + ["." state]] [data ["." name] ["." number] ["." product] ["." maybe] + ["." error] [text format] [collection @@ -86,13 +88,18 @@ (case expectedT (#.Sum _) (let [flat (type.flatten-variant expectedT) - type-size (list.size flat)] + type-size (list.size flat) + right? (n/= (dec type-size) + tag) + lefts (if right? + (dec tag) + tag)] (case (list.nth tag flat) (#.Some variant-type) (do @ [valueA (//type.with-type variant-type (analyse valueC))] - (wrap (//.sum-analysis type-size tag valueA))) + (wrap (//.variant [lefts right? valueA]))) #.None (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT]))) @@ -151,44 +158,32 @@ _ (///.throw invalid-variant-type [expectedT tag valueC]))))) -(def: (typed-product analyse membersC+) +(def: (typed-product analyse members) (-> Phase (List Code) (Operation Analysis)) (do ///.Monad<Operation> - [expectedT (extension.lift macro.expected-type)] - (loop [expectedT expectedT - membersC+ membersC+] - (case [expectedT membersC+] - ## If the tuple runs out, whatever expression is the last gets - ## matched to the remaining type. - [tailT (#.Cons tailC #.Nil)] - (//type.with-type tailT - (analyse tailC)) - - ## If the type and the code are still ongoing, match each - ## sub-expression to its corresponding type. - [(#.Product leftT rightT) (#.Cons leftC rightC)] - (do @ - [leftA (//type.with-type leftT - (analyse leftC)) - rightA (recur rightT rightC)] - (wrap (#//.Structure (#//.Product leftA rightA)))) - - ## If, however, the type runs out but there is still enough - ## tail, the remaining elements get packaged into another - ## tuple. - ## The reason for this is that it is assumed that the type of - ## the tuple represents the expectations of the user. - ## If the type is for a 3-tuple, but a 5-tuple is provided, it - ## is assumed that the user intended the following layout: - ## [+0, +1, [+2, +3, +4]] - ## but that, for whatever reason, it was written in a flat - ## way. - [tailT tailC] - (|> tailC - code.tuple - analyse - (//type.with-type tailT) - (:: @ map (|>> //.no-op))))))) + [expectedT (extension.lift macro.expected-type) + membersA+ (: (Operation (List Analysis)) + (loop [membersT+ (type.flatten-tuple expectedT) + membersC+ members] + (case [membersT+ membersC+] + [(#.Cons memberT #.Nil) _] + (//type.with-type memberT + (:: @ map (|>> list) (analyse (code.tuple membersC+)))) + + [_ (#.Cons memberC #.Nil)] + (//type.with-type (type.tuple membersT+) + (:: @ map (|>> list) (analyse memberC))) + + [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] + (do @ + [memberA (//type.with-type memberT + (analyse memberC)) + memberA+ (recur membersT+' membersC+')] + (wrap (#.Cons memberA memberA+))) + + _ + (///.throw cannot-analyse-tuple [expectedT members]))))] + (wrap (//.tuple membersA+)))) (def: #export (product analyse membersC) (-> Phase (List Code) (Operation Analysis)) @@ -220,7 +215,7 @@ _ (//type.with-env (check.check expectedT (type.tuple (list/map product.left membersTA))))] - (wrap (//.product-analysis (list/map product.right membersTA)))))) + (wrap (//.tuple (list/map product.right membersTA)))))) (^template [<tag> <instancer>] (<tag> _) @@ -268,8 +263,12 @@ (do @ [#let [case-size (list.size group)] inferenceT (inference.variant idx case-size variantT) - [inferredT valueA+] (inference.general analyse inferenceT (list valueC))] - (wrap (//.sum-analysis case-size idx (|> valueA+ list.head maybe.assume)))) + [inferredT valueA+] (inference.general analyse inferenceT (list valueC)) + #let [right? (n/= (dec case-size) idx) + lefts (if right? + (dec idx) + idx)]] + (wrap (//.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) _ (..sum analyse idx valueC)))) @@ -353,7 +352,7 @@ (do @ [inferenceT (inference.record recordT) [inferredT membersA] (inference.general analyse inferenceT membersC)] - (wrap (//.product-analysis membersA))) + (wrap (//.tuple membersA))) _ (..product analyse membersC)))))) diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux index 069ec4e1a..5406ac20a 100644 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux @@ -1138,7 +1138,7 @@ (|> inputsA (list.zip2 (list/map analysis.text typesT)) (list/map (function (_ [type value]) - (analysis.product-analysis (list type value)))))) + (analysis.tuple (list type value)))))) (def: invoke::static Handler diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux index 3e59637a8..c9de46ac9 100644 --- a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux +++ b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux @@ -19,18 +19,22 @@ [// ["." reference]]]]) -(def: (path' pattern bodyC) - (-> Pattern (Operation Path) (Operation Path)) +(def: clean-up + (-> Path Path) + (|>> (#//.Seq #//.Pop))) + +(def: (path' pattern end? thenC) + (-> Pattern Bit (Operation Path) (Operation Path)) (case pattern (#analysis.Simple simple) (case simple #analysis.Unit - bodyC + thenC (^template [<from> <to>] (<from> value) (operation/map (|>> (#//.Seq (#//.Test (|> value <to>)))) - bodyC)) + thenC)) ([#analysis.Bit #//.Bit] [#analysis.Nat (<| #//.I64 .i64)] [#analysis.Int (<| #//.I64 .i64)] @@ -45,40 +49,33 @@ (n/+ (dec arity) register) register))))) //.with-new-local - bodyC) - - (#analysis.Complex _) - (case (analysis.variant-pattern pattern) - (#.Some [lefts right? value-pattern]) - (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right? - (#.Right lefts) - (#.Left lefts)))))) - (path' value-pattern bodyC)) - - #.None - (let [tuple (analysis.tuple-pattern pattern) - tuple/last (dec (list.size tuple))] - (list/fold (function (_ [tuple/idx tuple/member] thenC) - (case tuple/member - (#analysis.Simple #analysis.Unit) - thenC - - _ - (let [last? (n/= tuple/last tuple/idx)] - (|> (if (or last? - (is? bodyC thenC)) - thenC - (operation/map (|>> (#//.Seq #//.Pop)) thenC)) - (path' tuple/member) - (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if last? - (#.Right (dec tuple/idx)) - (#.Left tuple/idx))))))))))) - bodyC - (list.reverse (list.enumerate tuple))))))) + thenC) + + (#analysis.Complex (#analysis.Variant [lefts right? value-pattern])) + (<| (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right? + (#.Right lefts) + (#.Left lefts))))))) + (path' value-pattern end?) + (when (not end?) (operation/map ..clean-up)) + thenC) + + (#analysis.Complex (#analysis.Tuple tuple)) + (let [tuple::last (dec (list.size tuple))] + (list/fold (function (_ [tuple::lefts tuple::member] nextC) + (let [right? (n/= tuple::last tuple::lefts) + end?' (and end? right?)] + (<| (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if right? + (#.Right (dec tuple::lefts)) + (#.Left tuple::lefts))))))) + (path' tuple::member end?') + (when (not end?') (operation/map ..clean-up)) + nextC))) + thenC + (list.reverse (list.enumerate tuple)))))) (def: #export (path synthesize pattern bodyA) (-> Phase Pattern Analysis (Operation Path)) - (path' pattern (operation/map (|>> #//.Then) (synthesize bodyA)))) + (path' pattern true (operation/map (|>> #//.Then) (synthesize bodyA)))) (def: #export (weave leftP rightP) (-> Path Path Path) diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux b/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux index e7db982d8..cd57c1d29 100644 --- a/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux +++ b/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux @@ -43,10 +43,10 @@ (#//.Structure structure) (case structure - (#//.Variant variantS) + (#analysis.Variant variantS) (proper? (get@ #analysis.value variantS)) - (#//.Tuple membersS+) + (#analysis.Tuple membersS+) (list.every? proper? membersS+)) (#//.Control controlS) @@ -197,18 +197,18 @@ (case exprS (#//.Structure structureS) (case structureS - (#//.Variant variantS) + (#analysis.Variant variantS) (do maybe.Monad<Maybe> [valueS' (|> variantS (get@ #analysis.value) recur)] (wrap (|> variantS (set@ #analysis.value valueS') - #//.Variant + #analysis.Variant #//.Structure))) - (#//.Tuple membersS+) + (#analysis.Tuple membersS+) (|> membersS+ (monad.map maybe.Monad<Maybe> recur) - (maybe/map (|>> #//.Tuple #//.Structure)))) + (maybe/map (|>> #analysis.Tuple #//.Structure)))) (#//.Reference reference) (case reference diff --git a/stdlib/source/lux/compiler/default/reference.lux b/stdlib/source/lux/compiler/default/reference.lux index cde1f5b5c..b945c1327 100644 --- a/stdlib/source/lux/compiler/default/reference.lux +++ b/stdlib/source/lux/compiler/default/reference.lux @@ -77,3 +77,12 @@ (#Foreign foreign) (format "-" (%n foreign)))) + +(def: #export (%reference reference) + (Format Reference) + (case reference + (#Variable variable) + (%variable variable) + + (#Constant constant) + (%name constant))) |