diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/synthesis/case.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/synthesis/case.lux | 25 |
1 files changed, 17 insertions, 8 deletions
diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux index e66bbf3a8..8bc1e43f9 100644 --- a/new-luxc/source/luxc/lang/synthesis/case.lux +++ b/new-luxc/source/luxc/lang/synthesis/case.lux @@ -9,8 +9,8 @@ (luxc (lang ["la" analysis] ["ls" synthesis]))) -(def: #export (path pattern) - (-> la;Pattern ls;Path) +(def: #export (path outer-arity pattern) + (-> ls;Arity la;Pattern ls;Path) (case pattern (^code ("lux case tuple" [(~@ membersP)])) (case (list;reverse membersP) @@ -18,7 +18,7 @@ (' ("lux case pop")) (#;Cons singletonP #;Nil) - (path singletonP) + (path outer-arity singletonP) (#;Cons lastP prevsP) (let [length (list;size membersP) @@ -26,10 +26,10 @@ [_ tuple-path] (list/fold (function [current-pattern [current-idx next-path]] [(n.dec current-idx) (` ("lux case seq" - ("lux case tuple left" (~ (code;nat current-idx)) (~ (path current-pattern))) + ("lux case tuple left" (~ (code;nat current-idx)) (~ (path outer-arity current-pattern))) (~ next-path)))]) [(n.dec last-idx) - (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))] + (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path outer-arity lastP))))] prevsP)] (` ("lux case seq" (~ tuple-path) @@ -38,12 +38,21 @@ (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) (` ("lux case seq" (~ (if (n.= (n.dec num-tags) tag) - (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP)))) - (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP)))))) + (` ("lux case variant right" (~ (code;nat tag)) (~ (path outer-arity memberP)))) + (` ("lux case variant left" (~ (code;nat tag)) (~ (path outer-arity memberP)))))) + ("lux case pop"))) + + (^code ("lux case bind" (~ [_ (#;Nat register)]))) + (` ("lux case seq" + ("lux case bind" (~ (if (n.> +1 outer-arity) + (code;nat (n.+ (n.dec outer-arity) register)) + (code;nat register)))) ("lux case pop"))) _ - pattern)) + (` ("lux case seq" + (~ pattern) + ("lux case pop"))))) (def: #export (weave leftP rightP) (-> ls;Path ls;Path ls;Path) |