diff options
Diffstat (limited to 'lux-r/source/luxc/lang/translation/r/runtime.jvm.lux')
| -rw-r--r-- | lux-r/source/luxc/lang/translation/r/runtime.jvm.lux | 802 |
1 files changed, 802 insertions, 0 deletions
diff --git a/lux-r/source/luxc/lang/translation/r/runtime.jvm.lux b/lux-r/source/luxc/lang/translation/r/runtime.jvm.lux new file mode 100644 index 000000000..d641041d2 --- /dev/null +++ b/lux-r/source/luxc/lang/translation/r/runtime.jvm.lux @@ -0,0 +1,802 @@ +(.module: + lux + (lux (control ["p" parser "p/" Monad<Parser>] + [monad #+ do]) + (data [bit] + [number (#+ hex) ("int/" Interval<Int>)] + text/format + (coll [list "list/" Monad<List>])) + [macro] + (macro [code] + ["s" syntax #+ syntax:]) + [io #+ Process]) + [//] + (luxc [lang] + (lang (host [r #+ SVar Expression @@])))) + +(def: prefix Text "LuxRuntime") + +(def: #export unit Expression (r.string //.unit)) + +(def: full-32 (hex "+FFFFFFFF")) +(def: half-32 (hex "+7FFFFFFF")) +(def: post-32 (hex "+100000000")) + +(def: (cap-32 input) + (-> Nat Int) + (cond (n/> full-32 input) + (|> input (bit.and full-32) cap-32) + + (n/> half-32 input) + (|> post-32 (n/- input) .int (i/* -1)) + + ## else + (.int input))) + +(def: high-32 (bit.logical-right-shift +32)) +(def: low-32 (|>> (bit.and (hex "+FFFFFFFF")))) + +(def: #export (int value) + (-> Int Expression) + (let [value (.nat value) + high (|> value ..high-32 cap-32) + low (|> value ..low-32 cap-32)] + (r.named-list (list [//.int-high-field (r.int high)] + [//.int-low-field (r.int low)])))) + +(def: (flag value) + (-> Bit Expression) + (if value + (r.string "") + r.null)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Expression) + (r.named-list (list [//.variant-tag-field tag] + [//.variant-flag-field last?] + [//.variant-value-field value]))) + +(def: #export (variant tag last? value) + (-> Nat Bit Expression Expression) + (variant' (r.int (.int tag)) + (flag last?) + value)) + +(def: #export none + Expression + (variant +0 #0 unit)) + +(def: #export some + (-> Expression Expression) + (variant +1 #1)) + +(def: #export left + (-> Expression Expression) + (variant +0 #0)) + +(def: #export right + (-> Expression Expression) + (variant +1 #1)) + +(type: Runtime Expression) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.seq s.local-identifier (p/wrap (list))) + (s.form (p.seq s.local-identifier (p.some s.local-identifier))))) + +(syntax: (runtime: {[name args] declaration} + definition) + (let [implementation (code.local-identifier (format "@@" name)) + runtime (format prefix "__" (lang.normalize-name name)) + $runtime (` (r.var (~ (code.text runtime)))) + @runtime (` (@@ (~ $runtime))) + argsC+ (list/map code.local-identifier args) + argsLC+ (list/map (|>> lang.normalize-name (format "LRV__") code.text (~) (r.var) (`)) + args) + declaration (` ((~ (code.local-identifier name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` r.Expression))) + r.Expression))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (r.apply (list (~+ argsC+)) (~ @runtime))))))) + (` (def: (~ implementation) + r.Expression + (~ (case argsC+ + #.Nil + (` (r.set! (~ $runtime) (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (r.set! (~ $runtime) + (r.function (list (~+ argsLC+)) + (~ definition))))))))))))) + +(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-identifier var) + (` (r.var (~ (code.text (format "LRV__" (lang.normalize-name var))))))))) + list/join))] + (~ body)))))) + +(def: high-shift (r.bit-shl (r.int 32))) + +(runtime: f2^32 (|> (r.int 2) (r.** (r.int 32)))) +(runtime: f2^63 (|> (r.int 2) (r.** (r.int 63)))) + +(def: (as-double value) + (-> Expression Expression) + (r.apply (list value) (r.global "as.double"))) + +(def: (as-integer value) + (-> Expression Expression) + (r.apply (list value) (r.global "as.integer"))) + +(runtime: (int//unsigned-low input) + (with-vars [low] + ($_ r.then + (r.set! low (|> (@@ input) (r.nth (r.string //.int-low-field)))) + (r.if (|> (@@ low) (r.>= (r.int 0))) + (@@ low) + (|> (@@ low) (r.+ f2^32)))))) + +(runtime: (int//to-float input) + (let [high (|> (@@ input) + (r.nth (r.string //.int-high-field)) + high-shift) + low (|> (@@ input) + int//unsigned-low)] + (|> high (r.+ low) as-double))) + +(runtime: (int//new high low) + (r.named-list (list [//.int-high-field (as-integer (@@ high))] + [//.int-low-field (as-integer (@@ low))]))) + +(template [<name> <value>] + [(runtime: <name> + (..int <value>))] + + [int//zero 0] + [int//one 1] + [int//min int/bottom] + [int//max int/top] + ) + +(def: #export int64-high (r.nth (r.string //.int-high-field))) +(def: #export int64-low (r.nth (r.string //.int-low-field))) + +(runtime: (bit//not input) + (int//new (|> (@@ input) int64-high r.bit-not) + (|> (@@ input) int64-low r.bit-not))) + +(runtime: (int//+ param subject) + (with-vars [sH sL pH pL + x00 x16 x32 x48] + ($_ r.then + (r.set! sH (|> (@@ subject) int64-high)) + (r.set! sL (|> (@@ subject) int64-low)) + (r.set! pH (|> (@@ param) int64-high)) + (r.set! pL (|> (@@ param) int64-low)) + (let [bits16 (r.code "0xFFFF") + move-top-16 (r.bit-shl (r.int 16)) + top-16 (r.bit-ushr (r.int 16)) + bottom-16 (r.bit-and bits16) + split-16 (function (_ source) + [(|> source top-16) + (|> source bottom-16)]) + split-int (function (_ high low) + [(split-16 high) + (split-16 low)]) + + [[s48 s32] [s16 s00]] (split-int (@@ sH) (@@ sL)) + [[p48 p32] [p16 p00]] (split-int (@@ pH) (@@ pL)) + new-half (function (_ top bottom) + (|> top bottom-16 move-top-16 + (r.bit-or (bottom-16 bottom))))] + ($_ r.then + (r.set! x00 (|> s00 (r.+ p00))) + (r.set! x16 (|> (@@ x00) top-16 (r.+ s16) (r.+ p16))) + (r.set! x32 (|> (@@ x16) top-16 (r.+ s32) (r.+ p32))) + (r.set! x48 (|> (@@ x32) top-16 (r.+ s48) (r.+ p48))) + (int//new (new-half (@@ x48) (@@ x32)) + (new-half (@@ x16) (@@ x00)))))))) + +(runtime: (int//= reference sample) + (let [n/a? (function (_ value) + (r.apply (list value) (r.global "is.na"))) + isTRUE? (function (_ value) + (r.apply (list value) (r.global "isTRUE"))) + comparison (: (-> (-> Expression Expression) Expression) + (function (_ field) + (|> (|> (field (@@ sample)) (r.= (field (@@ reference)))) + (r.or (|> (n/a? (field (@@ sample))) + (r.and (n/a? (field (@@ reference)))))))))] + (|> (comparison int64-high) + (r.and (comparison int64-low)) + isTRUE?))) + +(runtime: (int//negate input) + (r.if (|> (@@ input) (int//= int//min)) + int//min + (|> (@@ input) bit//not (int//+ int//one)))) + +(runtime: int//-one + (int//negate int//one)) + +(runtime: (int//- param subject) + (int//+ (int//negate (@@ param)) (@@ subject))) + +(runtime: (int//< reference sample) + (with-vars [r-? s-?] + ($_ r.then + (r.set! s-? (|> (@@ sample) int64-high (r.< (r.int 0)))) + (r.set! r-? (|> (@@ reference) int64-high (r.< (r.int 0)))) + (|> (|> (@@ s-?) (r.and (r.not (@@ r-?)))) + (r.or (|> (r.not (@@ s-?)) (r.and (@@ r-?)) r.not)) + (r.or (|> (@@ sample) + (int//- (@@ reference)) + int64-high + (r.< (r.int 0)))))))) + +(runtime: (int//from-float input) + (r.cond (list [(r.apply (list (@@ input)) (r.global "is.nan")) + int//zero] + [(|> (@@ input) (r.<= (r.negate f2^63))) + int//min] + [(|> (@@ input) (r.+ (r.float 1.0)) (r.>= f2^63)) + int//max] + [(|> (@@ input) (r.< (r.float 0.0))) + (|> (@@ input) r.negate int//from-float int//negate)]) + (int//new (|> (@@ input) (r./ f2^32)) + (|> (@@ input) (r.%% f2^32))))) + +(runtime: (int//* param subject) + (with-vars [sH sL pH pL + x00 x16 x32 x48] + ($_ r.then + (r.set! sH (|> (@@ subject) int64-high)) + (r.set! pH (|> (@@ param) int64-high)) + (let [negative-subject? (|> (@@ sH) (r.< (r.int 0))) + negative-param? (|> (@@ pH) (r.< (r.int 0)))] + (r.cond (list [negative-subject? + (r.if negative-param? + (int//* (int//negate (@@ param)) + (int//negate (@@ subject))) + (int//negate (int//* (@@ param) + (int//negate (@@ subject)))))] + + [negative-param? + (int//negate (int//* (int//negate (@@ param)) + (@@ subject)))]) + ($_ r.then + (r.set! sL (|> (@@ subject) int64-low)) + (r.set! pL (|> (@@ param) int64-low)) + (let [bits16 (r.code "0xFFFF") + move-top-16 (r.bit-shl (r.int 16)) + top-16 (r.bit-ushr (r.int 16)) + bottom-16 (r.bit-and bits16) + split-16 (function (_ source) + [(|> source top-16) + (|> source bottom-16)]) + split-int (function (_ high low) + [(split-16 high) + (split-16 low)]) + new-half (function (_ top bottom) + (|> top bottom-16 move-top-16 + (r.bit-or (bottom-16 bottom)))) + x16-top (|> (@@ x16) top-16) + x32-top (|> (@@ x32) top-16)] + (with-vars [s48 s32 s16 s00 + p48 p32 p16 p00] + (let [[[_s48 _s32] [_s16 _s00]] (split-int (@@ sH) (@@ sL)) + [[_p48 _p32] [_p16 _p00]] (split-int (@@ pH) (@@ pL)) + set-subject-chunks! ($_ r.then (r.set! s48 _s48) (r.set! s32 _s32) (r.set! s16 _s16) (r.set! s00 _s00)) + set-param-chunks! ($_ r.then (r.set! p48 _p48) (r.set! p32 _p32) (r.set! p16 _p16) (r.set! p00 _p00))] + ($_ r.then + set-subject-chunks! + set-param-chunks! + (r.set! x00 (|> (@@ s00) (r.* (@@ p00)))) + (r.set! x16 (|> (@@ x00) top-16 (r.+ (|> (@@ s16) (r.* (@@ p00)))))) + (r.set! x32 x16-top) + (r.set! x16 (|> (@@ x16) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p16)))))) + (r.set! x32 (|> (@@ x32) (r.+ x16-top) (r.+ (|> (@@ s32) (r.* (@@ p00)))))) + (r.set! x48 x32-top) + (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s16) (r.* (@@ p16)))))) + (r.set! x48 (|> (@@ x48) (r.+ x32-top))) + (r.set! x32 (|> (@@ x32) bottom-16 (r.+ (|> (@@ s00) (r.* (@@ p32)))))) + (r.set! x48 (|> (@@ x48) (r.+ x32-top) + (r.+ (|> (@@ s48) (r.* (@@ p00)))) + (r.+ (|> (@@ s32) (r.* (@@ p16)))) + (r.+ (|> (@@ s16) (r.* (@@ p32)))) + (r.+ (|> (@@ s00) (r.* (@@ p48)))))) + (int//new (new-half (@@ x48) (@@ x32)) + (new-half (@@ x16) (@@ x00)))))) + ))))))) + +(def: (limit-shift! shift) + (-> SVar Expression) + (r.set! shift (|> (@@ shift) (r.bit-and (r.int 63))))) + +(def: (no-shift-clause shift input) + (-> SVar SVar [Expression Expression]) + [(|> (@@ shift) (r.= (r.int 0))) + (@@ input)]) + +(runtime: (bit//left-shift shift input) + ($_ r.then + (limit-shift! shift) + (r.cond (list (no-shift-clause shift input) + [(|> (@@ shift) (r.< (r.int 32))) + (let [mid (|> (int64-low (@@ input)) (r.bit-ushr (|> (r.int 32) (r.- (@@ shift))))) + high (|> (int64-high (@@ input)) + (r.bit-shl (@@ shift)) + (r.bit-or mid)) + low (|> (int64-low (@@ input)) + (r.bit-shl (@@ shift)))] + (int//new high low))]) + (let [high (|> (int64-high (@@ input)) + (r.bit-shl (|> (@@ shift) (r.- (r.int 32)))))] + (int//new high (r.int 0)))))) + +(runtime: (bit//arithmetic-right-shift-32 shift input) + (let [top-bit (|> (@@ input) (r.bit-and (r.int (hex "80000000"))))] + (|> (@@ input) + (r.bit-ushr (@@ shift)) + (r.bit-or top-bit)))) + +(runtime: (bit//arithmetic-right-shift shift input) + ($_ r.then + (limit-shift! shift) + (r.cond (list (no-shift-clause shift input) + [(|> (@@ shift) (r.< (r.int 32))) + (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift))))) + high (|> (int64-high (@@ input)) + (bit//arithmetic-right-shift-32 (@@ shift))) + low (|> (int64-low (@@ input)) + (r.bit-ushr (@@ shift)) + (r.bit-or mid))] + (int//new high low))]) + (let [low (|> (int64-high (@@ input)) + (bit//arithmetic-right-shift-32 (|> (@@ shift) (r.- (r.int 32))))) + high (r.if (|> (int64-high (@@ input)) (r.>= (r.int 0))) + (r.int 0) + (r.int -1))] + (int//new high low))))) + +(runtime: (int/// param subject) + (let [negative? (|>> (int//< int//zero)) + valid-division-check [(|> (@@ param) (int//= int//zero)) + (r.stop (r.string "Cannot divide by zero!"))] + short-circuit-check [(|> (@@ subject) (int//= int//zero)) + int//zero]] + (r.cond (list valid-division-check + short-circuit-check + + [(|> (@@ subject) (int//= int//min)) + (r.cond (list [(|> (|> (@@ param) (int//= int//one)) + (r.or (|> (@@ param) (int//= int//-one)))) + int//min] + [(|> (@@ param) (int//= int//min)) + int//one]) + (with-vars [approximation] + ($_ r.then + (r.set! approximation + (|> (@@ subject) + (bit//arithmetic-right-shift (r.int 1)) + (int/// (@@ param)) + (bit//left-shift (r.int 1)))) + (r.if (|> (@@ approximation) (int//= int//zero)) + (r.if (negative? (@@ param)) + int//one + int//-one) + (let [remainder (int//- (int//* (@@ param) (@@ approximation)) + (@@ subject))] + (|> remainder + (int/// (@@ param)) + (int//+ (@@ approximation))))))))] + [(|> (@@ param) (int//= int//min)) + int//zero] + + [(negative? (@@ subject)) + (r.if (negative? (@@ param)) + (|> (int//negate (@@ subject)) + (int/// (int//negate (@@ param)))) + (|> (int//negate (@@ subject)) + (int/// (@@ param)) + int//negate))] + + [(negative? (@@ param)) + (|> (@@ param) + int//negate + (int/// (@@ subject)) + int//negate)]) + (with-vars [result remainder approximate approximate-result log2 approximate-remainder] + ($_ r.then + (r.set! result int//zero) + (r.set! remainder (@@ subject)) + (r.while (|> (|> (@@ remainder) (int//< (@@ param))) + (r.or (|> (@@ remainder) (int//= (@@ param))))) + (let [calc-rough-estimate (r.apply (list (|> (int//to-float (@@ remainder)) (r./ (int//to-float (@@ param))))) + (r.global "floor")) + calc-approximate-result (int//from-float (@@ approximate)) + calc-approximate-remainder (|> (@@ approximate-result) (int//* (@@ param))) + delta (r.if (|> (r.float 48.0) (r.<= (@@ log2))) + (r.float 1.0) + (r.** (|> (@@ log2) (r.- (r.float 48.0))) + (r.float 2.0)))] + ($_ r.then + (r.set! approximate (r.apply (list (r.float 1.0) calc-rough-estimate) + (r.global "max"))) + (r.set! log2 (let [log (function (_ input) + (r.apply (list input) (r.global "log")))] + (r.apply (list (|> (log (r.int 2)) + (r./ (log (@@ approximate))))) + (r.global "ceil")))) + (r.set! approximate-result calc-approximate-result) + (r.set! approximate-remainder calc-approximate-remainder) + (r.while (|> (negative? (@@ approximate-remainder)) + (r.or (|> (@@ approximate-remainder) (int//< (@@ remainder))))) + ($_ r.then + (r.set! approximate (|> delta (r.- (@@ approximate)))) + (r.set! approximate-result calc-approximate-result) + (r.set! approximate-remainder calc-approximate-remainder))) + (r.set! result (|> (r.if (|> (@@ approximate-result) (int//= int//zero)) + int//one + (@@ approximate-result)) + (int//+ (@@ result)))) + (r.set! remainder (|> (@@ remainder) (int//- (@@ approximate-remainder))))))) + (@@ result))) + ))) + +(runtime: (int//% param subject) + (let [flat (|> (@@ subject) (int/// (@@ param)) (int//* (@@ param)))] + (|> (@@ subject) (int//- flat)))) + +(def: runtime//int + Runtime + ($_ r.then + @@int//zero + @@int//one + @@int//min + @@int//max + @@int//= + @@int//< + @@int//+ + @@int//- + @@int//negate + @@int//-one + @@int//unsigned-low + @@int//to-float + @@int//* + @@int/// + @@int//%)) + +(runtime: (lux//try op) + (with-vars [error value] + (r.try ($_ r.then + (r.set! value (r.apply (list ..unit) (@@ op))) + (..right (@@ value))) + #.None + (#.Some (r.function (list error) + (..left (r.nth (r.string "message") + (@@ error))))) + #.None))) + +(runtime: (lux//program-args program-args) + (with-vars [inputs value] + ($_ r.then + (r.set! inputs ..none) + (<| (r.for-in value (@@ program-args)) + (r.set! inputs (..some (r.list (list (@@ value) (@@ inputs)))))) + (@@ inputs)))) + +(def: runtime//lux + Runtime + ($_ r.then + @@lux//try + @@lux//program-args)) + +(def: current-time-float + Expression + (let [raw-time (r.apply (list) (r.global "Sys.time"))] + (r.apply (list raw-time) (r.global "as.numeric")))) + +(runtime: (io//current-time! _) + (|> current-time-float + (r.* (r.float 1,000.0)) + int//from-float)) + +(def: runtime//io + Runtime + ($_ r.then + @@io//current-time!)) + +(def: minimum-index-length + (-> SVar Expression) + (|>> @@ (r.+ (r.int 1)))) + +(def: (product-element product index) + (-> Expression Expression Expression) + (|> product (r.nth (|> index (r.+ (r.int 1)))))) + +(def: (product-tail product) + (-> SVar Expression) + (|> (@@ product) (r.nth (r.length (@@ product))))) + +(def: (updated-index min-length product) + (-> Expression Expression Expression) + (|> min-length (r.- (r.length product)))) + +(runtime: (product//left product index) + (let [$index_min_length (r.var "index_min_length")] + ($_ r.then + (r.set! $index_min_length (minimum-index-length index)) + (r.if (|> (r.length (@@ product)) (r.> (@@ $index_min_length))) + ## No need for recursion + (product-element (@@ product) (@@ index)) + ## Needs recursion + (product//left (product-tail product) + (updated-index (@@ $index_min_length) (@@ product))))))) + +(runtime: (product//right product index) + (let [$index_min_length (r.var "index_min_length")] + ($_ r.then + (r.set! $index_min_length (minimum-index-length index)) + (r.cond (list [## Last element. + (|> (r.length (@@ product)) (r.= (@@ $index_min_length))) + (product-element (@@ product) (@@ index))] + [## Needs recursion + (|> (r.length (@@ product)) (r.< (@@ $index_min_length))) + (product//right (product-tail product) + (updated-index (@@ $index_min_length) (@@ product)))]) + ## Must slice + (|> (@@ product) (r.slice-from (@@ index))))))) + +(runtime: (sum//get sum wanted_tag wants_last) + (let [no-match r.null + sum-tag (|> (@@ sum) (r.nth (r.string //.variant-tag-field))) + sum-flag (|> (@@ sum) (r.nth (r.string //.variant-flag-field))) + sum-value (|> (@@ sum) (r.nth (r.string //.variant-value-field))) + is-last? (|> sum-flag (r.= (r.string ""))) + test-recursion (r.if is-last? + ## Must recurse. + (sum//get sum-value + (|> (@@ wanted_tag) (r.- sum-tag)) + (@@ wants_last)) + no-match)] + (r.cond (list [(r.= sum-tag (@@ wanted_tag)) + (r.if (r.= (@@ wants_last) sum-flag) + sum-value + test-recursion)] + + [(|> (@@ wanted_tag) (r.> sum-tag)) + test-recursion] + + [(|> (|> (@@ wants_last) (r.= (r.string ""))) + (r.and (|> (@@ wanted_tag) (r.< sum-tag)))) + (variant' (|> sum-tag (r.- (@@ wanted_tag))) sum-flag sum-value)]) + + no-match))) + +(def: runtime//adt + Runtime + ($_ r.then + @@product//left + @@product//right + @@sum//get + )) + +(template [<name> <op>] + [(runtime: (<name> mask input) + (int//new (<op> (int64-high (@@ mask)) + (int64-high (@@ input))) + (<op> (int64-low (@@ mask)) + (int64-low (@@ input)))))] + + [bit//and r.bit-and] + [bit//or r.bit-or] + [bit//xor r.bit-xor] + ) + +(runtime: (bit//logical-right-shift shift input) + ($_ r.then + (limit-shift! shift) + (r.cond (list (no-shift-clause shift input) + [(|> (@@ shift) (r.< (r.int 32))) + (with-vars [$mid] + (let [mid (|> (int64-high (@@ input)) (r.bit-shl (|> (r.int 32) (r.- (@@ shift))))) + high (|> (int64-high (@@ input)) (r.bit-ushr (@@ shift))) + low (|> (int64-low (@@ input)) + (r.bit-ushr (@@ shift)) + (r.bit-or (r.if (r.apply (list (@@ $mid)) (r.global "is.na")) + (r.int 0) + (@@ $mid))))] + ($_ r.then + (r.set! $mid mid) + (int//new high low))))] + [(|> (@@ shift) (r.= (r.int 32))) + (let [high (int64-high (@@ input))] + (int//new (r.int 0) high))]) + (let [low (|> (int64-high (@@ input)) (r.bit-ushr (|> (@@ shift) (r.- (r.int 32)))))] + (int//new (r.int 0) low))))) + +(def: runtime//bit + Runtime + ($_ r.then + @@bit//and + @@bit//or + @@bit//xor + @@bit//not + @@bit//left-shift + @@bit//arithmetic-right-shift-32 + @@bit//arithmetic-right-shift + @@bit//logical-right-shift + )) + +(runtime: (frac//decode input) + (with-vars [output] + ($_ r.then + (r.set! output (r.apply (list (@@ input)) (r.global "as.numeric"))) + (r.if (|> (@@ output) (r.= r.n/a)) + ..none + (..some (@@ output)))))) + +(def: runtime//frac + Runtime + ($_ r.then + @@frac//decode)) + +(def: inc (-> Expression Expression) (|>> (r.+ (r.int 1)))) + +(template [<name> <top-cmp>] + [(def: (<name> top value) + (-> Expression Expression Expression) + (|> (|> value (r.>= (r.int 0))) + (r.and (|> value (<top-cmp> top)))))] + + [within? r.<] + [up-to? r.<=] + ) + +(def: (text-clip start end text) + (-> Expression Expression Expression Expression) + (r.apply (list text start end) + (r.global "substr"))) + +(def: (text-length text) + (-> Expression Expression) + (r.apply (list text) (r.global "nchar"))) + +(runtime: (text//index subject param start) + (with-vars [idx startF subjectL] + ($_ r.then + (r.set! startF (int//to-float (@@ start))) + (r.set! subjectL (text-length (@@ subject))) + (r.if (|> (@@ startF) (within? (@@ subjectL))) + ($_ r.then + (r.set! idx (|> (r.apply-kw (list (@@ param) (r.if (|> (@@ startF) (r.= (r.int 0))) + (@@ subject) + (text-clip (inc (@@ startF)) + (inc (@@ subjectL)) + (@@ subject)))) + (list ["fixed" (r.bool #1)]) + (r.global "regexpr")) + (r.nth (r.int 1)))) + (r.if (|> (@@ idx) (r.= (r.int -1))) + ..none + (..some (int//from-float (|> (@@ idx) (r.+ (@@ startF))))))) + ..none)))) + +(runtime: (text//clip text from to) + (with-vars [length] + ($_ r.then + (r.set! length (r.length (@@ text))) + (r.if ($_ r.and + (|> (@@ to) (within? (@@ length))) + (|> (@@ from) (up-to? (@@ to)))) + (..some (text-clip (inc (@@ from)) (inc (@@ to)) (@@ text))) + ..none)))) + +(def: (char-at idx text) + (-> Expression Expression Expression) + (r.apply (list (text-clip idx idx text)) + (r.global "utf8ToInt"))) + +(runtime: (text//char text idx) + (r.if (|> (@@ idx) (within? (r.length (@@ text)))) + ($_ r.then + (r.set! idx (inc (@@ idx))) + (..some (int//from-float (char-at (@@ idx) (@@ text))))) + ..none)) + +(def: runtime//text + Runtime + ($_ r.then + @@text//index + @@text//clip + @@text//char)) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Expression) + (r.if (|> idx (r.<= (r.length array))) + body + (r.stop (r.string "Array index out of bounds!")))) + +(runtime: (array//new size) + (with-vars [output] + ($_ r.then + (r.set! output (r.list (list))) + (r.set-nth! (|> (@@ size) (r.+ (r.int 1))) + r.null + output) + (@@ output)))) + +(runtime: (array//get array idx) + (with-vars [temp] + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + ($_ r.then + (r.set! temp (|> (@@ array) (r.nth (@@ idx)))) + (r.if (|> (@@ temp) (r.= r.null)) + ..none + (..some (@@ temp))))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds (@@ array) (@@ idx)) + ($_ r.then + (r.set-nth! (@@ idx) (@@ value) array) + (@@ array)))) + +(def: runtime//array + Runtime + ($_ r.then + @@array//new + @@array//get + @@array//put)) + +(runtime: (box//write value box) + ($_ r.then + (r.set-nth! (r.int 1) (@@ value) box) + ..unit)) + +(def: runtime//box + Runtime + ($_ r.then + @@box//write)) + +(def: runtime + Runtime + ($_ r.then + runtime//lux + @@f2^32 + @@f2^63 + @@int//new + @@int//from-float + runtime//bit + runtime//int + runtime//adt + runtime//frac + runtime//text + runtime//array + runtime//box + runtime//io + )) + +(def: #export artifact Text (format prefix ".r")) + +(def: #export translate + (Meta (Process Any)) + (do macro.Monad<Meta> + [_ //.init-module-buffer + _ (//.save runtime)] + (//.save-module! artifact))) |