aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/r/case.jvm.lux')
-rw-r--r--new-luxc/source/luxc/lang/translation/r/case.jvm.lux195
1 files changed, 0 insertions, 195 deletions
diff --git a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux b/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
deleted file mode 100644
index 42460b620..000000000
--- a/new-luxc/source/luxc/lang/translation/r/case.jvm.lux
+++ /dev/null
@@ -1,195 +0,0 @@
-(.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!)))))