diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/lua/case.jvm.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/lua/case.jvm.lux | 174 |
1 files changed, 174 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux b/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux new file mode 100644 index 000000000..bce4d7bff --- /dev/null +++ b/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux @@ -0,0 +1,174 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data text/format + (coll [list "list/" Fold<List>])) + [macro #+ "meta/" Monad<Meta>]) + (luxc [lang] + (lang ["ls" synthesis] + (host [lua #+ Lua Expression Statement]))) + [//] + (// [".T" runtime] + [".T" primitive] + [".T" reference])) + +(def: (expression-block body) + (-> Statement Expression) + (lua.apply (lua.function (list) + body) + (list))) + +(def: #export (translate-let translate register valueS bodyS) + (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis + (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (expression-block + (lua.block! (list (lua.local! (referenceT.variable register) (#.Some valueO)) + (lua.return! bodyO))))))) + +(def: #export (translate-record-get translate valueS path) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bool]) + (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS)] + (wrap (list/fold (function [[idx tail?] source] + (let [method (if tail? + runtimeT.product//right + runtimeT.product//left)] + (method source (lua.int (:! Int idx))))) + valueO + path)))) + +(def: #export (translate-if testO thenO elseO) + (-> Expression Expression Expression Expression) + (expression-block + (lua.if! testO + (lua.return! thenO) + (lua.return! elseO)))) + +(def: savepoint + Expression + "pm_cursor_savepoint") + +(def: cursor + Expression + "pm_cursor") + +(def: (push-cursor! value) + (-> Expression Expression) + (lua.apply "table.insert" (list cursor value))) + +(def: save-cursor! + Statement + (lua.apply "table.insert" (list savepoint (runtimeT.array//copy cursor)))) + +(def: restore-cursor! + Statement + (lua.set! cursor (lua.apply "table.remove" (list savepoint)))) + +(def: cursor-top + Expression + (lua.nth (lua.length cursor) cursor)) + +(def: pop-cursor! + Statement + (lua.apply "table.remove" (list cursor))) + +(def: pm-error + Expression + (lua.string "PM-ERROR")) + +(exception: #export Unrecognized-Path) + +(def: (translate-pattern-matching' translate path) + (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) + (case path + (^code ("lux case exec" (~ bodyS))) + (do macro.Monad<Meta> + [bodyO (translate bodyS)] + (wrap (lua.return! bodyO))) + + (^code ("lux case pop")) + (meta/wrap pop-cursor!) + + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + (meta/wrap (lua.local! (referenceT.variable register) (#.Some cursor-top))) + + (^template [<tag> <format>] + [_ (<tag> value)] + (meta/wrap (lua.when! (lua.not (lua.= (|> value <format>) cursor-top)) + (lua.return! pm-error)))) + ([#.Nat (<| lua.int (:! Int))] + [#.Int lua.int] + [#.Deg (<| lua.int (:! Int))] + [#.Bool lua.bool] + [#.Frac lua.float] + [#.Text lua.string]) + + (^template [<pm> <getter>] + (^code (<pm> (~ [_ (#.Nat idx)]))) + (meta/wrap (push-cursor! (<getter> cursor-top (lua.int (:! Int idx)))))) + (["lux case tuple left" runtimeT.product//left] + ["lux case tuple right" runtimeT.product//right]) + + (^template [<pm> <flag>] + (^code (<pm> (~ [_ (#.Nat idx)]))) + (meta/wrap (lua.block! (list (lua.set! "temp" (runtimeT.sum//get cursor-top (lua.int (:! Int idx)) <flag>)) + (lua.if! (lua.not (lua.= lua.nil "temp")) + (push-cursor! "temp") + (lua.return! pm-error)))))) + (["lux case variant left" lua.nil] + ["lux case variant right" (lua.string "")]) + + (^code ("lux case seq" (~ leftP) (~ rightP))) + (do macro.Monad<Meta> + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap (lua.block! (list leftO rightO)))) + + (^code ("lux case alt" (~ leftP) (~ rightP))) + (do macro.Monad<Meta> + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap (lua.block! (list (format "local alt_success, alt_value = " (lua.apply "pcall" (list (lua.function (list) + (lua.block! (list save-cursor! + leftO))))) ";") + (lua.if! "alt_success" + (lua.return! "alt_value") + (lua.if! (lua.= pm-error "alt_value") + (lua.block! (list restore-cursor! + rightO)) + (lua.error "alt_value"))))))) + + _ + (lang.throw Unrecognized-Path (%code path)) + )) + +(def: (translate-pattern-matching translate path) + (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) + (do macro.Monad<Meta> + [pattern-matching (translate-pattern-matching' translate path)] + (wrap (lua.block! (list (format "local success, value = pcall(function () " pattern-matching " end);") + (lua.if! "success" + (lua.return! "value") + (lua.if! (lua.= pm-error "value") + (lua.error (lua.string "Invalid expression for pattern-matching.")) + (lua.error "value")))))))) + +(def: (initialize-pattern-matching stack-init) + (-> Expression Statement) + (lua.block! (list (lua.local! "temp" #.None) + (lua.local! cursor (#.Some (lua.array (list stack-init)))) + (lua.local! savepoint (#.Some (lua.array (list))))))) + +(def: #export (translate-case translate valueS path) + (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS) + pattern-matching (translate-pattern-matching translate path)] + (wrap (expression-block + (lua.block! (list (initialize-pattern-matching valueO) + pattern-matching)))))) |