diff options
Diffstat (limited to '')
10 files changed, 252 insertions, 261 deletions
diff --git a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux b/new-luxc/source/luxc/lang/translation/js/case.jvm.lux deleted file mode 100644 index e8fdcb00c..000000000 --- a/new-luxc/source/luxc/lang/translation/js/case.jvm.lux +++ /dev/null @@ -1,191 +0,0 @@ -(.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 [js #+ JS Expression Statement]))) - [//] - (// [".T" runtime] - [".T" primitive] - [".T" reference])) - -(def: #export (translate-let translate register valueS bodyS) - (-> (-> ls.Synthesis (Meta Expression)) Nat ls.Synthesis ls.Synthesis - (Meta Expression)) - (do macro.Monad<Meta> - [valueJS (translate valueS) - bodyJS (translate bodyS)] - (wrap (format "(function() {" - "var " (referenceT.variable register) " = " valueJS ";" - "return " bodyJS ";" - "})()")))) - -(def: #export (translate-record-get translate valueS path) - (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis (List [Nat Bit]) - (Meta Expression)) - (do macro.Monad<Meta> - [valueJS (translate valueS)] - (wrap (list/fold (function (_ [idx tail?] source) - (let [method (if tail? runtimeT.product//right runtimeT.product//left)] - (format method "(" source "," (|> idx .int %i) ")"))) - (format "(" valueJS ")") - path)))) - -(def: #export (translate-if testJS thenJS elseJS) - (-> Expression Expression Expression - Expression) - (format "(" testJS " ? " thenJS " : " elseJS ")")) - -(def: savepoint - Expression - "pm_cursor_savepoint") - -(def: cursor - Expression - "pm_cursor") - -(def: (push-cursor value) - (-> Expression Expression) - (format cursor ".push(" value ");")) - -(def: save-cursor - Statement - (format savepoint ".push(" cursor ".slice());")) - -(def: restore-cursor - Statement - (format cursor " = " savepoint ".pop();")) - -(def: peek-cursor - Expression - (format cursor "[" cursor ".length - 1]")) - -(def: pop-cursor - Statement - (format cursor ".pop();")) - -(def: pm-error - Expression - (%t "PM-ERROR")) - -(def: fail-pattern-matching - Statement - (format "throw " pm-error ";")) - -(exception: #export (Unrecognized-Path {message Text}) - message) - -(def: (translate-pattern-matching' translate path) - (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) - (case path - (^code ("lux case exec" (~ bodyS))) - (do macro.Monad<Meta> - [bodyJS (translate bodyS)] - (wrap (format "return " bodyJS ";"))) - - (^code ("lux case pop")) - (meta/wrap pop-cursor) - - (^code ("lux case bind" (~ [_ (#.Nat register)]))) - (meta/wrap (format "var " (referenceT.variable register) " = " peek-cursor ";")) - - (^template [<tag> <translate>] - [_ (<tag> value)] - (do macro.Monad<Meta> - [valueJS (<translate> value)] - (wrap (format "if(!" (format runtimeT.int//= "(" peek-cursor "," valueJS ")") ") { " fail-pattern-matching " }")))) - ([#.Nat primitiveT.translate-nat] - [#.Int primitiveT.translate-int] - [#.Rev primitiveT.translate-rev]) - - (^template [<tag> <format>] - [_ (<tag> value)] - (meta/wrap (format "if(" peek-cursor " !== " (<format> value) ") { " fail-pattern-matching " }"))) - ([#.Bit %b] - [#.Frac %f] - [#.Text %t]) - - (^template [<pm> <getter>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (push-cursor (format <getter> "(" peek-cursor "," (|> idx .int %i) ")")))) - (["lux case tuple left" runtimeT.product//left] - ["lux case tuple right" runtimeT.product//right]) - - (^template [<pm> <flag>] - (^code (<pm> (~ [_ (#.Nat idx)]))) - (meta/wrap (format "temp = " runtimeT.sum//get "(" peek-cursor "," (|> idx .int %i) "," <flag> ");" - "if(temp == null) {" - fail-pattern-matching - "}" - "else {" - (push-cursor "temp") - "}"))) - (["lux case variant left" "null"] - ["lux case variant right" "\"\""]) - - (^code ("lux case seq" (~ leftP) (~ rightP))) - (do macro.Monad<Meta> - [leftJS (translate-pattern-matching' translate leftP) - rightJS (translate-pattern-matching' translate rightP)] - (wrap (format leftJS rightJS))) - - (^code ("lux case alt" (~ leftP) (~ rightP))) - (do macro.Monad<Meta> - [leftJS (translate-pattern-matching' translate leftP) - rightJS (translate-pattern-matching' translate rightP)] - (wrap (format "try {" - save-cursor - leftJS - "}" - "catch(ex) {" - "if(ex === " pm-error ") {" - restore-cursor - rightJS - "}" - "else {" - "throw ex;" - "}" - "}"))) - - _ - (lang.throw Unrecognized-Path (%code path)) - )) - -(def: report-pattern-matching-error - Statement - (format "if(ex === " pm-error ") {" - "throw \"Invalid expression for pattern-matching.\";" - "}" - "else {" - "throw ex;" - "}")) - -(def: (translate-pattern-matching translate path) - (-> (-> ls.Synthesis (Meta Expression)) Code (Meta Expression)) - (do macro.Monad<Meta> - [pmJS (translate-pattern-matching' translate path)] - (wrap (format "try {" pmJS "}" - "catch(ex) {" - report-pattern-matching-error - "}")))) - -(def: (initialize-pattern-matching stack-init) - (-> Expression Statement) - (format "var temp;" - "var " cursor " = [" stack-init "];" - "var " savepoint " = [];")) - -(def: #export (translate-case translate valueS path) - (-> (-> ls.Synthesis (Meta Expression)) ls.Synthesis Code (Meta Expression)) - (do macro.Monad<Meta> - [valueJS (translate valueS) - pmJS (translate-pattern-matching translate path)] - (wrap (format "(function() {" - "\"use strict\";" - (initialize-pattern-matching valueJS) - pmJS - "})()")))) diff --git a/stdlib/source/lux/host/js.lux b/stdlib/source/lux/host/js.lux index fbaf12fc3..b297be69a 100644 --- a/stdlib/source/lux/host/js.lux +++ b/stdlib/source/lux/host/js.lux @@ -299,6 +299,11 @@ " else " (..block else!)))) + (def: #export (when test then!) + (-> Expression Statement Statement) + (:abstraction (format "if(" (:representation test) ") " + (..block then!)))) + (def: #export (while test body) (-> Expression Statement Statement) (:abstraction (format "while(" (:representation test) ") " diff --git a/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux b/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux index 5d85bfd16..033effdfe 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux @@ -34,12 +34,24 @@ (-> Register expression))) (|>> .int %i (format prefix) variable)) +(def: #export foreign + (All [expression] + (-> (-> Text expression) + (-> Register expression))) + (variable-maker "f")) + +(def: #export local + (All [expression] + (-> (-> Text expression) + (-> Register expression))) + (variable-maker "l")) + (def: #export (system constant variable) (All [expression] (-> (-> Text expression) (-> Text expression) (System expression))) - (let [local (variable-maker "l" variable) - foreign (variable-maker "f" variable) + (let [local (..local variable) + foreign (..foreign variable) variable (:share [expression] {(-> Text expression) variable} diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux new file mode 100644 index 000000000..91c7b4ace --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux @@ -0,0 +1,175 @@ +(.module: + [lux (#- case let if) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." number] + ["." text + format] + [collection + ["." list ("#/." functor fold)]]] + [host + ["_" js (#+ Expression Computation Var Statement)]]] + [// + ["//." runtime (#+ Operation Phase)] + ["//." reference] + ["//." primitive] + [// + [common + ["common-." reference]] + ["//." // ("#/." monad) + ["." synthesis (#+ Synthesis Path)] + [// + [reference (#+ Register)]]]]]) + +(def: register + (common-reference.local _.var)) + +(def: #export (let translate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation Computation)) + (do ////.monad + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (<| (_.closure (list)) + ($_ _.then + (_.define (..register register) valueO) + (_.return bodyO)))))) + +(def: #export (record-get translate valueS pathP) + (-> Phase Synthesis (List [Nat Bit]) + (Operation Expression)) + (do ////.monad + [valueO (translate valueS)] + (wrap (list/fold (function (_ [idx tail?] source) + (.let [method (.if tail? + //runtime.product//right + //runtime.product//left)] + (method source (_.i32 (.int idx))))) + valueO + pathP)))) + +(def: #export (if translate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do ////.monad + [testO (translate testS) + thenO (translate thenS) + elseO (translate elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) +(def: @alt-error (_.var "alt_error")) + +(def: (push-cursor! value) + (-> Expression Statement) + (_.statement (|> @cursor (_.do "push" (list value))))) + +(def: pop-cursor! + Statement + (_.statement (|> @cursor (_.do "pop" (list))))) + +(def: peek-cursor + Expression + (.let [idx (|> @cursor (_.the "length") (_.- (_.i32 -1)))] + (|> @cursor (_.at idx)))) + +(def: save-cursor! + Statement + (.let [cursor (|> @cursor (_.do "slice" (list)))] + (_.statement (|> @savepoint (_.do "push" (list cursor)))))) + +(def: restore-cursor! + Statement + (_.set @cursor (|> @savepoint (_.do "pop" (list))))) + +(def: pm-error (_.string "PM-ERROR")) +(def: fail-pm! (_.throw pm-error)) + +(exception: #export unrecognized-path) + +(def: (pm-catch on-catch!) + (-> Statement [Var Statement]) + [@alt-error + (_.if (_.= ..pm-error @alt-error) + on-catch! + (_.throw @alt-error))]) + +(def: (pattern-matching' translate pathP) + (-> Phase Path (Operation Statement)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (do ////.monad + [body! (translate bodyS)] + (wrap (_.return body!))) + + #synthesis.Pop + (/////wrap pop-cursor!) + + (#synthesis.Bind register) + (/////wrap (_.define (..register register) ..peek-cursor)) + + (^template [<tag> <format> <=>] + (^ (<tag> value)) + (/////wrap (_.when (|> value <format> (<=> ..peek-cursor) _.not) + fail-pm!))) + ([synthesis.path/bit //primitive.bit _.=] + [synthesis.path/i64 (<| //primitive.i64 .int) //runtime.i64//=] + [synthesis.path/f64 //primitive.f64 _.=] + [synthesis.path/text //primitive.text _.=]) + + (^template [<pm> <flag> <prep>] + (^ (<pm> idx)) + (/////wrap ($_ _.then + (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek-cursor <flag>))) + (_.if (_.= _.null @temp) + fail-pm! + (push-cursor! @temp))))) + ([synthesis.side/left _.null (<|)] + [synthesis.side/right (_.string "") inc]) + + (^template [<pm> <getter> <prep>] + (^ (<pm> idx)) + (/////wrap (|> idx <prep> .int _.i32 (<getter> ..peek-cursor) push-cursor!))) + ([synthesis.member/left //runtime.product//left (<|)] + [synthesis.member/right //runtime.product//right inc]) + + (^template [<tag> <computation>] + (^ (<tag> leftP rightP)) + (do ////.monad + [left! (pattern-matching' translate leftP) + right! (pattern-matching' translate rightP)] + (wrap <computation>))) + ([synthesis.path/seq (_.then left! right!)] + [synthesis.path/alt (_.try ($_ _.then + ..save-cursor! + left!) + (pm-catch ($_ _.then + ..restore-cursor! + right!)))]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching translate pathP) + (-> Phase Path (Operation Statement)) + (do ////.monad + [pattern-matching! (pattern-matching' translate pathP)] + (wrap (_.try pattern-matching! + (pm-catch (_.throw (_.string "Invalid expression for pattern-matching."))))))) + +(def: #export (case translate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation Computation)) + (do ////.monad + [stack-init (translate valueS) + path! (pattern-matching translate pathP) + #let [closure (<| (_.closure (list)) + ($_ _.then + (_.declare @temp) + (_.define @cursor (_.array (list stack-init))) + (_.define @savepoint (_.array (list))) + path!))]] + (wrap (_.apply/* closure (list))))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux index d99eec0e9..7b475c2e7 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux @@ -1,23 +1,19 @@ (.module: - [lux (#- int) + [lux (#- i64) [control [pipe (#+ cond> new>)]] [data [number ["." i64] - ["." frac]] - [text - format]] + ["." frac]]] [host ["_" js (#+ Expression)]]] [// - ["//." runtime (#+ Operation)] - [// - ["//." // ("#/." monad)]]]) + ["//." runtime]]) (def: #export bit - (-> Bit (Operation Expression)) - (|>> _.boolean /////wrap)) + (-> Bit Expression) + _.boolean) (def: high (-> Int Int) @@ -28,13 +24,13 @@ (let [mask (dec (i64.left-shift 32 1))] (|>> (i64.and mask)))) -(def: #export (int value) - (-> Int (Operation Expression)) - (/////wrap (//runtime.i64//new (|> value ..high _.i32) - (|> value ..low _.i32)))) +(def: #export (i64 value) + (-> Int Expression) + (//runtime.i64//new (|> value ..high _.i32) + (|> value ..low _.i32))) -(def: #export frac - (-> Frac (Operation Expression)) +(def: #export f64 + (-> Frac Expression) (|>> (cond> [(f/= frac.positive-infinity)] [(new> _.positive-infinity [])] @@ -45,9 +41,8 @@ [(new> _.not-a-number [])] ## else - [_.number]) - /////wrap)) + [_.number]))) (def: #export text - (-> Text (Operation Expression)) - (|>> _.string /////wrap)) + (-> Text Expression) + _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux index 4949ddacf..bac907bea 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux @@ -5,28 +5,28 @@ [host ["_" js (#+ Expression)]]] [// - ["//." runtime (#+ Generator)] + ["//." runtime (#+ Operation Phase)] ["//." primitive] - ["//." /// + ["/." /// [analysis (#+ Variant Tuple)] ["." synthesis (#+ Synthesis)]]]) -(def: #export (tuple elemsS+ translate) - (Generator (Tuple Synthesis)) +(def: #export (tuple translate elemsS+) + (-> Phase (Tuple Synthesis) (Operation Expression)) (case elemsS+ #.Nil - (//primitive.text synthesis.unit) + (:: ////.monad wrap (//primitive.text synthesis.unit)) (#.Cons singletonS #.Nil) (translate singletonS) _ - (do /////.monad + (do ////.monad [elemsT+ (monad.map @ translate elemsS+)] (wrap (_.array elemsT+))))) -(def: #export (variant [lefts right? valueS] translate) - (Generator (Variant Synthesis)) - (do /////.monad +(def: #export (variant translate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation Expression)) + (do ////.monad [valueT (translate valueS)] (wrap (//runtime.variant (_.i32 (.int lefts)) (//runtime.flag right?) valueT)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux index 92b55cb80..0cb6a6c9d 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux @@ -8,18 +8,23 @@ ["." text format] [collection - ["." list ("#/." functor fold)] - [set (#+ Set)]]]] + ["." list ("#/." functor fold)]]] + [host + ["_" scheme (#+ Expression Computation Var)]]] [// ["." runtime (#+ Operation Phase)] + ["//." primitive] ["." reference] - ["/." /// ("#/." monad) - ["." synthesis (#+ Synthesis Path)] - [// - [reference (#+ Register)] + [// + [common + ["common-." reference]] + ["//." // ("#/." monad) + ["." synthesis (#+ Synthesis Path)] [// - [host - ["_" scheme (#+ Expression Computation Var)]]]]]]) + [reference (#+ Register)]]]]]) + +(def: register + (common-reference.local _.var)) (def: #export (let translate [valueS register bodyS]) (-> Phase [Synthesis Register Synthesis] @@ -27,7 +32,7 @@ (do ////.monad [valueO (translate valueS) bodyO (translate bodyS)] - (wrap (_.let (list [(reference.local' register) valueO]) + (wrap (_.let (list [(..register register) valueO]) bodyO)))) (def: #export (record-get translate valueS pathP) @@ -39,7 +44,7 @@ (.let [method (.if tail? runtime.product//right runtime.product//left)] - (method source (_.int (:coerce Int idx))))) + (method source (_.int (.int idx))))) valueO pathP)))) @@ -53,23 +58,22 @@ (wrap (_.if testO thenO elseO)))) (def: @savepoint (_.var "lux_pm_cursor_savepoint")) - (def: @cursor (_.var "lux_pm_cursor")) - -(def: top _.length/1) +(def: @temp (_.var "lux_pm_temp")) +(def: @alt-error (_.var "alt_error")) (def: (push! value var) (-> Expression Var Computation) (_.set! var (_.cons/2 value var))) -(def: (pop! var) - (-> Var Computation) - (_.set! var var)) - (def: (push-cursor! value) (-> Expression Computation) (push! value @cursor)) +(def: (pop! var) + (-> Var Computation) + (_.set! var var)) + (def: save-cursor! Computation (push! @cursor @savepoint)) @@ -90,19 +94,14 @@ (def: fail-pm! (_.raise/1 pm-error)) -(def: @temp (_.var "lux_pm_temp")) - -(exception: #export (unrecognized-path) - "") - -(def: $alt_error (_.var "alt_error")) +(exception: #export unrecognized-path) (def: (pm-catch handler) (-> Expression Computation) - (_.lambda [(list $alt_error) #.None] - (_.if (|> $alt_error (_.eqv?/2 pm-error)) + (_.lambda [(list @alt-error) #.None] + (_.if (|> @alt-error (_.eqv?/2 pm-error)) handler - (_.raise/1 $alt_error)))) + (_.raise/1 @alt-error)))) (def: (pattern-matching' translate pathP) (-> Phase Path (Operation Expression)) @@ -114,17 +113,17 @@ (/////wrap pop-cursor!) (#synthesis.Bind register) - (/////wrap (_.define (reference.local' register) [(list) #.None] + (/////wrap (_.define (..register register) [(list) #.None] cursor-top)) (^template [<tag> <format> <=>] (^ (<tag> value)) (/////wrap (_.when (|> value <format> (<=> cursor-top) _.not/1) fail-pm!))) - ([synthesis.path/bit _.bool _.eqv?/2] - [synthesis.path/i64 (<| _.int .int) _.=/2] - [synthesis.path/f64 _.float _.=/2] - [synthesis.path/text _.string _.eqv?/2]) + ([synthesis.path/bit //primitive.bit _.eqv?/2] + [synthesis.path/i64 (<| //primitive.i64 .int) _.=/2] + [synthesis.path/f64 //primitive.f64 _.=/2] + [synthesis.path/text //primitive.text _.eqv?/2]) (^template [<pm> <flag> <prep>] (^ (<pm> idx)) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux index 53d7bbbcb..c54311da0 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux @@ -19,7 +19,7 @@ (case synthesis (^template [<tag> <generator>] (^ (<tag> value)) - (<generator> value)) + (:: ///.monad wrap (<generator> value))) ([synthesis.bit primitive.bit] [synthesis.i64 primitive.i64] [synthesis.f64 primitive.f64] diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux index 86bf44c0f..dff6cd644 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux @@ -1,16 +1,12 @@ (.module: [lux (#- i64) [host - ["_" scheme (#+ Expression)]]] - [// - [runtime (#+ Operation)] - [// - ["//." // ("#/." monad)]]]) + ["_" scheme (#+ Expression)]]]) (do-template [<name> <type> <code>] [(def: #export <name> - (-> <type> (Operation Expression)) - (|>> <code> /////wrap))] + (-> <type> Expression) + <code>)] [bit Bit _.bool] [i64 Int _.int] diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux index aa4742fb1..d90569d9c 100644 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux @@ -15,7 +15,7 @@ (-> Phase (Tuple Synthesis) (Operation Expression)) (case elemsS+ #.Nil - (primitive.text synthesis.unit) + (:: ///.monad wrap (primitive.text synthesis.unit)) (#.Cons singletonS #.Nil) (translate singletonS) |