diff options
Diffstat (limited to 'lux-r/source/luxc/lang/translation/r/case.jvm.lux')
| -rw-r--r-- | lux-r/source/luxc/lang/translation/r/case.jvm.lux | 195 |
1 files changed, 195 insertions, 0 deletions
diff --git a/lux-r/source/luxc/lang/translation/r/case.jvm.lux b/lux-r/source/luxc/lang/translation/r/case.jvm.lux new file mode 100644 index 000000000..42460b620 --- /dev/null +++ b/lux-r/source/luxc/lang/translation/r/case.jvm.lux @@ -0,0 +1,195 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data [number] + [text] + text/format + (coll [list "list/" Functor<List> Fold<List>] + (set ["set" unordered #+ Set]))) + [macro #+ "meta/" Monad<Meta>] + (macro [code])) + (luxc [lang] + (lang [".L" variable #+ Register Variable] + ["ls" synthesis #+ Synthesis Path] + (host [r #+ Expression SVar @@]))) + [//] + (// [".T" runtime] + [".T" primitive] + [".T" reference])) + +(def: #export (translate-let translate register valueS bodyS) + (-> (-> Synthesis (Meta Expression)) Register Synthesis Synthesis + (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS) + bodyO (translate bodyS) + #let [$register (referenceT.variable register)]] + (wrap (r.block + ($_ r.then + (r.set! $register valueO) + bodyO))))) + +(def: #export (translate-record-get translate valueS pathP) + (-> (-> Synthesis (Meta Expression)) Synthesis (List [Nat Bit]) + (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 (r.int (:coerce Int idx))))) + valueO + pathP)))) + +(def: #export (translate-if testO thenO elseO) + (-> Expression Expression Expression Expression) + (r.if testO thenO elseO)) + +(def: $savepoint (r.var "lux_pm_cursor_savepoint")) +(def: $cursor (r.var "lux_pm_cursor")) + +(def: top r.length) +(def: next (|>> r.length (r.+ (r.int 1)))) +(def: (push! value var) + (-> Expression SVar Expression) + (r.set-nth! (next (@@ var)) value var)) +(def: (pop! var) + (-> SVar Expression) + (r.set-nth! (top (@@ var)) r.null var)) + +(def: (push-cursor! value) + (-> Expression Expression) + (push! value $cursor)) + +(def: save-cursor! + Expression + (push! (r.slice (r.float 1.0) (r.length (@@ $cursor)) (@@ $cursor)) + $savepoint)) + +(def: restore-cursor! + Expression + (r.set! $cursor (r.nth (top (@@ $savepoint)) (@@ $savepoint)))) + +(def: cursor-top + Expression + (|> (@@ $cursor) (r.nth (top (@@ $cursor))))) + +(def: pop-cursor! + Expression + (pop! $cursor)) + +(def: pm-error (r.string "PM-ERROR")) + +(def: fail-pm! (r.stop pm-error)) + +(def: $temp (r.var "lux_pm_temp")) + +(exception: #export (Unrecognized-Path {message Text}) + message) + +(def: $alt_error (r.var "alt_error")) + +(def: (pm-catch handler) + (-> Expression Expression) + (r.function (list $alt_error) + (r.if (|> (@@ $alt_error) (r.= pm-error)) + handler + (r.stop (@@ $alt_error))))) + +(def: (translate-pattern-matching' translate pathP) + (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) + (case pathP + (^code ("lux case exec" (~ bodyS))) + (do macro.Monad<Meta> + [bodyO (translate bodyS)] + (wrap bodyO)) + + (^code ("lux case pop")) + (meta/wrap pop-cursor!) + + (^code ("lux case bind" (~ [_ (#.Nat register)]))) + (meta/wrap (r.set! (referenceT.variable register) cursor-top)) + + (^template [<tag> <format>] + [_ (<tag> value)] + (meta/wrap (r.when (r.not (r.= (|> value <format>) cursor-top)) + fail-pm!))) + ([#.Bit r.bool] + [#.Frac r.float] + [#.Text r.string]) + + (^template [<tag> <format>] + [_ (<tag> value)] + (meta/wrap (r.when (r.not (runtimeT.int//= (|> value <format>) cursor-top)) + fail-pm!))) + ([#.Nat (<| runtimeT.int (:coerce Int))] + [#.Int runtimeT.int] + [#.Rev (<| runtimeT.int (:coerce Int))]) + + (^template [<pm> <getter>] + (^code (<pm> (~ [_ (#.Nat idx)]))) + (meta/wrap (push-cursor! (<getter> cursor-top (r.int (:coerce 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 ($_ r.then + (r.set! $temp (runtimeT.sum//get cursor-top (r.int (:coerce Int idx)) <flag>)) + (r.if (r.= r.null (@@ $temp)) + fail-pm! + (push-cursor! (@@ $temp)))))) + (["lux case variant left" r.null] + ["lux case variant right" (r.string "")]) + + (^code ("lux case seq" (~ leftP) (~ rightP))) + (do macro.Monad<Meta> + [leftO (translate-pattern-matching' translate leftP) + rightO (translate-pattern-matching' translate rightP)] + (wrap ($_ r.then + 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 (r.try ($_ r.then + save-cursor! + leftO) + #.None + (#.Some (pm-catch ($_ r.then + restore-cursor! + rightO))) + #.None))) + + _ + (lang.throw Unrecognized-Path (%code pathP)) + )) + +(def: (translate-pattern-matching translate pathP) + (-> (-> Synthesis (Meta Expression)) Path (Meta Expression)) + (do macro.Monad<Meta> + [pattern-matching! (translate-pattern-matching' translate pathP)] + (wrap (r.try pattern-matching! + #.None + (#.Some (pm-catch (r.stop (r.string "Invalid expression for pattern-matching.")))) + #.None)))) + +(def: (initialize-pattern-matching! stack-init) + (-> Expression Expression) + ($_ r.then + (r.set! $cursor (r.list (list stack-init))) + (r.set! $savepoint (r.list (list))))) + +(def: #export (translate-case translate valueS pathP) + (-> (-> Synthesis (Meta Expression)) Synthesis Path (Meta Expression)) + (do macro.Monad<Meta> + [valueO (translate valueS) + pattern-matching! (translate-pattern-matching translate pathP)] + (wrap (r.block + ($_ r.then + (initialize-pattern-matching! valueO) + pattern-matching!))))) |