From 196c1843d1a4a32ab92b9ba5c549933a5ce30c17 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Aug 2018 19:06:17 -0400 Subject: Fixes for pattern-matching/case synthesis & translation. --- stdlib/source/lux.lux | 10 +- .../source/lux/compiler/default/phase/analysis.lux | 133 ++++++--------------- .../lux/compiler/default/phase/analysis/case.lux | 10 +- .../default/phase/analysis/case/coverage.lux | 79 ++++++------ .../compiler/default/phase/analysis/structure.lux | 85 +++++++------ .../default/phase/extension/analysis/host.jvm.lux | 2 +- .../lux/compiler/default/phase/synthesis/case.lux | 67 +++++------ .../lux/compiler/default/phase/synthesis/loop.lux | 12 +- stdlib/source/lux/compiler/default/reference.lux | 9 ++ 9 files changed, 173 insertions(+), 234 deletions(-) (limited to 'stdlib') 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 [ ] - [(def: #export ( size tag value) - (-> Nat Tag ) - (let [left (function.constant (|>> #.Left #Sum )) - right (|>> #.Right #Sum )] - (if (last? size tag) - (list/fold left - (right value) - (list.indices (dec tag))) - (list/fold left - (case value - ( (#Sum _)) - ( value) - - _ - value) - (list.indices (inc tag))))))] - - [sum-analysis Analysis #Structure ..no-op] - [sum-pattern Pattern #Complex id] - ) - -(do-template [ ] - [(def: #export ( members) - (-> (Tuple ) ) - (case (list.reverse members) - #.Nil - ( #Unit) - - (#.Cons singleton #.Nil) - singleton - - (#.Cons last prevs) - (list/fold (function (_ left right) ( (#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 [ ] - [(def: #export ( value) - (-> (Tuple )) - (case value - ( (#Product left right)) - (#.Cons left ( right)) - - _ - (list value)))] - - [tuple Analysis #Structure] - [tuple-pattern Pattern #Complex] - ) - -(do-template [ ] - [(def: #export ( value) - (-> (Maybe (Variant ))) - (loop [lefts 0 - variantA value] - (case variantA - ( (#Sum (#.Left valueA))) - (case valueA - ( (#Sum _)) - (recur (inc lefts) valueA) - - _ - (#.Some {#lefts lefts - #right? #0 - #value valueA})) - - ( (#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 [ ] + [(template: #export ( content) + (.<| #Complex + + content))] + + [pattern/variant #..Variant] + [pattern/tuple #..Tuple] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Structure + + 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)] ["." /// (#+ 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 - [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 - [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) - (dict.put variant-idx value-coverage)))))))) + [lastC (determine lastP)] + (monad.fold ////.Monad + (function (_ leftP rightC) + (do ////.Monad + [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 + [value-coverage (determine value) + #let [idx (if right? + (inc lefts) + lefts)]] + (wrap (#Variant (if right? + (#.Some idx) + #.None) + (|> (dict.new number.Hash) + (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 - [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 [ ] ( _) @@ -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 [ ] ( value) (operation/map (|>> (#//.Seq (#//.Test (|> value )))) - 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 [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 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))) -- cgit v1.2.3