From e8f99539a71febaca6013d72d30f6afc33059b4e Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Fri, 13 Jul 2018 20:03:50 -0400
Subject: - Fixes for compiler build [part 0].
---
stdlib/source/lux.lux | 59 +-
stdlib/source/lux/function.lux | 6 +-
stdlib/source/lux/language/compiler.lux | 23 +-
stdlib/source/lux/language/compiler/analysis.lux | 60 +-
.../source/lux/language/compiler/analysis/case.lux | 36 +-
.../lux/language/compiler/analysis/expression.lux | 57 +-
.../lux/language/compiler/analysis/function.lux | 37 +-
.../lux/language/compiler/analysis/inference.lux | 21 +-
.../lux/language/compiler/analysis/module.lux | 255 ++++++
.../lux/language/compiler/analysis/primitive.lux | 13 +-
.../lux/language/compiler/analysis/reference.lux | 36 +-
.../lux/language/compiler/analysis/scope.lux | 196 +++++
.../lux/language/compiler/analysis/structure.lux | 51 +-
.../source/lux/language/compiler/analysis/type.lux | 51 +-
stdlib/source/lux/language/compiler/extension.lux | 125 ++-
.../lux/language/compiler/extension/analysis.lux | 25 +-
.../compiler/extension/analysis/common.lux | 444 +++++-----
.../compiler/extension/analysis/host.jvm.lux | 904 ++++++++++-----------
.../lux/language/compiler/extension/bundle.lux | 6 +-
stdlib/source/lux/language/compiler/synthesis.lux | 58 +-
.../lux/language/compiler/synthesis/case.lux | 57 +-
.../lux/language/compiler/synthesis/expression.lux | 85 +-
.../lux/language/compiler/synthesis/function.lux | 31 +-
.../lux/language/compiler/synthesis/loop.lux | 31 +-
.../source/lux/language/compiler/translation.lux | 79 +-
.../compiler/translation/scheme/case.jvm.lux | 14 +-
.../compiler/translation/scheme/expression.jvm.lux | 53 +-
.../compiler/translation/scheme/extension.jvm.lux | 4 +-
.../translation/scheme/extension/common.jvm.lux | 4 +-
.../compiler/translation/scheme/function.jvm.lux | 6 +-
.../compiler/translation/scheme/loop.jvm.lux | 6 +-
.../compiler/translation/scheme/reference.jvm.lux | 2 +-
.../compiler/translation/scheme/runtime.jvm.lux | 20 +-
.../compiler/translation/scheme/structure.jvm.lux | 6 +-
stdlib/source/lux/language/module.lux | 243 ------
stdlib/source/lux/language/scope.lux | 191 -----
36 files changed, 1668 insertions(+), 1627 deletions(-)
create mode 100644 stdlib/source/lux/language/compiler/analysis/module.lux
create mode 100644 stdlib/source/lux/language/compiler/analysis/scope.lux
delete mode 100644 stdlib/source/lux/language/module.lux
delete mode 100644 stdlib/source/lux/language/scope.lux
(limited to 'stdlib/source')
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
[imports' (monad/map Monad
(: (-> Code (Meta (List Importation)))
@@ -4226,7 +4215,7 @@
(case token
[_ (#Symbol ["" m-name])]
(do Monad
- [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
- [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
- [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
- [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
- [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 (~' 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)]
[collection [list ("list/" Fold)]]]
[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 Monoid Functor)]]]
["." 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
- [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
- [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 /coverage.merge outputHC outputTC)
+ outputHC (|> outputH product.left coverage.determine)
+ outputTC (monad.map @ (|>> product.left coverage.determine) outputT)
+ _ (.case (monad.fold error.Monad 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
- [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 [ ]
( value)
( 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 [ ]
(^ (#.Form (list& [_ ( tag)]
@@ -60,42 +60,39 @@
_
( 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
- ## [extension (extensionL.find-analysis extension-name)]
- ## (extension compile eval extension-args))
+ (extension.apply compile [extension-name extension-args])
## (^ (#.Form (list& func args)))
## (do ///.Monad
- ## [[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
- [functionT macro.expected-type]
+ (-> Compiler Text Text Code (Operation Analysis))
+ (do ///.Monad
+ [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
- [[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
+ [[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)]]]
[macro]]
- [//// ["." type
- ["tc" check]]]
- [/// ("operation/" Monad)]
+ [////
+ ["." type
+ ["tc" check]]]
+ [/// ("operation/" Monad)
+ [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
- [[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)
+ format]
+ ["e" error]
+ [collection
+ [list ("list/" Fold Functor)]
+ [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 []
+ [(exception: #export ( {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
+ [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
+ [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
+ [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
+ [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
+ [_ (create hash name)
+ output (//.with-current-module name
+ action)
+ module (extension.lift (macro.find-module name))]
+ (wrap [module output])))
+
+(do-template [ ]
+ [(def: #export ( 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 module))
+ state)
+ []])
+ ((///.throw can-only-change-state-of-active-module [module-name ])
+ state)))
+
+ #.None
+ ((///.throw unknown-module module-name) state)))))
+
+ (def: #export ( 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)
+ true
+ _ false)])
+
+ #.None
+ ((///.throw unknown-module module-name) state)))))]
+
+ [set-active active? #.Active]
+ [set-compiled compiled? #.Compiled]
+ [set-cached cached? #.Cached]
+ )
+
+(do-template [ ]
+ [(def: ( module-name)
+ (-> Text (Operation ))
+ (extension.lift
+ (function (_ state)
+ (case (|> state (get@ #.modules) (plist.get module-name))
+ (#.Some module)
+ (#e.Success [state (get@ 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
+ [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
+ [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 [ ]
[(def: #export ( value)
- (-> (Meta Analysis))
- (do macro.Monad
+ (-> (Operation Analysis))
+ (do ///.Monad
[_ (typeA.infer )]
(wrap (#//.Primitive ( value)))))]
@@ -22,7 +23,7 @@
)
(def: #export unit
- (Meta Analysis)
- (do macro.Monad
+ (Operation Analysis)
+ (do ///.Monad
[_ (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)
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 [ (wrap (|> def-name ////reference.constant #//.Reference))]
+ (with-expansions [ (wrap (|> def-name reference.constant #//.Reference))]
(do ///.Monad
- [[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)
(if (macro.export? def-anns)
(do @
- [imported! (macro.imported-by? ::module current)]
+ [imported! (extension.lift (macro.imported-by? ::module current))]
(if imported!
(///.throw foreign-module-has-not-been-imported [current ::module])))
@@ -50,12 +54,12 @@
(def: (variable var-name)
(-> Text (Operation (Maybe Analysis)))
(do ///.Monad
- [?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)
+ format]
+ [maybe ("maybe/" Monad)]
+ [product]
+ ["e" error]
+ [collection
+ [list ("list/" Functor Fold Monoid)]
+ [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 [ ]
+ [(def:
+ (Bindings Text [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
- [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
- [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
- [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
- [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
- [key (macro.normalize key)]
+ [key (extension.lift (macro.normalize key))]
(wrap [key val]))
_
@@ -302,8 +303,8 @@
(#.Cons [head-k head-v] _)
(do ///.Monad
- [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
- [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 [ (as-is (Dictionary Text (-> Text (Handler s i o))))]
+(with-expansions [ (as-is (Dictionary Text (Handler s i o)))]
(type: #export (Handler s i o)
- (-> (Compiler [s ] (Extension i) (Extension o))
- (Compiler [s ] (List (Extension i)) (Extension o))))
+ (-> Text
+ (//.Compiler [ s] i o)
+ (//.Compiler [ s] (List i) o)))
(type: #export (Bundle s i o)
))
+(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 []
[(exception: #export ( {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
- [[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
- [[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))
+ (#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)]
- ["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)))
+(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
@@ -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
[[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
@@ -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 [ ]
-## [(def: ( extension)
-## (-> Text ..Handler)
-## (function (_ analyse args)
+## [(def:
+## analysis.Handler
+## (function (_ extension-name analyse args)
## (case args
## (^ (list typeC valueC))
## (do ////.Monad
@@ -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
@@ -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
[[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
[[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
[[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
@@ -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
[[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
[[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
@@ -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
[[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
[[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)]
[text ("text/" Equivalence)
- format
- ["l" lexer]]
+ format]
[collection
[list ("list/" Fold Functor Monoid)]
[array]
- ["dict" dictionary (#+ Dictionary)]]]
- [macro ("macro/" Monad)
- [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)
+ [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 []
+ [(exception: #export ( {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 []
[(exception: #export ( {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 []
- [(exception: #export ( {class Text} {method Text} {hints (List [Type (List Type)])})
+ [(exception: #export ( {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)
- (/.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 [ ]
[(def:
- /.Bundle
- (<| (/.prefix )
- (|> (dict.new text.Hash)
- (/.install "+" (/.binary ))
- (/.install "-" (/.binary ))
- (/.install "*" (/.binary ))
- (/.install "/" (/.binary ))
- (/.install "%" (/.binary ))
- (/.install "=" (/.binary Boolean))
- (/.install "<" (/.binary Boolean))
- (/.install "and" (/.binary ))
- (/.install "or" (/.binary ))
- (/.install "xor" (/.binary ))
- (/.install "shl" (/.binary Integer ))
- (/.install "shr" (/.binary Integer ))
- (/.install "ushr" (/.binary Integer ))
+ Bundle
+ (<| (bundle.prefix )
+ (|> bundle.empty
+ (bundle.install "+" (common.binary ))
+ (bundle.install "-" (common.binary ))
+ (bundle.install "*" (common.binary ))
+ (bundle.install "/" (common.binary ))
+ (bundle.install "%" (common.binary ))
+ (bundle.install "=" (common.binary Boolean))
+ (bundle.install "<" (common.binary Boolean))
+ (bundle.install "and" (common.binary ))
+ (bundle.install "or" (common.binary ))
+ (bundle.install "xor" (common.binary ))
+ (bundle.install "shl" (common.binary Integer ))
+ (bundle.install "shr" (common.binary Integer ))
+ (bundle.install "ushr" (common.binary Integer ))
)))]
- [int-procs "int" Integer]
- [long-procs "long" Long]
+ [bundle::int "int" Integer]
+ [bundle::long "long" Long]
)
(do-template [ ]
[(def:
- /.Bundle
- (<| (/.prefix )
- (|> (dict.new text.Hash)
- (/.install "+" (/.binary ))
- (/.install "-" (/.binary ))
- (/.install "*" (/.binary ))
- (/.install "/" (/.binary ))
- (/.install "%" (/.binary ))
- (/.install "=" (/.binary Boolean))
- (/.install "<" (/.binary Boolean))
+ Bundle
+ (<| (bundle.prefix )
+ (|> bundle.empty
+ (bundle.install "+" (common.binary ))
+ (bundle.install "-" (common.binary ))
+ (bundle.install "*" (common.binary ))
+ (bundle.install "/" (common.binary ))
+ (bundle.install "%" (common.binary ))
+ (bundle.install "=" (common.binary Boolean))
+ (bundle.install "<" (common.binary 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)
- (/.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)))
+ (dictionary.from-list text.Hash