aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/host/js.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/common/reference.lux16
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/case.lux175
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux33
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux18
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux61
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux2
9 files changed, 252 insertions, 70 deletions
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)