diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/generation/python/case.lux | 218 |
1 files changed, 218 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/python/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/python/case.lux new file mode 100644 index 000000000..82a96836d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/python/case.lux @@ -0,0 +1,218 @@ +(.module: + [lux (#- case let if) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." text + format] + [collection + ["." list ("#@." functor fold)] + ["." set]]] + [host + ["_" python (#+ Expression SVar Statement)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." reference] + ["#." primitive] + ["#/" // + ["#." reference] + ["#/" // ("#@." monad) + [synthesis + ["." case]] + ["#/" // #_ + ["." reference (#+ Register)] + ["#." synthesis (#+ Synthesis Path)]]]]]) + +(def: #export register + (///reference.local _.var)) + +(def: #export capture + (///reference.foreign _.var)) + +(def: #export (let generate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation (Expression Any))) + (do ////.monad + [valueO (generate valueS) + bodyO (generate bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. + (wrap (_.apply/* (_.lambda (list (..register register)) + bodyO) + (list valueO))))) + +(def: #export (record-get generate valueS pathP) + (-> Phase Synthesis (List [Nat Bit]) + (Operation (Expression Any))) + (do ////.monad + [valueO (generate valueS)] + (wrap (list@fold (function (_ [idx tail?] source) + (.let [method (.if tail? + //runtime.product//right + //runtime.product//left)] + (method source (_.int (.int idx))))) + valueO + pathP)))) + +(def: #export (if generate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation (Expression Any))) + (do ////.monad + [testO (generate testS) + thenO (generate thenS) + elseO (generate elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) + +(def: (push-cursor! value) + (-> (Expression Any) (Statement Any)) + (_.statement (|> @cursor (_.do "append" (list value))))) + +(def: peek-and-pop-cursor + (Expression Any) + (|> @cursor (_.do "pop" (list)))) + +(def: pop-cursor! + (Statement Any) + (_.statement ..peek-and-pop-cursor)) + +(def: peek-cursor + (Expression Any) + (_.nth (_.int -1) @cursor)) + +(def: save-cursor! + (Statement Any) + (.let [cursor (_.slice-from (_.int +0) @cursor)] + (_.statement (|> @savepoint (_.do "append" (list cursor)))))) + +(def: restore-cursor! + (Statement Any) + (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) + +(def: fail-pm! _.break) + +(exception: #export unrecognized-path) + +(def: (multi-pop-cursor! pops) + (-> Nat (Statement Any)) + (_.delete (_.slice-from (_.int (i/* -1 (.int pops))) @cursor))) + +(def: (pattern-matching' generate pathP) + (-> Phase Path (Operation (Statement Any))) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (do ////.monad + [body! (generate bodyS)] + (wrap (_.return body!))) + + #/////synthesis.Pop + (////@wrap pop-cursor!) + + (#/////synthesis.Bind register) + (////@wrap (_.set (list (..register register)) ..peek-cursor)) + + (^template [<tag> <format>] + (^ (<tag> value)) + (////@wrap (_.when (|> value <format> (_.= ..peek-cursor) _.not) + fail-pm!))) + ([/////synthesis.path/bit //primitive.bit] + [/////synthesis.path/i64 //primitive.i64] + [/////synthesis.path/f64 //primitive.f64] + [/////synthesis.path/text //primitive.text]) + + (^template [<pm> <flag> <prep>] + (^ (<pm> idx)) + (////@wrap ($_ _.then + (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek-cursor <flag>))) + (_.if (_.= _.none @temp) + fail-pm! + (push-cursor! @temp))))) + ([/////synthesis.side/left _.none (<|)] + [/////synthesis.side/right (_.string "") inc]) + + (^template [<pm> <getter> <prep>] + (^ (<pm> idx)) + (////@wrap (|> idx <prep> .int _.int (<getter> ..peek-cursor) push-cursor!))) + ([/////synthesis.member/left //runtime.product//left (<|)] + [/////synthesis.member/right //runtime.product//right inc]) + + (^ ($_ /////synthesis.path/seq + (#/////synthesis.Bind register) + #/////synthesis.Pop + thenP)) + (do ////.monad + [then! (pattern-matching' generate thenP)] + (////@wrap ($_ _.then + (_.set (list (..register register)) ..peek-and-pop-cursor) + then!))) + + (^ ($_ /////synthesis.path/seq + #/////synthesis.Pop + #/////synthesis.Pop + nextP)) + (.let [[extra-pops nextP'] (case.count-pops nextP)] + (do ////.monad + [next! (pattern-matching' generate nextP')] + (////@wrap ($_ _.then + (multi-pop-cursor! (n/+ 2 extra-pops)) + next!)))) + + (^template [<tag> <computation>] + (^ (<tag> leftP rightP)) + (do ////.monad + [left! (pattern-matching' generate leftP) + right! (pattern-matching' generate rightP)] + (wrap <computation>))) + ([/////synthesis.path/seq (_.then left! right!)] + [/////synthesis.path/alt ($_ _.then + (_.while (_.bool true) + ($_ _.then + ..save-cursor! + left!)) + ($_ _.then + ..restore-cursor! + right!))]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation (Statement Any))) + (do ////.monad + [pattern-matching! (pattern-matching' generate pathP)] + (wrap ($_ _.then + (_.while (_.bool true) + pattern-matching!) + (_.raise (_.Exception/1 (_.string case.pattern-matching-error))))))) + +(def: (gensym prefix) + (-> Text (Operation SVar)) + (:: ////.monad map (|>> %n (format prefix) _.var) ///.next)) + +(def: #export (case generate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation (Expression Any))) + (do ////.monad + [initG (generate valueS) + pattern-matching! (pattern-matching generate pathP) + @case (..gensym "case") + @init (..gensym "init") + #let [@dependencies+ (|> (case.storage pathP) + (get@ #case.dependencies) + set.to-list + (list@map (function (_ variable) + (.case variable + (#reference.Local register) + (..register register) + + (#reference.Foreign register) + (..capture register)))))] + _ (///.save! ["" (_.code @case)] + (_.def @case (list& @init @dependencies+) + ($_ _.then + (_.set (list @cursor) (_.list (list @init))) + (_.set (list @savepoint) (_.list (list))) + pattern-matching!)))] + (wrap (_.apply/* @case (list& initG @dependencies+))))) |