aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/lua/case.jvm.lux
diff options
context:
space:
mode:
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.lux174
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))))))