aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux.lux59
-rw-r--r--stdlib/source/lux/function.lux6
-rw-r--r--stdlib/source/lux/language/compiler.lux23
-rw-r--r--stdlib/source/lux/language/compiler/analysis.lux60
-rw-r--r--stdlib/source/lux/language/compiler/analysis/case.lux36
-rw-r--r--stdlib/source/lux/language/compiler/analysis/expression.lux57
-rw-r--r--stdlib/source/lux/language/compiler/analysis/function.lux37
-rw-r--r--stdlib/source/lux/language/compiler/analysis/inference.lux21
-rw-r--r--stdlib/source/lux/language/compiler/analysis/module.lux255
-rw-r--r--stdlib/source/lux/language/compiler/analysis/primitive.lux13
-rw-r--r--stdlib/source/lux/language/compiler/analysis/reference.lux36
-rw-r--r--stdlib/source/lux/language/compiler/analysis/scope.lux196
-rw-r--r--stdlib/source/lux/language/compiler/analysis/structure.lux51
-rw-r--r--stdlib/source/lux/language/compiler/analysis/type.lux51
-rw-r--r--stdlib/source/lux/language/compiler/extension.lux125
-rw-r--r--stdlib/source/lux/language/compiler/extension/analysis.lux25
-rw-r--r--stdlib/source/lux/language/compiler/extension/analysis/common.lux444
-rw-r--r--stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux904
-rw-r--r--stdlib/source/lux/language/compiler/extension/bundle.lux6
-rw-r--r--stdlib/source/lux/language/compiler/synthesis.lux58
-rw-r--r--stdlib/source/lux/language/compiler/synthesis/case.lux57
-rw-r--r--stdlib/source/lux/language/compiler/synthesis/expression.lux85
-rw-r--r--stdlib/source/lux/language/compiler/synthesis/function.lux31
-rw-r--r--stdlib/source/lux/language/compiler/synthesis/loop.lux31
-rw-r--r--stdlib/source/lux/language/compiler/translation.lux79
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux14
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux53
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux4
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux4
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux6
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux6
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux2
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux20
-rw-r--r--stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux6
-rw-r--r--stdlib/source/lux/language/module.lux243
-rw-r--r--stdlib/source/lux/language/scope.lux191
36 files changed, 1668 insertions, 1627 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 56fa96018..ecf5584d6 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -4084,7 +4084,7 @@
(fail "only/exclude requires symbols."))))
defs))
-(def: (parse-short-referrals tokens)
+(def: (parse-referrals tokens)
(-> (List Code) (Meta [Referrals (List Code)]))
(case tokens
(^or (^ (list& [_ (#Form (list& [_ (#Tag ["" "+"])] defs))] tokens'))
@@ -4106,7 +4106,7 @@
_
(return [#Nothing tokens])))
-(def: (parse-short-openings parts)
+(def: (parse-openings parts)
(-> (List Code) (Meta [(List Openings) (List Code)]))
(case parts
#.Nil
@@ -4123,7 +4123,7 @@
_
(fail "Expected all structures of opening form to be symbols.")))
structs)
- next+remainder (parse-short-openings parts')]
+ next+remainder (parse-openings parts')]
(let [[next remainder] next+remainder]
(return [(#.Cons [prefix structs'] next)
remainder])))
@@ -4131,19 +4131,6 @@
_
(return [#.Nil parts])))
-(def: (decorate-sub-importations super-name)
- (-> Text (List Importation) (List Importation))
- (list/map (: (-> Importation Importation)
- (function (_ importation)
- (let [{#import-name _name
- #import-alias _alias
- #import-refer {#refer-defs _referrals
- #refer-open _openings}} importation]
- {#import-name ($_ text/compose super-name "/" _name)
- #import-alias _alias
- #import-refer {#refer-defs _referrals
- #refer-open _openings}})))))
-
(def: (split at x)
(-> Nat Text (Maybe [Text Text]))
(case [(..clip2 +0 at x) (..clip1 at x)]
@@ -4192,11 +4179,13 @@
[_ (#Cons _ a+')]
(list/drop (n/- +1 amount) a+')))
-(def: (clean-module relative-root module)
- (-> Text Text (Meta Text))
+(def: (clean-module nested? relative-root module)
+ (-> Bool Text Text (Meta Text))
(case (count-ups +0 module)
+0
- (return module)
+ (return (if nested?
+ ($_ "lux text concat" relative-root "/" module)
+ module))
ups
(let [parts (text/split "/" relative-root)]
@@ -4217,8 +4206,8 @@
"Importing module: " module "\n"
" Relative Root: " relative-root "\n"))))))
-(def: (parse-imports relative-root imports)
- (-> Text (List Code) (Meta (List Importation)))
+(def: (parse-imports nested? relative-root imports)
+ (-> Bool Text (List Code) (Meta (List Importation)))
(do Monad<Meta>
[imports' (monad/map Monad<Meta>
(: (-> Code (Meta (List Importation)))
@@ -4226,7 +4215,7 @@
(case token
[_ (#Symbol ["" m-name])]
(do Monad<Meta>
- [m-name (clean-module relative-root m-name)]
+ [m-name (clean-module nested? relative-root m-name)]
(wrap (list {#import-name m-name
#import-alias #None
#import-refer {#refer-defs #All
@@ -4234,7 +4223,7 @@
(^ [_ (#Tuple (list [_ (#Symbol ["" m-name])]))])
(do Monad<Meta>
- [import-name (clean-module relative-root m-name)]
+ [import-name (clean-module nested? relative-root m-name)]
(wrap (list {#import-name import-name
#import-alias (#Some m-name)
#import-refer {#refer-defs #Nothing
@@ -4242,13 +4231,12 @@
(^ [_ (#Tuple (list& [_ (#Text alias)] [_ (#Symbol ["" m-name])] extra))])
(do Monad<Meta>
- [import-name (clean-module relative-root m-name)
- referral+extra (parse-short-referrals extra)
+ [import-name (clean-module nested? relative-root m-name)
+ referral+extra (parse-referrals extra)
#let [[referral extra] referral+extra]
- openings+extra (parse-short-openings extra)
+ openings+extra (parse-openings extra)
#let [[openings extra] openings+extra]
- sub-imports (parse-imports relative-root extra)
- #let [sub-imports (decorate-sub-importations import-name sub-imports)]]
+ sub-imports (parse-imports true import-name extra)]
(wrap (list& {#import-name import-name
#import-alias (#Some (replace-all "." m-name alias))
#import-refer {#refer-defs referral
@@ -4257,13 +4245,12 @@
(^ [_ (#Tuple (list& [_ (#Symbol ["" m-name])] extra))])
(do Monad<Meta>
- [import-name (clean-module relative-root m-name)
- referral+extra (parse-short-referrals extra)
+ [import-name (clean-module nested? relative-root m-name)
+ referral+extra (parse-referrals extra)
#let [[referral extra] referral+extra]
- openings+extra (parse-short-openings extra)
+ openings+extra (parse-openings extra)
#let [[openings extra] openings+extra]
- sub-imports (parse-imports relative-root extra)
- #let [sub-imports (decorate-sub-importations import-name sub-imports)]]
+ sub-imports (parse-imports true import-name extra)]
(wrap (case [referral openings]
[#Nothing #Nil] sub-imports
_ (list& {#import-name import-name
@@ -4752,9 +4739,9 @@
(def: (read-refer module-name options)
(-> Text (List Code) (Meta Refer))
(do Monad<Meta>
- [referral+options (parse-short-referrals options)
+ [referral+options (parse-referrals options)
#let [[referral options] referral+options]
- openings+options (parse-short-openings options)
+ openings+options (parse-openings options)
#let [[openings options] openings+options]
current-module current-module-name
#let [test-referrals (: (-> Text (List Text) (List Text) (Meta (List Any)))
@@ -4895,7 +4882,7 @@
_
[(list) tokens]))]
current-module current-module-name
- imports (parse-imports current-module _imports)
+ imports (parse-imports false current-module _imports)
#let [=imports (list/map (: (-> Importation Code)
(function (_ [m-name m-alias =refer])
(` [(~ (text$ m-name)) (~ (text$ (default "" m-alias)))])))
diff --git a/stdlib/source/lux/function.lux b/stdlib/source/lux/function.lux
index f883e36df..4d4af846a 100644
--- a/stdlib/source/lux/function.lux
+++ b/stdlib/source/lux/function.lux
@@ -8,10 +8,10 @@
(-> (-> b c) (-> a b) (-> a c)))
(|>> g f))
-(def: #export (constant c)
+(def: #export (constant value)
{#.doc "Create constant functions."}
- (All [a b] (-> a (-> b a)))
- (function (_ _) c))
+ (All [o] (-> o (All [i] (-> i o))))
+ (function (_ _) value))
(def: #export (flip f)
{#.doc "Flips the order of the arguments of a function."}
diff --git a/stdlib/source/lux/language/compiler.lux b/stdlib/source/lux/language/compiler.lux
index d8b622c31..e714773b7 100644
--- a/stdlib/source/lux/language/compiler.lux
+++ b/stdlib/source/lux/language/compiler.lux
@@ -9,7 +9,6 @@
[error (#+ Error)]
["." text
format]]
- [function]
[macro ["s" syntax (#+ syntax:)]]])
(type: #export (Operation s o)
@@ -21,6 +20,11 @@
(type: #export (Compiler s i o)
(-> i (Operation s o)))
+(def: #export (run' state operation)
+ (All [s o]
+ (-> s (Operation s o) (Error [s o])))
+ (operation state))
+
(def: #export (run state operation)
(All [s o]
(-> s (Operation s o) (Error o)))
@@ -42,23 +46,6 @@
(:: ..Monad<Operation> (~' wrap) [])
(..throw (~ exception) (~ message)))))))
-(def: #export (localized transform)
- (All [s o]
- (-> (-> s s)
- (-> (Operation s o) (Operation s o))))
- (function (_ operation)
- (function (_ state)
- (case (operation (transform state))
- (#error.Error error)
- (#error.Error error)
-
- (#error.Success [state' output])
- (#error.Success [state output])))))
-
-(def: #export (with-state state)
- (All [s o] (-> s (-> (Operation s o) (Operation s o))))
- (localized (function.constant state)))
-
(def: #export (with-stack exception message action)
(All [e s o] (-> (Exception e) e (Operation s o) (Operation s o)))
(<<| (ex.with-stack exception message)
diff --git a/stdlib/source/lux/language/compiler/analysis.lux b/stdlib/source/lux/language/compiler/analysis.lux
index 6956cd0b4..0ca620e42 100644
--- a/stdlib/source/lux/language/compiler/analysis.lux
+++ b/stdlib/source/lux/language/compiler/analysis.lux
@@ -6,8 +6,10 @@
[text ("text/" Equivalence<Text>)]
[collection [list ("list/" Fold<List>)]]]
[function]]
- [///reference (#+ Register Variable Reference)]
- [//])
+ [//
+ [extension (#+ Extension)]
+ [//
+ [reference (#+ Register Variable Reference)]]])
(type: #export #rec Primitive
#Unit
@@ -45,13 +47,20 @@
(#Reference Reference)
(#Case Analysis (Match' Analysis))
(#Function Environment Analysis)
- (#Apply Analysis Analysis))
+ (#Apply Analysis Analysis)
+ (#Extension (Extension Analysis)))
(type: #export Operation
- (//.Operation .Lux))
+ (extension.Operation .Lux Code Analysis))
(type: #export Compiler
- (//.Compiler .Lux Code Analysis))
+ (extension.Compiler .Lux Code Analysis))
+
+(type: #export Handler
+ (extension.Handler .Lux .Code Analysis))
+
+(type: #export Bundle
+ (extension.Bundle .Lux .Code Analysis))
(type: #export Branch
(Branch' Analysis))
@@ -97,7 +106,7 @@
(n/= (dec size) tag))
(template: #export (no-op value)
- (|> +1 #///reference.Local #///reference.Variable #..Reference
+ (|> +1 #reference.Local #reference.Variable #..Reference
(#..Function (list))
(#..Apply value)))
@@ -216,14 +225,14 @@
(def: #export (with-source-code source action)
(All [a] (-> Source (Operation a) (Operation a)))
- (function (_ compiler)
+ (function (_ [bundle compiler])
(let [old-source (get@ #.source compiler)]
- (case (action (set@ #.source source compiler))
+ (case (action [bundle (set@ #.source source compiler)])
(#error.Error error)
(#error.Error error)
- (#error.Success [compiler' output])
- (#error.Success [(set@ #.source old-source compiler')
+ (#error.Success [[bundle' compiler'] output])
+ (#error.Success [[bundle' (set@ #.source old-source compiler')]
output])))))
(def: fresh-bindings
@@ -240,42 +249,35 @@
(def: #export (with-scope action)
(All [a] (-> (Operation a) (Operation [Scope a])))
- (function (_ compiler)
- (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler))
- (#error.Success [compiler' output])
+ (function (_ [bundle compiler])
+ (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler)])
+ (#error.Success [[bundle' compiler'] output])
(case (get@ #.scopes compiler')
#.Nil
(#error.Error "Impossible error: Drained scopes!")
(#.Cons head tail)
- (#error.Success [(set@ #.scopes tail compiler')
+ (#error.Success [[bundle' (set@ #.scopes tail compiler')]
[head output]]))
(#error.Error error)
(#error.Error error))))
-(def: #export (with-current-module name action)
+(def: #export (with-current-module name)
(All [a] (-> Text (Operation a) (Operation a)))
- (function (_ compiler)
- (case (action (set@ #.current-module (#.Some name) compiler))
- (#error.Success [compiler' output])
- (#error.Success [(set@ #.current-module
- (get@ #.current-module compiler)
- compiler')
- output])
-
- (#error.Error error)
- (#error.Error error))))
+ (extension.localized (get@ #.current-module)
+ (set@ #.current-module)
+ (function.constant (#.Some name))))
(def: #export (with-cursor cursor action)
(All [a] (-> Cursor (Operation a) (Operation a)))
(if (text/= "" (product.left cursor))
action
- (function (_ compiler)
+ (function (_ [bundle compiler])
(let [old-cursor (get@ #.cursor compiler)]
- (case (action (set@ #.cursor cursor compiler))
- (#error.Success [compiler' output])
- (#error.Success [(set@ #.cursor old-cursor compiler')
+ (case (action [bundle (set@ #.cursor cursor compiler)])
+ (#error.Success [[bundle' compiler'] output])
+ (#error.Success [[bundle' (set@ #.cursor old-cursor compiler')]
output])
(#error.Error error)
diff --git a/stdlib/source/lux/language/compiler/analysis/case.lux b/stdlib/source/lux/language/compiler/analysis/case.lux
index d1ef6ece1..760ea3b03 100644
--- a/stdlib/source/lux/language/compiler/analysis/case.lux
+++ b/stdlib/source/lux/language/compiler/analysis/case.lux
@@ -12,15 +12,17 @@
[collection [list ("list/" Fold<List> Monoid<List> Functor<List>)]]]
["." macro
[code]]]
- [////
- ["." type
- ["tc" check]]
- [scope]]
- [///]
- [// (#+ Pattern Analysis Operation Compiler)]
- [//type]
- [//structure]
- [/coverage])
+ [// (#+ Pattern Analysis Operation Compiler)
+ [scope]
+ ["//." type]
+ [structure]
+ ["/." //
+ [extension]
+ [//
+ ["." type
+ ["tc" check]]]]]
+ [/
+ [coverage]])
(exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code})
(ex.report ["Type" (%type type)]
@@ -215,8 +217,8 @@
[cursor (#.Record record)]
(do ///.Monad<Operation>
- [record (//structure.normalize record)
- [members recordT] (//structure.order record)
+ [record (structure.normalize record)
+ [members recordT] (structure.order record)
_ (//type.with-env
(tc.check inputT recordT))]
(analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next))
@@ -257,8 +259,8 @@
(^ [cursor (#.Form (list& [_ (#.Tag tag)] values))])
(//.with-cursor cursor
(do ///.Monad<Operation>
- [tag (macro.normalize tag)
- [idx group variantT] (macro.resolve-tag tag)
+ [tag (extension.lift (macro.normalize tag))
+ [idx group variantT] (extension.lift (macro.resolve-tag tag))
_ (//type.with-env
(tc.check inputT variantT))]
(analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next)))
@@ -282,12 +284,12 @@
(function (_ [patternT bodyT])
(analyse-pattern #.None inputT patternT (analyse bodyT)))
branchesT)
- outputHC (|> outputH product.left /coverage.determine)
- outputTC (monad.map @ (|>> product.left /coverage.determine) outputT)
- _ (.case (monad.fold error.Monad<Error> /coverage.merge outputHC outputTC)
+ outputHC (|> outputH product.left coverage.determine)
+ outputTC (monad.map @ (|>> product.left coverage.determine) outputT)
+ _ (.case (monad.fold error.Monad<Error> coverage.merge outputHC outputTC)
(#error.Success coverage)
(///.assert non-exhaustive-pattern-matching ""
- (/coverage.exhaustive? coverage))
+ (coverage.exhaustive? coverage))
(#error.Error error)
(///.fail error))]
diff --git a/stdlib/source/lux/language/compiler/analysis/expression.lux b/stdlib/source/lux/language/compiler/analysis/expression.lux
index f6ec5d11a..1c5c8794c 100644
--- a/stdlib/source/lux/language/compiler/analysis/expression.lux
+++ b/stdlib/source/lux/language/compiler/analysis/expression.lux
@@ -9,16 +9,16 @@
[text
format]]
[macro]]
- [//// (#+ Eval)
- ## [".L" macro]
- ## [".L" extension]
- ]
- [///]
- [// (#+ Analysis Operation Compiler)]
- [//type]
- [//primitive]
- [//structure]
- [//reference])
+ ["." ///
+ [extension]]
+ [// (#+ Analysis Operation Compiler)
+ [type]
+ [primitive]
+ [structure]
+ [reference]
+ ["/." /// (#+ Eval)
+ ## [".L" macro]
+ ]])
(exception: #export (macro-expansion-failed {message Text})
message)
@@ -35,7 +35,7 @@
(-> Eval Compiler)
(function (compile code)
(do ///.Monad<Operation>
- [expectedT macro.expected-type]
+ [expectedT (extension.lift macro.expected-type)]
(let [[cursor code'] code]
## The cursor must be set in the compiler for the sake
## of having useful error messages.
@@ -44,12 +44,12 @@
(^template [<tag> <analyser>]
(<tag> value)
(<analyser> value))
- ([#.Bool //primitive.bool]
- [#.Nat //primitive.nat]
- [#.Int //primitive.int]
- [#.Rev //primitive.rev]
- [#.Frac //primitive.frac]
- [#.Text //primitive.text])
+ ([#.Bool primitive.bool]
+ [#.Nat primitive.nat]
+ [#.Int primitive.int]
+ [#.Rev primitive.rev]
+ [#.Frac primitive.frac]
+ [#.Text primitive.text])
(^template [<tag> <analyser>]
(^ (#.Form (list& [_ (<tag> tag)]
@@ -60,42 +60,39 @@
_
(<analyser> compile tag (` [(~+ values)]))))
- ([#.Nat //structure.sum]
- [#.Tag //structure.tagged-sum])
+ ([#.Nat structure.sum]
+ [#.Tag structure.tagged-sum])
(#.Tag tag)
- (//structure.tagged-sum compile tag (' []))
+ (structure.tagged-sum compile tag (' []))
(^ (#.Tuple (list)))
- //primitive.unit
+ primitive.unit
(^ (#.Tuple (list singleton)))
(compile singleton)
(^ (#.Tuple elems))
- (//structure.product compile elems)
+ (structure.product compile elems)
(^ (#.Record pairs))
- (//structure.record compile pairs)
+ (structure.record compile pairs)
(#.Symbol reference)
- (//reference.reference reference)
+ (reference.reference reference)
(^ (#.Form (list& [_ (#.Text extension-name)] extension-args)))
- (undefined)
- ## (do ///.Monad<Operation>
- ## [extension (extensionL.find-analysis extension-name)]
- ## (extension compile eval extension-args))
+ (extension.apply compile [extension-name extension-args])
## (^ (#.Form (list& func args)))
## (do ///.Monad<Operation>
- ## [[funcT funcA] (//type.with-inference
+ ## [[funcT funcA] (type.with-inference
## (compile func))]
## (case funcA
## [_ (#.Symbol def-name)]
## (do @
## [?macro (///.with-error-tracking
- ## (macro.find-macro def-name))]
+ ## (extension.lift (macro.find-macro def-name)))]
## (case ?macro
## (#.Some macro)
## (do @
diff --git a/stdlib/source/lux/language/compiler/analysis/function.lux b/stdlib/source/lux/language/compiler/analysis/function.lux
index 95eacc47e..51f1892de 100644
--- a/stdlib/source/lux/language/compiler/analysis/function.lux
+++ b/stdlib/source/lux/language/compiler/analysis/function.lux
@@ -12,12 +12,13 @@
[code]]
[language
["." type
- ["tc" check]]
- [".L" scope]]]
- [///]
- [// (#+ Analysis Compiler)]
- [//type]
- [//inference])
+ ["tc" check]]]]
+ [// (#+ Analysis Operation Compiler)
+ [scope]
+ ["//." type]
+ [inference]
+ ["/." //
+ [extension]]])
(exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code})
(ex.report ["Type" (%type expected)]
@@ -34,9 +35,9 @@
(text.join-with ""))]))
(def: #export (function analyse function-name arg-name body)
- (-> Compiler Text Text Code (Meta Analysis))
- (do macro.Monad<Meta>
- [functionT macro.expected-type]
+ (-> Compiler Text Text Code (Operation Analysis))
+ (do ///.Monad<Operation>
+ [functionT (extension.lift macro.expected-type)]
(loop [expectedT functionT]
(///.with-stack cannot-analyse [expectedT function-name arg-name body]
(case expectedT
@@ -81,12 +82,12 @@
(#.Function inputT outputT)
(<| (:: @ map (.function (_ [scope bodyA])
- (#//.Function (scopeL.environment scope) bodyA)))
+ (#//.Function (scope.environment scope) bodyA)))
//.with-scope
## Functions have access not only to their argument, but
## also to themselves, through a local variable.
- (scopeL.with-local [function-name expectedT])
- (scopeL.with-local [arg-name inputT])
+ (scope.with-local [function-name expectedT])
+ (scope.with-local [arg-name inputT])
(//type.with-type outputT)
(analyse body))
@@ -94,9 +95,9 @@
(///.fail "")
)))))
-(def: #export (apply analyse functionT functionA args)
- (-> Compiler Type Analysis (List Code) (Meta Analysis))
- (<| (///.with-stack cannot-apply [functionT args])
- (do macro.Monad<Meta>
- [[applyT argsA] (//inference.general analyse functionT args)])
- (wrap (//.apply [functionA argsA]))))
+(def: #export (apply analyse functionT functionA argsC+)
+ (-> Compiler Type Analysis (List Code) (Operation Analysis))
+ (<| (///.with-stack cannot-apply [functionT argsC+])
+ (do ///.Monad<Operation>
+ [[applyT argsA+] (inference.general analyse functionT argsC+)])
+ (wrap (//.apply [functionA argsA+]))))
diff --git a/stdlib/source/lux/language/compiler/analysis/inference.lux b/stdlib/source/lux/language/compiler/analysis/inference.lux
index 1539e1a0d..403ad0092 100644
--- a/stdlib/source/lux/language/compiler/analysis/inference.lux
+++ b/stdlib/source/lux/language/compiler/analysis/inference.lux
@@ -9,9 +9,11 @@
format]
[collection [list ("list/" Functor<List>)]]]
[macro]]
- [//// ["." type
- ["tc" check]]]
- [/// ("operation/" Monad<Operation>)]
+ [////
+ ["." type
+ ["tc" check]]]
+ [/// ("operation/" Monad<Operation>)
+ [extension]]
[// (#+ Tag Analysis Operation Compiler)]
[//type])
@@ -75,16 +77,17 @@
_
type))
+(def: (named-type cursor id)
+ (-> Cursor Nat Type)
+ (let [name (format "{New Type @ " (.cursor-description cursor) " " (%n id) "}")]
+ (#.Primitive name (list))))
+
(def: new-named-type
(Operation Type)
(do ///.Monad<Operation>
- [[module line column] macro.cursor
+ [cursor (extension.lift macro.cursor)
[ex-id _] (//type.with-env tc.existential)]
- (wrap (#.Primitive (format "{New Type @ " (%t module)
- "," (%n line)
- "," (%n column)
- "} " (%n ex-id))
- (list)))))
+ (wrap (named-type cursor ex-id))))
## Type-inference works by applying some (potentially quantified) type
## to a sequence of values.
diff --git a/stdlib/source/lux/language/compiler/analysis/module.lux b/stdlib/source/lux/language/compiler/analysis/module.lux
new file mode 100644
index 000000000..2a2aef5c3
--- /dev/null
+++ b/stdlib/source/lux/language/compiler/analysis/module.lux
@@ -0,0 +1,255 @@
+(.module:
+ [lux #*
+ [control
+ [monad (#+ do)]
+ ["ex" exception (#+ exception:)]
+ pipe]
+ [data
+ [text ("text/" Equivalence<Text>)
+ format]
+ ["e" error]
+ [collection
+ [list ("list/" Fold<List> Functor<List>)]
+ [dictionary
+ [plist]]]]
+ [macro]]
+ [// (#+ Operation)
+ ["/." //
+ [extension]]])
+
+(type: #export Tag Text)
+
+(exception: #export (unknown-module {module Text})
+ module)
+
+(exception: #export (cannot-declare-tag-twice {module Text} {tag Text})
+ (ex.report ["Module" module]
+ ["Tag" tag]))
+
+(do-template [<name>]
+ [(exception: #export (<name> {tags (List Text)} {owner Type})
+ (ex.report ["Tags" (text.join-with " " tags)]
+ ["Type" (%type owner)]))]
+
+ [cannot-declare-tags-for-unnamed-type]
+ [cannot-declare-tags-for-foreign-type]
+ )
+
+(exception: #export (cannot-define-more-than-once {name Ident})
+ (%ident name))
+
+(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State})
+ (ex.report ["Module" module]
+ ["Desired state" (case state
+ #.Active "Active"
+ #.Compiled "Compiled"
+ #.Cached "Cached")]))
+
+(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code})
+ (ex.report ["Module" module]
+ ["Old annotations" (%code old)]
+ ["New annotations" (%code new)]))
+
+(def: (new hash)
+ (-> Nat Module)
+ {#.module-hash hash
+ #.module-aliases (list)
+ #.definitions (list)
+ #.imports (list)
+ #.tags (list)
+ #.types (list)
+ #.module-annotations #.None
+ #.module-state #.Active})
+
+(def: #export (set-annotations annotations)
+ (-> Code (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)
+ self (extension.lift macro.current-module)]
+ (case (get@ #.module-annotations self)
+ #.None
+ (extension.lift
+ (function (_ state)
+ (#e.Success [(update@ #.modules
+ (plist.put self-name (set@ #.module-annotations (#.Some annotations) self))
+ state)
+ []])))
+
+ (#.Some old)
+ (///.throw cannot-set-module-annotations-more-than-once [self-name old annotations]))))
+
+(def: #export (import module)
+ (-> Text (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)]
+ (extension.lift
+ (function (_ state)
+ (#e.Success [(update@ #.modules
+ (plist.update self-name (update@ #.imports (|>> (#.Cons module))))
+ state)
+ []])))))
+
+(def: #export (alias alias module)
+ (-> Text Text (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)]
+ (extension.lift
+ (function (_ state)
+ (#e.Success [(update@ #.modules
+ (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text]))
+ (|>> (#.Cons [alias module])))))
+ state)
+ []])))))
+
+(def: #export (exists? module)
+ (-> Text (Operation Bool))
+ (extension.lift
+ (function (_ state)
+ (|> state
+ (get@ #.modules)
+ (plist.get module)
+ (case> (#.Some _) true #.None false)
+ [state] #e.Success))))
+
+(def: #export (define name definition)
+ (-> Text Definition (Operation []))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)
+ self (extension.lift macro.current-module)]
+ (extension.lift
+ (function (_ state)
+ (case (plist.get name (get@ #.definitions self))
+ #.None
+ (#e.Success [(update@ #.modules
+ (plist.put self-name
+ (update@ #.definitions
+ (: (-> (List [Text Definition]) (List [Text Definition]))
+ (|>> (#.Cons [name definition])))
+ self))
+ state)
+ []])
+
+ (#.Some already-existing)
+ ((///.throw cannot-define-more-than-once [self-name name]) state))))))
+
+(def: #export (create hash name)
+ (-> Nat Text (Operation []))
+ (extension.lift
+ (function (_ state)
+ (let [module (new hash)]
+ (#e.Success [(update@ #.modules
+ (plist.put name module)
+ state)
+ []])))))
+
+(def: #export (with-module hash name action)
+ (All [a] (-> Nat Text (Operation a) (Operation [Module a])))
+ (do ///.Monad<Operation>
+ [_ (create hash name)
+ output (//.with-current-module name
+ action)
+ module (extension.lift (macro.find-module name))]
+ (wrap [module output])))
+
+(do-template [<setter> <asker> <tag>]
+ [(def: #export (<setter> module-name)
+ (-> Text (Operation Any))
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module-name))
+ (#.Some module)
+ (let [active? (case (get@ #.module-state module)
+ #.Active true
+ _ false)]
+ (if active?
+ (#e.Success [(update@ #.modules
+ (plist.put module-name (set@ #.module-state <tag> module))
+ state)
+ []])
+ ((///.throw can-only-change-state-of-active-module [module-name <tag>])
+ state)))
+
+ #.None
+ ((///.throw unknown-module module-name) state)))))
+
+ (def: #export (<asker> module-name)
+ (-> Text (Operation Bool))
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module-name))
+ (#.Some module)
+ (#e.Success [state
+ (case (get@ #.module-state module)
+ <tag> true
+ _ false)])
+
+ #.None
+ ((///.throw unknown-module module-name) state)))))]
+
+ [set-active active? #.Active]
+ [set-compiled compiled? #.Compiled]
+ [set-cached cached? #.Cached]
+ )
+
+(do-template [<name> <tag> <type>]
+ [(def: (<name> module-name)
+ (-> Text (Operation <type>))
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module-name))
+ (#.Some module)
+ (#e.Success [state (get@ <tag> module)])
+
+ #.None
+ ((///.throw unknown-module module-name) state)))))]
+
+ [tags #.tags (List [Text [Nat (List Ident) Bool Type]])]
+ [types #.types (List [Text [(List Ident) Bool Type]])]
+ [hash #.module-hash Nat]
+ )
+
+(def: (ensure-undeclared-tags module-name tags)
+ (-> Text (List Tag) (Operation Any))
+ (do ///.Monad<Operation>
+ [bindings (..tags module-name)
+ _ (monad.map @
+ (function (_ tag)
+ (case (plist.get tag bindings)
+ #.None
+ (wrap [])
+
+ (#.Some _)
+ (///.throw cannot-declare-tag-twice [module-name tag])))
+ tags)]
+ (wrap [])))
+
+(def: #export (declare-tags tags exported? type)
+ (-> (List Tag) Bool Type (Operation Any))
+ (do ///.Monad<Operation>
+ [self-name (extension.lift macro.current-module-name)
+ [type-module type-name] (case type
+ (#.Named type-ident _)
+ (wrap type-ident)
+
+ _
+ (///.throw cannot-declare-tags-for-unnamed-type [tags type]))
+ _ (ensure-undeclared-tags self-name tags)
+ _ (///.assert cannot-declare-tags-for-foreign-type [tags type]
+ (text/= self-name type-module))]
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get self-name))
+ (#.Some module)
+ (let [namespaced-tags (list/map (|>> [self-name]) tags)]
+ (#e.Success [(update@ #.modules
+ (plist.update self-name
+ (|>> (update@ #.tags (function (_ tag-bindings)
+ (list/fold (function (_ [idx tag] table)
+ (plist.put tag [idx namespaced-tags exported? type] table))
+ tag-bindings
+ (list.enumerate tags))))
+ (update@ #.types (plist.put type-name [namespaced-tags exported? type]))))
+ state)
+ []]))
+ #.None
+ ((///.throw unknown-module self-name) state))))))
diff --git a/stdlib/source/lux/language/compiler/analysis/primitive.lux b/stdlib/source/lux/language/compiler/analysis/primitive.lux
index cbfef367f..eabbcb7d8 100644
--- a/stdlib/source/lux/language/compiler/analysis/primitive.lux
+++ b/stdlib/source/lux/language/compiler/analysis/primitive.lux
@@ -2,14 +2,15 @@
[lux (#- nat int rev)
[control monad]
[macro]]
- [// (#+ Analysis)
- [".A" type]])
+ [// (#+ Analysis Operation)
+ [".A" type]
+ ["/." //]])
## [Analysers]
(do-template [<name> <type> <tag>]
[(def: #export (<name> value)
- (-> <type> (Meta Analysis))
- (do macro.Monad<Meta>
+ (-> <type> (Operation Analysis))
+ (do ///.Monad<Operation>
[_ (typeA.infer <type>)]
(wrap (#//.Primitive (<tag> value)))))]
@@ -22,7 +23,7 @@
)
(def: #export unit
- (Meta Analysis)
- (do macro.Monad<Meta>
+ (Operation Analysis)
+ (do ///.Monad<Operation>
[_ (typeA.infer Any)]
(wrap (#//.Primitive #//.Unit))))
diff --git a/stdlib/source/lux/language/compiler/analysis/reference.lux b/stdlib/source/lux/language/compiler/analysis/reference.lux
index cdffd6870..af134ebe3 100644
--- a/stdlib/source/lux/language/compiler/analysis/reference.lux
+++ b/stdlib/source/lux/language/compiler/analysis/reference.lux
@@ -5,15 +5,19 @@
["ex" exception (#+ exception:)]]
["." macro
[code]]
- [language [type ["tc" check]]]
+ [language
+ [type
+ ["tc" check]]]
[data
[text ("text/" Equivalence<Text>)
format]]]
- [///]
- [// (#+ Analysis Operation)]
- [//type]
- [////reference]
- [////scope])
+ [// (#+ Analysis Operation)
+ [scope]
+ [type]
+ ["/." //
+ [extension]
+ [//
+ [reference]]]])
(exception: #export (foreign-module-has-not-been-imported {current Text} {foreign Text})
(ex.report ["Current" current]
@@ -25,23 +29,23 @@
## [Analysers]
(def: (definition def-name)
(-> Ident (Operation Analysis))
- (with-expansions [<return> (wrap (|> def-name ////reference.constant #//.Reference))]
+ (with-expansions [<return> (wrap (|> def-name reference.constant #//.Reference))]
(do ///.Monad<Operation>
- [[actualT def-anns _] (macro.find-def def-name)]
+ [[actualT def-anns _] (extension.lift (macro.find-def def-name))]
(case (macro.get-symbol-ann (ident-for #.alias) def-anns)
(#.Some real-def-name)
(definition real-def-name)
_
(do @
- [_ (//type.infer actualT)
- (^@ def-name [::module ::name]) (macro.normalize def-name)
- current macro.current-module-name]
+ [_ (type.infer actualT)
+ (^@ def-name [::module ::name]) (extension.lift (macro.normalize def-name))
+ current (extension.lift macro.current-module-name)]
(if (text/= current ::module)
<return>
(if (macro.export? def-anns)
(do @
- [imported! (macro.imported-by? ::module current)]
+ [imported! (extension.lift (macro.imported-by? ::module current))]
(if imported!
<return>
(///.throw foreign-module-has-not-been-imported [current ::module])))
@@ -50,12 +54,12 @@
(def: (variable var-name)
(-> Text (Operation (Maybe Analysis)))
(do ///.Monad<Operation>
- [?var (////scope.find var-name)]
+ [?var (scope.find var-name)]
(case ?var
(#.Some [actualT ref])
(do @
- [_ (//type.infer actualT)]
- (wrap (#.Some (|> ref ////reference.variable #//.Reference))))
+ [_ (type.infer actualT)]
+ (wrap (#.Some (|> ref reference.variable #//.Reference))))
#.None
(wrap #.None))))
@@ -72,7 +76,7 @@
#.None
(do @
- [this-module macro.current-module-name]
+ [this-module (extension.lift macro.current-module-name)]
(definition [this-module simple-name]))))
_
diff --git a/stdlib/source/lux/language/compiler/analysis/scope.lux b/stdlib/source/lux/language/compiler/analysis/scope.lux
new file mode 100644
index 000000000..2468ede27
--- /dev/null
+++ b/stdlib/source/lux/language/compiler/analysis/scope.lux
@@ -0,0 +1,196 @@
+(.module:
+ [lux #*
+ [control
+ monad]
+ [data
+ [text ("text/" Equivalence<Text>)
+ format]
+ [maybe ("maybe/" Monad<Maybe>)]
+ [product]
+ ["e" error]
+ [collection
+ [list ("list/" Functor<List> Fold<List> Monoid<List>)]
+ [dictionary [plist]]]]]
+ [// (#+ Operation Compiler)
+ ["compiler" //
+ [extension]
+ [//
+ [reference (#+ Register Variable)]]]])
+
+(type: Local (Bindings Text [Type Register]))
+(type: Foreign (Bindings Text [Type Variable]))
+
+(def: (local? name scope)
+ (-> Text Scope Bool)
+ (|> scope
+ (get@ [#.locals #.mappings])
+ (plist.contains? name)))
+
+(def: (local name scope)
+ (-> Text Scope (Maybe [Type Variable]))
+ (|> scope
+ (get@ [#.locals #.mappings])
+ (plist.get name)
+ (maybe/map (function (_ [type value])
+ [type (#reference.Local value)]))))
+
+(def: (captured? name scope)
+ (-> Text Scope Bool)
+ (|> scope
+ (get@ [#.captured #.mappings])
+ (plist.contains? name)))
+
+(def: (captured name scope)
+ (-> Text Scope (Maybe [Type Variable]))
+ (loop [idx +0
+ mappings (get@ [#.captured #.mappings] scope)]
+ (case mappings
+ #.Nil
+ #.None
+
+ (#.Cons [_name [_source-type _source-ref]] mappings')
+ (if (text/= name _name)
+ (#.Some [_source-type (#reference.Foreign idx)])
+ (recur (inc idx) mappings')))))
+
+(def: (reference? name scope)
+ (-> Text Scope Bool)
+ (or (local? name scope)
+ (captured? name scope)))
+
+(def: (reference name scope)
+ (-> Text Scope (Maybe [Type Variable]))
+ (case (..local name scope)
+ (#.Some type)
+ (#.Some type)
+
+ _
+ (..captured name scope)))
+
+(def: #export (find name)
+ (-> Text (Operation (Maybe [Type Variable])))
+ (extension.lift
+ (function (_ state)
+ (let [[inner outer] (|> state
+ (get@ #.scopes)
+ (list.split-with (|>> (reference? name) not)))]
+ (case outer
+ #.Nil
+ (#.Right [state #.None])
+
+ (#.Cons top-outer _)
+ (let [[ref-type init-ref] (maybe.default (undefined)
+ (..reference name top-outer))
+ [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)])
+ (function (_ scope ref+inner)
+ [(#reference.Foreign (get@ [#.captured #.counter] scope))
+ (#.Cons (update@ #.captured
+ (: (-> Foreign Foreign)
+ (|>> (update@ #.counter inc)
+ (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)]))))
+ scope)
+ (product.right ref+inner))]))
+ [init-ref #.Nil]
+ (list.reverse inner))
+ scopes (list/compose inner' outer)]
+ (#.Right [(set@ #.scopes scopes state)
+ (#.Some [ref-type ref])]))
+ )))))
+
+(def: #export (with-local [name type] action)
+ (All [a] (-> [Text Type] (Operation a) (Operation a)))
+ (function (_ [bundle state])
+ (case (get@ #.scopes state)
+ (#.Cons head tail)
+ (let [old-mappings (get@ [#.locals #.mappings] head)
+ new-var-id (get@ [#.locals #.counter] head)
+ new-head (update@ #.locals
+ (: (-> Local Local)
+ (|>> (update@ #.counter inc)
+ (update@ #.mappings (plist.put name [type new-var-id]))))
+ head)]
+ (case (compiler.run' [bundle (set@ #.scopes (#.Cons new-head tail) state)]
+ action)
+ (#e.Success [[bundle' state'] output])
+ (case (get@ #.scopes state')
+ (#.Cons head' tail')
+ (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head')
+ tail')]
+ (#e.Success [[bundle' (set@ #.scopes scopes' state')]
+ output]))
+
+ _
+ (error! "Invalid scope alteration/"))
+
+ (#e.Error error)
+ (#e.Error error)))
+
+ _
+ (#e.Error "Cannot create local binding without a scope."))
+ ))
+
+(do-template [<name> <val-type>]
+ [(def: <name>
+ (Bindings Text [Type <val-type>])
+ {#.counter +0
+ #.mappings (list)})]
+
+ [init-locals Nat]
+ [init-captured Variable]
+ )
+
+(def: (scope parent-name child-name)
+ (-> (List Text) Text Scope)
+ {#.name (list& child-name parent-name)
+ #.inner +0
+ #.locals init-locals
+ #.captured init-captured})
+
+(def: #export (with-scope name action)
+ (All [a] (-> Text (Operation a) (Operation a)))
+ (function (_ [bundle state])
+ (let [parent-name (case (get@ #.scopes state)
+ #.Nil
+ (list)
+
+ (#.Cons top _)
+ (get@ #.name top))]
+ (case (action [bundle (update@ #.scopes
+ (|>> (#.Cons (scope parent-name name)))
+ state)])
+ (#e.Error error)
+ (#e.Error error)
+
+ (#e.Success [[bundle' state'] output])
+ (#e.Success [[bundle' (update@ #.scopes
+ (|>> list.tail (maybe.default (list)))
+ state')]
+ output])
+ ))
+ ))
+
+(def: #export next-local
+ (Operation Register)
+ (extension.lift
+ (function (_ state)
+ (case (get@ #.scopes state)
+ #.Nil
+ (#e.Error "Cannot get next reference when there is no scope.")
+
+ (#.Cons top _)
+ (#e.Success [state (get@ [#.locals #.counter] top)])))))
+
+(def: (ref-to-variable ref)
+ (-> Ref Variable)
+ (case ref
+ (#.Local register)
+ (#reference.Local register)
+
+ (#.Captured register)
+ (#reference.Foreign register)))
+
+(def: #export (environment scope)
+ (-> Scope (List Variable))
+ (|> scope
+ (get@ [#.captured #.mappings])
+ (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref)))))
diff --git a/stdlib/source/lux/language/compiler/analysis/structure.lux b/stdlib/source/lux/language/compiler/analysis/structure.lux
index e30d22bad..382eab486 100644
--- a/stdlib/source/lux/language/compiler/analysis/structure.lux
+++ b/stdlib/source/lux/language/compiler/analysis/structure.lux
@@ -13,14 +13,15 @@
["dict" dictionary (#+ Dictionary)]]]
["." macro
[code]]]
- [////
- ["." type
- ["tc" check]]]
- [///]
- [// (#+ Tag Analysis Operation Compiler)]
- [//type]
- [//primitive]
- [//inference])
+ [// (#+ Tag Analysis Operation Compiler)
+ ["//." type]
+ [primitive]
+ [inference]
+ ["/." //
+ [extension]
+ ["//." //
+ ["." type
+ ["tc" check]]]]])
(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code})
(ex.report ["Type" (%type type)]
@@ -79,7 +80,7 @@
(def: #export (sum analyse tag valueC)
(-> Compiler Nat Code (Operation Analysis))
(do ///.Monad<Operation>
- [expectedT macro.expected-type]
+ [expectedT (extension.lift macro.expected-type)]
(///.with-stack cannot-analyse-variant [expectedT tag valueC]
(case expectedT
(#.Sum _)
@@ -93,7 +94,7 @@
(wrap (//.sum-analysis type-size tag valueA)))
#.None
- (///.throw //inference.variant-tag-out-of-bounds [type-size tag expectedT])))
+ (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT])))
(#.Named name unnamedT)
(//type.with-type unnamedT
@@ -152,7 +153,7 @@
(def: (typed-product analyse membersC+)
(-> Compiler (List Code) (Operation Analysis))
(do ///.Monad<Operation>
- [expectedT macro.expected-type]
+ [expectedT (extension.lift macro.expected-type)]
(loop [expectedT expectedT
membersC+ membersC+]
(case [expectedT membersC+]
@@ -191,7 +192,7 @@
(def: #export (product analyse membersC)
(-> Compiler (List Code) (Operation Analysis))
(do ///.Monad<Operation>
- [expectedT macro.expected-type]
+ [expectedT (extension.lift macro.expected-type)]
(///.with-stack cannot-analyse-tuple [expectedT membersC]
(case expectedT
(#.Product _)
@@ -258,15 +259,15 @@
(def: #export (tagged-sum analyse tag valueC)
(-> Compiler Ident Code (Operation Analysis))
(do ///.Monad<Operation>
- [tag (macro.normalize tag)
- [idx group variantT] (macro.resolve-tag tag)
- expectedT macro.expected-type]
+ [tag (extension.lift (macro.normalize tag))
+ [idx group variantT] (extension.lift (macro.resolve-tag tag))
+ expectedT (extension.lift macro.expected-type)]
(case expectedT
(#.Var _)
(do @
[#let [case-size (list.size group)]
- inferenceT (//inference.variant idx case-size variantT)
- [inferredT valueA+] (//inference.general analyse inferenceT (list valueC))]
+ inferenceT (inference.variant idx case-size variantT)
+ [inferredT valueA+] (inference.general analyse inferenceT (list valueC))]
(wrap (//.sum-analysis case-size idx (|> valueA+ list.head maybe.assume))))
_
@@ -283,7 +284,7 @@
(case key
[_ (#.Tag key)]
(do ///.Monad<Operation>
- [key (macro.normalize key)]
+ [key (extension.lift (macro.normalize key))]
(wrap [key val]))
_
@@ -302,8 +303,8 @@
(#.Cons [head-k head-v] _)
(do ///.Monad<Operation>
- [head-k (macro.normalize head-k)
- [_ tag-set recordT] (macro.resolve-tag head-k)
+ [head-k (extension.lift (macro.normalize head-k))
+ [_ tag-set recordT] (extension.lift (macro.resolve-tag head-k))
#let [size-record (list.size record)
size-ts (list.size tag-set)]
_ (if (n/= size-ts size-record)
@@ -314,7 +315,7 @@
idx->val (monad.fold @
(function (_ [key val] idx->val)
(do @
- [key (macro.normalize key)]
+ [key (extension.lift (macro.normalize key))]
(case (dict.get key tag->idx)
#.None
(///.throw tag-does-not-belong-to-record [key recordT])
@@ -338,19 +339,19 @@
[membersC recordT] (order members)]
(case membersC
(^ (list))
- //primitive.unit
+ primitive.unit
(^ (list singletonC))
(analyse singletonC)
_
(do @
- [expectedT macro.expected-type]
+ [expectedT (extension.lift macro.expected-type)]
(case expectedT
(#.Var _)
(do @
- [inferenceT (//inference.record recordT)
- [inferredT membersA] (//inference.general analyse inferenceT membersC)]
+ [inferenceT (inference.record recordT)
+ [inferredT membersA] (inference.general analyse inferenceT membersC)]
(wrap (//.product-analysis membersA)))
_
diff --git a/stdlib/source/lux/language/compiler/analysis/type.lux b/stdlib/source/lux/language/compiler/analysis/type.lux
index 0c73dedab..f87a96758 100644
--- a/stdlib/source/lux/language/compiler/analysis/type.lux
+++ b/stdlib/source/lux/language/compiler/analysis/type.lux
@@ -1,51 +1,42 @@
(.module:
[lux #*
- [control [monad (#+ do)]]
- [data [error]]
+ [control
+ [monad (#+ do)]]
+ [data
+ [error]]
+ [function]
[macro]
- [language [type ["tc" check]]]]
- [///]
- [// (#+ Operation)])
+ [language
+ [type ["tc" check]]]]
+ [// (#+ Operation)
+ ["/." //
+ [extension]]])
-(def: #export (with-type expected action)
+(def: #export (with-type expected)
(All [a] (-> Type (Operation a) (Operation a)))
- (function (_ compiler)
- (case (action (set@ #.expected (#.Some expected) compiler))
- (#error.Success [compiler' output])
- (let [old-expected (get@ #.expected compiler)]
- (#error.Success [(set@ #.expected old-expected compiler')
- output]))
-
- (#error.Error error)
- (#error.Error error))))
+ (extension.localized (get@ #.expected) (set@ #.expected)
+ (function.constant (#.Some expected))))
(def: #export (with-env action)
(All [a] (-> (tc.Check a) (Operation a)))
- (function (_ compiler)
- (case (action (get@ #.type-context compiler))
+ (function (_ (^@ stateE [bundle state]))
+ (case (action (get@ #.type-context state))
(#error.Error error)
- ((///.fail error) compiler)
+ ((///.fail error) stateE)
(#error.Success [context' output])
- (#error.Success [(set@ #.type-context context' compiler)
+ (#error.Success [[bundle (set@ #.type-context context' state)]
output]))))
-(def: #export (with-fresh-env action)
+(def: #export with-fresh-env
(All [a] (-> (Operation a) (Operation a)))
- (function (_ compiler)
- (let [old (get@ #.type-context compiler)]
- (case (action (set@ #.type-context tc.fresh-context compiler))
- (#error.Success [compiler' output])
- (#error.Success [(set@ #.type-context old compiler')
- output])
-
- output
- output))))
+ (extension.localized (get@ #.type-context) (set@ #.type-context)
+ (function.constant tc.fresh-context)))
(def: #export (infer actualT)
(-> Type (Operation Any))
(do ///.Monad<Operation>
- [expectedT macro.expected-type]
+ [expectedT (extension.lift macro.expected-type)]
(with-env
(tc.check expectedT actualT))))
diff --git a/stdlib/source/lux/language/compiler/extension.lux b/stdlib/source/lux/language/compiler/extension.lux
index 478c90564..fc41aa30d 100644
--- a/stdlib/source/lux/language/compiler/extension.lux
+++ b/stdlib/source/lux/language/compiler/extension.lux
@@ -6,61 +6,108 @@
[data
[error (#+ Error)]
[text]
- [collection ["dict" dictionary (#+ Dictionary)]]]]
- [// (#+ Operation Compiler)])
+ [collection ["dict" dictionary (#+ Dictionary)]]]
+ [function]]
+ [//])
(type: #export (Extension i)
- (#Base i)
- (#Extension [Text (List (Extension i))]))
+ [Text (List i)])
-(with-expansions [<Bundle> (as-is (Dictionary Text (-> Text (Handler s i o))))]
+(with-expansions [<Bundle> (as-is (Dictionary Text (Handler s i o)))]
(type: #export (Handler s i o)
- (-> (Compiler [s <Bundle>] (Extension i) (Extension o))
- (Compiler [s <Bundle>] (List (Extension i)) (Extension o))))
+ (-> Text
+ (//.Compiler [<Bundle> s] i o)
+ (//.Compiler [<Bundle> s] (List i) o)))
(type: #export (Bundle s i o)
<Bundle>))
+(type: #export (Operation s i o v)
+ (//.Operation [(Bundle s i o) s] v))
+
+(type: #export (Compiler s i o)
+ (//.Compiler [(Bundle s i o) s] i o))
+
(do-template [<name>]
[(exception: #export (<name> {name Text})
(ex.report ["Name" name]))]
- [unknown-extension]
- [cannot-overwrite-existing-extension]
+ [unknown]
+ [cannot-overwrite]
)
-(def: #export (extend compiler)
+(def: #export (install name handler)
+ (All [s i o]
+ (-> Text (Handler s i o) (Operation s i o Any)))
+ (function (_ [bundle state])
+ (if (dict.contains? name bundle)
+ (ex.throw cannot-overwrite name)
+ (#error.Success [[(dict.put name handler bundle) state]
+ []]))))
+
+(def: #export (apply compiler [name parameters])
(All [s i o]
- (-> (Compiler s i o)
- (Compiler [s (Bundle s i o)]
- (Extension i)
- (Extension o))))
- (function (compiler' input (^@ stateE [stateB bundle]))
- (case input
- (#Base input')
- (do error.Monad<Error>
- [[stateB' output] (compiler input' stateB)]
- (wrap [[stateB' bundle] (#Base output)]))
+ (-> (Compiler s i o) (Extension i) (Operation s i o o)))
+ (function (_ (^@ stateE [bundle state]))
+ (case (dict.get name bundle)
+ #.None
+ (ex.throw unknown name)
- (#Extension name parameters)
- (case (dict.get name bundle)
- (#.Some handler)
- (do error.Monad<Error>
- [[stateE' output] (handler name compiler' parameters stateE)]
- (wrap [stateE' output]))
-
- #.None
- (ex.throw unknown-extension name)))))
+ (#.Some handler)
+ ((handler name compiler) parameters stateE))))
-(def: #export (install name handler)
+(def: #export (localized get set transform)
+ (All [s s' i o v]
+ (-> (-> s s') (-> s' s s) (-> s' s')
+ (-> (Operation s i o v) (Operation s i o v))))
+ (function (_ operation)
+ (function (_ [bundle state])
+ (let [old (get state)]
+ (case (operation [bundle (set (transform old) state)])
+ (#error.Error error)
+ (#error.Error error)
+
+ (#error.Success [[bundle' state'] output])
+ (#error.Success [[bundle' (set old state')] output]))))))
+
+(def: #export (temporary transform)
+ (All [s i o v]
+ (-> (-> s s)
+ (-> (Operation s i o v) (Operation s i o v))))
+ (function (_ operation)
+ (function (_ [bundle state])
+ (case (operation [bundle (transform state)])
+ (#error.Error error)
+ (#error.Error error)
+
+ (#error.Success [[bundle' state'] output])
+ (#error.Success [[bundle' state] output])))))
+
+(def: #export (with-state state)
+ (All [s i o v]
+ (-> s (-> (Operation s i o v) (Operation s i o v))))
+ (..temporary (function.constant state)))
+
+(def: #export (read get)
+ (All [s i o v]
+ (-> (-> s v) (Operation s i o v)))
+ (function (_ [bundle state])
+ (#error.Success [[bundle state] (get state)])))
+
+(def: #export (update transform)
(All [s i o]
- (-> Text (-> Text (Handler s i o))
- (Operation [s (Bundle s i o)] Any)))
- (function (_ (^@ stateE [_ bundle]))
- (if (dict.contains? name bundle)
- (ex.throw cannot-overwrite-existing-extension name)
- (ex.return [stateE (dict.put name handler bundle)]))))
+ (-> (-> s s) (Operation s i o Any)))
+ (function (_ [bundle state])
+ (#error.Success [[bundle (transform state)] []])))
+
+(def: #export (lift action)
+ (All [s i o v]
+ (-> (//.Operation s v)
+ (//.Operation [(Bundle s i o) s] v)))
+ (function (_ [bundle state])
+ (case (action state)
+ (#error.Error error)
+ (#error.Error error)
-(def: #export fresh
- Bundle
- (dict.new text.Hash<Text>))
+ (#error.Success [state' output])
+ (#error.Success [[bundle state] output]))))
diff --git a/stdlib/source/lux/language/compiler/extension/analysis.lux b/stdlib/source/lux/language/compiler/extension/analysis.lux
index ba37b4578..0f57de1ff 100644
--- a/stdlib/source/lux/language/compiler/extension/analysis.lux
+++ b/stdlib/source/lux/language/compiler/extension/analysis.lux
@@ -1,20 +1,15 @@
(.module:
[lux #*
[data
- [text]
[collection
- [list ("list/" Functor<List>)]
- ["dict" dictionary (#+ Dictionary)]]]]
- [///analysis (#+ Analysis State)]
- [///synthesis (#+ Synthesis)]
- [//]
- [/common]
- [/host])
+ [dictionary]]]]
+ [///
+ [analysis (#+ Bundle)]]
+ [/
+ [common]
+ [host]])
-(def: #export defaults
- (//.Bundle State Analysis Synthesis)
- (|> /common.extensions
- (dict.merge /host.extensions)
- dict.entries
- (list/map (function (_ [name proc]) [name (proc name)]))
- (dict.from-list text.Hash<Text>)))
+(def: #export bundle
+ Bundle
+ (dictionary.merge host.bundle
+ common.bundle))
diff --git a/stdlib/source/lux/language/compiler/extension/analysis/common.lux b/stdlib/source/lux/language/compiler/extension/analysis/common.lux
index 0dac69ced..55d479052 100644
--- a/stdlib/source/lux/language/compiler/extension/analysis/common.lux
+++ b/stdlib/source/lux/language/compiler/extension/analysis/common.lux
@@ -15,23 +15,19 @@
["." language
[type ["tc" check]]]
[io (#+ IO)]]
- [////]
- [////
- [analysis (#+ Analysis)
+ ["." ////
+ [analysis (#+ Analysis Bundle)
[".A" type]
[".A" case]
[".A" function]]]
- [///]
- [///bundle])
-
-(type: Handler
- (///.Handler .Lux .Code Analysis))
+ ["." ///
+ [bundle]])
## [Utils]
-(def: (simple extension inputsT+ outputT)
- (-> Text (List Type) Type ..Handler)
+(def: (simple inputsT+ outputT)
+ (-> (List Type) Type analysis.Handler)
(let [num-expected (list.size inputsT+)]
- (function (_ analyse args)
+ (function (_ extension-name analyse args)
(let [num-actual (list.size args)]
(if (n/= num-expected num-actual)
(do ////.Monad<Operation>
@@ -41,40 +37,40 @@
(typeA.with-type argT
(analyse argC)))
(list.zip2 inputsT+ args))]
- (wrap (#///.Extension extension argsA)))
- (language.throw ///bundle.incorrect-arity [extension num-expected num-actual]))))))
+ (wrap (#analysis.Extension extension-name argsA)))
+ (////.throw bundle.incorrect-arity [extension-name num-expected num-actual]))))))
-(def: #export (nullary valueT extension)
- (-> Type Text ..Handler)
- (simple extension (list) valueT))
+(def: #export (nullary valueT)
+ (-> Type analysis.Handler)
+ (simple (list) valueT))
-(def: #export (unary inputT outputT extension)
- (-> Type Type Text ..Handler)
- (simple extension (list inputT) outputT))
+(def: #export (unary inputT outputT)
+ (-> Type Type analysis.Handler)
+ (simple (list inputT) outputT))
-(def: #export (binary subjectT paramT outputT extension)
- (-> Type Type Type Text ..Handler)
- (simple extension (list subjectT paramT) outputT))
+(def: #export (binary subjectT paramT outputT)
+ (-> Type Type Type analysis.Handler)
+ (simple (list subjectT paramT) outputT))
-(def: #export (trinary subjectT param0T param1T outputT extension)
- (-> Type Type Type Type Text ..Handler)
- (simple extension (list subjectT param0T param1T) outputT))
+(def: #export (trinary subjectT param0T param1T outputT)
+ (-> Type Type Type Type analysis.Handler)
+ (simple (list subjectT param0T param1T) outputT))
## [Analysers]
## "lux is" represents reference/pointer equality.
-(def: (lux//is extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: lux::is
+ analysis.Handler
+ (function (_ extension-name analyse args)
(do ////.Monad<Operation>
[[var-id varT] (typeA.with-env tc.var)]
- ((binary varT varT Bool extension)
+ ((binary varT varT Bool extension-name)
analyse args))))
## "lux try" provides a simple way to interact with the host platform's
## error-handling facilities.
-(def: (lux//try extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: lux::try
+ analysis.Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list opC))
(do ////.Monad<Operation>
@@ -82,26 +78,26 @@
_ (typeA.infer (type (Either Text varT)))
opA (typeA.with-type (type (IO varT))
(analyse opC))]
- (wrap (#///.Extension extension (list opA))))
+ (wrap (#analysis.Extension extension-name (list opA))))
_
- (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
-(def: (lux//in-module extension)
- (-> Text ..Handler)
- (function (_ analyse argsC+)
+(def: lux::in-module
+ analysis.Handler
+ (function (_ extension-name analyse argsC+)
(case argsC+
(^ (list [_ (#.Text module-name)] exprC))
- (language.with-current-module module-name
+ (analysis.with-current-module module-name
(analyse exprC))
_
- (language.throw ///bundle.invalid-syntax [extension]))))
+ (////.throw bundle.invalid-syntax [extension-name]))))
## (do-template [<name> <type>]
-## [(def: (<name> extension)
-## (-> Text ..Handler)
-## (function (_ analyse args)
+## [(def: <name>
+## analysis.Handler
+## (function (_ extension-name analyse args)
## (case args
## (^ (list typeC valueC))
## (do ////.Monad<Operation>
@@ -111,15 +107,15 @@
## (analyse valueC)))
## _
-## (language.throw ///bundle.incorrect-arity [extension +2 (list.size args)]))))]
+## (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))]
-## [lux//check (:coerce Type actualT)]
-## [lux//coerce Any]
+## [lux::check (:coerce Type actualT)]
+## [lux::coerce Any]
## )
-(def: (lux//check//type extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: lux::check::type
+ analysis.Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list valueC))
(do ////.Monad<Operation>
@@ -129,145 +125,145 @@
(wrap valueA))
_
- (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)]))))
-
-(def: bundle/lux
- ///.Bundle
- (|> ///.fresh
- (///bundle.install "is" lux//is)
- (///bundle.install "try" lux//try)
- (///bundle.install "check" lux//check)
- (///bundle.install "coerce" lux//coerce)
- (///bundle.install "check type" lux//check//type)
- (///bundle.install "in-module" lux//in-module)))
-
-(def: bundle/io
- ///.Bundle
- (<| (///bundle.prefix "io")
- (|> ///.fresh
- (///bundle.install "log" (unary Text Any))
- (///bundle.install "error" (unary Text Nothing))
- (///bundle.install "exit" (unary Int Nothing))
- (///bundle.install "current-time" (nullary Int)))))
-
-(def: bundle/bit
- ///.Bundle
- (<| (///bundle.prefix "bit")
- (|> ///.fresh
- (///bundle.install "and" (binary Nat Nat Nat))
- (///bundle.install "or" (binary Nat Nat Nat))
- (///bundle.install "xor" (binary Nat Nat Nat))
- (///bundle.install "left-shift" (binary Nat Nat Nat))
- (///bundle.install "logical-right-shift" (binary Nat Nat Nat))
- (///bundle.install "arithmetic-right-shift" (binary Int Nat Int))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
+
+(def: bundle::lux
+ Bundle
+ (|> bundle.empty
+ (bundle.install "is" lux::is)
+ (bundle.install "try" lux::try)
+ ## (bundle.install "check" lux::check)
+ ## (bundle.install "coerce" lux::coerce)
+ (bundle.install "check type" lux::check::type)
+ (bundle.install "in-module" lux::in-module)))
+
+(def: bundle::io
+ Bundle
+ (<| (bundle.prefix "io")
+ (|> bundle.empty
+ (bundle.install "log" (unary Text Any))
+ (bundle.install "error" (unary Text Nothing))
+ (bundle.install "exit" (unary Int Nothing))
+ (bundle.install "current-time" (nullary Int)))))
+
+(def: bundle::bit
+ Bundle
+ (<| (bundle.prefix "bit")
+ (|> bundle.empty
+ (bundle.install "and" (binary Nat Nat Nat))
+ (bundle.install "or" (binary Nat Nat Nat))
+ (bundle.install "xor" (binary Nat Nat Nat))
+ (bundle.install "left-shift" (binary Nat Nat Nat))
+ (bundle.install "logical-right-shift" (binary Nat Nat Nat))
+ (bundle.install "arithmetic-right-shift" (binary Int Nat Int))
)))
-(def: bundle/int
- ///.Bundle
- (<| (///bundle.prefix "int")
- (|> ///.fresh
- (///bundle.install "+" (binary Int Int Int))
- (///bundle.install "-" (binary Int Int Int))
- (///bundle.install "*" (binary Int Int Int))
- (///bundle.install "/" (binary Int Int Int))
- (///bundle.install "%" (binary Int Int Int))
- (///bundle.install "=" (binary Int Int Bool))
- (///bundle.install "<" (binary Int Int Bool))
- (///bundle.install "to-frac" (unary Int Frac))
- (///bundle.install "char" (unary Int Text)))))
-
-(def: bundle/frac
- ///.Bundle
- (<| (///bundle.prefix "frac")
- (|> ///.fresh
- (///bundle.install "+" (binary Frac Frac Frac))
- (///bundle.install "-" (binary Frac Frac Frac))
- (///bundle.install "*" (binary Frac Frac Frac))
- (///bundle.install "/" (binary Frac Frac Frac))
- (///bundle.install "%" (binary Frac Frac Frac))
- (///bundle.install "=" (binary Frac Frac Bool))
- (///bundle.install "<" (binary Frac Frac Bool))
- (///bundle.install "smallest" (nullary Frac))
- (///bundle.install "min" (nullary Frac))
- (///bundle.install "max" (nullary Frac))
- (///bundle.install "to-rev" (unary Frac Rev))
- (///bundle.install "to-int" (unary Frac Int))
- (///bundle.install "encode" (unary Frac Text))
- (///bundle.install "decode" (unary Text (type (Maybe Frac)))))))
-
-(def: bundle/text
- ///.Bundle
- (<| (///bundle.prefix "text")
- (|> ///.fresh
- (///bundle.install "=" (binary Text Text Bool))
- (///bundle.install "<" (binary Text Text Bool))
- (///bundle.install "concat" (binary Text Text Text))
- (///bundle.install "index" (trinary Text Text Nat (type (Maybe Nat))))
- (///bundle.install "size" (unary Text Nat))
- (///bundle.install "char" (binary Text Nat (type (Maybe Nat))))
- (///bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text))))
+(def: bundle::int
+ Bundle
+ (<| (bundle.prefix "int")
+ (|> bundle.empty
+ (bundle.install "+" (binary Int Int Int))
+ (bundle.install "-" (binary Int Int Int))
+ (bundle.install "*" (binary Int Int Int))
+ (bundle.install "/" (binary Int Int Int))
+ (bundle.install "%" (binary Int Int Int))
+ (bundle.install "=" (binary Int Int Bool))
+ (bundle.install "<" (binary Int Int Bool))
+ (bundle.install "to-frac" (unary Int Frac))
+ (bundle.install "char" (unary Int Text)))))
+
+(def: bundle::frac
+ Bundle
+ (<| (bundle.prefix "frac")
+ (|> bundle.empty
+ (bundle.install "+" (binary Frac Frac Frac))
+ (bundle.install "-" (binary Frac Frac Frac))
+ (bundle.install "*" (binary Frac Frac Frac))
+ (bundle.install "/" (binary Frac Frac Frac))
+ (bundle.install "%" (binary Frac Frac Frac))
+ (bundle.install "=" (binary Frac Frac Bool))
+ (bundle.install "<" (binary Frac Frac Bool))
+ (bundle.install "smallest" (nullary Frac))
+ (bundle.install "min" (nullary Frac))
+ (bundle.install "max" (nullary Frac))
+ (bundle.install "to-rev" (unary Frac Rev))
+ (bundle.install "to-int" (unary Frac Int))
+ (bundle.install "encode" (unary Frac Text))
+ (bundle.install "decode" (unary Text (type (Maybe Frac)))))))
+
+(def: bundle::text
+ Bundle
+ (<| (bundle.prefix "text")
+ (|> bundle.empty
+ (bundle.install "=" (binary Text Text Bool))
+ (bundle.install "<" (binary Text Text Bool))
+ (bundle.install "concat" (binary Text Text Text))
+ (bundle.install "index" (trinary Text Text Nat (type (Maybe Nat))))
+ (bundle.install "size" (unary Text Nat))
+ (bundle.install "char" (binary Text Nat (type (Maybe Nat))))
+ (bundle.install "clip" (trinary Text Nat Nat (type (Maybe Text))))
)))
-(def: (array//get extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: array::get
+ analysis.Handler
+ (function (_ extension-name analyse args)
(do ////.Monad<Operation>
[[var-id varT] (typeA.with-env tc.var)]
- ((binary (type (Array varT)) Nat (type (Maybe varT)) extension)
+ ((binary (type (Array varT)) Nat (type (Maybe varT)) extension-name)
analyse args))))
-(def: (array//put extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: array::put
+ analysis.Handler
+ (function (_ extension-name analyse args)
(do ////.Monad<Operation>
[[var-id varT] (typeA.with-env tc.var)]
- ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension)
+ ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension-name)
analyse args))))
-(def: (array//remove extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: array::remove
+ analysis.Handler
+ (function (_ extension-name analyse args)
(do ////.Monad<Operation>
[[var-id varT] (typeA.with-env tc.var)]
- ((binary (type (Array varT)) Nat (type (Array varT)) extension)
+ ((binary (type (Array varT)) Nat (type (Array varT)) extension-name)
analyse args))))
-(def: bundle/array
- ///.Bundle
- (<| (///bundle.prefix "array")
- (|> ///.fresh
- (///bundle.install "new" (unary Nat Array))
- (///bundle.install "get" array//get)
- (///bundle.install "put" array//put)
- (///bundle.install "remove" array//remove)
- (///bundle.install "size" (unary (type (Ex [a] (Array a))) Nat))
+(def: bundle::array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (bundle.install "new" (unary Nat Array))
+ (bundle.install "get" array::get)
+ (bundle.install "put" array::put)
+ (bundle.install "remove" array::remove)
+ (bundle.install "size" (unary (type (Ex [a] (Array a))) Nat))
)))
-(def: bundle/math
- ///.Bundle
- (<| (///bundle.prefix "math")
- (|> ///.fresh
- (///bundle.install "cos" (unary Frac Frac))
- (///bundle.install "sin" (unary Frac Frac))
- (///bundle.install "tan" (unary Frac Frac))
- (///bundle.install "acos" (unary Frac Frac))
- (///bundle.install "asin" (unary Frac Frac))
- (///bundle.install "atan" (unary Frac Frac))
- (///bundle.install "cosh" (unary Frac Frac))
- (///bundle.install "sinh" (unary Frac Frac))
- (///bundle.install "tanh" (unary Frac Frac))
- (///bundle.install "exp" (unary Frac Frac))
- (///bundle.install "log" (unary Frac Frac))
- (///bundle.install "ceil" (unary Frac Frac))
- (///bundle.install "floor" (unary Frac Frac))
- (///bundle.install "round" (unary Frac Frac))
- (///bundle.install "atan2" (binary Frac Frac Frac))
- (///bundle.install "pow" (binary Frac Frac Frac))
+(def: bundle::math
+ Bundle
+ (<| (bundle.prefix "math")
+ (|> bundle.empty
+ (bundle.install "cos" (unary Frac Frac))
+ (bundle.install "sin" (unary Frac Frac))
+ (bundle.install "tan" (unary Frac Frac))
+ (bundle.install "acos" (unary Frac Frac))
+ (bundle.install "asin" (unary Frac Frac))
+ (bundle.install "atan" (unary Frac Frac))
+ (bundle.install "cosh" (unary Frac Frac))
+ (bundle.install "sinh" (unary Frac Frac))
+ (bundle.install "tanh" (unary Frac Frac))
+ (bundle.install "exp" (unary Frac Frac))
+ (bundle.install "log" (unary Frac Frac))
+ (bundle.install "ceil" (unary Frac Frac))
+ (bundle.install "floor" (unary Frac Frac))
+ (bundle.install "round" (unary Frac Frac))
+ (bundle.install "atan2" (binary Frac Frac Frac))
+ (bundle.install "pow" (binary Frac Frac Frac))
)))
-(def: (atom-new extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: atom::new
+ analysis.Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list initC))
(do ////.Monad<Operation>
@@ -275,39 +271,39 @@
_ (typeA.infer (type (Atom varT)))
initA (typeA.with-type varT
(analyse initC))]
- (wrap (#///.Extension extension (list initA))))
+ (wrap (#analysis.Extension extension-name (list initA))))
_
- (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
-(def: (atom-read extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: atom::read
+ analysis.Handler
+ (function (_ extension-name analyse args)
(do ////.Monad<Operation>
[[var-id varT] (typeA.with-env tc.var)]
- ((unary (type (Atom varT)) varT extension)
+ ((unary (type (Atom varT)) varT extension-name)
analyse args))))
-(def: (atom//compare-and-swap extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: atom::compare-and-swap
+ analysis.Handler
+ (function (_ extension-name analyse args)
(do ////.Monad<Operation>
[[var-id varT] (typeA.with-env tc.var)]
- ((trinary (type (Atom varT)) varT varT Bool extension)
+ ((trinary (type (Atom varT)) varT varT Bool extension-name)
analyse args))))
-(def: bundle/atom
- ///.Bundle
- (<| (///bundle.prefix "atom")
- (|> ///.fresh
- (///bundle.install "new" atom-new)
- (///bundle.install "read" atom-read)
- (///bundle.install "compare-and-swap" atom//compare-and-swap)
+(def: bundle::atom
+ Bundle
+ (<| (bundle.prefix "atom")
+ (|> bundle.empty
+ (bundle.install "new" atom::new)
+ (bundle.install "read" atom::read)
+ (bundle.install "compare-and-swap" atom::compare-and-swap)
)))
-(def: (box//new extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: box::new
+ analysis.Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list initC))
(do ////.Monad<Operation>
@@ -315,59 +311,59 @@
_ (typeA.infer (type (All [!] (Box ! varT))))
initA (typeA.with-type varT
(analyse initC))]
- (wrap (#///.Extension extension (list initA))))
+ (wrap (#analysis.Extension extension-name (list initA))))
_
- (language.throw ///bundle.incorrect-arity [extension +1 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
-(def: (box//read extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: box::read
+ analysis.Handler
+ (function (_ extension-name analyse args)
(do ////.Monad<Operation>
[[thread-id threadT] (typeA.with-env tc.var)
[var-id varT] (typeA.with-env tc.var)]
- ((unary (type (Box threadT varT)) varT extension)
+ ((unary (type (Box threadT varT)) varT extension-name)
analyse args))))
-(def: (box//write extension)
- (-> Text ..Handler)
- (function (_ analyse args)
+(def: box::write
+ analysis.Handler
+ (function (_ extension-name analyse args)
(do ////.Monad<Operation>
[[thread-id threadT] (typeA.with-env tc.var)
[var-id varT] (typeA.with-env tc.var)]
- ((binary varT (type (Box threadT varT)) Any extension)
+ ((binary varT (type (Box threadT varT)) Any extension-name)
analyse args))))
-(def: bundle/box
- ///.Bundle
- (<| (///bundle.prefix "box")
- (|> ///.fresh
- (///bundle.install "new" box//new)
- (///bundle.install "read" box//read)
- (///bundle.install "write" box//write)
+(def: bundle::box
+ Bundle
+ (<| (bundle.prefix "box")
+ (|> bundle.empty
+ (bundle.install "new" box::new)
+ (bundle.install "read" box::read)
+ (bundle.install "write" box::write)
)))
-(def: bundle/process
- ///.Bundle
- (<| (///bundle.prefix "process")
- (|> ///.fresh
- (///bundle.install "parallelism" (nullary Nat))
- (///bundle.install "schedule" (binary Nat (type (IO Any)) Any))
+(def: bundle::process
+ Bundle
+ (<| (bundle.prefix "process")
+ (|> bundle.empty
+ (bundle.install "parallelism" (nullary Nat))
+ (bundle.install "schedule" (binary Nat (type (IO Any)) Any))
)))
(def: #export bundle
- ///.Bundle
- (<| (///bundle.prefix "lux")
- (|> ///.fresh
- (dict.merge bundle/lux)
- (dict.merge bundle/bit)
- (dict.merge bundle/int)
- (dict.merge bundle/frac)
- (dict.merge bundle/text)
- (dict.merge bundle/array)
- (dict.merge bundle/math)
- (dict.merge bundle/atom)
- (dict.merge bundle/box)
- (dict.merge bundle/process)
- (dict.merge bundle/io))
+ Bundle
+ (<| (bundle.prefix "lux")
+ (|> bundle.empty
+ (dict.merge bundle::lux)
+ (dict.merge bundle::bit)
+ (dict.merge bundle::int)
+ (dict.merge bundle::frac)
+ (dict.merge bundle::text)
+ (dict.merge bundle::array)
+ (dict.merge bundle::math)
+ (dict.merge bundle::atom)
+ (dict.merge bundle::box)
+ (dict.merge bundle::process)
+ (dict.merge bundle::io))
))
diff --git a/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux b/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux
index e13b32c08..d25be6e40 100644
--- a/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux
+++ b/stdlib/source/lux/language/compiler/extension/analysis/host.jvm.lux
@@ -3,43 +3,50 @@
[control
[monad (#+ do)]
["p" parser]
- ["ex" exception (#+ exception:)]]
+ ["ex" exception (#+ exception:)]
+ pipe]
[data
["e" error]
[maybe]
[product]
- [bool ("bool/" Equivalence<Bool>)]
[text ("text/" Equivalence<Text>)
- format
- ["l" lexer]]
+ format]
[collection
[list ("list/" Fold<List> Functor<List> Monoid<List>)]
[array]
- ["dict" dictionary (#+ Dictionary)]]]
- [macro ("macro/" Monad<Meta>)
- [code]
+ [dictionary (#+ Dictionary)]]]
+ ["." macro
["s" syntax]]
- ["." language
+ [language
["." type
- ["tc" check]]]
+ [check]]]
[host]]
- ["/" //common]
- [////
- [".L" analysis (#+ Analysis)
- [".A" type]
- [".A" inference]]]
- [///]
+ [//
+ [common]
+ ["/." //
+ [bundle]
+ ["//." // ("operation/" Monad<Operation>)
+ [analysis (#+ Analysis Operation Handler Bundle)
+ [".A" type]
+ [".A" inference]]]]]
)
+(type: Method-Signature
+ {#method Type
+ #exceptions (List Type)})
+
(host.import: #long java/lang/reflect/Type
(getTypeName [] String))
-(def: jvm-type-name
- (-> java/lang/reflect/Type Text)
- (java/lang/reflect/Type::getTypeName []))
+(do-template [<name>]
+ [(exception: #export (<name> {jvm-type java/lang/reflect/Type})
+ (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName [] jvm-type)]))]
-(exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type})
- (jvm-type-name jvm-type))
+ [jvm-type-is-not-a-class]
+ [cannot-convert-to-a-class]
+ [cannot-convert-to-a-parameter]
+ [cannot-convert-to-a-lux-type]
+ )
(do-template [<name>]
[(exception: #export (<name> {type Type})
@@ -77,20 +84,19 @@
[cannot-possibly-be-an-instance]
- [cannot-convert-to-a-class]
- [cannot-convert-to-a-parameter]
- [cannot-convert-to-a-lux-type]
[unknown-type-var]
[type-parameter-mismatch]
[cannot-correspond-type-with-a-class]
)
(do-template [<name>]
- [(exception: #export (<name> {class Text} {method Text} {hints (List [Type (List Type)])})
+ [(exception: #export (<name> {class Text}
+ {method Text}
+ {hints (List Method-Signature)})
(ex.report ["Class" class]
["Method" method]
["Hints" (|> hints
- (list/map (|>> %type (format "\n\t")))
+ (list/map (|>> product.left %type (format "\n\t")))
(text.join-with ""))]))]
[no-candidates]
@@ -122,83 +128,83 @@
[char "char"]
)
-(def: conversion-procs
- /.Bundle
- (<| (/.prefix "convert")
- (|> (dict.new text.Hash<Text>)
- (/.install "double-to-float" (/.unary Double Float))
- (/.install "double-to-int" (/.unary Double Integer))
- (/.install "double-to-long" (/.unary Double Long))
- (/.install "float-to-double" (/.unary Float Double))
- (/.install "float-to-int" (/.unary Float Integer))
- (/.install "float-to-long" (/.unary Float Long))
- (/.install "int-to-byte" (/.unary Integer Byte))
- (/.install "int-to-char" (/.unary Integer Character))
- (/.install "int-to-double" (/.unary Integer Double))
- (/.install "int-to-float" (/.unary Integer Float))
- (/.install "int-to-long" (/.unary Integer Long))
- (/.install "int-to-short" (/.unary Integer Short))
- (/.install "long-to-double" (/.unary Long Double))
- (/.install "long-to-float" (/.unary Long Float))
- (/.install "long-to-int" (/.unary Long Integer))
- (/.install "long-to-short" (/.unary Long Short))
- (/.install "long-to-byte" (/.unary Long Byte))
- (/.install "char-to-byte" (/.unary Character Byte))
- (/.install "char-to-short" (/.unary Character Short))
- (/.install "char-to-int" (/.unary Character Integer))
- (/.install "char-to-long" (/.unary Character Long))
- (/.install "byte-to-long" (/.unary Byte Long))
- (/.install "short-to-long" (/.unary Short Long))
+(def: bundle::conversion
+ Bundle
+ (<| (bundle.prefix "convert")
+ (|> bundle.empty
+ (bundle.install "double-to-float" (common.unary Double Float))
+ (bundle.install "double-to-int" (common.unary Double Integer))
+ (bundle.install "double-to-long" (common.unary Double Long))
+ (bundle.install "float-to-double" (common.unary Float Double))
+ (bundle.install "float-to-int" (common.unary Float Integer))
+ (bundle.install "float-to-long" (common.unary Float Long))
+ (bundle.install "int-to-byte" (common.unary Integer Byte))
+ (bundle.install "int-to-char" (common.unary Integer Character))
+ (bundle.install "int-to-double" (common.unary Integer Double))
+ (bundle.install "int-to-float" (common.unary Integer Float))
+ (bundle.install "int-to-long" (common.unary Integer Long))
+ (bundle.install "int-to-short" (common.unary Integer Short))
+ (bundle.install "long-to-double" (common.unary Long Double))
+ (bundle.install "long-to-float" (common.unary Long Float))
+ (bundle.install "long-to-int" (common.unary Long Integer))
+ (bundle.install "long-to-short" (common.unary Long Short))
+ (bundle.install "long-to-byte" (common.unary Long Byte))
+ (bundle.install "char-to-byte" (common.unary Character Byte))
+ (bundle.install "char-to-short" (common.unary Character Short))
+ (bundle.install "char-to-int" (common.unary Character Integer))
+ (bundle.install "char-to-long" (common.unary Character Long))
+ (bundle.install "byte-to-long" (common.unary Byte Long))
+ (bundle.install "short-to-long" (common.unary Short Long))
)))
(do-template [<name> <prefix> <type>]
[(def: <name>
- /.Bundle
- (<| (/.prefix <prefix>)
- (|> (dict.new text.Hash<Text>)
- (/.install "+" (/.binary <type> <type> <type>))
- (/.install "-" (/.binary <type> <type> <type>))
- (/.install "*" (/.binary <type> <type> <type>))
- (/.install "/" (/.binary <type> <type> <type>))
- (/.install "%" (/.binary <type> <type> <type>))
- (/.install "=" (/.binary <type> <type> Boolean))
- (/.install "<" (/.binary <type> <type> Boolean))
- (/.install "and" (/.binary <type> <type> <type>))
- (/.install "or" (/.binary <type> <type> <type>))
- (/.install "xor" (/.binary <type> <type> <type>))
- (/.install "shl" (/.binary <type> Integer <type>))
- (/.install "shr" (/.binary <type> Integer <type>))
- (/.install "ushr" (/.binary <type> Integer <type>))
+ Bundle
+ (<| (bundle.prefix <prefix>)
+ (|> bundle.empty
+ (bundle.install "+" (common.binary <type> <type> <type>))
+ (bundle.install "-" (common.binary <type> <type> <type>))
+ (bundle.install "*" (common.binary <type> <type> <type>))
+ (bundle.install "/" (common.binary <type> <type> <type>))
+ (bundle.install "%" (common.binary <type> <type> <type>))
+ (bundle.install "=" (common.binary <type> <type> Boolean))
+ (bundle.install "<" (common.binary <type> <type> Boolean))
+ (bundle.install "and" (common.binary <type> <type> <type>))
+ (bundle.install "or" (common.binary <type> <type> <type>))
+ (bundle.install "xor" (common.binary <type> <type> <type>))
+ (bundle.install "shl" (common.binary <type> Integer <type>))
+ (bundle.install "shr" (common.binary <type> Integer <type>))
+ (bundle.install "ushr" (common.binary <type> Integer <type>))
)))]
- [int-procs "int" Integer]
- [long-procs "long" Long]
+ [bundle::int "int" Integer]
+ [bundle::long "long" Long]
)
(do-template [<name> <prefix> <type>]
[(def: <name>
- /.Bundle
- (<| (/.prefix <prefix>)
- (|> (dict.new text.Hash<Text>)
- (/.install "+" (/.binary <type> <type> <type>))
- (/.install "-" (/.binary <type> <type> <type>))
- (/.install "*" (/.binary <type> <type> <type>))
- (/.install "/" (/.binary <type> <type> <type>))
- (/.install "%" (/.binary <type> <type> <type>))
- (/.install "=" (/.binary <type> <type> Boolean))
- (/.install "<" (/.binary <type> <type> Boolean))
+ Bundle
+ (<| (bundle.prefix <prefix>)
+ (|> bundle.empty
+ (bundle.install "+" (common.binary <type> <type> <type>))
+ (bundle.install "-" (common.binary <type> <type> <type>))
+ (bundle.install "*" (common.binary <type> <type> <type>))
+ (bundle.install "/" (common.binary <type> <type> <type>))
+ (bundle.install "%" (common.binary <type> <type> <type>))
+ (bundle.install "=" (common.binary <type> <type> Boolean))
+ (bundle.install "<" (common.binary <type> <type> Boolean))
)))]
- [float-procs "float" Float]
- [double-procs "double" Double]
+ [bundle::float "float" Float]
+ [bundle::double "double" Double]
)
-(def: char-procs
- /.Bundle
- (<| (/.prefix "char")
- (|> (dict.new text.Hash<Text>)
- (/.install "=" (/.binary Character Character Boolean))
- (/.install "<" (/.binary Character Character Boolean))
+(def: bundle::char
+ Bundle
+ (<| (bundle.prefix "char")
+ (|> bundle.empty
+ (bundle.install "=" (common.binary Character Character Boolean))
+ (bundle.install "<" (common.binary Character Character Boolean))
)))
(def: #export boxes
@@ -211,33 +217,33 @@
["float" "java.lang.Float"]
["double" "java.lang.Double"]
["char" "java.lang.Character"])
- (dict.from-list text.Hash<Text>)))
+ (dictionary.from-list text.Hash<Text>)))
-(def: (array//length proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: array::length
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list arrayC))
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[_ (typeA.infer Nat)
- [var-id varT] (typeA.with-env tc.var)
+ [var-id varT] (typeA.with-env check.var)
arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))]
- (wrap (#analysisL.Extension proc (list arrayA))))
+ (wrap (#analysis.Extension extension-name (list arrayA))))
_
- (language.throw /.incorrect-extension-arity [proc +1 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
-(def: (array//new proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: array::new
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list lengthC))
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[lengthA (typeA.with-type Nat
(analyse lengthC))
- expectedT macro.expected-type
- [level elem-class] (: (Meta [Nat Text])
+ expectedT (///.lift macro.expected-type)
+ [level elem-class] (: (Operation [Nat Text])
(loop [analysisT expectedT
level +0]
(case analysisT
@@ -247,7 +253,7 @@
(recur outputT level)
#.None
- (language.throw non-array expectedT))
+ (////.throw non-array expectedT))
(^ (#.Primitive "#Array" (list elemT)))
(recur elemT (inc level))
@@ -256,28 +262,28 @@
(wrap [level class])
_
- (language.throw non-array expectedT))))
+ (////.throw non-array expectedT))))
_ (if (n/> +0 level)
(wrap [])
- (language.throw non-array expectedT))]
- (wrap (#analysisL.Extension proc (list (analysisL.nat (dec level))
- (analysisL.text elem-class)
- lengthA))))
+ (////.throw non-array expectedT))]
+ (wrap (#analysis.Extension extension-name (list (analysis.nat (dec level))
+ (analysis.text elem-class)
+ lengthA))))
_
- (language.throw /.incorrect-extension-arity [proc +1 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
(def: (check-jvm objectT)
- (-> Type (Meta Text))
+ (-> Type (Operation Text))
(case objectT
(#.Primitive name _)
- (macro/wrap name)
+ (operation/wrap name)
(#.Named name unnamed)
(check-jvm unnamed)
(#.Var id)
- (macro/wrap "java.lang.Object")
+ (operation/wrap "java.lang.Object")
(^template [<tag>]
(<tag> env unquantified)
@@ -291,130 +297,130 @@
(check-jvm outputT)
#.None
- (language.throw non-object objectT))
+ (////.throw non-object objectT))
_
- (language.throw non-object objectT)))
+ (////.throw non-object objectT)))
(def: (check-object objectT)
- (-> Type (Meta Text))
- (do macro.Monad<Meta>
+ (-> Type (Operation Text))
+ (do ////.Monad<Operation>
[name (check-jvm objectT)]
- (if (dict.contains? name boxes)
- (language.throw primitives-are-not-objects name)
- (macro/wrap name))))
+ (if (dictionary.contains? name boxes)
+ (////.throw primitives-are-not-objects name)
+ (operation/wrap name))))
(def: (box-array-element-type elemT)
- (-> Type (Meta [Type Text]))
+ (-> Type (Operation [Type Text]))
(case elemT
(#.Primitive name #.Nil)
- (let [boxed-name (|> (dict.get name boxes)
+ (let [boxed-name (|> (dictionary.get name boxes)
(maybe.default name))]
- (macro/wrap [(#.Primitive boxed-name #.Nil)
- boxed-name]))
+ (operation/wrap [(#.Primitive boxed-name #.Nil)
+ boxed-name]))
(#.Primitive name _)
- (if (dict.contains? name boxes)
- (language.throw primitives-cannot-have-type-parameters name)
- (macro/wrap [elemT name]))
+ (if (dictionary.contains? name boxes)
+ (////.throw primitives-cannot-have-type-parameters name)
+ (operation/wrap [elemT name]))
_
- (language.throw invalid-type-for-array-element (%type elemT))))
+ (////.throw invalid-type-for-array-element (%type elemT))))
-(def: (array//read proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: array::read
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list arrayC idxC))
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)
+ (do ////.Monad<Operation>
+ [[var-id varT] (typeA.with-env check.var)
_ (typeA.infer varT)
arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))
?elemT (typeA.with-env
- (tc.read var-id))
+ (check.read var-id))
[elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
idxA (typeA.with-type Nat
(analyse idxC))]
- (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA arrayA))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA arrayA))))
_
- (language.throw /.incorrect-extension-arity [proc +2 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))
-(def: (array//write proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: array::write
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list arrayC idxC valueC))
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)
+ (do ////.Monad<Operation>
+ [[var-id varT] (typeA.with-env check.var)
_ (typeA.infer (type (Array varT)))
arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))
?elemT (typeA.with-env
- (tc.read var-id))
+ (check.read var-id))
[valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
idxA (typeA.with-type Nat
(analyse idxC))
valueA (typeA.with-type valueT
(analyse valueC))]
- (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA valueA arrayA))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA valueA arrayA))))
_
- (language.throw /.incorrect-extension-arity [proc +3 (list.size args)]))))
-
-(def: array-procs
- /.Bundle
- (<| (/.prefix "array")
- (|> (dict.new text.Hash<Text>)
- (/.install "length" array//length)
- (/.install "new" array//new)
- (/.install "read" array//read)
- (/.install "write" array//write)
+ (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)]))))
+
+(def: bundle::array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> bundle.empty
+ (bundle.install "length" array::length)
+ (bundle.install "new" array::new)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
)))
-(def: (object//null proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: object::null
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list))
- (do macro.Monad<Meta>
- [expectedT macro.expected-type
+ (do ////.Monad<Operation>
+ [expectedT (///.lift macro.expected-type)
_ (check-object expectedT)]
- (wrap (#analysisL.Extension proc (list))))
+ (wrap (#analysis.Extension extension-name (list))))
_
- (language.throw /.incorrect-extension-arity [proc +0 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +0 (list.size args)]))))
-(def: (object//null? proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: object::null?
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list objectC))
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[_ (typeA.infer Bool)
[objectT objectA] (typeA.with-inference
(analyse objectC))
_ (check-object objectT)]
- (wrap (#analysisL.Extension proc (list objectA))))
+ (wrap (#analysis.Extension extension-name (list objectA))))
_
- (language.throw /.incorrect-extension-arity [proc +1 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
-(def: (object//synchronized proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: object::synchronized
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list monitorC exprC))
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[[monitorT monitorA] (typeA.with-inference
(analyse monitorC))
_ (check-object monitorT)
exprA (analyse exprC)]
- (wrap (#analysisL.Extension proc (list monitorA exprA))))
+ (wrap (#analysis.Extension extension-name (list monitorA exprA))))
_
- (language.throw /.incorrect-extension-arity [proc +2 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))
(host.import: java/lang/Object
(equals [Object] boolean))
@@ -476,110 +482,110 @@
(getDeclaredMethods [] (Array Method)))
(def: (load-class name)
- (-> Text (Meta (Class Object)))
- (do macro.Monad<Meta>
+ (-> Text (Operation (Class Object)))
+ (do ////.Monad<Operation>
[]
(case (Class::forName [name])
(#e.Success [class])
(wrap class)
(#e.Error error)
- (language.throw unknown-class name))))
+ (////.throw unknown-class name))))
(def: (sub-class? super sub)
- (-> Text Text (Meta Bool))
- (do macro.Monad<Meta>
+ (-> Text Text (Operation Bool))
+ (do ////.Monad<Operation>
[super (load-class super)
sub (load-class sub)]
(wrap (Class::isAssignableFrom [sub] super))))
-(def: (object//throw proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: object::throw
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list exceptionC))
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[_ (typeA.infer Nothing)
[exceptionT exceptionA] (typeA.with-inference
(analyse exceptionC))
exception-class (check-object exceptionT)
? (sub-class? "java.lang.Throwable" exception-class)
- _ (: (Meta Any)
+ _ (: (Operation Any)
(if ?
(wrap [])
- (language.throw non-throwable exception-class)))]
- (wrap (#analysisL.Extension proc (list exceptionA))))
+ (////.throw non-throwable exception-class)))]
+ (wrap (#analysis.Extension extension-name (list exceptionA))))
_
- (language.throw /.incorrect-extension-arity [proc +1 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
-(def: (object//class proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: object::class
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list classC))
(case classC
[_ (#.Text class)]
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
_ (load-class class)]
- (wrap (#analysisL.Extension proc (list (analysisL.text class)))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text class)))))
_
- (language.throw /.invalid-syntax [proc args]))
+ (////.throw bundle.invalid-syntax extension-name))
_
- (language.throw /.incorrect-extension-arity [proc +1 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
-(def: (object//instance? proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: object::instance?
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list classC objectC))
(case classC
[_ (#.Text class)]
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[_ (typeA.infer Bool)
[objectT objectA] (typeA.with-inference
(analyse objectC))
object-class (check-object objectT)
? (sub-class? class object-class)]
(if ?
- (wrap (#analysisL.Extension proc (list (analysisL.text class))))
- (language.throw cannot-possibly-be-an-instance (format object-class " !<= " class))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text class))))
+ (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class))))
_
- (language.throw /.invalid-syntax [proc args]))
+ (////.throw bundle.invalid-syntax extension-name))
_
- (language.throw /.incorrect-extension-arity [proc +2 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))
-(def: (java-type-to-class type)
- (-> java/lang/reflect/Type (Meta Text))
- (cond (host.instance? Class type)
- (macro/wrap (Class::getName [] (:coerce Class type)))
+(def: (java-type-to-class jvm-type)
+ (-> java/lang/reflect/Type (Operation Text))
+ (cond (host.instance? Class jvm-type)
+ (operation/wrap (Class::getName [] (:coerce Class jvm-type)))
- (host.instance? ParameterizedType type)
- (java-type-to-class (ParameterizedType::getRawType [] (:coerce ParameterizedType type)))
+ (host.instance? ParameterizedType jvm-type)
+ (java-type-to-class (ParameterizedType::getRawType [] (:coerce ParameterizedType jvm-type)))
## else
- (language.throw cannot-convert-to-a-class (jvm-type-name type))))
+ (////.throw cannot-convert-to-a-class jvm-type)))
(type: Mappings
(Dictionary Text Type))
-(def: fresh-mappings Mappings (dict.new text.Hash<Text>))
+(def: fresh-mappings Mappings (dictionary.new text.Hash<Text>))
(def: (java-type-to-lux-type mappings java-type)
- (-> Mappings java/lang/reflect/Type (Meta Type))
+ (-> Mappings java/lang/reflect/Type (Operation Type))
(cond (host.instance? TypeVariable java-type)
(let [var-name (TypeVariable::getName [] (:coerce TypeVariable java-type))]
- (case (dict.get var-name mappings)
+ (case (dictionary.get var-name mappings)
(#.Some var-type)
- (macro/wrap var-type)
+ (operation/wrap var-type)
#.None
- (language.throw unknown-type-var var-name)))
+ (////.throw unknown-type-var var-name)))
(host.instance? WildcardType java-type)
(let [java-type (:coerce WildcardType java-type)]
@@ -589,47 +595,47 @@
(java-type-to-lux-type mappings bound)
_
- (macro/wrap Any)))
+ (operation/wrap Any)))
(host.instance? Class java-type)
(let [java-type (:coerce (Class Object) java-type)
class-name (Class::getName [] java-type)]
- (macro/wrap (case (array.size (Class::getTypeParameters [] java-type))
- +0
- (#.Primitive class-name (list))
-
- arity
- (|> (list.n/range +0 (dec arity))
- list.reverse
- (list/map (|>> (n/* +2) inc #.Parameter))
- (#.Primitive class-name)
- (type.univ-q arity)))))
+ (operation/wrap (case (array.size (Class::getTypeParameters [] java-type))
+ +0
+ (#.Primitive class-name (list))
+
+ arity
+ (|> (list.n/range +0 (dec arity))
+ list.reverse
+ (list/map (|>> (n/* +2) inc #.Parameter))
+ (#.Primitive class-name)
+ (type.univ-q arity)))))
(host.instance? ParameterizedType java-type)
(let [java-type (:coerce ParameterizedType java-type)
raw (ParameterizedType::getRawType [] java-type)]
(if (host.instance? Class raw)
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[paramsT (|> java-type
(ParameterizedType::getActualTypeArguments [])
array.to-list
(monad.map @ (java-type-to-lux-type mappings)))]
- (macro/wrap (#.Primitive (Class::getName [] (:coerce (Class Object) raw))
- paramsT)))
- (language.throw jvm-type-is-not-a-class raw)))
+ (operation/wrap (#.Primitive (Class::getName [] (:coerce (Class Object) raw))
+ paramsT)))
+ (////.throw jvm-type-is-not-a-class raw)))
(host.instance? GenericArrayType java-type)
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[innerT (|> (:coerce GenericArrayType java-type)
(GenericArrayType::getGenericComponentType [])
(java-type-to-lux-type mappings))]
(wrap (#.Primitive "#Array" (list innerT))))
## else
- (language.throw cannot-convert-to-a-lux-type (jvm-type-name java-type))))
+ (////.throw cannot-convert-to-a-lux-type java-type)))
(def: (correspond-type-params class type)
- (-> (Class Object) Type (Meta Mappings))
+ (-> (Class Object) Type (Operation Mappings))
(case type
(#.Primitive name params)
(let [class-name (Class::getName [] class)
@@ -637,38 +643,38 @@
num-class-params (list.size class-params)
num-type-params (list.size params)]
(cond (not (text/= class-name name))
- (language.throw cannot-correspond-type-with-a-class
- (format "Class = " class-name "\n"
- "Type = " (%type type)))
+ (////.throw cannot-correspond-type-with-a-class
+ (format "Class = " class-name "\n"
+ "Type = " (%type type)))
(not (n/= num-class-params num-type-params))
- (language.throw type-parameter-mismatch
- (format "Expected: " (%i (.int num-class-params)) "\n"
- " Actual: " (%i (.int num-type-params)) "\n"
- " Class: " class-name "\n"
- " Type: " (%type type)))
+ (////.throw type-parameter-mismatch
+ (format "Expected: " (%i (.int num-class-params)) "\n"
+ " Actual: " (%i (.int num-type-params)) "\n"
+ " Class: " class-name "\n"
+ " Type: " (%type type)))
## else
- (macro/wrap (|> params
- (list.zip2 (list/map (TypeVariable::getName []) class-params))
- (dict.from-list text.Hash<Text>)))
+ (operation/wrap (|> params
+ (list.zip2 (list/map (TypeVariable::getName []) class-params))
+ (dictionary.from-list text.Hash<Text>)))
))
_
- (language.throw non-jvm-type type)))
+ (////.throw non-jvm-type type)))
-(def: (object//cast proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: object::cast
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list valueC))
- (do macro.Monad<Meta>
- [toT macro.expected-type
+ (do ////.Monad<Operation>
+ [toT (///.lift macro.expected-type)
to-name (check-jvm toT)
[valueT valueA] (typeA.with-inference
(analyse valueC))
from-name (check-jvm valueT)
- can-cast? (: (Meta Bool)
+ can-cast? (: (Operation Bool)
(case [from-name to-name]
(^template [<primitive> <object>]
(^or [<primitive> <object>]
@@ -687,10 +693,10 @@
_
(do @
- [_ (language.assert primitives-are-not-objects from-name
- (not (dict.contains? from-name boxes)))
- _ (language.assert primitives-are-not-objects to-name
- (not (dict.contains? to-name boxes)))
+ [_ (////.assert primitives-are-not-objects from-name
+ (not (dictionary.contains? from-name boxes)))
+ _ (////.assert primitives-are-not-objects to-name
+ (not (dictionary.contains? to-name boxes)))
to-class (load-class to-name)]
(loop [[current-name currentT] [from-name valueT]]
(if (text/= to-name current-name)
@@ -699,10 +705,10 @@
(wrap true))
(do @
[current-class (load-class current-name)
- _ (language.assert cannot-cast (format "From class/primitive: " current-name "\n"
- " To class/primitive: " to-name "\n"
- " For value: " (%code valueC) "\n")
- (Class::isAssignableFrom [current-class] to-class))
+ _ (////.assert cannot-cast (format "From class/primitive: " current-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n")
+ (Class::isAssignableFrom [current-class] to-class))
candiate-parents (monad.map @
(function (_ java-type)
(do @
@@ -721,54 +727,54 @@
(recur [next-name nextT]))
#.Nil
- (language.throw cannot-cast (format "From class/primitive: " from-name "\n"
- " To class/primitive: " to-name "\n"
- " For value: " (%code valueC) "\n")))
+ (////.throw cannot-cast (format "From class/primitive: " from-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n")))
))))))]
(if can-cast?
- (wrap (#analysisL.Extension proc (list (analysisL.text from-name)
- (analysisL.text to-name)
- valueA)))
- (language.throw cannot-cast (format "From class/primitive: " from-name "\n"
- " To class/primitive: " to-name "\n"
- " For value: " (%code valueC) "\n"))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text from-name)
+ (analysis.text to-name)
+ valueA)))
+ (////.throw cannot-cast (format "From class/primitive: " from-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n"))))
_
- (language.throw /.invalid-syntax [proc args]))))
-
-(def: object-procs
- /.Bundle
- (<| (/.prefix "object")
- (|> (dict.new text.Hash<Text>)
- (/.install "null" object//null)
- (/.install "null?" object//null?)
- (/.install "synchronized" object//synchronized)
- (/.install "throw" object//throw)
- (/.install "class" object//class)
- (/.install "instance?" object//instance?)
- (/.install "cast" object//cast)
+ (////.throw bundle.invalid-syntax extension-name))))
+
+(def: bundle::object
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> bundle.empty
+ (bundle.install "null" object::null)
+ (bundle.install "null?" object::null?)
+ (bundle.install "synchronized" object::synchronized)
+ (bundle.install "throw" object::throw)
+ (bundle.install "class" object::class)
+ (bundle.install "instance?" object::instance?)
+ (bundle.install "cast" object::cast)
)))
(def: (find-field class-name field-name)
- (-> Text Text (Meta [(Class Object) Field]))
- (do macro.Monad<Meta>
+ (-> Text Text (Operation [(Class Object) Field]))
+ (do ////.Monad<Operation>
[class (load-class class-name)]
(case (Class::getDeclaredField [field-name] class)
(#e.Success field)
(let [owner (Field::getDeclaringClass [] field)]
(if (is? owner class)
(wrap [class field])
- (language.throw mistaken-field-owner
- (format " Field: " field-name "\n"
- " Owner Class: " (Class::getName [] owner) "\n"
- "Target Class: " class-name "\n"))))
+ (////.throw mistaken-field-owner
+ (format " Field: " field-name "\n"
+ " Owner Class: " (Class::getName [] owner) "\n"
+ "Target Class: " class-name "\n"))))
(#e.Error _)
- (language.throw unknown-field (format class-name "#" field-name)))))
+ (////.throw unknown-field (format class-name "#" field-name)))))
(def: (static-field class-name field-name)
- (-> Text Text (Meta [Type Bool]))
- (do macro.Monad<Meta>
+ (-> Text Text (Operation [Type Bool]))
+ (do ////.Monad<Operation>
[[class fieldJ] (find-field class-name field-name)
#let [modifiers (Field::getModifiers [] fieldJ)]]
(if (Modifier::isStatic [modifiers])
@@ -776,11 +782,11 @@
(do @
[fieldT (java-type-to-lux-type fresh-mappings fieldJT)]
(wrap [fieldT (Modifier::isFinal [modifiers])])))
- (language.throw not-a-static-field (format class-name "#" field-name)))))
+ (////.throw not-a-static-field (format class-name "#" field-name)))))
(def: (virtual-field class-name field-name objectT)
- (-> Text Text Type (Meta [Type Bool]))
- (do macro.Monad<Meta>
+ (-> Text Text Type (Operation [Type Bool]))
+ (do ////.Monad<Operation>
[[class fieldJ] (find-field class-name field-name)
#let [modifiers (Field::getModifiers [] fieldJ)]]
(if (not (Modifier::isStatic [modifiers]))
@@ -790,130 +796,130 @@
(Class::getTypeParameters [])
array.to-list
(list/map (TypeVariable::getName [])))]
- mappings (: (Meta Mappings)
+ mappings (: (Operation Mappings)
(case objectT
(#.Primitive _class-name _class-params)
(do @
[#let [num-params (list.size _class-params)
num-vars (list.size var-names)]
- _ (language.assert type-parameter-mismatch
- (format "Expected: " (%i (.int num-params)) "\n"
- " Actual: " (%i (.int num-vars)) "\n"
- " Class: " _class-name "\n"
- " Type: " (%type objectT))
- (n/= num-params num-vars))]
+ _ (////.assert type-parameter-mismatch
+ (format "Expected: " (%i (.int num-params)) "\n"
+ " Actual: " (%i (.int num-vars)) "\n"
+ " Class: " _class-name "\n"
+ " Type: " (%type objectT))
+ (n/= num-params num-vars))]
(wrap (|> (list.zip2 var-names _class-params)
- (dict.from-list text.Hash<Text>))))
+ (dictionary.from-list text.Hash<Text>))))
_
- (language.throw non-object objectT)))
+ (////.throw non-object objectT)))
fieldT (java-type-to-lux-type mappings fieldJT)]
(wrap [fieldT (Modifier::isFinal [modifiers])]))
- (language.throw not-a-virtual-field (format class-name "#" field-name)))))
+ (////.throw not-a-virtual-field (format class-name "#" field-name)))))
-(def: (static//get proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: static::get
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list classC fieldC))
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[[fieldT final?] (static-field class field)]
- (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field)))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field)))))
_
- (language.throw /.invalid-syntax [proc args]))
+ (////.throw bundle.invalid-syntax extension-name))
_
- (language.throw /.incorrect-extension-arity [proc +2 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))
-(def: (static//put proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: static::put
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list classC fieldC valueC))
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[_ (typeA.infer Any)
[fieldT final?] (static-field class field)
- _ (language.assert cannot-set-a-final-field (format class "#" field)
- (not final?))
+ _ (////.assert cannot-set-a-final-field (format class "#" field)
+ (not final?))
valueA (typeA.with-type fieldT
(analyse valueC))]
- (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA))))
_
- (language.throw /.invalid-syntax [proc args]))
+ (////.throw bundle.invalid-syntax extension-name))
_
- (language.throw /.incorrect-extension-arity [proc +3 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)]))))
-(def: (virtual//get proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: virtual::get
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list classC fieldC objectC))
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[[objectT objectA] (typeA.with-inference
(analyse objectC))
[fieldT final?] (virtual-field class field objectT)]
- (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) objectA))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) objectA))))
_
- (language.throw /.invalid-syntax [proc args]))
+ (////.throw bundle.invalid-syntax extension-name))
_
- (language.throw /.incorrect-extension-arity [proc +3 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)]))))
-(def: (virtual//put proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: virtual::put
+ Handler
+ (function (_ extension-name analyse args)
(case args
(^ (list classC fieldC valueC objectC))
(case [classC fieldC]
[[_ (#.Text class)] [_ (#.Text field)]]
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[[objectT objectA] (typeA.with-inference
(analyse objectC))
_ (typeA.infer objectT)
[fieldT final?] (virtual-field class field objectT)
- _ (language.assert cannot-set-a-final-field (format class "#" field)
- (not final?))
+ _ (////.assert cannot-set-a-final-field (format class "#" field)
+ (not final?))
valueA (typeA.with-type fieldT
(analyse valueC))]
- (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA objectA))))
+ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA objectA))))
_
- (language.throw /.invalid-syntax [proc args]))
+ (////.throw bundle.invalid-syntax extension-name))
_
- (language.throw /.incorrect-extension-arity [proc +4 (list.size args)]))))
+ (////.throw bundle.incorrect-arity [extension-name +4 (list.size args)]))))
(def: (java-type-to-parameter type)
- (-> java/lang/reflect/Type (Meta Text))
+ (-> java/lang/reflect/Type (Operation Text))
(cond (host.instance? Class type)
- (macro/wrap (Class::getName [] (:coerce Class type)))
+ (operation/wrap (Class::getName [] (:coerce Class type)))
(host.instance? ParameterizedType type)
(java-type-to-parameter (ParameterizedType::getRawType [] (:coerce ParameterizedType type)))
(or (host.instance? TypeVariable type)
(host.instance? WildcardType type))
- (macro/wrap "java.lang.Object")
+ (operation/wrap "java.lang.Object")
(host.instance? GenericArrayType type)
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:coerce GenericArrayType type)))]
(wrap (format componentP "[]")))
## else
- (language.throw cannot-convert-to-a-parameter (jvm-type-name type))))
+ (////.throw cannot-convert-to-a-parameter type)))
-(type: Method-style
+(type: Method-Style
#Static
#Abstract
#Virtual
@@ -921,8 +927,8 @@
#Interface)
(def: (check-method class method-name method-style arg-classes method)
- (-> (Class Object) Text Method-style (List Text) Method (Meta Bool))
- (do macro.Monad<Meta>
+ (-> (Class Object) Text Method-Style (List Text) Method (Operation Bool))
+ (do ////.Monad<Operation>
[parameters (|> (Method::getGenericParameterTypes [] method)
array.to-list
(monad.map @ java-type-to-parameter))
@@ -950,8 +956,8 @@
(list.zip2 arg-classes parameters))))))
(def: (check-constructor class arg-classes constructor)
- (-> (Class Object) (List Text) (Constructor Object) (Meta Bool))
- (do macro.Monad<Meta>
+ (-> (Class Object) (List Text) (Constructor Object) (Operation Bool))
+ (do ////.Monad<Operation>
[parameters (|> (Constructor::getGenericParameterTypes [] constructor)
array.to-list
(monad.map @ java-type-to-parameter))]
@@ -974,8 +980,8 @@
(|> (list.n/range offset (|> amount dec (n/+ offset)))
(list/map idx-to-parameter))))
-(def: (method-to-type method-style method)
- (-> Method-style Method (Meta [Type (List Type)]))
+(def: (method-signature method-style method)
+ (-> Method-Style Method (Operation Method-Signature))
(let [owner (Method::getDeclaringClass [] method)
owner-name (Class::getName [] owner)
owner-tvars (case method-style
@@ -1001,8 +1007,8 @@
(|> (list/compose owner-tvarsT method-tvarsT)
list.reverse
(list.zip2 all-tvars)
- (dict.from-list text.Hash<Text>))))]
- (do macro.Monad<Meta>
+ (dictionary.from-list text.Hash<Text>))))]
+ (do ////.Monad<Operation>
[inputsT (|> (Method::getGenericParameterTypes [] method)
array.to-list
(monad.map @ (java-type-to-lux-type mappings)))
@@ -1021,14 +1027,14 @@
outputT)]]
(wrap [methodT exceptionsT]))))
-(type: (Evaluation a)
- (#Pass a)
- (#Hint a)
+(type: Evaluation
+ (#Pass Method-Signature)
+ (#Hint Method-Signature)
#Fail)
(do-template [<name> <tag>]
[(def: <name>
- (All [a] (-> (Evaluation a) (Maybe a)))
+ (-> Evaluation (Maybe Method-Signature))
(|>> (case> (<tag> output)
(#.Some output)
@@ -1040,40 +1046,36 @@
)
(def: (method-candidate class-name method-name method-style arg-classes)
- (-> Text Text Method-style (List Text) (Meta [Type (List Type)]))
- (do macro.Monad<Meta>
+ (-> Text Text Method-Style (List Text) (Operation Method-Signature))
+ (do ////.Monad<Operation>
[class (load-class class-name)
candidates (|> class
(Class::getDeclaredMethods [])
array.to-list
- (monad.map @ (: (-> Method (Meta (Evaluation Method)))
+ (monad.map @ (: (-> Method (Operation Evaluation))
(function (_ method)
(do @
[passes? (check-method class method-name method-style arg-classes method)]
- (wrap (cond passes?
- (#Pass method)
+ (cond passes?
+ (:: @ map (|>> #Pass) (method-signature method-style method))
- (text/= method-name (Method::getName [] method))
- (#Hint method)
+ (text/= method-name (Method::getName [] method))
+ (:: @ map (|>> #Hint) (method-signature method-style method))
- ## else
- #Fail)))))))]
+ ## else
+ (wrap #Fail)))))))]
(case (list.search-all pass! candidates)
#.Nil
- (language.throw no-candidates [class-name method-name
- (|> candidates
- (list.search-all hint!)
- (list/map (method-to-type method-style)))])
+ (////.throw no-candidates [class-name method-name (list.search-all hint! candidates)])
(#.Cons method #.Nil)
- (method-to-type method-style method)
+ (wrap method)
candidates
- (language.throw too-many-candidates [class-name method-name
- (list/map (method-to-type method-style) candidates)]))))
+ (////.throw too-many-candidates [class-name method-name candidates]))))
-(def: (constructor-to-type constructor)
- (-> (Constructor Object) (Meta [Type (List Type)]))
+(def: (constructor-signature constructor)
+ (-> (Constructor Object) (Operation Method-Signature))
(let [owner (Constructor::getDeclaringClass [] constructor)
owner-name (Class::getName [] owner)
owner-tvars (|> (Class::getTypeParameters [] owner)
@@ -1093,8 +1095,8 @@
(|> (list/compose owner-tvarsT constructor-tvarsT)
list.reverse
(list.zip2 all-tvars)
- (dict.from-list text.Hash<Text>))))]
- (do macro.Monad<Meta>
+ (dictionary.from-list text.Hash<Text>))))]
+ (do ////.Monad<Operation>
[inputsT (|> (Constructor::getGenericParameterTypes [] constructor)
array.to-list
(monad.map @ (java-type-to-lux-type mappings)))
@@ -1110,8 +1112,8 @@
(def: constructor-method "<init>")
(def: (constructor-candidate class-name arg-classes)
- (-> Text (List Text) (Meta [Type (List Type)]))
- (do macro.Monad<Meta>
+ (-> Text (List Text) (Operation Method-Signature))
+ (do ////.Monad<Operation>
[class (load-class class-name)
candidates (|> class
(Class::getConstructors [])
@@ -1119,52 +1121,50 @@
(monad.map @ (function (_ constructor)
(do @
[passes? (check-constructor class arg-classes constructor)]
- (wrap [passes? constructor])))))]
+ (:: @ map
+ (if passes? (|>> #Pass) (|>> #Hint))
+ (constructor-signature constructor))))))]
(case (list.search-all pass! candidates)
#.Nil
- (language.throw no-candidates [class-name ..constructor-method
- (|> candidates
- (list.search-all hint!)
- (list/map constructor-to-type))])
+ (////.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)])
(#.Cons constructor #.Nil)
- (constructor-to-type constructor)
+ (wrap constructor)
candidates
- (language.throw too-many-candidates [class-name ..constructor-method
- (list/map constructor-to-type candidates)]))))
+ (////.throw too-many-candidates [class-name ..constructor-method candidates]))))
(def: (decorate-inputs typesT inputsA)
(-> (List Text) (List Analysis) (List Analysis))
(|> inputsA
- (list.zip2 (list/map analysisL.text typesT))
+ (list.zip2 (list/map analysis.text typesT))
(list/map (function (_ [type value])
- (analysisL.product-analysis (list type value))))))
+ (analysis.product-analysis (list type value))))))
-(def: (invoke//static proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: invoke::static
+ Handler
+ (function (_ extension-name analyse args)
(case (: (e.Error [Text Text (List [Text Code])])
(s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any))))))
(#e.Success [class method argsTC])
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Static argsT)
[outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))
outputJC (check-jvm outputT)]
- (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method)
- (analysisL.text outputJC) (decorate-inputs argsT argsA)))))
+ (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method)
+ (analysis.text outputJC) (decorate-inputs argsT argsA)))))
_
- (language.throw /.invalid-syntax [proc args]))))
+ (////.throw bundle.invalid-syntax extension-name))))
-(def: (invoke//virtual proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: invoke::virtual
+ Handler
+ (function (_ extension-name analyse args)
(case (: (e.Error [Text Text Code (List [Text Code])])
(s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))))))
(#e.Success [class method objectC argsTC])
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Virtual argsT)
[outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
@@ -1175,98 +1175,98 @@
_
(undefined))]
outputJC (check-jvm outputT)]
- (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method)
- (analysisL.text outputJC) objectA (decorate-inputs argsT argsA)))))
+ (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method)
+ (analysis.text outputJC) objectA (decorate-inputs argsT argsA)))))
_
- (language.throw /.invalid-syntax [proc args]))))
+ (////.throw bundle.invalid-syntax extension-name))))
-(def: (invoke//special proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: invoke::special
+ Handler
+ (function (_ extension-name analyse args)
(case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]])
(p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!)))
(#e.Success [_ [class method objectC argsTC _]])
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Special argsT)
[outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
outputJC (check-jvm outputT)]
- (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method)
- (analysisL.text outputJC) (decorate-inputs argsT argsA)))))
+ (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method)
+ (analysis.text outputJC) (decorate-inputs argsT argsA)))))
_
- (language.throw /.invalid-syntax [proc args]))))
+ (////.throw bundle.invalid-syntax extension-name))))
-(def: (invoke//interface proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: invoke::interface
+ Handler
+ (function (_ extension-name analyse args)
(case (: (e.Error [Text Text Code (List [Text Code])])
(s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))))))
(#e.Success [class-name method objectC argsTC])
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[#let [argsT (list/map product.left argsTC)]
class (load-class class-name)
- _ (language.assert non-interface class-name
- (Modifier::isInterface [(Class::getModifiers [] class)]))
+ _ (////.assert non-interface class-name
+ (Modifier::isInterface [(Class::getModifiers [] class)]))
[methodT exceptionsT] (method-candidate class-name method #Interface argsT)
[outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC)))
outputJC (check-jvm outputT)]
- (wrap (#analysisL.Extension proc
- (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC)
- (decorate-inputs argsT argsA)))))
+ (wrap (#analysis.Extension extension-name
+ (list& (analysis.text class-name) (analysis.text method) (analysis.text outputJC)
+ (decorate-inputs argsT argsA)))))
_
- (language.throw /.invalid-syntax [proc args]))))
+ (////.throw bundle.invalid-syntax extension-name))))
-(def: (invoke//constructor proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
+(def: invoke::constructor
+ Handler
+ (function (_ extension-name analyse args)
(case (: (e.Error [Text (List [Text Code])])
(s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any))))))
(#e.Success [class argsTC])
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[#let [argsT (list/map product.left argsTC)]
[methodT exceptionsT] (constructor-candidate class argsT)
[outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))]
- (wrap (#analysisL.Extension proc (list& (analysisL.text class) (decorate-inputs argsT argsA)))))
+ (wrap (#analysis.Extension extension-name (list& (analysis.text class) (decorate-inputs argsT argsA)))))
_
- (language.throw /.invalid-syntax [proc args]))))
-
-(def: member-procs
- /.Bundle
- (<| (/.prefix "member")
- (|> (dict.new text.Hash<Text>)
- (dict.merge (<| (/.prefix "static")
- (|> (dict.new text.Hash<Text>)
- (/.install "get" static//get)
- (/.install "put" static//put))))
- (dict.merge (<| (/.prefix "virtual")
- (|> (dict.new text.Hash<Text>)
- (/.install "get" virtual//get)
- (/.install "put" virtual//put))))
- (dict.merge (<| (/.prefix "invoke")
- (|> (dict.new text.Hash<Text>)
- (/.install "static" invoke//static)
- (/.install "virtual" invoke//virtual)
- (/.install "special" invoke//special)
- (/.install "interface" invoke//interface)
- (/.install "constructor" invoke//constructor)
- )))
+ (////.throw bundle.invalid-syntax extension-name))))
+
+(def: bundle::member
+ Bundle
+ (<| (bundle.prefix "member")
+ (|> bundle.empty
+ (dictionary.merge (<| (bundle.prefix "static")
+ (|> bundle.empty
+ (bundle.install "get" static::get)
+ (bundle.install "put" static::put))))
+ (dictionary.merge (<| (bundle.prefix "virtual")
+ (|> bundle.empty
+ (bundle.install "get" virtual::get)
+ (bundle.install "put" virtual::put))))
+ (dictionary.merge (<| (bundle.prefix "invoke")
+ (|> bundle.empty
+ (bundle.install "static" invoke::static)
+ (bundle.install "virtual" invoke::virtual)
+ (bundle.install "special" invoke::special)
+ (bundle.install "interface" invoke::interface)
+ (bundle.install "constructor" invoke::constructor)
+ )))
)))
-(def: #export extensions
- /.Bundle
- (<| (/.prefix "jvm")
- (|> (dict.new text.Hash<Text>)
- (dict.merge conversion-procs)
- (dict.merge int-procs)
- (dict.merge long-procs)
- (dict.merge float-procs)
- (dict.merge double-procs)
- (dict.merge char-procs)
- (dict.merge array-procs)
- (dict.merge object-procs)
- (dict.merge member-procs)
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "jvm")
+ (|> bundle.empty
+ (dictionary.merge bundle::conversion)
+ (dictionary.merge bundle::int)
+ (dictionary.merge bundle::long)
+ (dictionary.merge bundle::float)
+ (dictionary.merge bundle::double)
+ (dictionary.merge bundle::char)
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+ (dictionary.merge bundle::member)
)))
diff --git a/stdlib/source/lux/language/compiler/extension/bundle.lux b/stdlib/source/lux/language/compiler/extension/bundle.lux
index 315d05523..222ad7f5e 100644
--- a/stdlib/source/lux/language/compiler/extension/bundle.lux
+++ b/stdlib/source/lux/language/compiler/extension/bundle.lux
@@ -20,9 +20,13 @@
(ex.report ["Extension" name]))
## [Utils]
+(def: #export empty
+ //.Bundle
+ (dict.new text.Hash<Text>))
+
(def: #export (install name anonymous)
(All [s i o]
- (-> Text (-> Text (//.Handler s i o))
+ (-> Text (//.Handler s i o)
(-> (//.Bundle s i o) (//.Bundle s i o))))
(dict.put name anonymous))
diff --git a/stdlib/source/lux/language/compiler/synthesis.lux b/stdlib/source/lux/language/compiler/synthesis.lux
index 2e359d2ea..05be98f3c 100644
--- a/stdlib/source/lux/language/compiler/synthesis.lux
+++ b/stdlib/source/lux/language/compiler/synthesis.lux
@@ -4,9 +4,11 @@
[data
[error (#+ Error)]
[collection ["dict" dictionary (#+ Dictionary)]]]]
- [///reference (#+ Register Variable Reference)]
- [// (#+ Operation Compiler)]
- [//analysis (#+ Environment Arity Analysis)])
+ ["." //
+ [analysis (#+ Environment Arity Analysis)]
+ [extension (#+ Extension)]
+ [//
+ [reference (#+ Register Variable Reference)]]])
(type: #export Resolver (Dictionary Variable Variable))
@@ -18,7 +20,7 @@
(def: #export fresh-resolver
Resolver
- (dict.new ///reference.Hash<Variable>))
+ (dict.new reference.Hash<Variable>))
(def: #export init
State
@@ -34,8 +36,8 @@
(#Text Text))
(type: #export (Structure a)
- (#Variant (//analysis.Variant a))
- (#Tuple (//analysis.Tuple a)))
+ (#Variant (analysis.Variant a))
+ (#Tuple (analysis.Tuple a)))
(type: #export Side
(Either Nat Nat))
@@ -88,7 +90,14 @@
(#Primitive Primitive)
(#Structure (Structure Synthesis))
(#Reference Reference)
- (#Control (Control Synthesis)))
+ (#Control (Control Synthesis))
+ (#Extension (Extension Synthesis)))
+
+(type: #export Operation
+ (extension.Operation ..State Analysis Synthesis))
+
+(type: #export Compiler
+ (extension.Compiler ..State Analysis Synthesis))
(type: #export Path
(Path' Synthesis))
@@ -144,13 +153,10 @@
(def: #export unit Text "")
-(type: #export Synthesizer
- (Compiler ..State Analysis Synthesis))
-
(do-template [<name> <value>]
[(def: #export <name>
- (All [a] (-> (Operation ..State a) (Operation ..State a)))
- (//.localized (set@ #direct? <value>)))]
+ (All [a] (-> (Operation a) (Operation a)))
+ (extension.temporary (set@ #direct? <value>)))]
[indirectly false]
[directly true]
@@ -158,8 +164,8 @@
(do-template [<name> <type> <tag>]
[(def: #export (<name> value)
- (-> <type> (All [a] (-> (Operation ..State a) (Operation ..State a))))
- (//.localized (set@ <tag> value)))]
+ (-> <type> (All [a] (-> (Operation a) (Operation a))))
+ (extension.temporary (set@ <tag> value)))]
[with-scope-arity Arity #scope-arity]
[with-resolver Resolver #resolver]
@@ -167,19 +173,17 @@
)
(def: #export (with-abstraction arity resolver)
- (All [o]
- (-> Arity Resolver
- (-> (Operation ..State o) (Operation ..State o))))
- (//.with-state {#scope-arity arity
- #resolver resolver
- #direct? true
- #locals arity}))
+ (-> Arity Resolver
+ (All [a] (-> (Operation a) (Operation a))))
+ (extension.with-state {#scope-arity arity
+ #resolver resolver
+ #direct? true
+ #locals arity}))
(do-template [<name> <tag> <type>]
[(def: #export <name>
- (Operation ..State <type>)
- (function (_ state)
- (#error.Success [state (get@ <tag> state)])))]
+ (Operation <type>)
+ (extension.read (get@ <tag>)))]
[scope-arity #scope-arity Arity]
[resolver #resolver Resolver]
@@ -188,7 +192,7 @@
)
(def: #export with-new-local
- (All [a] (-> (Operation ..State a) (Operation ..State a)))
+ (All [a] (-> (Operation a) (Operation a)))
(<<| (do //.Monad<Operation>
[locals ..locals])
(..with-locals (inc locals))))
@@ -219,8 +223,8 @@
<tag>
content))]
- [variable/local ///reference.local]
- [variable/foreign ///reference.foreign]
+ [variable/local reference.local]
+ [variable/foreign reference.foreign]
)
(do-template [<name> <family> <tag>]
diff --git a/stdlib/source/lux/language/compiler/synthesis/case.lux b/stdlib/source/lux/language/compiler/synthesis/case.lux
index 7dd8b3157..de7a4f9fd 100644
--- a/stdlib/source/lux/language/compiler/synthesis/case.lux
+++ b/stdlib/source/lux/language/compiler/synthesis/case.lux
@@ -11,42 +11,43 @@
format]
[number ("frac/" Equivalence<Frac>)]
[collection [list ("list/" Fold<List> Monoid<List>)]]]]
- [///reference]
- [///compiler (#+ Operation) ("operation/" Monad<Operation>)]
- [///analysis (#+ Pattern Match Analysis)]
- [// (#+ Path Synthesis)]
- [//function])
+ [// (#+ Path Synthesis)
+ [function]
+ [///
+ [reference]
+ [compiler (#+ Operation) ("operation/" Monad<Operation>)]
+ [analysis (#+ Pattern Match Analysis)]]])
(def: (path' pattern bodyC)
(-> Pattern (Operation //.State Path) (Operation //.State Path))
(case pattern
- (#///analysis.Simple simple)
+ (#analysis.Simple simple)
(case simple
- #///analysis.Unit
+ #analysis.Unit
bodyC
(^template [<from> <to>]
(<from> value)
(operation/map (|>> (#//.Seq (#//.Test (|> value <to>))))
bodyC))
- ([#///analysis.Bool #//.Bool]
- [#///analysis.Nat (<| #//.I64 .i64)]
- [#///analysis.Int (<| #//.I64 .i64)]
- [#///analysis.Rev (<| #//.I64 .i64)]
- [#///analysis.Frac #//.F64]
- [#///analysis.Text #//.Text]))
+ ([#analysis.Bool #//.Bool]
+ [#analysis.Nat (<| #//.I64 .i64)]
+ [#analysis.Int (<| #//.I64 .i64)]
+ [#analysis.Rev (<| #//.I64 .i64)]
+ [#analysis.Frac #//.F64]
+ [#analysis.Text #//.Text]))
- (#///analysis.Bind register)
- (<| (do ///compiler.Monad<Operation>
+ (#analysis.Bind register)
+ (<| (do compiler.Monad<Operation>
[arity //.scope-arity])
- (:: @ map (|>> (#//.Seq (#//.Bind (if (//function.nested? arity)
+ (:: @ map (|>> (#//.Seq (#//.Bind (if (function.nested? arity)
(n/+ (dec arity) register)
register)))))
//.with-new-local
bodyC)
- (#///analysis.Complex _)
- (case (///analysis.variant-pattern pattern)
+ (#analysis.Complex _)
+ (case (analysis.variant-pattern pattern)
(#.Some [lefts right? value-pattern])
(operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right?
(#.Right lefts)
@@ -54,11 +55,11 @@
(path' value-pattern bodyC))
#.None
- (let [tuple (///analysis.tuple-pattern pattern)
+ (let [tuple (analysis.tuple-pattern pattern)
tuple/last (dec (list.size tuple))]
(list/fold (function (_ [tuple/idx tuple/member] thenC)
(case tuple/member
- (#///analysis.Simple #///analysis.Unit)
+ (#analysis.Simple #analysis.Unit)
thenC
_
@@ -126,15 +127,15 @@
(def: #export (synthesize synthesize^ inputA [headB tailB+])
(-> //.Synthesizer Analysis Match (Operation //.State Synthesis))
- (do ///compiler.Monad<Operation>
+ (do compiler.Monad<Operation>
[inputS (synthesize^ inputA)]
(with-expansions [<unnecesary-let>
- (as-is (^multi (^ (#///analysis.Reference (///reference.local outputR)))
+ (as-is (^multi (^ (#analysis.Reference (reference.local outputR)))
(n/= inputR outputR))
(wrap inputS))
<let>
- (as-is [[(#///analysis.Bind inputR) headB/bodyA]
+ (as-is [[(#analysis.Bind inputR) headB/bodyA]
#.Nil]
(case headB/bodyA
<unnecesary-let>
@@ -145,16 +146,16 @@
headB/bodyS (//.with-new-local
(synthesize^ headB/bodyA))]
(wrap (//.branch/let [inputS
- (if (//function.nested? arity)
+ (if (function.nested? arity)
(n/+ (dec arity) inputR)
inputR)
headB/bodyS])))))
<if>
- (as-is (^or (^ [[(///analysis.pattern/bool true) thenA]
- (list [(///analysis.pattern/bool false) elseA])])
- (^ [[(///analysis.pattern/bool false) elseA]
- (list [(///analysis.pattern/bool true) thenA])]))
+ (as-is (^or (^ [[(analysis.pattern/bool true) thenA]
+ (list [(analysis.pattern/bool false) elseA])])
+ (^ [[(analysis.pattern/bool false) elseA]
+ (list [(analysis.pattern/bool true) thenA])]))
(do @
[thenS (synthesize^ thenA)
elseS (synthesize^ elseA)]
diff --git a/stdlib/source/lux/language/compiler/synthesis/expression.lux b/stdlib/source/lux/language/compiler/synthesis/expression.lux
index ffc22d89a..80480de68 100644
--- a/stdlib/source/lux/language/compiler/synthesis/expression.lux
+++ b/stdlib/source/lux/language/compiler/synthesis/expression.lux
@@ -8,95 +8,96 @@
[collection
[list ("list/" Functor<List>)]
["dict" dictionary (#+ Dictionary)]]]]
- [///reference]
- [///compiler ("operation/" Monad<Operation>)]
- [///analysis (#+ Analysis)]
- [///extension (#+ Extension)]
- [// (#+ Synthesis)]
- [//function]
- [//case])
+ [// (#+ Synthesis)
+ [function]
+ [case]
+ [///
+ [reference]
+ ["." compiler ("operation/" Monad<Operation>)
+ [analysis (#+ Analysis)]
+ [extension (#+ Extension)]]]])
(exception: #export (unknown-synthesis-extension {name Text})
name)
(def: (primitive analysis)
- (-> ///analysis.Primitive //.Primitive)
+ (-> analysis.Primitive //.Primitive)
(case analysis
- #///analysis.Unit
+ #analysis.Unit
(#//.Text //.unit)
(^template [<analysis> <synthesis>]
(<analysis> value)
(<synthesis> value))
- ([#///analysis.Bool #//.Bool]
- [#///analysis.Frac #//.F64]
- [#///analysis.Text #//.Text])
+ ([#analysis.Bool #//.Bool]
+ [#analysis.Frac #//.F64]
+ [#analysis.Text #//.Text])
(^template [<analysis> <synthesis>]
(<analysis> value)
(<synthesis> (.i64 value)))
- ([#///analysis.Nat #//.I64]
- [#///analysis.Int #//.I64]
- [#///analysis.Rev #//.I64])))
+ ([#analysis.Nat #//.I64]
+ [#analysis.Int #//.I64]
+ [#analysis.Rev #//.I64])))
(def: #export (synthesizer extensions)
- (-> (Extension ///extension.Synthesis) //.Synthesizer)
+ (-> (Extension extension.Synthesis) //.Synthesizer)
(function (synthesize analysis)
(case analysis
- (#///analysis.Primitive analysis')
+ (#analysis.Primitive analysis')
(operation/wrap (#//.Primitive (..primitive analysis')))
- (#///analysis.Structure composite)
- (case (///analysis.variant analysis)
+ (#analysis.Structure composite)
+ (case (analysis.variant analysis)
(#.Some variant)
- (do ///compiler.Monad<Operation>
- [valueS (synthesize (get@ #///analysis.value variant))]
- (wrap (#//.Structure (#//.Variant (set@ #///analysis.value valueS variant)))))
+ (do compiler.Monad<Operation>
+ [valueS (synthesize (get@ #analysis.value variant))]
+ (wrap (#//.Structure (#//.Variant (set@ #analysis.value valueS variant)))))
_
- (do ///compiler.Monad<Operation>
- [tupleS (monad.map @ synthesize (///analysis.tuple analysis))]
+ (do compiler.Monad<Operation>
+ [tupleS (monad.map @ synthesize (analysis.tuple analysis))]
(wrap (#//.Structure (#//.Tuple tupleS)))))
- (#///analysis.Apply _)
- (//function.apply (|>> synthesize //.indirectly) analysis)
+ (#analysis.Apply _)
+ (function.apply (|>> synthesize //.indirectly) analysis)
- (#///analysis.Function environmentA bodyA)
- (//function.function synthesize environmentA bodyA)
+ (#analysis.Function environmentA bodyA)
+ (function.function synthesize environmentA bodyA)
- (#///analysis.Extension name args)
+ (#analysis.Extension name args)
(case (dict.get name extensions)
#.None
- (///compiler.throw unknown-synthesis-extension name)
+ (compiler.throw unknown-synthesis-extension name)
(#.Some extension)
(extension (|>> synthesize //.indirectly) args))
- (#///analysis.Reference reference)
+ (#analysis.Reference reference)
(case reference
- (#///reference.Constant constant)
+ (#reference.Constant constant)
(operation/wrap (#//.Reference reference))
- (#///reference.Variable var)
- (do ///compiler.Monad<Operation>
+ (#reference.Variable var)
+ (do compiler.Monad<Operation>
[resolver //.resolver]
(case var
- (#///reference.Local register)
+ (#reference.Local register)
(do @
[arity //.scope-arity]
- (wrap (if (//function.nested? arity)
+ (wrap (if (function.nested? arity)
(if (n/= +0 register)
(|> (dec arity)
(list.n/range +1)
(list/map (|>> //.variable/local))
[(//.variable/local +0)]
//.function/apply)
- (#//.Reference (#///reference.Variable (//function.adjust arity false var))))
- (#//.Reference (#///reference.Variable var)))))
+ (#//.Reference (#reference.Variable (function.adjust arity false var))))
+ (#//.Reference (#reference.Variable var)))))
- (#///reference.Foreign register)
- (wrap (|> resolver (dict.get var) (maybe.default var) #///reference.Variable #//.Reference)))))
+ (#reference.Foreign register)
+ (wrap (|> resolver (dict.get var) (maybe.default var) #reference.Variable #//.Reference)))))
- (#///analysis.Case inputA branchesAB+)
- (//case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+)
+ (#analysis.Case inputA branchesAB+)
+ (case.synthesize (|>> synthesize //.indirectly) inputA branchesAB+)
)))
diff --git a/stdlib/source/lux/language/compiler/synthesis/function.lux b/stdlib/source/lux/language/compiler/synthesis/function.lux
index 2b9cffd19..92e75dc94 100644
--- a/stdlib/source/lux/language/compiler/synthesis/function.lux
+++ b/stdlib/source/lux/language/compiler/synthesis/function.lux
@@ -11,11 +11,12 @@
[collection
[list ("list/" Functor<List> Monoid<List> Fold<List>)]
["dict" dictionary (#+ Dictionary)]]]]
- [///reference (#+ Variable)]
- [///compiler (#+ Operation)]
- [///analysis (#+ Environment Arity Analysis)]
- [// (#+ Synthesis Synthesizer)]
- [//loop])
+ [// (#+ Synthesis Synthesizer)
+ [loop]
+ [///
+ [reference (#+ Variable)]
+ [compiler (#+ Operation)
+ [analysis (#+ Environment Arity Analysis)]]]])
(def: #export nested?
(-> Arity Bool)
@@ -24,9 +25,9 @@
(def: #export (adjust up-arity after? var)
(-> Arity Bool Variable Variable)
(case var
- (#///reference.Local register)
+ (#reference.Local register)
(if (and after? (n/>= up-arity register))
- (#///reference.Local (n/+ (dec up-arity) register))
+ (#reference.Local (n/+ (dec up-arity) register))
var)
_
@@ -37,7 +38,7 @@
(loop [apply apply
args (list)]
(case apply
- (#///analysis.Apply arg func)
+ (#analysis.Apply arg func)
(recur func (#.Cons arg args))
_
@@ -54,7 +55,7 @@
(case funcS
(^ (//.function/abstraction functionS))
(wrap (|> functionS
- (//loop.loop (get@ #//.environment functionS) locals argsS)
+ (loop.loop (get@ #//.environment functionS) locals argsS)
(maybe.default (//.function/apply [funcS argsS]))))
(^ (//.function/apply [funcS' argsS']))
@@ -64,11 +65,11 @@
(wrap (//.function/apply [funcS argsS])))))))
(def: (prepare up down)
- (-> Arity Arity (//loop.Transform Synthesis))
+ (-> Arity Arity (loop.Transform Synthesis))
(.function (_ body)
(if (nested? up)
(#.Some body)
- (//loop.recursion down body))))
+ (loop.recursion down body))))
(exception: #export (cannot-prepare-function-body {_ []})
"")
@@ -76,14 +77,14 @@
(def: return
(All [a] (-> (Maybe a) (Operation //.State a)))
(|>> (case> (#.Some output)
- (:: ///compiler.Monad<Operation> wrap output)
+ (:: compiler.Monad<Operation> wrap output)
#.None
- (///compiler.throw cannot-prepare-function-body []))))
+ (compiler.throw cannot-prepare-function-body []))))
(def: #export (function synthesize environment body)
(-> Synthesizer Environment Analysis (Operation //.State Synthesis))
- (do ///compiler.Monad<Operation>
+ (do compiler.Monad<Operation>
[direct? //.direct?
arity //.scope-arity
resolver //.resolver
@@ -107,7 +108,7 @@
_
(|> (list.size environment) dec (list.n/range +0)
- (list/map (|>> #///reference.Foreign)))))
+ (list/map (|>> #reference.Foreign)))))
resolver' (if (and (nested? function-arity)
direct?)
(list/fold (.function (_ [from to] resolver')
diff --git a/stdlib/source/lux/language/compiler/synthesis/loop.lux b/stdlib/source/lux/language/compiler/synthesis/loop.lux
index 05af31a83..564fe5421 100644
--- a/stdlib/source/lux/language/compiler/synthesis/loop.lux
+++ b/stdlib/source/lux/language/compiler/synthesis/loop.lux
@@ -9,10 +9,11 @@
[macro
[code]
[syntax]]]
- [///]
- [///reference (#+ Register Variable)]
- [///analysis (#+ Environment)]
- [// (#+ Path Abstraction Synthesis)])
+ [// (#+ Path Abstraction Synthesis)
+ [///
+ [reference (#+ Register Variable)]
+ [compiler
+ [analysis (#+ Environment)]]]])
(type: #export (Transform a)
(-> a (Maybe a)))
@@ -24,7 +25,7 @@
#.None false))
(template: #export (self)
- (#//.Reference (///reference.local +0)))
+ (#//.Reference (reference.local +0)))
(template: (recursive-apply args)
(#//.Apply (self) args))
@@ -41,7 +42,7 @@
(#//.Structure structure)
(case structure
(#//.Variant variantS)
- (proper? (get@ #///analysis.value variantS))
+ (proper? (get@ #analysis.value variantS))
(#//.Tuple membersS+)
(list.every? proper? membersS+))
@@ -84,7 +85,7 @@
(#//.Function functionS)
(case functionS
(#//.Abstraction environment arity bodyS)
- (list.every? ///reference.self? environment)
+ (list.every? reference.self? environment)
(#//.Apply funcS argsS)
(and (proper? funcS)
@@ -161,7 +162,7 @@
(-> Environment (Transform Variable))
(function (_ variable)
(case variable
- (#///reference.Foreign register)
+ (#reference.Foreign register)
(list.nth register environment)
_
@@ -196,9 +197,9 @@
(case structureS
(#//.Variant variantS)
(do maybe.Monad<Maybe>
- [valueS' (|> variantS (get@ #///analysis.value) recur)]
+ [valueS' (|> variantS (get@ #analysis.value) recur)]
(wrap (|> variantS
- (set@ #///analysis.value valueS')
+ (set@ #analysis.value valueS')
#//.Variant
#//.Structure)))
@@ -209,16 +210,16 @@
(#//.Reference reference)
(case reference
- (^ (///reference.constant constant))
+ (^ (reference.constant constant))
(#.Some exprS)
- (^ (///reference.local register))
- (#.Some (#//.Reference (///reference.local (n/+ offset register))))
+ (^ (reference.local register))
+ (#.Some (#//.Reference (reference.local (n/+ offset register))))
- (^ (///reference.foreign register))
+ (^ (reference.foreign register))
(|> scope-environment
(list.nth register)
- (maybe/map (|>> #///reference.Variable #//.Reference))))
+ (maybe/map (|>> #reference.Variable #//.Reference))))
(^ (//.branch/case [inputS pathS]))
(do maybe.Monad<Maybe>
diff --git a/stdlib/source/lux/language/compiler/translation.lux b/stdlib/source/lux/language/compiler/translation.lux
index 01dc584e6..077076d2f 100644
--- a/stdlib/source/lux/language/compiler/translation.lux
+++ b/stdlib/source/lux/language/compiler/translation.lux
@@ -11,8 +11,10 @@
[collection
[row (#+ Row)]
["dict" dictionary (#+ Dictionary)]]]
+ [function]
[world [file (#+ File)]]]
- [// (#+ Operation Compiler)]
+ ["." //
+ [extension]]
[//synthesis (#+ Synthesis)])
(do-template [<name>]
@@ -47,8 +49,11 @@
#buffer (Maybe (Buffer code))
#artifacts (Artifacts code)})
-(type: #export (Translator anchor code)
- (Compiler (State anchor code) Synthesis code))
+(type: #export (Operation anchor code)
+ (extension.Operation (State anchor code) Synthesis code))
+
+(type: #export (Compiler anchor code)
+ (extension.Compiler (State anchor code) Synthesis code))
(def: #export (init host)
(All [anchor code] (-> (Host code) (..State anchor code)))
@@ -61,26 +66,23 @@
(def: #export (with-context expr)
(All [anchor code output]
- (-> (Operation (..State anchor code) output)
- (Operation (..State anchor code) [Text output])))
- (function (_ state)
+ (-> (Operation anchor code output)
+ (Operation anchor code [Text output])))
+ (function (_ [bundle state])
(let [[old-scope old-inner] (get@ #context state)
new-scope (format old-scope "c___" (%i (.int old-inner)))]
- (case (expr (set@ #context [new-scope +0] state))
- (#error.Success [state' output])
- (#error.Success [(set@ #context [old-scope (inc old-inner)] state')
+ (case (expr [bundle (set@ #context [new-scope +0] state)])
+ (#error.Success [[bundle' state'] output])
+ (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')]
[new-scope output]])
(#error.Error error)
(#error.Error error)))))
(def: #export context
- (All [anchor code] (Operation (..State anchor code) Text))
- (function (_ state)
- (#error.Success [state
- (|> state
- (get@ #context)
- (get@ #scope-name))])))
+ (All [anchor code] (Operation anchor code Text))
+ (extension.read (|>> (get@ #context)
+ (get@ #scope-name))))
(do-template [<tag>
<with-declaration> <with-type> <with-value>
@@ -88,57 +90,56 @@
[(def: #export <with-declaration>
(All [anchor code output] <with-type>)
(function (_ body)
- (function (_ state)
- (case (body (set@ <tag> (#.Some <with-value>) state))
- (#error.Success [state' output])
- (#error.Success [(set@ <tag> (get@ <tag> state) state')
+ (function (_ [bundle state])
+ (case (body [bundle (set@ <tag> (#.Some <with-value>) state)])
+ (#error.Success [[bundle' state'] output])
+ (#error.Success [[bundle' (set@ <tag> (get@ <tag> state) state')]
output])
(#error.Error error)
(#error.Error error)))))
(def: #export <get>
- (All [anchor code] (Operation (..State anchor code) <get-type>))
- (function (_ state)
+ (All [anchor code] (Operation anchor code <get-type>))
+ (function (_ (^@ stateE [bundle state]))
(case (get@ <tag> state)
(#.Some output)
- (#error.Success [state output])
+ (#error.Success [stateE output])
#.None
(ex.throw <exception> []))))]
[#anchor
(with-anchor anchor)
- (-> anchor (Operation (..State anchor code) output)
- (Operation (..State anchor code) output))
+ (-> anchor (Operation anchor code output)
+ (Operation anchor code output))
anchor
anchor anchor no-anchor]
[#buffer
with-buffer
- (-> (Operation (..State anchor code) output)
- (Operation (..State anchor code) output))
+ (-> (Operation anchor code output)
+ (Operation anchor code output))
row.empty
buffer (Buffer code) no-active-buffer]
)
(def: #export artifacts
(All [anchor code]
- (Operation (..State anchor code) (Artifacts code)))
- (function (_ state)
- (#error.Success [state (get@ #artifacts state)])))
+ (Operation anchor code (Artifacts code)))
+ (extension.read (get@ #artifacts)))
(do-template [<name>]
[(def: #export (<name> code)
(All [anchor code]
- (-> code (Operation (..State anchor code) Any)))
- (function (_ state)
+ (-> code (Operation anchor code Any)))
+ (function (_ (^@ stateE [bundle state]))
(case (:: (get@ #host state) <name> code)
(#error.Error error)
(ex.throw cannot-interpret error)
(#error.Success output)
- (#error.Success [state output]))))]
+ (#error.Success [stateE output]))))]
[execute!]
[evaluate!]
@@ -146,20 +147,14 @@
(def: #export (save! name code)
(All [anchor code]
- (-> Ident code (Operation (..State anchor code) Any)))
+ (-> Ident code (Operation anchor code Any)))
(do //.Monad<Operation>
[_ (execute! code)]
- (function (_ state)
- (#error.Success [(update@ #buffer
- (maybe/map (row.add [name code]))
- state)
- []]))))
+ (extension.update (update@ #buffer (maybe/map (row.add [name code]))))))
(def: #export (save-buffer! target)
(All [anchor code]
- (-> File (Operation (..State anchor code) Any)))
+ (-> File (Operation anchor code Any)))
(do //.Monad<Operation>
[buffer ..buffer]
- (function (_ state)
- (#error.Success [(update@ #artifacts (dict.put target buffer) state)
- []]))))
+ (extension.update (update@ #artifacts (dict.put target buffer)))))
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux
index 4460a3102..3ef368c18 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/case.jvm.lux
@@ -15,11 +15,11 @@
[host ["_" scheme (#+ Expression Computation Var)]]
[compiler ("operation/" Monad<Operation>)
[synthesis (#+ Synthesis Path)]]]
- [//runtime (#+ Operation Translator)]
+ [//runtime (#+ Operation Compiler)]
[//reference])
(def: #export (let translate [valueS register bodyS])
- (-> Translator [Synthesis Register Synthesis]
+ (-> Compiler [Synthesis Register Synthesis]
(Operation Computation))
(do compiler.Monad<Operation>
[valueO (translate valueS)
@@ -28,7 +28,7 @@
bodyO))))
(def: #export (record-get translate valueS pathP)
- (-> Translator Synthesis (List [Nat Bool])
+ (-> Compiler Synthesis (List [Nat Bool])
(Operation Expression))
(do compiler.Monad<Operation>
[valueO (translate valueS)]
@@ -41,7 +41,7 @@
pathP))))
(def: #export (if translate [testS thenS elseS])
- (-> Translator [Synthesis Synthesis Synthesis]
+ (-> Compiler [Synthesis Synthesis Synthesis]
(Operation Computation))
(do compiler.Monad<Operation>
[testO (translate testS)
@@ -102,7 +102,7 @@
(_.raise/1 $alt_error))))
(def: (pattern-matching' translate pathP)
- (-> Translator Path (Operation Expression))
+ (-> Compiler Path (Operation Expression))
(.case pathP
(^ (synthesis.path/then bodyS))
(translate bodyS)
@@ -157,7 +157,7 @@
(compiler.throw unrecognized-path [])))
(def: (pattern-matching translate pathP)
- (-> Translator Path (Operation Computation))
+ (-> Compiler Path (Operation Computation))
(do compiler.Monad<Operation>
[pattern-matching! (pattern-matching' translate pathP)]
(wrap (_.with-exception-handler
@@ -166,7 +166,7 @@
pattern-matching!)))))
(def: #export (case translate [valueS pathP])
- (-> Translator [Synthesis Path] (Operation Computation))
+ (-> Compiler [Synthesis Path] (Operation Computation))
(do compiler.Monad<Operation>
[valueO (translate valueS)]
(<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))]
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux
index 464f2c27d..d7ef01e61 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/expression.jvm.lux
@@ -1,55 +1,58 @@
(.module:
[lux #*
[control [monad (#+ do)]]]
- [/////
- ["." compiler
+ [//
+ [runtime (#+ Compiler)]
+ [primitive]
+ [structure]
+ [reference]
+ [function]
+ [case]
+ [loop]
+ ["." ///
[synthesis]
- [extension]]]
- [//runtime (#+ Translator)]
- [//primitive]
- [//structure]
- [//reference]
- [//function]
- [//case]
- [//loop])
+ [extension]]])
(def: #export (translate synthesis)
- Translator
+ Compiler
(case synthesis
(^template [<tag> <generator>]
(^ (<tag> value))
(<generator> value))
- ([synthesis.bool //primitive.bool]
- [synthesis.i64 //primitive.i64]
- [synthesis.f64 //primitive.f64]
- [synthesis.text //primitive.text])
+ ([synthesis.bool primitive.bool]
+ [synthesis.i64 primitive.i64]
+ [synthesis.f64 primitive.f64]
+ [synthesis.text primitive.text])
(^ (synthesis.variant variantS))
- (//structure.variant translate variantS)
+ (structure.variant translate variantS)
(^ (synthesis.tuple members))
- (//structure.tuple translate members)
+ (structure.tuple translate members)
(#synthesis.Reference reference)
- (//reference.reference reference)
+ (reference.reference reference)
(^ (synthesis.branch/case case))
- (//case.case translate case)
+ (case.case translate case)
(^ (synthesis.branch/let let))
- (//case.let translate let)
+ (case.let translate let)
(^ (synthesis.branch/if if))
- (//case.if translate if)
+ (case.if translate if)
(^ (synthesis.loop/scope scope))
- (//loop.scope translate scope)
+ (loop.scope translate scope)
(^ (synthesis.loop/recur updates))
- (//loop.recur translate updates)
+ (loop.recur translate updates)
(^ (synthesis.function/abstraction abstraction))
- (//function.function translate abstraction)
+ (function.function translate abstraction)
(^ (synthesis.function/apply application))
- (//function.apply translate application)))
+ (function.apply translate application)
+
+ (#synthesis.Extension extension)
+ (extension.apply translate extension)))
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux
index a54d67425..c7d161f14 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/extension.jvm.lux
@@ -13,7 +13,7 @@
[host ["_" scheme (#+ Computation)]]
[compiler ("operation/" Monad<Operation>)
[synthesis (#+ Synthesis)]]]
- [//runtime (#+ Operation Translator)]
+ [//runtime (#+ Operation Compiler)]
[/common]
## [/host]
)
@@ -28,7 +28,7 @@
))
(def: #export (extension translate name args)
- (-> Translator Text (List Synthesis)
+ (-> Compiler Text (List Synthesis)
(Operation Computation))
(<| (maybe.default (compiler.throw unknown-extension (%t name)))
(do maybe.Monad<Maybe>
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux
index 377fed8f5..40f817aea 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/extension/common.jvm.lux
@@ -20,11 +20,11 @@
[host ["_" scheme (#+ Expression Computation)]]
["." compiler
[synthesis (#+ Synthesis)]]]
- [///runtime (#+ Operation Translator)])
+ [///runtime (#+ Operation Compiler)])
## [Types]
(type: #export Extension
- (-> Translator (List Synthesis) (Operation Computation)))
+ (-> Compiler (List Synthesis) (Operation Computation)))
(type: #export Bundle
(Dictionary Text Extension))
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux
index 6afb04799..d5dc4541f 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/function.jvm.lux
@@ -16,12 +16,12 @@
[analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)]
[synthesis (#+ Synthesis)]]]
[///]
- [//runtime (#+ Operation Translator)]
+ [//runtime (#+ Operation Compiler)]
[//primitive]
[//reference])
(def: #export (apply translate [functionS argsS+])
- (-> Translator (Application Synthesis) (Operation Computation))
+ (-> Compiler (Application Synthesis) (Operation Computation))
(do compiler.Monad<Operation>
[functionO (translate functionS)
argsO+ (monad.map @ translate argsS+)]
@@ -50,7 +50,7 @@
(|>> inc //reference.local'))
(def: #export (function translate [environment arity bodyS])
- (-> Translator (Abstraction Synthesis) (Operation Computation))
+ (-> Compiler (Abstraction Synthesis) (Operation Computation))
(do compiler.Monad<Operation>
[[function-name bodyO] (///.with-context
(do @
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux
index 227a2eda9..4e8d90341 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/loop.jvm.lux
@@ -14,13 +14,13 @@
["." compiler
[synthesis (#+ Scope Synthesis)]]]
[///]
- [//runtime (#+ Operation Translator)]
+ [//runtime (#+ Operation Compiler)]
[//reference])
(def: @scope (_.var "scope"))
(def: #export (scope translate [start initsS+ bodyS])
- (-> Translator (Scope Synthesis) (Operation Computation))
+ (-> Compiler (Scope Synthesis) (Operation Computation))
(do compiler.Monad<Operation>
[initsO+ (monad.map @ translate initsS+)
bodyO (///.with-anchor @scope
@@ -33,7 +33,7 @@
(_.apply/* @scope initsO+)))))
(def: #export (recur translate argsS+)
- (-> Translator (List Synthesis) (Operation Computation))
+ (-> Compiler (List Synthesis) (Operation Computation))
(do compiler.Monad<Operation>
[@scope ///.anchor
argsO+ (monad.map @ translate argsS+)]
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux
index 51dd2f515..f9eba9bd7 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/reference.jvm.lux
@@ -12,7 +12,7 @@
[compiler ("operation/" Monad<Operation>)
[analysis (#+ Variant Tuple)]
[synthesis (#+ Synthesis)]]]
- [//runtime (#+ Operation Translator)]
+ [//runtime (#+ Operation)]
[//primitive])
(do-template [<name> <prefix>]
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux
index d2a72d140..a1ce941d2 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/runtime.jvm.lux
@@ -12,19 +12,19 @@
[macro
[code]
["s" syntax (#+ syntax:)]]]
- [/// (#+ State)]
- [/////
- [name]
- [host ["_" scheme (#+ Expression Computation Var)]]
- ["." compiler
+ ["." ///
+ ["//." //
[analysis (#+ Variant)]
- [synthesis]]])
+ [synthesis]
+ [//
+ [name]
+ [host ["_" scheme (#+ Expression Computation Var)]]]]])
(type: #export Operation
- (compiler.Operation (State Var Expression)))
+ (///.Operation Var Expression))
-(type: #export Translator
- (///.Translator Var Expression))
+(type: #export Compiler
+ (///.Compiler Var Expression))
(def: prefix Text "LuxRuntime")
@@ -362,6 +362,6 @@
(def: #export translate
(Operation Any)
(///.with-buffer
- (do compiler.Monad<Operation>
+ (do ////.Monad<Operation>
[_ (///.save! ["" ..prefix] ..runtime)]
(///.save-buffer! ""))))
diff --git a/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux b/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux
index ea5440d67..4637d1a25 100644
--- a/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux
+++ b/stdlib/source/lux/language/compiler/translation/scheme/structure.jvm.lux
@@ -7,11 +7,11 @@
["." compiler
[analysis (#+ Variant Tuple)]
[synthesis (#+ Synthesis)]]]
- [//runtime (#+ Operation Translator)]
+ [//runtime (#+ Operation Compiler)]
[//primitive])
(def: #export (tuple translate elemsS+)
- (-> Translator (Tuple Synthesis) (Operation Expression))
+ (-> Compiler (Tuple Synthesis) (Operation Expression))
(case elemsS+
#.Nil
(//primitive.text synthesis.unit)
@@ -25,7 +25,7 @@
(wrap (_.vector/* elemsT+)))))
(def: #export (variant translate [lefts right? valueS])
- (-> Translator (Variant Synthesis) (Operation Expression))
+ (-> Compiler (Variant Synthesis) (Operation Expression))
(do compiler.Monad<Operation>
[valueT (translate valueS)]
(wrap (//runtime.variant [lefts right? valueT]))))
diff --git a/stdlib/source/lux/language/module.lux b/stdlib/source/lux/language/module.lux
deleted file mode 100644
index 75a1ab302..000000000
--- a/stdlib/source/lux/language/module.lux
+++ /dev/null
@@ -1,243 +0,0 @@
-(.module:
- [lux #*
- [control
- [monad (#+ do)]
- ["ex" exception (#+ exception:)]
- pipe]
- [data
- [text ("text/" Equivalence<Text>)
- format]
- ["e" error]
- [collection
- [list ("list/" Fold<List> Functor<List>)]
- [dictionary [plist]]]]
- [macro]]
- ["." //compiler
- [analysis]])
-
-(type: #export Tag Text)
-
-(exception: #export (unknown-module {module Text})
- module)
-
-(exception: #export (cannot-declare-tag-twice {module Text} {tag Text})
- (ex.report ["Module" module]
- ["Tag" tag]))
-
-(do-template [<name>]
- [(exception: #export (<name> {tags (List Text)} {owner Type})
- (ex.report ["Tags" (text.join-with " " tags)]
- ["Type" (%type owner)]))]
-
- [cannot-declare-tags-for-unnamed-type]
- [cannot-declare-tags-for-foreign-type]
- )
-
-(exception: #export (cannot-define-more-than-once {name Ident})
- (%ident name))
-
-(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State})
- (ex.report ["Module" module]
- ["Desired state" (case state
- #.Active "Active"
- #.Compiled "Compiled"
- #.Cached "Cached")]))
-
-(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code})
- (ex.report ["Module" module]
- ["Old annotations" (%code old)]
- ["New annotations" (%code new)]))
-
-(def: (new hash)
- (-> Nat Module)
- {#.module-hash hash
- #.module-aliases (list)
- #.definitions (list)
- #.imports (list)
- #.tags (list)
- #.types (list)
- #.module-annotations #.None
- #.module-state #.Active})
-
-(def: #export (set-annotations annotations)
- (-> Code (Meta Any))
- (do macro.Monad<Meta>
- [self-name macro.current-module-name
- self macro.current-module]
- (case (get@ #.module-annotations self)
- #.None
- (function (_ compiler)
- (#e.Success [(update@ #.modules
- (plist.put self-name (set@ #.module-annotations (#.Some annotations) self))
- compiler)
- []]))
-
- (#.Some old)
- (//compiler.throw cannot-set-module-annotations-more-than-once [self-name old annotations]))))
-
-(def: #export (import module)
- (-> Text (Meta Any))
- (do macro.Monad<Meta>
- [self-name macro.current-module-name]
- (function (_ compiler)
- (#e.Success [(update@ #.modules
- (plist.update self-name (update@ #.imports (|>> (#.Cons module))))
- compiler)
- []]))))
-
-(def: #export (alias alias module)
- (-> Text Text (Meta Any))
- (do macro.Monad<Meta>
- [self-name macro.current-module-name]
- (function (_ compiler)
- (#e.Success [(update@ #.modules
- (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text]))
- (|>> (#.Cons [alias module])))))
- compiler)
- []]))))
-
-(def: #export (exists? module)
- (-> Text (Meta Bool))
- (function (_ compiler)
- (|> compiler
- (get@ #.modules)
- (plist.get module)
- (case> (#.Some _) true #.None false)
- [compiler] #e.Success)))
-
-(def: #export (define name definition)
- (-> Text Definition (Meta []))
- (do macro.Monad<Meta>
- [self-name macro.current-module-name
- self macro.current-module]
- (function (_ compiler)
- (case (plist.get name (get@ #.definitions self))
- #.None
- (#e.Success [(update@ #.modules
- (plist.put self-name
- (update@ #.definitions
- (: (-> (List [Text Definition]) (List [Text Definition]))
- (|>> (#.Cons [name definition])))
- self))
- compiler)
- []])
-
- (#.Some already-existing)
- ((//compiler.throw cannot-define-more-than-once [self-name name]) compiler)))))
-
-(def: #export (create hash name)
- (-> Nat Text (Meta []))
- (function (_ compiler)
- (let [module (new hash)]
- (#e.Success [(update@ #.modules
- (plist.put name module)
- compiler)
- []]))))
-
-(def: #export (with-module hash name action)
- (All [a] (-> Nat Text (Meta a) (Meta [Module a])))
- (do macro.Monad<Meta>
- [_ (create hash name)
- output (analysis.with-current-module name
- action)
- module (macro.find-module name)]
- (wrap [module output])))
-
-(do-template [<setter> <asker> <tag>]
- [(def: #export (<setter> module-name)
- (-> Text (Meta Any))
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (plist.get module-name))
- (#.Some module)
- (let [active? (case (get@ #.module-state module)
- #.Active true
- _ false)]
- (if active?
- (#e.Success [(update@ #.modules
- (plist.put module-name (set@ #.module-state <tag> module))
- compiler)
- []])
- ((//compiler.throw can-only-change-state-of-active-module [module-name <tag>])
- compiler)))
-
- #.None
- ((//compiler.throw unknown-module module-name) compiler))))
-
- (def: #export (<asker> module-name)
- (-> Text (Meta Bool))
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (plist.get module-name))
- (#.Some module)
- (#e.Success [compiler
- (case (get@ #.module-state module)
- <tag> true
- _ false)])
-
- #.None
- ((//compiler.throw unknown-module module-name) compiler))))]
-
- [set-active active? #.Active]
- [set-compiled compiled? #.Compiled]
- [set-cached cached? #.Cached]
- )
-
-(do-template [<name> <tag> <type>]
- [(def: (<name> module-name)
- (-> Text (Meta <type>))
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (plist.get module-name))
- (#.Some module)
- (#e.Success [compiler (get@ <tag> module)])
-
- #.None
- ((//compiler.throw unknown-module module-name) compiler))))]
-
- [tags #.tags (List [Text [Nat (List Ident) Bool Type]])]
- [types #.types (List [Text [(List Ident) Bool Type]])]
- [hash #.module-hash Nat]
- )
-
-(def: (ensure-undeclared-tags module-name tags)
- (-> Text (List Tag) (Meta Any))
- (do macro.Monad<Meta>
- [bindings (..tags module-name)
- _ (monad.map @
- (function (_ tag)
- (case (plist.get tag bindings)
- #.None
- (wrap [])
-
- (#.Some _)
- (//compiler.throw cannot-declare-tag-twice [module-name tag])))
- tags)]
- (wrap [])))
-
-(def: #export (declare-tags tags exported? type)
- (-> (List Tag) Bool Type (Meta Any))
- (do macro.Monad<Meta>
- [self-name macro.current-module-name
- [type-module type-name] (case type
- (#.Named type-ident _)
- (wrap type-ident)
-
- _
- (//compiler.throw cannot-declare-tags-for-unnamed-type [tags type]))
- _ (ensure-undeclared-tags self-name tags)
- _ (//compiler.assert cannot-declare-tags-for-foreign-type [tags type]
- (text/= self-name type-module))]
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (plist.get self-name))
- (#.Some module)
- (let [namespaced-tags (list/map (|>> [self-name]) tags)]
- (#e.Success [(update@ #.modules
- (plist.update self-name
- (|>> (update@ #.tags (function (_ tag-bindings)
- (list/fold (function (_ [idx tag] table)
- (plist.put tag [idx namespaced-tags exported? type] table))
- tag-bindings
- (list.enumerate tags))))
- (update@ #.types (plist.put type-name [namespaced-tags exported? type]))))
- compiler)
- []]))
- #.None
- ((//compiler.throw unknown-module self-name) compiler)))))
diff --git a/stdlib/source/lux/language/scope.lux b/stdlib/source/lux/language/scope.lux
deleted file mode 100644
index 1f0cbffc4..000000000
--- a/stdlib/source/lux/language/scope.lux
+++ /dev/null
@@ -1,191 +0,0 @@
-(.module:
- [lux #*
- [control
- monad]
- [data
- [text ("text/" Equivalence<Text>)
- format]
- [maybe ("maybe/" Monad<Maybe>)]
- [product]
- ["e" error]
- [collection
- [list ("list/" Functor<List> Fold<List> Monoid<List>)]
- [dictionary [plist]]]]
- [macro]]
- [//reference (#+ Register Variable)])
-
-(type: Locals (Bindings Text [Type Register]))
-(type: Foreign (Bindings Text [Type Variable]))
-
-(def: (is-local? name scope)
- (-> Text Scope Bool)
- (|> scope
- (get@ [#.locals #.mappings])
- (plist.contains? name)))
-
-(def: (get-local name scope)
- (-> Text Scope (Maybe [Type Variable]))
- (|> scope
- (get@ [#.locals #.mappings])
- (plist.get name)
- (maybe/map (function (_ [type value])
- [type (#//reference.Local value)]))))
-
-(def: (is-captured? name scope)
- (-> Text Scope Bool)
- (|> scope
- (get@ [#.captured #.mappings])
- (plist.contains? name)))
-
-(def: (get-captured name scope)
- (-> Text Scope (Maybe [Type Variable]))
- (loop [idx +0
- mappings (get@ [#.captured #.mappings] scope)]
- (case mappings
- #.Nil
- #.None
-
- (#.Cons [_name [_source-type _source-ref]] mappings')
- (if (text/= name _name)
- (#.Some [_source-type (#//reference.Foreign idx)])
- (recur (inc idx) mappings')))))
-
-(def: (is-ref? name scope)
- (-> Text Scope Bool)
- (or (is-local? name scope)
- (is-captured? name scope)))
-
-(def: (get-ref name scope)
- (-> Text Scope (Maybe [Type Variable]))
- (case (get-local name scope)
- (#.Some type)
- (#.Some type)
-
- _
- (get-captured name scope)))
-
-(def: #export (find name)
- (-> Text (Meta (Maybe [Type Variable])))
- (function (_ compiler)
- (let [[inner outer] (|> compiler
- (get@ #.scopes)
- (list.split-with (|>> (is-ref? name) not)))]
- (case outer
- #.Nil
- (#.Right [compiler #.None])
-
- (#.Cons top-outer _)
- (let [[ref-type init-ref] (maybe.default (undefined)
- (get-ref name top-outer))
- [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)])
- (function (_ scope ref+inner)
- [(#//reference.Foreign (get@ [#.captured #.counter] scope))
- (#.Cons (update@ #.captured
- (: (-> Foreign Foreign)
- (|>> (update@ #.counter inc)
- (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)]))))
- scope)
- (product.right ref+inner))]))
- [init-ref #.Nil]
- (list.reverse inner))
- scopes (list/compose inner' outer)]
- (#.Right [(set@ #.scopes scopes compiler)
- (#.Some [ref-type ref])]))
- ))))
-
-(def: #export (with-local [name type] action)
- (All [a] (-> [Text Type] (Meta a) (Meta a)))
- (function (_ compiler)
- (case (get@ #.scopes compiler)
- (#.Cons head tail)
- (let [old-mappings (get@ [#.locals #.mappings] head)
- new-var-id (get@ [#.locals #.counter] head)
- new-head (update@ #.locals
- (: (-> Locals Locals)
- (|>> (update@ #.counter inc)
- (update@ #.mappings (plist.put name [type new-var-id]))))
- head)]
- (case (macro.run' (set@ #.scopes (#.Cons new-head tail) compiler)
- action)
- (#e.Success [compiler' output])
- (case (get@ #.scopes compiler')
- (#.Cons head' tail')
- (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head')
- tail')]
- (#e.Success [(set@ #.scopes scopes' compiler')
- output]))
-
- _
- (error! "Invalid scope alteration/"))
-
- (#e.Error error)
- (#e.Error error)))
-
- _
- (#e.Error "Cannot create local binding without a scope."))
- ))
-
-(do-template [<name> <val-type>]
- [(def: <name>
- (Bindings Text [Type <val-type>])
- {#.counter +0
- #.mappings (list)})]
-
- [init-locals Nat]
- [init-captured Variable]
- )
-
-(def: (scope parent-name child-name)
- (-> (List Text) Text Scope)
- {#.name (list& child-name parent-name)
- #.inner +0
- #.locals init-locals
- #.captured init-captured})
-
-(def: #export (with-scope name action)
- (All [a] (-> Text (Meta a) (Meta a)))
- (function (_ compiler)
- (let [parent-name (case (get@ #.scopes compiler)
- #.Nil
- (list)
-
- (#.Cons top _)
- (get@ #.name top))]
- (case (action (update@ #.scopes
- (|>> (#.Cons (scope parent-name name)))
- compiler))
- (#e.Error error)
- (#e.Error error)
-
- (#e.Success [compiler' output])
- (#e.Success [(update@ #.scopes
- (|>> list.tail (maybe.default (list)))
- compiler')
- output])
- ))
- ))
-
-(def: #export next-local
- (Meta Register)
- (function (_ compiler)
- (case (get@ #.scopes compiler)
- #.Nil
- (#e.Error "Cannot get next reference when there is no scope.")
-
- (#.Cons top _)
- (#e.Success [compiler (get@ [#.locals #.counter] top)]))))
-
-(def: (ref-to-variable ref)
- (-> Ref Variable)
- (case ref
- (#.Local register)
- (#//reference.Local register)
-
- (#.Captured register)
- (#//reference.Foreign register)))
-
-(def: #export (environment scope)
- (-> Scope (List Variable))
- (|> scope
- (get@ [#.captured #.mappings])
- (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref)))))