aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2018-06-17 22:27:40 -0400
committerEduardo Julian2018-06-17 22:27:40 -0400
commitb7b0dd9bd952ede4710da157b40304d714229e04 (patch)
tree26362697e783723fc5da52dad5369b714d6579fe /stdlib/source
parentb6ccfc87c52e1a98ead3b04b45bccc119418a4dc (diff)
- Heavy refactoring to integrate extensions better with the rest of the compiler.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/lang.lux112
-rw-r--r--stdlib/source/lux/lang/analysis/expression.lux122
-rw-r--r--stdlib/source/lux/lang/compiler.lux57
-rw-r--r--stdlib/source/lux/lang/compiler/analysis.lux (renamed from stdlib/source/lux/lang/analysis.lux)92
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/case.lux (renamed from stdlib/source/lux/lang/analysis/case.lux)159
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/case/coverage.lux (renamed from stdlib/source/lux/lang/analysis/case/coverage.lux)55
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/expression.lux121
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/function.lux (renamed from stdlib/source/lux/lang/analysis/function.lux)45
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/inference.lux (renamed from stdlib/source/lux/lang/analysis/inference.lux)126
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/primitive.lux (renamed from stdlib/source/lux/lang/analysis/primitive.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/reference.lux (renamed from stdlib/source/lux/lang/analysis/reference.lux)25
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/structure.lux (renamed from stdlib/source/lux/lang/analysis/structure.lux)148
-rw-r--r--stdlib/source/lux/lang/compiler/analysis/type.lux (renamed from stdlib/source/lux/lang/analysis/type.lux)47
-rw-r--r--stdlib/source/lux/lang/compiler/extension.lux68
-rw-r--r--stdlib/source/lux/lang/compiler/extension/analysis.lux (renamed from stdlib/source/lux/lang/extension/analysis.lux)4
-rw-r--r--stdlib/source/lux/lang/compiler/extension/analysis/common.lux396
-rw-r--r--stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux (renamed from stdlib/source/lux/lang/extension/analysis/host.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/extension/bundle.lux31
-rw-r--r--stdlib/source/lux/lang/compiler/extension/synthesis.lux (renamed from stdlib/source/lux/lang/extension/synthesis.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/extension/translation.lux (renamed from stdlib/source/lux/lang/extension/translation.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/init.lux51
-rw-r--r--stdlib/source/lux/lang/compiler/synthesis.lux (renamed from stdlib/source/lux/lang/synthesis.lux)30
-rw-r--r--stdlib/source/lux/lang/compiler/synthesis/case.lux (renamed from stdlib/source/lux/lang/synthesis/case.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/synthesis/expression.lux (renamed from stdlib/source/lux/lang/synthesis/expression.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/synthesis/function.lux (renamed from stdlib/source/lux/lang/synthesis/function.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/synthesis/loop.lux (renamed from stdlib/source/lux/lang/synthesis/loop.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation.lux (renamed from stdlib/source/lux/lang/translation.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/case.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/expression.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/extension.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/function.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/loop.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/reference.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux (renamed from stdlib/source/lux/lang/translation/scheme/structure.jvm.lux)0
-rw-r--r--stdlib/source/lux/lang/extension.lux131
-rw-r--r--stdlib/source/lux/lang/extension/analysis/common.lux444
-rw-r--r--stdlib/source/lux/lang/host.lux (renamed from stdlib/source/lux/lang/target.lux)4
-rw-r--r--stdlib/source/lux/lang/init.lux61
-rw-r--r--stdlib/source/lux/lang/module.lux51
42 files changed, 1146 insertions, 1234 deletions
diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux
index 322b9f655..bc6e2c9ec 100644
--- a/stdlib/source/lux/lang.lux
+++ b/stdlib/source/lux/lang.lux
@@ -1,17 +1,5 @@
(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data [product]
- ["e" error]
- [text "text/" Eq<Text>]
- text/format)
- [macro]
- (macro ["s" syntax #+ syntax:])))
-
-(type: #export (Extension e)
- {#name Text
- #parameters (List e)})
+ lux)
(type: #export Eval
(-> Type Code (Meta Any)))
@@ -19,101 +7,3 @@
(type: #export Version Text)
(def: #export version Version "0.6.0")
-
-(def: #export (fail message)
- (All [a] (-> Text (Meta a)))
- (do macro.Monad<Meta>
- [[file line col] macro.cursor
- #let [location (format file
- "," (|> line .int %i)
- "," (|> col .int %i))]]
- (macro.fail (format message "\n\n"
- "@ " location))))
-
-(def: #export (throw exception message)
- (All [e a] (-> (ex.Exception e) e (Meta a)))
- (fail (ex.construct exception message)))
-
-(syntax: #export (assert exception message test)
- (wrap (list (` (if (~ test)
- (:: macro.Monad<Meta> (~' wrap) [])
- (..throw (~ exception) (~ message)))))))
-
-(def: #export (with-source-code source action)
- (All [a] (-> Source (Meta a) (Meta a)))
- (function (_ compiler)
- (let [old-source (get@ #.source compiler)]
- (case (action (set@ #.source source compiler))
- (#e.Error error)
- (#e.Error error)
-
- (#e.Success [compiler' output])
- (#e.Success [(set@ #.source old-source compiler')
- output])))))
-
-(def: #export (with-stacked-errors handler action)
- (All [a] (-> (-> [] Text) (Meta a) (Meta a)))
- (function (_ compiler)
- (case (action compiler)
- (#e.Success [compiler' output])
- (#e.Success [compiler' output])
-
- (#e.Error error)
- (#e.Error (if (text/= "" error)
- (handler [])
- (format (handler []) "\n\n-----------------------------------------\n\n" error))))))
-
-(def: fresh-bindings
- (All [k v] (Bindings k v))
- {#.counter +0
- #.mappings (list)})
-
-(def: fresh-scope
- Scope
- {#.name (list)
- #.inner +0
- #.locals fresh-bindings
- #.captured fresh-bindings})
-
-(def: #export (with-scope action)
- (All [a] (-> (Meta a) (Meta [Scope a])))
- (function (_ compiler)
- (case (action (update@ #.scopes (|>> (#.Cons fresh-scope)) compiler))
- (#e.Success [compiler' output])
- (case (get@ #.scopes compiler')
- #.Nil
- (#e.Error "Impossible error: Drained scopes!")
-
- (#.Cons head tail)
- (#e.Success [(set@ #.scopes tail compiler')
- [head output]]))
-
- (#e.Error error)
- (#e.Error error))))
-
-(def: #export (with-current-module name action)
- (All [a] (-> Text (Meta a) (Meta a)))
- (function (_ compiler)
- (case (action (set@ #.current-module (#.Some name) compiler))
- (#e.Success [compiler' output])
- (#e.Success [(set@ #.current-module
- (get@ #.current-module compiler)
- compiler')
- output])
-
- (#e.Error error)
- (#e.Error error))))
-
-(def: #export (with-cursor cursor action)
- (All [a] (-> Cursor (Meta a) (Meta a)))
- (if (text/= "" (product.left cursor))
- action
- (function (_ compiler)
- (let [old-cursor (get@ #.cursor compiler)]
- (case (action (set@ #.cursor cursor compiler))
- (#e.Success [compiler' output])
- (#e.Success [(set@ #.cursor old-cursor compiler')
- output])
-
- (#e.Error error)
- (#e.Error error))))))
diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux
deleted file mode 100644
index 325394e73..000000000
--- a/stdlib/source/lux/lang/analysis/expression.lux
+++ /dev/null
@@ -1,122 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data ["e" error]
- [product]
- text/format)
- [macro]
- [lang #+ Eval]
- (lang [type]
- (type ["tc" check])
- [".L" analysis #+ Analysis Analyser]
- (analysis [".A" type]
- [".A" primitive]
- [".A" structure]
- [".A" reference])
- ## [".L" macro]
- [".L" extension])))
-
-(exception: #export (macro-expansion-failed {message Text})
- message)
-
-(do-template [<name>]
- [(exception: #export (<name> {code Code})
- (%code code))]
-
- [macro-call-must-have-single-expansion]
- [unrecognized-syntax]
- )
-
-(def: #export (analyser eval)
- (-> Eval Analyser)
- (: (-> Code (Meta Analysis))
- (function (analyse code)
- (do macro.Monad<Meta>
- [expectedT macro.expected-type]
- (let [[cursor code'] code]
- ## The cursor must be set in the compiler for the sake
- ## of having useful error messages.
- (lang.with-cursor cursor
- (case code'
- (^template [<tag> <analyser>]
- (<tag> value)
- (<analyser> value))
- ([#.Bool primitiveA.bool]
- [#.Nat primitiveA.nat]
- [#.Int primitiveA.int]
- [#.Deg primitiveA.deg]
- [#.Frac primitiveA.frac]
- [#.Text primitiveA.text])
-
- (^template [<tag> <analyser>]
- (^ (#.Form (list& [_ (<tag> tag)]
- values)))
- (case values
- (#.Cons value #.Nil)
- (<analyser> analyse tag value)
-
- _
- (<analyser> analyse tag (` [(~+ values)]))))
- ([#.Nat structureA.sum]
- [#.Tag structureA.tagged-sum])
-
- (#.Tag tag)
- (structureA.tagged-sum analyse tag (' []))
-
- (^ (#.Tuple (list)))
- primitiveA.unit
-
- (^ (#.Tuple (list singleton)))
- (analyse singleton)
-
- (^ (#.Tuple elems))
- (structureA.product analyse elems)
-
- (^ (#.Record pairs))
- (structureA.record analyse pairs)
-
- (#.Symbol reference)
- (referenceA.reference reference)
-
- (^ (#.Form (list& [_ (#.Text proc-name)] proc-args)))
- (do macro.Monad<Meta>
- [procedure (extensionL.find-analysis proc-name)]
- (procedure analyse eval proc-args))
-
- ## (^ (#.Form (list& func args)))
- ## (do macro.Monad<Meta>
- ## [[funcT funcA] (typeA.with-inference
- ## (analyse func))]
- ## (case funcA
- ## [_ (#.Symbol def-name)]
- ## (do @
- ## [?macro (lang.with-error-tracking
- ## (macro.find-macro def-name))]
- ## (case ?macro
- ## (#.Some macro)
- ## (do @
- ## [expansion (: (Meta (List Code))
- ## (function (_ compiler)
- ## (case (macroL.expand macro args compiler)
- ## (#e.Error error)
- ## ((lang.throw macro-expansion-failed error) compiler)
-
- ## output
- ## output)))]
- ## (case expansion
- ## (^ (list single))
- ## (analyse single)
-
- ## _
- ## (lang.throw macro-call-must-have-single-expansion code)))
-
- ## _
- ## (functionA.analyse-apply analyse funcT funcA args)))
-
- ## _
- ## (functionA.analyse-apply analyse funcT funcA args)))
-
- _
- (lang.throw unrecognized-syntax code)
- )))))))
diff --git a/stdlib/source/lux/lang/compiler.lux b/stdlib/source/lux/lang/compiler.lux
index c2f9af1e2..20278a6cd 100644
--- a/stdlib/source/lux/lang/compiler.lux
+++ b/stdlib/source/lux/lang/compiler.lux
@@ -4,12 +4,21 @@
["ex" exception #+ Exception exception:]
[monad #+ do])
(data [product]
- [error #+ Error])
- [function]))
+ [error #+ Error]
+ [text]
+ text/format)
+ [function]
+ (macro ["s" syntax #+ syntax:])))
(type: #export (Operation s o)
(state.State' Error s o))
+(def: #export Monad<Operation>
+ (state.Monad<State'> error.Monad<Error>))
+
+(type: #export (Compiler s i o)
+ (-> i (Operation s o)))
+
(def: #export (run state operation)
(All [s o]
(-> s (Operation s o) (Error o)))
@@ -17,11 +26,20 @@
operation
(:: error.Monad<Error> map product.right)))
+(def: #export fail
+ (-> Text Operation)
+ (|>> error.fail (state.lift error.Monad<Error>)))
+
(def: #export (throw exception parameters)
(All [e] (-> (Exception e) e Operation))
(state.lift error.Monad<Error>
(ex.throw exception parameters)))
+(syntax: #export (assert exception message test)
+ (wrap (list (` (if (~ test)
+ (:: ..Monad<Operation> (~' wrap) [])
+ (..throw (~ exception) (~ message)))))))
+
(def: #export (localized transform)
(All [s o]
(-> (-> s s)
@@ -39,8 +57,35 @@
(All [s o] (-> s (-> (Operation s o) (Operation s o))))
(localized (function.constant state)))
-(def: #export Monad<Operation>
- (state.Monad<State'> error.Monad<Error>))
+(def: error-separator
+ (format "\n\n"
+ "-----------------------------------------"
+ "\n\n"))
-(type: #export (Compiler s i o)
- (-> i (Operation s o)))
+(def: #export (with-stacked-errors handler action)
+ (All [s o] (-> (-> [] Text) (Operation s o) (Operation s o)))
+ (function (_ state)
+ (case (action state)
+ (#error.Error error)
+ (#error.Error (if (text.empty? error)
+ (handler [])
+ (format (handler []) error-separator error)))
+
+ success
+ success)))
+
+(def: #export identity
+ (All [s a] (Compiler s a a))
+ (function (_ input state)
+ (#error.Success [state input])))
+
+(def: #export (compose pre post)
+ (All [s0 s1 i t o]
+ (-> (Compiler s0 i t)
+ (Compiler s1 t o)
+ (Compiler [s0 s1] i o)))
+ (function (_ input [pre/state post/state])
+ (do error.Monad<Error>
+ [[pre/state' temp] (pre input pre/state)
+ [post/state' output] (post temp post/state)]
+ (wrap [[pre/state' post/state'] output]))))
diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/compiler/analysis.lux
index 6efa934d8..235e399fb 100644
--- a/stdlib/source/lux/lang/analysis.lux
+++ b/stdlib/source/lux/lang/compiler/analysis.lux
@@ -1,9 +1,12 @@
(.module:
[lux #- nat int deg]
- (lux [function]
- (data (coll [list "list/" Fold<List>])))
- [// #+ Extension]
- [//reference #+ Register Variable Reference])
+ (lux (data [product]
+ [error]
+ [text "text/" Eq<Text>]
+ (coll [list "list/" Fold<List>]))
+ [function])
+ [///reference #+ Register Variable Reference]
+ [//])
(type: #export #rec Primitive
#Unit
@@ -41,8 +44,13 @@
(#Reference Reference)
(#Case Analysis (Match' Analysis))
(#Function Environment Analysis)
- (#Apply Analysis Analysis)
- (#Extension (Extension Analysis)))
+ (#Apply Analysis Analysis))
+
+(type: #export Operation
+ (//.Operation .Lux))
+
+(type: #export Compiler
+ (//.Compiler .Lux Code Analysis))
(type: #export Branch
(Branch' Analysis))
@@ -88,7 +96,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)))
@@ -138,9 +146,6 @@
(-> (Application Analysis) Analysis)
(list/fold (function (_ arg func) (#Apply arg func)) func args))
-(type: #export Analyser
- (-> Code (Meta Analysis)))
-
(do-template [<name> <type> <tag>]
[(def: #export (<name> value)
(-> <type> (Tuple <type>))
@@ -207,3 +212,70 @@
[pattern/frac #..Frac]
[pattern/text #..Text]
)
+
+(def: #export (with-source-code source action)
+ (All [a] (-> Source (Operation a) (Operation a)))
+ (function (_ compiler)
+ (let [old-source (get@ #.source compiler)]
+ (case (action (set@ #.source source compiler))
+ (#error.Error error)
+ (#error.Error error)
+
+ (#error.Success [compiler' output])
+ (#error.Success [(set@ #.source old-source compiler')
+ output])))))
+
+(def: fresh-bindings
+ (All [k v] (Bindings k v))
+ {#.counter +0
+ #.mappings (list)})
+
+(def: fresh-scope
+ Scope
+ {#.name (list)
+ #.inner +0
+ #.locals fresh-bindings
+ #.captured fresh-bindings})
+
+(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])
+ (case (get@ #.scopes compiler')
+ #.Nil
+ (#error.Error "Impossible error: Drained scopes!")
+
+ (#.Cons head tail)
+ (#error.Success [(set@ #.scopes tail compiler')
+ [head output]]))
+
+ (#error.Error error)
+ (#error.Error error))))
+
+(def: #export (with-current-module name action)
+ (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))))
+
+(def: #export (with-cursor cursor action)
+ (All [a] (-> Cursor (Operation a) (Operation a)))
+ (if (text/= "" (product.left cursor))
+ action
+ (function (_ compiler)
+ (let [old-cursor (get@ #.cursor compiler)]
+ (case (action (set@ #.cursor cursor compiler))
+ (#error.Success [compiler' output])
+ (#error.Success [(set@ #.cursor old-cursor compiler')
+ output])
+
+ (#error.Error error)
+ (#error.Error error))))))
diff --git a/stdlib/source/lux/lang/analysis/case.lux b/stdlib/source/lux/lang/compiler/analysis/case.lux
index 744d3cf24..9e67a24f9 100644
--- a/stdlib/source/lux/lang/analysis/case.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/case.lux
@@ -1,27 +1,22 @@
(.module:
[lux #- case]
(lux (control [monad #+ do]
- ["ex" exception #+ exception:]
- [equality #+ Eq])
- (data [bool]
- [number]
- [product]
- ["e" error]
+ ["ex" exception #+ exception:])
+ (data [product]
+ [error]
[maybe]
- [text]
text/format
(coll [list "list/" Fold<List> Monoid<List> Functor<List>]))
- [function]
[macro]
- (macro [code])
- [lang]
- (lang [type]
- (type ["tc" check])
- [".L" scope]
- [".L" analysis #+ Pattern Analysis Analyser]
- (analysis [".A" type]
- [".A" structure]
- (case [".A" coverage])))))
+ (macro [code]))
+ (//// [type]
+ (type ["tc" check])
+ [scope])
+ [///]
+ [// #+ Pattern Analysis Operation Compiler]
+ [//type]
+ [//structure]
+ [/coverage])
(exception: #export (cannot-match-type-with-pattern {type Type} {pattern Code})
(ex.report ["Type" (%type type)]
@@ -62,21 +57,21 @@
## This function makes it easier for "case" analysis to properly
## type-check the input with respect to the patterns.
(def: (simplify-case-type caseT)
- (-> Type (Meta Type))
+ (-> Type (Operation Type))
(loop [envs (: (List (List Type))
(list))
caseT caseT]
(.case caseT
(#.Var id)
- (do macro.Monad<Meta>
- [?caseT' (typeA.with-env
+ (do ///.Monad<Operation>
+ [?caseT' (//type.with-env
(tc.read id))]
(.case ?caseT'
(#.Some caseT')
(recur envs caseT')
_
- (lang.throw cannot-simplify-type-for-pattern-matching caseT)))
+ (///.throw cannot-simplify-type-for-pattern-matching caseT)))
(#.Named name unnamedT)
(recur envs unnamedT)
@@ -85,16 +80,16 @@
(recur (#.Cons env envs) unquantifiedT)
(#.ExQ _)
- (do macro.Monad<Meta>
- [[ex-id exT] (typeA.with-env
+ (do ///.Monad<Operation>
+ [[ex-id exT] (//type.with-env
tc.existential)]
(recur envs (maybe.assume (type.apply (list exT) caseT))))
(#.Apply inputT funcT)
(.case funcT
(#.Var funcT-id)
- (do macro.Monad<Meta>
- [funcT' (typeA.with-env
+ (do ///.Monad<Operation>
+ [funcT' (//type.with-env
(do tc.Monad<Check>
[?funct' (tc.read funcT-id)]
(.case ?funct'
@@ -111,23 +106,23 @@
(recur envs outputT)
#.None
- (lang.throw cannot-simplify-type-for-pattern-matching caseT)))
+ (///.throw cannot-simplify-type-for-pattern-matching caseT)))
(#.Product _)
(|> caseT
type.flatten-tuple
(list/map (re-quantify envs))
type.tuple
- (:: macro.Monad<Meta> wrap))
+ (:: ///.Monad<Operation> wrap))
_
- (:: macro.Monad<Meta> wrap (re-quantify envs caseT)))))
+ (:: ///.Monad<Operation> wrap (re-quantify envs caseT)))))
(def: (analyse-primitive type inputT cursor output next)
- (All [a] (-> Type Type Cursor Pattern (Meta a) (Meta [Pattern a])))
- (lang.with-cursor cursor
- (do macro.Monad<Meta>
- [_ (typeA.with-env
+ (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a])))
+ (//.with-cursor cursor
+ (do ///.Monad<Operation>
+ [_ (//type.with-env
(tc.check inputT type))
outputA next]
(wrap [output outputA]))))
@@ -149,33 +144,33 @@
## That is why the body must be analysed in the context of the
## pattern, and not separately.
(def: (analyse-pattern num-tags inputT pattern next)
- (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a])))
+ (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])))
(.case pattern
[cursor (#.Symbol ["" name])]
- (lang.with-cursor cursor
- (do macro.Monad<Meta>
- [outputA (scopeL.with-local [name inputT]
+ (//.with-cursor cursor
+ (do ///.Monad<Operation>
+ [outputA (scope.with-local [name inputT]
next)
- idx scopeL.next-local]
- (wrap [(#analysisL.Bind idx) outputA])))
+ idx scope.next-local]
+ (wrap [(#//.Bind idx) outputA])))
(^template [<type> <input> <output>]
[cursor <input>]
- (analyse-primitive <type> inputT cursor (#analysisL.Simple <output>) next))
- ([Bool (#.Bool pattern-value) (#analysisL.Bool pattern-value)]
- [Nat (#.Nat pattern-value) (#analysisL.Nat pattern-value)]
- [Int (#.Int pattern-value) (#analysisL.Int pattern-value)]
- [Deg (#.Deg pattern-value) (#analysisL.Deg pattern-value)]
- [Frac (#.Frac pattern-value) (#analysisL.Frac pattern-value)]
- [Text (#.Text pattern-value) (#analysisL.Text pattern-value)]
- [Any (#.Tuple #.Nil) #analysisL.Unit])
+ (analyse-primitive <type> inputT cursor (#//.Simple <output>) next))
+ ([Bool (#.Bool pattern-value) (#//.Bool pattern-value)]
+ [Nat (#.Nat pattern-value) (#//.Nat pattern-value)]
+ [Int (#.Int pattern-value) (#//.Int pattern-value)]
+ [Deg (#.Deg pattern-value) (#//.Deg pattern-value)]
+ [Frac (#.Frac pattern-value) (#//.Frac pattern-value)]
+ [Text (#.Text pattern-value) (#//.Text pattern-value)]
+ [Any (#.Tuple #.Nil) #//.Unit])
(^ [cursor (#.Tuple (list singleton))])
(analyse-pattern #.None inputT singleton next)
[cursor (#.Tuple sub-patterns)]
- (lang.with-cursor cursor
- (do macro.Monad<Meta>
+ (//.with-cursor cursor
+ (do ///.Monad<Operation>
[inputT' (simplify-case-type inputT)]
(.case inputT'
(#.Product _)
@@ -195,11 +190,11 @@
(list.zip2 sub-types sub-patterns))]
(do @
[[memberP+ thenA] (list/fold (: (All [a]
- (-> [Type Code] (Meta [(List Pattern) a])
- (Meta [(List Pattern) a])))
+ (-> [Type Code] (Operation [(List Pattern) a])
+ (Operation [(List Pattern) a])))
(function (_ [memberT memberC] then)
(do @
- [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Meta a) (Meta [Pattern a])))
+ [[memberP [memberP+ thenA]] ((:! (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])))
analyse-pattern)
#.None memberT memberC then)]
(wrap [(list& memberP memberP+) thenA]))))
@@ -207,28 +202,28 @@
[nextA next]
(wrap [(list) nextA]))
(list.reverse matches))]
- (wrap [(analysisL.product-pattern memberP+)
+ (wrap [(//.product-pattern memberP+)
thenA])))
_
- (lang.throw cannot-match-type-with-pattern [inputT pattern])
+ (///.throw cannot-match-type-with-pattern [inputT pattern])
)))
[cursor (#.Record record)]
- (do macro.Monad<Meta>
- [record (structureA.normalize record)
- [members recordT] (structureA.order record)
- _ (typeA.with-env
+ (do ///.Monad<Operation>
+ [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))
[cursor (#.Tag tag)]
- (lang.with-cursor cursor
+ (//.with-cursor cursor
(analyse-pattern #.None inputT (` ((~ pattern))) next))
(^ [cursor (#.Form (list& [_ (#.Nat idx)] values))])
- (lang.with-cursor cursor
- (do macro.Monad<Meta>
+ (//.with-cursor cursor
+ (do ///.Monad<Operation>
[inputT' (simplify-case-type inputT)]
(.case inputT'
(#.Sum _)
@@ -238,7 +233,7 @@
(.case (list.nth idx flat-sum)
(^multi (#.Some case-type)
(n/< num-cases idx))
- (do macro.Monad<Meta>
+ (do ///.Monad<Operation>
[[testP nextA] (if (and (n/> num-cases size-sum)
(n/= (dec num-cases) idx))
(analyse-pattern #.None
@@ -246,50 +241,50 @@
(` [(~+ values)])
next)
(analyse-pattern #.None case-type (` [(~+ values)]) next))]
- (wrap [(analysisL.sum-pattern num-cases idx testP)
+ (wrap [(//.sum-pattern num-cases idx testP)
nextA]))
_
- (lang.throw sum-type-has-no-case [idx inputT])))
+ (///.throw sum-type-has-no-case [idx inputT])))
_
- (lang.throw cannot-match-type-with-pattern [inputT pattern]))))
+ (///.throw cannot-match-type-with-pattern [inputT pattern]))))
(^ [cursor (#.Form (list& [_ (#.Tag tag)] values))])
- (lang.with-cursor cursor
- (do macro.Monad<Meta>
+ (//.with-cursor cursor
+ (do ///.Monad<Operation>
[tag (macro.normalize tag)
[idx group variantT] (macro.resolve-tag tag)
- _ (typeA.with-env
+ _ (//type.with-env
(tc.check inputT variantT))]
(analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next)))
_
- (lang.throw unrecognized-pattern-syntax pattern)
+ (///.throw unrecognized-pattern-syntax pattern)
))
(def: #export (case analyse inputC branches)
- (-> Analyser Code (List [Code Code]) (Meta Analysis))
+ (-> Compiler Code (List [Code Code]) (Operation Analysis))
(.case branches
#.Nil
- (lang.throw cannot-have-empty-branches "")
+ (///.throw cannot-have-empty-branches "")
(#.Cons [patternH bodyH] branchesT)
- (do macro.Monad<Meta>
- [[inputT inputA] (typeA.with-inference
+ (do ///.Monad<Operation>
+ [[inputT inputA] (//type.with-inference
(analyse inputC))
outputH (analyse-pattern #.None inputT patternH (analyse bodyH))
outputT (monad.map @
(function (_ [patternT bodyT])
(analyse-pattern #.None inputT patternT (analyse bodyT)))
branchesT)
- outputHC (|> outputH product.left coverageA.determine)
- outputTC (monad.map @ (|>> product.left coverageA.determine) outputT)
- _ (.case (monad.fold e.Monad<Error> coverageA.merge outputHC outputTC)
- (#e.Success coverage)
- (lang.assert non-exhaustive-pattern-matching ""
- (coverageA.exhaustive? coverage))
-
- (#e.Error error)
- (lang.fail error))]
- (wrap (#analysisL.Case inputA [outputH outputT])))))
+ 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))
+
+ (#error.Error error)
+ (///.fail error))]
+ (wrap (#//.Case inputA [outputH outputT])))))
diff --git a/stdlib/source/lux/lang/analysis/case/coverage.lux b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux
index a5958001f..6a965742a 100644
--- a/stdlib/source/lux/lang/analysis/case/coverage.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux
@@ -9,10 +9,9 @@
[maybe]
text/format
(coll [list "list/" Fold<List>]
- (dictionary ["dict" unordered #+ Dict])))
- [macro "macro/" Monad<Meta>]
- [lang]
- (lang [".L" analysis #+ Pattern Variant])))
+ (dictionary ["dict" unordered #+ Dict]))))
+ [//// "operation/" Monad<Operation>]
+ [/// #+ Pattern Variant Operation])
(def: cases
(-> (Maybe Nat) Nat)
@@ -25,18 +24,18 @@
(case variantP
(#.Left valueP)
(case valueP
- (#analysisL.Complex (#analysisL.Sum value-side))
+ (#///.Complex (#///.Sum value-side))
(recur (inc lefts) value-side)
_
- {#analysisL.lefts lefts
- #analysisL.right? false
- #analysisL.value valueP})
+ {#///.lefts lefts
+ #///.right? false
+ #///.value valueP})
(#.Right valueP)
- {#analysisL.lefts lefts
- #analysisL.right? true
- #analysisL.value valueP})))
+ {#///.lefts lefts
+ #///.right? true
+ #///.value valueP})))
## The coverage of a pattern-matching expression summarizes how well
## all the possible values of an input are being covered by the
@@ -68,33 +67,33 @@
false))
(def: #export (determine pattern)
- (-> Pattern (Meta Coverage))
+ (-> Pattern (Operation Coverage))
(case pattern
- (^or (#analysisL.Simple #analysisL.Unit)
- (#analysisL.Bind _))
- (macro/wrap #Exhaustive)
+ (^or (#///.Simple #///.Unit)
+ (#///.Bind _))
+ (operation/wrap #Exhaustive)
## Primitive patterns always have partial coverage because there
## are too many possibilities as far as values go.
(^template [<tag>]
- (#analysisL.Simple (<tag> _))
- (macro/wrap #Partial))
- ([#analysisL.Nat]
- [#analysisL.Int]
- [#analysisL.Deg]
- [#analysisL.Frac]
- [#analysisL.Text])
+ (#///.Simple (<tag> _))
+ (operation/wrap #Partial))
+ ([#///.Nat]
+ [#///.Int]
+ [#///.Deg]
+ [#///.Frac]
+ [#///.Text])
## Bools are the exception, since there is only "true" and
## "false", which means it is possible for boolean
## pattern-matching to become exhaustive if complementary parts meet.
- (#analysisL.Simple (#analysisL.Bool value))
- (macro/wrap (#Bool value))
+ (#///.Simple (#///.Bool value))
+ (operation/wrap (#Bool value))
## Tuple patterns can be exhaustive if there is exhaustiveness for all of
## their sub-patterns.
- (#analysisL.Complex (#analysisL.Product [left right]))
- (do macro.Monad<Meta>
+ (#///.Complex (#///.Product [left right]))
+ (do ////.Monad<Operation>
[left (determine left)
right (determine right)]
(case right
@@ -104,11 +103,11 @@
_
(wrap (#Seq left right))))
- (#analysisL.Complex (#analysisL.Sum sum-side))
+ (#///.Complex (#///.Sum sum-side))
(let [[variant-lefts variant-right? variant-value] (variant sum-side)]
## Variant patterns can be shown to be exhaustive if all the possible
## cases are handled exhaustively.
- (do macro.Monad<Meta>
+ (do ////.Monad<Operation>
[value-coverage (determine variant-value)
#let [variant-idx (if variant-right?
(inc variant-lefts)
diff --git a/stdlib/source/lux/lang/compiler/analysis/expression.lux b/stdlib/source/lux/lang/compiler/analysis/expression.lux
new file mode 100644
index 000000000..879f383e8
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/analysis/expression.lux
@@ -0,0 +1,121 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data ["e" error]
+ [product]
+ text/format)
+ [macro])
+ [//// #+ Eval]
+ ## (//// [".L" macro]
+ ## [".L" extension])
+ [///]
+ [// #+ Analysis Operation Compiler]
+ [//type]
+ [//primitive]
+ [//structure]
+ [//reference])
+
+(exception: #export (macro-expansion-failed {message Text})
+ message)
+
+(do-template [<name>]
+ [(exception: #export (<name> {code Code})
+ (%code code))]
+
+ [macro-call-must-have-single-expansion]
+ [unrecognized-syntax]
+ )
+
+(def: #export (analyser eval)
+ (-> Eval Compiler)
+ (function (compile code)
+ (do ///.Monad<Operation>
+ [expectedT macro.expected-type]
+ (let [[cursor code'] code]
+ ## The cursor must be set in the compiler for the sake
+ ## of having useful error messages.
+ (//.with-cursor cursor
+ (case code'
+ (^template [<tag> <analyser>]
+ (<tag> value)
+ (<analyser> value))
+ ([#.Bool //primitive.bool]
+ [#.Nat //primitive.nat]
+ [#.Int //primitive.int]
+ [#.Deg //primitive.deg]
+ [#.Frac //primitive.frac]
+ [#.Text //primitive.text])
+
+ (^template [<tag> <analyser>]
+ (^ (#.Form (list& [_ (<tag> tag)]
+ values)))
+ (case values
+ (#.Cons value #.Nil)
+ (<analyser> compile tag value)
+
+ _
+ (<analyser> compile tag (` [(~+ values)]))))
+ ([#.Nat //structure.sum]
+ [#.Tag //structure.tagged-sum])
+
+ (#.Tag tag)
+ (//structure.tagged-sum compile tag (' []))
+
+ (^ (#.Tuple (list)))
+ //primitive.unit
+
+ (^ (#.Tuple (list singleton)))
+ (compile singleton)
+
+ (^ (#.Tuple elems))
+ (//structure.product compile elems)
+
+ (^ (#.Record pairs))
+ (//structure.record compile pairs)
+
+ (#.Symbol 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))
+
+ ## (^ (#.Form (list& func args)))
+ ## (do ///.Monad<Operation>
+ ## [[funcT funcA] (//type.with-inference
+ ## (compile func))]
+ ## (case funcA
+ ## [_ (#.Symbol def-name)]
+ ## (do @
+ ## [?macro (///.with-error-tracking
+ ## (macro.find-macro def-name))]
+ ## (case ?macro
+ ## (#.Some macro)
+ ## (do @
+ ## [expansion (: (Operation (List Code))
+ ## (function (_ compiler)
+ ## (case (macroL.expand macro args compiler)
+ ## (#e.Error error)
+ ## ((///.throw macro-expansion-failed error) compiler)
+
+ ## output
+ ## output)))]
+ ## (case expansion
+ ## (^ (list single))
+ ## (compile single)
+
+ ## _
+ ## (///.throw macro-call-must-have-single-expansion code)))
+
+ ## _
+ ## (functionA.apply compile funcT funcA args)))
+
+ ## _
+ ## (functionA.apply compile funcT funcA args)))
+
+ _
+ (///.throw unrecognized-syntax code)
+ ))))))
diff --git a/stdlib/source/lux/lang/analysis/function.lux b/stdlib/source/lux/lang/compiler/analysis/function.lux
index f6fea9bb0..b6e09f11a 100644
--- a/stdlib/source/lux/lang/analysis/function.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/function.lux
@@ -8,13 +8,13 @@
(coll [list "list/" Fold<List> Monoid<List> Monad<List>]))
[macro]
(macro [code])
- [lang]
(lang [type]
(type ["tc" check])
- [".L" scope]
- [".L" analysis #+ Analysis Analyser]
- (analysis [".A" type]
- [".A" inference]))))
+ [".L" scope]))
+ [///]
+ [// #+ Analysis Compiler]
+ [//type]
+ [//inference])
(exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code})
(ex.report ["Type" (%type expected)]
@@ -30,13 +30,12 @@
(format "\n " (%n idx) " " (%code argC))))
(text.join-with ""))]))
-## [Analysers]
(def: #export (function analyse function-name arg-name body)
- (-> Analyser Text Text Code (Meta Analysis))
+ (-> Compiler Text Text Code (Meta Analysis))
(do macro.Monad<Meta>
[functionT macro.expected-type]
(loop [expectedT functionT]
- (lang.with-stacked-errors
+ (///.with-stacked-errors
(.function (_ _)
(ex.construct cannot-analyse [expectedT function-name arg-name body]))
(case expectedT
@@ -49,56 +48,56 @@
(recur value)
#.None
- (lang.fail (ex.construct cannot-analyse [expectedT function-name arg-name body])))
+ (///.fail (ex.construct cannot-analyse [expectedT function-name arg-name body])))
(^template [<tag> <instancer>]
(<tag> _)
(do @
- [[_ instanceT] (typeA.with-env <instancer>)]
+ [[_ instanceT] (//type.with-env <instancer>)]
(recur (maybe.assume (type.apply (list instanceT) expectedT)))))
([#.UnivQ tc.existential]
[#.ExQ tc.var])
(#.Var id)
(do @
- [?expectedT' (typeA.with-env
+ [?expectedT' (//type.with-env
(tc.read id))]
(case ?expectedT'
(#.Some expectedT')
(recur expectedT')
- _
## Inference
+ _
(do @
- [[input-id inputT] (typeA.with-env tc.var)
- [output-id outputT] (typeA.with-env tc.var)
+ [[input-id inputT] (//type.with-env tc.var)
+ [output-id outputT] (//type.with-env tc.var)
#let [functionT (#.Function inputT outputT)]
functionA (recur functionT)
- _ (typeA.with-env
+ _ (//type.with-env
(tc.check expectedT functionT))]
(wrap functionA))
))
(#.Function inputT outputT)
(<| (:: @ map (.function (_ [scope bodyA])
- (#analysisL.Function (scopeL.environment scope) bodyA)))
- lang.with-scope
+ (#//.Function (scopeL.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])
- (typeA.with-type outputT)
+ (//type.with-type outputT)
(analyse body))
_
- (lang.fail "")
+ (///.fail "")
)))))
(def: #export (apply analyse functionT functionA args)
- (-> Analyser Type Analysis (List Code) (Meta Analysis))
- (lang.with-stacked-errors
+ (-> Compiler Type Analysis (List Code) (Meta Analysis))
+ (///.with-stacked-errors
(.function (_ _)
(ex.construct cannot-apply [functionT args]))
(do macro.Monad<Meta>
- [[applyT argsA] (inferenceA.general analyse functionT args)]
- (wrap (analysisL.apply [functionA argsA])))))
+ [[applyT argsA] (//inference.general analyse functionT args)]
+ (wrap (//.apply [functionA argsA])))))
diff --git a/stdlib/source/lux/lang/analysis/inference.lux b/stdlib/source/lux/lang/compiler/analysis/inference.lux
index 732a8e6e3..abf1529d6 100644
--- a/stdlib/source/lux/lang/analysis/inference.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/inference.lux
@@ -6,16 +6,16 @@
[text]
text/format
(coll [list "list/" Functor<List>]))
- [macro "macro/" Monad<Meta>]
- [lang]
- (lang [type]
- (type ["tc" check])
- [analysis #+ Analysis Analyser]
- (analysis [".A" type]))))
-
-(exception: #export (variant-tag-out-of-bounds {size Nat} {tag analysis.Tag} {type Type})
+ [macro])
+ (//// [type]
+ (type ["tc" check]))
+ [/// #+ "operation/" Monad<Operation>]
+ [// #+ Tag Analysis Operation Compiler]
+ [//type])
+
+(exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type})
(ex.report ["Tag" (%n tag)]
- ["Variant size" (%n size)]
+ ["Variant size" (%i (.int size))]
["Variant type" (%type type)]))
(exception: #export (cannot-infer {type Type} {args (List Code)})
@@ -43,16 +43,16 @@
[invalid-type-application]
)
-(def: (replace-bound bound-idx replacementT type)
+(def: (replace bound-idx replacement type)
(-> Nat Type Type Type)
(case type
(#.Primitive name params)
- (#.Primitive name (list/map (replace-bound bound-idx replacementT) params))
+ (#.Primitive name (list/map (replace bound-idx replacement) params))
(^template [<tag>]
(<tag> left right)
- (<tag> (replace-bound bound-idx replacementT left)
- (replace-bound bound-idx replacementT right)))
+ (<tag> (replace bound-idx replacement left)
+ (replace bound-idx replacement right)))
([#.Sum]
[#.Product]
[#.Function]
@@ -60,13 +60,13 @@
(#.Bound idx)
(if (n/= bound-idx idx)
- replacementT
+ replacement
type)
(^template [<tag>]
(<tag> env quantified)
- (<tag> (list/map (replace-bound bound-idx replacementT) env)
- (replace-bound (n/+ +2 bound-idx) replacementT quantified)))
+ (<tag> (list/map (replace bound-idx replacement) env)
+ (replace (n/+ +2 bound-idx) replacement quantified)))
([#.UnivQ]
[#.ExQ])
@@ -74,13 +74,13 @@
type))
(def: new-named-type
- (Meta Type)
- (do macro.Monad<Meta>
- [[_module _line _column] macro.cursor
- [ex-id exT] (typeA.with-env tc.existential)]
- (wrap (#.Primitive (format "{New Type @ " (%t _module)
- "," (%n _line)
- "," (%n _column)
+ (Operation Type)
+ (do ///.Monad<Operation>
+ [[module line column] macro.cursor
+ [ex-id _] (//type.with-env tc.existential)]
+ (wrap (#.Primitive (format "{New Type @ " (%t module)
+ "," (%n line)
+ "," (%n column)
"} " (%n ex-id))
(list)))))
@@ -92,11 +92,11 @@
## But, so long as the type being used for the inference can be treated
## as a function type, this method of inference should work.
(def: #export (general analyse inferT args)
- (-> Analyser Type (List Code) (Meta [Type (List Analysis)]))
+ (-> Compiler Type (List Code) (Operation [Type (List Analysis)]))
(case args
#.Nil
- (do macro.Monad<Meta>
- [_ (typeA.infer inferT)]
+ (do ///.Monad<Operation>
+ [_ (//type.infer inferT)]
(wrap [inferT (list)]))
(#.Cons argC args')
@@ -105,23 +105,23 @@
(general analyse unnamedT args)
(#.UnivQ _)
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)]
+ (do ///.Monad<Operation>
+ [[var-id varT] (//type.with-env tc.var)]
(general analyse (maybe.assume (type.apply (list varT) inferT)) args))
(#.ExQ _)
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)
+ (do ///.Monad<Operation>
+ [[var-id varT] (//type.with-env tc.var)
output (general analyse
(maybe.assume (type.apply (list varT) inferT))
args)
- bound? (typeA.with-env
+ bound? (//type.with-env
(tc.bound? var-id))
_ (if bound?
(wrap [])
(do @
[newT new-named-type]
- (typeA.with-env
+ (//type.with-env
(tc.check varT newT))))]
(wrap output))
@@ -131,7 +131,7 @@
(general analyse outputT args)
#.None
- (lang.throw invalid-type-application inferT))
+ (///.throw invalid-type-application inferT))
## Arguments are inferred back-to-front because, by convention,
## Lux functions take the most important arguments *last*, which
@@ -141,39 +141,39 @@
## avoided in Lux code, since the inference algorithm can piece
## things together more easily.
(#.Function inputT outputT)
- (do macro.Monad<Meta>
+ (do ///.Monad<Operation>
[[outputT' args'A] (general analyse outputT args')
- argA (lang.with-stacked-errors
+ argA (///.with-stacked-errors
(function (_ _)
(ex.construct cannot-infer-argument [inputT argC]))
- (typeA.with-type inputT
+ (//type.with-type inputT
(analyse argC)))]
(wrap [outputT' (list& argA args'A)]))
(#.Var infer-id)
- (do macro.Monad<Meta>
- [?inferT' (typeA.with-env (tc.read infer-id))]
+ (do ///.Monad<Operation>
+ [?inferT' (//type.with-env (tc.read infer-id))]
(case ?inferT'
(#.Some inferT')
(general analyse inferT' args)
_
- (lang.throw cannot-infer [inferT args])))
+ (///.throw cannot-infer [inferT args])))
_
- (lang.throw cannot-infer [inferT args]))
+ (///.throw cannot-infer [inferT args]))
))
## Turns a record type into the kind of function type suitable for inference.
(def: #export (record inferT)
- (-> Type (Meta Type))
+ (-> Type (Operation Type))
(case inferT
(#.Named name unnamedT)
(record unnamedT)
(^template [<tag>]
(<tag> env bodyT)
- (do macro.Monad<Meta>
+ (do ///.Monad<Operation>
[bodyT+ (record bodyT)]
(wrap (<tag> env bodyT+))))
([#.UnivQ]
@@ -185,28 +185,28 @@
(record outputT)
#.None
- (lang.throw invalid-type-application inferT))
+ (///.throw invalid-type-application inferT))
(#.Product _)
- (macro/wrap (type.function (type.flatten-tuple inferT) inferT))
+ (operation/wrap (type.function (type.flatten-tuple inferT) inferT))
_
- (lang.throw not-a-record-type inferT)))
+ (///.throw not-a-record-type inferT)))
## Turns a variant type into the kind of function type suitable for inference.
(def: #export (variant tag expected-size inferT)
- (-> Nat Nat Type (Meta Type))
+ (-> Nat Nat Type (Operation Type))
(loop [depth +0
currentT inferT]
(case currentT
(#.Named name unnamedT)
- (do macro.Monad<Meta>
+ (do ///.Monad<Operation>
[unnamedT+ (recur depth unnamedT)]
(wrap unnamedT+))
(^template [<tag>]
(<tag> env bodyT)
- (do macro.Monad<Meta>
+ (do ///.Monad<Operation>
[bodyT+ (recur (inc depth) bodyT)]
(wrap (<tag> env bodyT+))))
([#.UnivQ]
@@ -221,28 +221,28 @@
(n/< boundary tag)))
(case (list.nth tag cases)
(#.Some caseT)
- (macro/wrap (if (n/= +0 depth)
- (type.function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)]
- (type.function (list (replace! caseT))
- (replace! currentT)))))
+ (operation/wrap (if (n/= +0 depth)
+ (type.function (list caseT) currentT)
+ (let [replace' (replace (|> depth dec (n/* +2)) inferT)]
+ (type.function (list (replace' caseT))
+ (replace' currentT)))))
#.None
- (lang.throw variant-tag-out-of-bounds [expected-size tag inferT]))
+ (///.throw variant-tag-out-of-bounds [expected-size tag inferT]))
(n/< expected-size actual-size)
- (lang.throw smaller-variant-than-expected [expected-size actual-size])
+ (///.throw smaller-variant-than-expected [expected-size actual-size])
(n/= boundary tag)
(let [caseT (type.variant (list.drop boundary cases))]
- (macro/wrap (if (n/= +0 depth)
- (type.function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)]
- (type.function (list (replace! caseT))
- (replace! currentT))))))
+ (operation/wrap (if (n/= +0 depth)
+ (type.function (list caseT) currentT)
+ (let [replace' (replace (|> depth dec (n/* +2)) inferT)]
+ (type.function (list (replace' caseT))
+ (replace' currentT))))))
## else
- (lang.throw variant-tag-out-of-bounds [expected-size tag inferT])))
+ (///.throw variant-tag-out-of-bounds [expected-size tag inferT])))
(#.Apply inputT funcT)
(case (type.apply (list inputT) funcT)
@@ -250,7 +250,7 @@
(variant tag expected-size outputT)
#.None
- (lang.throw invalid-type-application inferT))
+ (///.throw invalid-type-application inferT))
_
- (lang.throw not-a-variant-type inferT))))
+ (///.throw not-a-variant-type inferT))))
diff --git a/stdlib/source/lux/lang/analysis/primitive.lux b/stdlib/source/lux/lang/compiler/analysis/primitive.lux
index 74596fba2..74596fba2 100644
--- a/stdlib/source/lux/lang/analysis/primitive.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/primitive.lux
diff --git a/stdlib/source/lux/lang/analysis/reference.lux b/stdlib/source/lux/lang/compiler/analysis/reference.lux
index cceb4db7d..6f4908f9d 100644
--- a/stdlib/source/lux/lang/analysis/reference.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/reference.lux
@@ -4,15 +4,16 @@
[macro]
(macro [code])
(lang (type ["tc" check])))
- [// #+ Analysis]
+ [///]
+ [// #+ Analysis Operation]
[//type]
- [///reference]
- [///scope])
+ [////reference]
+ [////scope])
## [Analysers]
(def: (definition def-name)
- (-> Ident (Meta Analysis))
- (do macro.Monad<Meta>
+ (-> Ident (Operation Analysis))
+ (do ///.Monad<Operation>
[[actualT def-anns _] (macro.find-def def-name)]
(case (macro.get-symbol-ann (ident-for #.alias) def-anns)
(#.Some real-def-name)
@@ -21,27 +22,27 @@
_
(do @
[_ (//type.infer actualT)]
- (:: @ map (|>> ///reference.constant #//.Reference)
+ (:: @ map (|>> ////reference.constant #//.Reference)
(macro.normalize def-name))))))
(def: (variable var-name)
- (-> Text (Meta (Maybe Analysis)))
- (do macro.Monad<Meta>
- [?var (///scope.find var-name)]
+ (-> Text (Operation (Maybe Analysis)))
+ (do ///.Monad<Operation>
+ [?var (////scope.find var-name)]
(case ?var
(#.Some [actualT ref])
(do @
[_ (//type.infer actualT)]
- (wrap (#.Some (|> ref ///reference.variable #//.Reference))))
+ (wrap (#.Some (|> ref ////reference.variable #//.Reference))))
#.None
(wrap #.None))))
(def: #export (reference reference)
- (-> Ident (Meta Analysis))
+ (-> Ident (Operation Analysis))
(case reference
["" simple-name]
- (do macro.Monad<Meta>
+ (do ///.Monad<Operation>
[?var (variable simple-name)]
(case ?var
(#.Some varA)
diff --git a/stdlib/source/lux/lang/analysis/structure.lux b/stdlib/source/lux/lang/compiler/analysis/structure.lux
index bc527cd49..78b36bc32 100644
--- a/stdlib/source/lux/lang/analysis/structure.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/structure.lux
@@ -10,16 +10,16 @@
(dictionary ["dict" unordered #+ Dict]))
text/format)
[macro]
- (macro [code])
- [lang]
- (lang [type]
- (type ["tc" check])
- [analysis #+ Analysis Analyser]
- (analysis [".A" type]
- [".A" primitive]
- [".A" inference]))))
-
-(exception: #export (invalid-variant-type {type Type} {tag analysis.Tag} {code Code})
+ (macro [code]))
+ (//// [type]
+ (type ["tc" check]))
+ [///]
+ [// #+ Tag Analysis Operation Compiler]
+ [//type]
+ [//primitive]
+ [//inference])
+
+(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code})
(ex.report ["Type" (%type type)]
["Tag" (%n tag)]
["Expression" (%code code)]))
@@ -37,7 +37,7 @@
(%type type))
(do-template [<name>]
- [(exception: #export (<name> {type Type} {tag analysis.Tag} {code Code})
+ [(exception: #export (<name> {type Type} {tag Tag} {code Code})
(ex.report ["Type" (%type type)]
["Tag" (%n tag)]
["Expression" (%code code)]))]
@@ -74,10 +74,10 @@
code.record))]))
(def: #export (sum analyse tag valueC)
- (-> Analyser Nat Code (Meta Analysis))
- (do macro.Monad<Meta>
+ (-> Compiler Nat Code (Operation Analysis))
+ (do ///.Monad<Operation>
[expectedT macro.expected-type]
- (lang.with-stacked-errors
+ (///.with-stacked-errors
(function (_ _)
(ex.construct cannot-analyse-variant [expectedT tag valueC]))
(case expectedT
@@ -87,38 +87,38 @@
(case (list.nth tag flat)
(#.Some variant-type)
(do @
- [valueA (typeA.with-type variant-type
+ [valueA (//type.with-type variant-type
(analyse valueC))]
- (wrap (analysis.sum-analysis type-size tag valueA)))
+ (wrap (//.sum-analysis type-size tag valueA)))
#.None
- (lang.throw inferenceA.variant-tag-out-of-bounds [type-size tag expectedT])))
+ (///.throw //inference.variant-tag-out-of-bounds [type-size tag expectedT])))
(#.Named name unnamedT)
- (typeA.with-type unnamedT
+ (//type.with-type unnamedT
(sum analyse tag valueC))
(#.Var id)
(do @
- [?expectedT' (typeA.with-env
+ [?expectedT' (//type.with-env
(tc.read id))]
(case ?expectedT'
(#.Some expectedT')
- (typeA.with-type expectedT'
+ (//type.with-type expectedT'
(sum analyse tag valueC))
_
## Cannot do inference when the tag is numeric.
## This is because there is no way of knowing how many
## cases the inferred sum type would have.
- (lang.throw cannot-infer-numeric-tag [expectedT tag valueC])
+ (///.throw cannot-infer-numeric-tag [expectedT tag valueC])
))
(^template [<tag> <instancer>]
(<tag> _)
(do @
- [[instance-id instanceT] (typeA.with-env <instancer>)]
- (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT))
+ [[instance-id instanceT] (//type.with-env <instancer>)]
+ (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT))
(sum analyse tag valueC))))
([#.UnivQ tc.existential]
[#.ExQ tc.var])
@@ -127,30 +127,30 @@
(case funT
(#.Var funT-id)
(do @
- [?funT' (typeA.with-env (tc.read funT-id))]
+ [?funT' (//type.with-env (tc.read funT-id))]
(case ?funT'
(#.Some funT')
- (typeA.with-type (#.Apply inputT funT')
+ (//type.with-type (#.Apply inputT funT')
(sum analyse tag valueC))
_
- (lang.throw invalid-variant-type [expectedT tag valueC])))
+ (///.throw invalid-variant-type [expectedT tag valueC])))
_
(case (type.apply (list inputT) funT)
#.None
- (lang.throw not-a-quantified-type funT)
+ (///.throw not-a-quantified-type funT)
(#.Some outputT)
- (typeA.with-type outputT
+ (//type.with-type outputT
(sum analyse tag valueC))))
_
- (lang.throw invalid-variant-type [expectedT tag valueC])))))
+ (///.throw invalid-variant-type [expectedT tag valueC])))))
(def: (typed-product analyse membersC+)
- (-> Analyser (List Code) (Meta Analysis))
- (do macro.Monad<Meta>
+ (-> Compiler (List Code) (Operation Analysis))
+ (do ///.Monad<Operation>
[expectedT macro.expected-type]
(loop [expectedT expectedT
membersC+ membersC+]
@@ -158,17 +158,17 @@
## If the tuple runs out, whatever expression is the last gets
## matched to the remaining type.
[tailT (#.Cons tailC #.Nil)]
- (typeA.with-type tailT
+ (//type.with-type tailT
(analyse tailC))
## If the type and the code are still ongoing, match each
## sub-expression to its corresponding type.
[(#.Product leftT rightT) (#.Cons leftC rightC)]
(do @
- [leftA (typeA.with-type leftT
+ [leftA (//type.with-type leftT
(analyse leftC))
rightA (recur rightT rightC)]
- (wrap (#analysis.Structure (#analysis.Product leftA rightA))))
+ (wrap (#//.Structure (#//.Product leftA rightA))))
## If, however, the type runs out but there is still enough
## tail, the remaining elements get packaged into another
@@ -184,14 +184,14 @@
(|> tailC
code.tuple
analyse
- (typeA.with-type tailT)
- (:: @ map (|>> analysis.no-op)))))))
+ (//type.with-type tailT)
+ (:: @ map (|>> //.no-op)))))))
(def: #export (product analyse membersC)
- (-> Analyser (List Code) (Meta Analysis))
- (do macro.Monad<Meta>
+ (-> Compiler (List Code) (Operation Analysis))
+ (do ///.Monad<Operation>
[expectedT macro.expected-type]
- (lang.with-stacked-errors
+ (///.with-stacked-errors
(function (_ _)
(ex.construct cannot-analyse-tuple [expectedT membersC]))
(case expectedT
@@ -199,33 +199,33 @@
(..typed-product analyse membersC)
(#.Named name unnamedT)
- (typeA.with-type unnamedT
+ (//type.with-type unnamedT
(product analyse membersC))
(#.Var id)
(do @
- [?expectedT' (typeA.with-env
+ [?expectedT' (//type.with-env
(tc.read id))]
(case ?expectedT'
(#.Some expectedT')
- (typeA.with-type expectedT'
+ (//type.with-type expectedT'
(product analyse membersC))
_
## Must do inference...
(do @
- [membersTA (monad.map @ (|>> analyse typeA.with-inference)
+ [membersTA (monad.map @ (|>> analyse //type.with-inference)
membersC)
- _ (typeA.with-env
+ _ (//type.with-env
(tc.check expectedT
(type.tuple (list/map product.left membersTA))))]
- (wrap (analysis.product-analysis (list/map product.right membersTA))))))
+ (wrap (//.product-analysis (list/map product.right membersTA))))))
(^template [<tag> <instancer>]
(<tag> _)
(do @
- [[instance-id instanceT] (typeA.with-env <instancer>)]
- (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT))
+ [[instance-id instanceT] (//type.with-env <instancer>)]
+ (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT))
(product analyse membersC))))
([#.UnivQ tc.existential]
[#.ExQ tc.var])
@@ -234,31 +234,31 @@
(case funT
(#.Var funT-id)
(do @
- [?funT' (typeA.with-env (tc.read funT-id))]
+ [?funT' (//type.with-env (tc.read funT-id))]
(case ?funT'
(#.Some funT')
- (typeA.with-type (#.Apply inputT funT')
+ (//type.with-type (#.Apply inputT funT')
(product analyse membersC))
_
- (lang.throw invalid-tuple-type [expectedT membersC])))
+ (///.throw invalid-tuple-type [expectedT membersC])))
_
(case (type.apply (list inputT) funT)
#.None
- (lang.throw not-a-quantified-type funT)
+ (///.throw not-a-quantified-type funT)
(#.Some outputT)
- (typeA.with-type outputT
+ (//type.with-type outputT
(product analyse membersC))))
_
- (lang.throw invalid-tuple-type [expectedT membersC])
+ (///.throw invalid-tuple-type [expectedT membersC])
))))
(def: #export (tagged-sum analyse tag valueC)
- (-> Analyser Ident Code (Meta Analysis))
- (do macro.Monad<Meta>
+ (-> Compiler Ident Code (Operation Analysis))
+ (do ///.Monad<Operation>
[tag (macro.normalize tag)
[idx group variantT] (macro.resolve-tag tag)
expectedT macro.expected-type]
@@ -266,9 +266,9 @@
(#.Var _)
(do @
[#let [case-size (list.size group)]
- inferenceT (inferenceA.variant idx case-size variantT)
- [inferredT valueA+] (inferenceA.general analyse inferenceT (list valueC))]
- (wrap (analysis.sum-analysis case-size idx (|> valueA+ list.head maybe.assume))))
+ 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))))
_
(..sum analyse idx valueC))))
@@ -278,38 +278,38 @@
## Normalization just means that all the tags get resolved to their
## canonical form (with their corresponding module identified).
(def: #export (normalize record)
- (-> (List [Code Code]) (Meta (List [Ident Code])))
- (monad.map macro.Monad<Meta>
+ (-> (List [Code Code]) (Operation (List [Ident Code])))
+ (monad.map ///.Monad<Operation>
(function (_ [key val])
(case key
[_ (#.Tag key)]
- (do macro.Monad<Meta>
+ (do ///.Monad<Operation>
[key (macro.normalize key)]
(wrap [key val]))
_
- (lang.throw record-keys-must-be-tags [key record])))
+ (///.throw record-keys-must-be-tags [key record])))
record))
## Lux already possesses the means to analyse tuples, so
## re-implementing the same functionality for records makes no sense.
## Records, thus, get transformed into tuples by ordering the elements.
(def: #export (order record)
- (-> (List [Ident Code]) (Meta [(List Code) Type]))
+ (-> (List [Ident Code]) (Operation [(List Code) Type]))
(case record
## empty-record = empty-tuple = unit = []
#.Nil
- (:: macro.Monad<Meta> wrap [(list) Any])
+ (:: ///.Monad<Operation> wrap [(list) Any])
(#.Cons [head-k head-v] _)
- (do macro.Monad<Meta>
+ (do ///.Monad<Operation>
[head-k (macro.normalize head-k)
[_ tag-set recordT] (macro.resolve-tag head-k)
#let [size-record (list.size record)
size-ts (list.size tag-set)]
_ (if (n/= size-ts size-record)
(wrap [])
- (lang.throw record-size-mismatch [size-ts size-record recordT record]))
+ (///.throw record-size-mismatch [size-ts size-record recordT record]))
#let [tuple-range (list.n/range +0 (dec size-ts))
tag->idx (dict.from-list ident.Hash<Ident> (list.zip2 tag-set tuple-range))]
idx->val (monad.fold @
@@ -318,11 +318,11 @@
[key (macro.normalize key)]
(case (dict.get key tag->idx)
#.None
- (lang.throw tag-does-not-belong-to-record [key recordT])
+ (///.throw tag-does-not-belong-to-record [key recordT])
(#.Some idx)
(if (dict.contains? idx idx->val)
- (lang.throw cannot-repeat-tag [key record])
+ (///.throw cannot-repeat-tag [key record])
(wrap (dict.put idx val idx->val))))))
(: (Dict Nat Code)
(dict.new number.Hash<Nat>))
@@ -333,13 +333,13 @@
))
(def: #export (record analyse members)
- (-> Analyser (List [Code Code]) (Meta Analysis))
- (do macro.Monad<Meta>
+ (-> Compiler (List [Code Code]) (Operation Analysis))
+ (do ///.Monad<Operation>
[members (normalize members)
[membersC recordT] (order members)]
(case membersC
(^ (list))
- primitiveA.unit
+ //primitive.unit
(^ (list singletonC))
(analyse singletonC)
@@ -350,9 +350,9 @@
(case expectedT
(#.Var _)
(do @
- [inferenceT (inferenceA.record recordT)
- [inferredT membersA] (inferenceA.general analyse inferenceT membersC)]
- (wrap (analysis.product-analysis membersA)))
+ [inferenceT (//inference.record recordT)
+ [inferredT membersA] (//inference.general analyse inferenceT membersC)]
+ (wrap (//.product-analysis membersA)))
_
(..product analyse membersC))))))
diff --git a/stdlib/source/lux/lang/analysis/type.lux b/stdlib/source/lux/lang/compiler/analysis/type.lux
index a7f9b3b29..9fcfb2743 100644
--- a/stdlib/source/lux/lang/analysis/type.lux
+++ b/stdlib/source/lux/lang/compiler/analysis/type.lux
@@ -1,56 +1,57 @@
(.module:
lux
(lux (control [monad #+ do])
- (data ["e" error])
+ (data [error])
[macro]
- [lang]
- (lang (type ["tc" check]))))
+ (lang (type ["tc" check])))
+ [///]
+ [// #+ Operation])
(def: #export (with-type expected action)
- (All [a] (-> Type (Meta a) (Meta a)))
+ (All [a] (-> Type (Operation a) (Operation a)))
(function (_ compiler)
(case (action (set@ #.expected (#.Some expected) compiler))
- (#e.Success [compiler' output])
+ (#error.Success [compiler' output])
(let [old-expected (get@ #.expected compiler)]
- (#e.Success [(set@ #.expected old-expected compiler')
- output]))
+ (#error.Success [(set@ #.expected old-expected compiler')
+ output]))
- (#e.Error error)
- (#e.Error error))))
+ (#error.Error error)
+ (#error.Error error))))
(def: #export (with-env action)
- (All [a] (-> (tc.Check a) (Meta a)))
+ (All [a] (-> (tc.Check a) (Operation a)))
(function (_ compiler)
(case (action (get@ #.type-context compiler))
- (#e.Error error)
- ((lang.fail error) compiler)
+ (#error.Error error)
+ ((///.fail error) compiler)
- (#e.Success [context' output])
- (#e.Success [(set@ #.type-context context' compiler)
- output]))))
+ (#error.Success [context' output])
+ (#error.Success [(set@ #.type-context context' compiler)
+ output]))))
(def: #export (with-fresh-env action)
- (All [a] (-> (Meta a) (Meta a)))
+ (All [a] (-> (Operation a) (Operation a)))
(function (_ compiler)
(let [old (get@ #.type-context compiler)]
(case (action (set@ #.type-context tc.fresh-context compiler))
- (#e.Success [compiler' output])
- (#e.Success [(set@ #.type-context old compiler')
- output])
+ (#error.Success [compiler' output])
+ (#error.Success [(set@ #.type-context old compiler')
+ output])
output
output))))
(def: #export (infer actualT)
- (-> Type (Meta Any))
- (do macro.Monad<Meta>
+ (-> Type (Operation Any))
+ (do ///.Monad<Operation>
[expectedT macro.expected-type]
(with-env
(tc.check expectedT actualT))))
(def: #export (with-inference action)
- (All [a] (-> (Meta a) (Meta [Type a])))
- (do macro.Monad<Meta>
+ (All [a] (-> (Operation a) (Operation [Type a])))
+ (do ///.Monad<Operation>
[[_ varT] (..with-env
tc.var)
output (with-type varT
diff --git a/stdlib/source/lux/lang/compiler/extension.lux b/stdlib/source/lux/lang/compiler/extension.lux
new file mode 100644
index 000000000..28dcd4637
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/extension.lux
@@ -0,0 +1,68 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data [error #+ Error]
+ [text]
+ (coll (dictionary ["dict" unordered #+ Dict]))))
+ [// #+ Eval]
+ [//compiler #+ Operation Compiler]
+ [//analysis #+ Analyser]
+ [//synthesis #+ Synthesizer]
+ [//translation #+ Translator])
+
+(type: #export (Extension i)
+ (#Base i)
+ (#Extension [Text (List (Extension i))]))
+
+(with-expansions [<Bundle> (as-is (Dict Text (-> 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))))
+
+ (type: #export (Bundle s i o)
+ <Bundle>))
+
+(do-template [<name>]
+ [(exception: #export (<name> {name Text})
+ (ex.report ["Name" name]))]
+
+ [unknown-extension]
+ [cannot-overwrite-existing-extension]
+ )
+
+(def: #export (extend compiler)
+ (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)]))
+
+ (#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)))))
+
+(def: #export (install name handler)
+ (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)]))))
+
+(def: #export fresh
+ Bundle
+ (dict.new text.Hash<Text>))
diff --git a/stdlib/source/lux/lang/extension/analysis.lux b/stdlib/source/lux/lang/compiler/extension/analysis.lux
index b412e28df..77439643e 100644
--- a/stdlib/source/lux/lang/extension/analysis.lux
+++ b/stdlib/source/lux/lang/compiler/extension/analysis.lux
@@ -3,12 +3,14 @@
(lux (data [text]
(coll [list "list/" Functor<List>]
(dictionary ["dict" unordered #+ Dict]))))
+ [///analysis #+ Analysis State]
+ [///synthesis #+ Synthesis]
[//]
[/common]
[/host])
(def: #export defaults
- (//.Extension //.Analysis)
+ (//.Bundle State Analysis Synthesis)
(|> /common.extensions
(dict.merge /host.extensions)
dict.entries
diff --git a/stdlib/source/lux/lang/compiler/extension/analysis/common.lux b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux
new file mode 100644
index 000000000..6bd1a93bf
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux
@@ -0,0 +1,396 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:]
+ [thread #+ Box])
+ (concurrency [atom #+ Atom])
+ (data [text]
+ text/format
+ (coll [list "list/" Functor<List>]
+ [array]
+ (dictionary ["dict" unordered #+ Dict])))
+ [lang]
+ (lang (type ["tc" check])
+ (analysis [".A" type]
+ [".A" case]
+ [".A" function]))
+ [io #+ IO])
+ (//// [compiler]
+ [analysis #+ Analysis])
+ [///]
+ [///bundle])
+
+(type: Handler
+ (///.Handler .Lux .Code Analysis))
+
+## [Utils]
+(def: (simple extension inputsT+ outputT)
+ (-> Text (List Type) Type ..Handler)
+ (let [num-expected (list.size inputsT+)]
+ (function (_ analyse args)
+ (let [num-actual (list.size args)]
+ (if (n/= num-expected num-actual)
+ (do compiler.Monad<Operation>
+ [_ (typeA.infer outputT)
+ argsA (monad.map @
+ (function (_ [argT argC])
+ (typeA.with-type argT
+ (analyse argC)))
+ (list.zip2 inputsT+ args))]
+ (wrap (#///.Extension extension argsA)))
+ (lang.throw ///bundle.incorrect-arity [extension num-expected num-actual]))))))
+
+(def: #export (nullary valueT extension)
+ (-> Type Text ..Handler)
+ (simple extension (list) valueT))
+
+(def: #export (unary inputT outputT extension)
+ (-> Type Type Text ..Handler)
+ (simple extension (list inputT) outputT))
+
+(def: #export (binary subjectT paramT outputT extension)
+ (-> Type Type Type Text ..Handler)
+ (simple extension (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))
+
+## [Analysers]
+## "lux is" represents reference/pointer equality.
+(def: (lux//is extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((binary varT varT Bool extension)
+ 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)
+ (case args
+ (^ (list opC))
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (Either Text varT)))
+ opA (typeA.with-type (type (IO varT))
+ (analyse opC))]
+ (wrap (#///.Extension extension (list opA))))
+
+ _
+ (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)]))))
+
+(def: (lux//in-module extension)
+ (-> Text ..Handler)
+ (function (_ analyse argsC+)
+ (case argsC+
+ (^ (list [_ (#.Text module-name)] exprC))
+ (lang.with-current-module module-name
+ (analyse exprC))
+
+ _
+ (lang.throw ///bundle.invalid-syntax [extension]))))
+
+## (do-template [<name> <type>]
+## [(def: (<name> extension)
+## (-> Text ..Handler)
+## (function (_ analyse args)
+## (case args
+## (^ (list typeC valueC))
+## (do compiler.Monad<Operation>
+## [actualT (eval Type typeC)
+## _ (typeA.infer (:! Type actualT))]
+## (typeA.with-type <type>
+## (analyse valueC)))
+
+## _
+## (lang.throw ///bundle.incorrect-arity [extension +2 (list.size args)]))))]
+
+## [lux//check (:! Type actualT)]
+## [lux//coerce Any]
+## )
+
+(def: (lux//check//type extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (case args
+ (^ (list valueC))
+ (do compiler.Monad<Operation>
+ [_ (typeA.infer Type)
+ valueA (typeA.with-type Type
+ (analyse valueC))]
+ (wrap valueA))
+
+ _
+ (lang.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))
+ )))
+
+(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 "min" (nullary Int))
+ (///bundle.install "max" (nullary Int))
+ (///bundle.install "to-nat" (unary Int Nat))
+ (///bundle.install "to-frac" (unary Int Frac))
+ (///bundle.install "char" (unary Int Text)))))
+
+(def: bundle/deg
+ ///.Bundle
+ (<| (///bundle.prefix "deg")
+ (|> ///.fresh
+ (///bundle.install "+" (binary Deg Deg Deg))
+ (///bundle.install "-" (binary Deg Deg Deg))
+ (///bundle.install "*" (binary Deg Deg Deg))
+ (///bundle.install "/" (binary Deg Deg Deg))
+ (///bundle.install "%" (binary Deg Deg Deg))
+ (///bundle.install "=" (binary Deg Deg Bool))
+ (///bundle.install "<" (binary Deg Deg Bool))
+ (///bundle.install "scale" (binary Deg Nat Deg))
+ (///bundle.install "reciprocal" (binary Deg Nat Deg))
+ (///bundle.install "min" (nullary Deg))
+ (///bundle.install "max" (nullary Deg))
+ (///bundle.install "to-frac" (unary Deg Frac)))))
+
+(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 "not-a-number" (nullary Frac))
+ (///bundle.install "positive-infinity" (nullary Frac))
+ (///bundle.install "negative-infinity" (nullary Frac))
+ (///bundle.install "to-deg" (unary Frac Deg))
+ (///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 "hash" (unary Text Nat))
+ (///bundle.install "replace-once" (trinary Text Text Text Text))
+ (///bundle.install "replace-all" (trinary Text Text Text Text))
+ (///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)
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((binary (type (Array varT)) Nat (type (Maybe varT)) extension)
+ analyse args))))
+
+(def: (array//put extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((trinary (type (Array varT)) Nat varT (type (Array varT)) extension)
+ analyse args))))
+
+(def: (array//remove extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((binary (type (Array varT)) Nat (type (Array varT)) extension)
+ 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/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: (atom-new extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (case args
+ (^ (list initC))
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (Atom varT)))
+ initA (typeA.with-type varT
+ (analyse initC))]
+ (wrap (#///.Extension extension (list initA))))
+
+ _
+ (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)]))))
+
+(def: (atom-read extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((unary (type (Atom varT)) varT extension)
+ analyse args))))
+
+(def: (atom//compare-and-swap extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)]
+ ((trinary (type (Atom varT)) varT varT Bool extension)
+ 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: (box//new extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (case args
+ (^ (list initC))
+ (do compiler.Monad<Operation>
+ [[var-id varT] (typeA.with-env tc.var)
+ _ (typeA.infer (type (All [!] (Box ! varT))))
+ initA (typeA.with-type varT
+ (analyse initC))]
+ (wrap (#///.Extension extension (list initA))))
+
+ _
+ (lang.throw ///bundle.incorrect-arity [extension +1 (list.size args)]))))
+
+(def: (box//read extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (do compiler.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)
+ analyse args))))
+
+(def: (box//write extension)
+ (-> Text ..Handler)
+ (function (_ analyse args)
+ (do compiler.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)
+ 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/process
+ ///.Bundle
+ (<| (///bundle.prefix "process")
+ (|> ///.fresh
+ (///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/deg)
+ (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/lang/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux
index 56da166c5..56da166c5 100644
--- a/stdlib/source/lux/lang/extension/analysis/host.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux
diff --git a/stdlib/source/lux/lang/compiler/extension/bundle.lux b/stdlib/source/lux/lang/compiler/extension/bundle.lux
new file mode 100644
index 000000000..ff4bd66ad
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/extension/bundle.lux
@@ -0,0 +1,31 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data [text]
+ text/format
+ (coll [list "list/" Functor<List>]
+ (dictionary ["dict" unordered #+ Dict]))))
+ [//])
+
+(exception: #export (incorrect-arity {name Text} {arity Nat} {args Nat})
+ (ex.report ["Extension" (%t name)]
+ ["Expected arity" (|> arity .int %i)]
+ ["Actual arity" (|> args .int %i)]))
+
+(exception: #export (invalid-syntax {name Text})
+ (ex.report ["Extension" name]))
+
+## [Utils]
+(def: #export (install name anonymous)
+ (All [s i o]
+ (-> Text (-> Text (//.Handler s i o))
+ (-> (//.Bundle s i o) (//.Bundle s i o))))
+ (dict.put name anonymous))
+
+(def: #export (prefix prefix)
+ (All [s i o]
+ (-> Text (-> (//.Bundle s i o) (//.Bundle s i o))))
+ (|>> dict.entries
+ (list/map (function (_ [key val]) [(format prefix " " key) val]))
+ (dict.from-list text.Hash<Text>)))
diff --git a/stdlib/source/lux/lang/extension/synthesis.lux b/stdlib/source/lux/lang/compiler/extension/synthesis.lux
index c48f3e3a5..c48f3e3a5 100644
--- a/stdlib/source/lux/lang/extension/synthesis.lux
+++ b/stdlib/source/lux/lang/compiler/extension/synthesis.lux
diff --git a/stdlib/source/lux/lang/extension/translation.lux b/stdlib/source/lux/lang/compiler/extension/translation.lux
index bc95ed1f4..bc95ed1f4 100644
--- a/stdlib/source/lux/lang/extension/translation.lux
+++ b/stdlib/source/lux/lang/compiler/extension/translation.lux
diff --git a/stdlib/source/lux/lang/compiler/init.lux b/stdlib/source/lux/lang/compiler/init.lux
new file mode 100644
index 000000000..92a066b7e
--- /dev/null
+++ b/stdlib/source/lux/lang/compiler/init.lux
@@ -0,0 +1,51 @@
+(.module:
+ lux
+ [///]
+ [///host])
+
+(def: #export (cursor file)
+ (-> Text Cursor)
+ [file +1 +0])
+
+(def: #export (source file code)
+ (-> Text Text Source)
+ [(cursor file) +0 code])
+
+(def: dummy-source
+ Source
+ [.dummy-cursor +0 ""])
+
+(def: #export type-context
+ Type-Context
+ {#.ex-counter +0
+ #.var-counter +0
+ #.var-bindings (list)})
+
+(`` (def: #export info
+ Info
+ {#.target (for {(~~ (static ///host.common-lisp)) ///host.common-lisp
+ (~~ (static ///host.js)) ///host.js
+ (~~ (static ///host.jvm)) ///host.jvm
+ (~~ (static ///host.lua)) ///host.lua
+ (~~ (static ///host.php)) ///host.php
+ (~~ (static ///host.python)) ///host.python
+ (~~ (static ///host.r)) ///host.r
+ (~~ (static ///host.ruby)) ///host.ruby
+ (~~ (static ///host.scheme)) ///host.scheme})
+ #.version ///.version
+ #.mode #.Build}))
+
+(def: #export (compiler host)
+ (-> Any Lux)
+ {#.info ..info
+ #.source dummy-source
+ #.cursor .dummy-cursor
+ #.current-module #.None
+ #.modules (list)
+ #.scopes (list)
+ #.type-context ..type-context
+ #.expected #.None
+ #.seed +0
+ #.scope-type-vars (list)
+ #.extensions []
+ #.host host})
diff --git a/stdlib/source/lux/lang/synthesis.lux b/stdlib/source/lux/lang/compiler/synthesis.lux
index 1bf06cdd0..eece3c7ab 100644
--- a/stdlib/source/lux/lang/synthesis.lux
+++ b/stdlib/source/lux/lang/compiler/synthesis.lux
@@ -3,10 +3,9 @@
(lux (control [monad #+ do])
(data [error #+ Error]
(coll (dictionary ["dict" unordered #+ Dict]))))
- [// #+ Extension]
- [//reference #+ Register Variable Reference]
- [//analysis #+ Environment Arity Analysis]
- [//compiler #+ Operation Compiler])
+ [///reference #+ Register Variable Reference]
+ [// #+ Operation Compiler]
+ [//analysis #+ Environment Arity Analysis])
(type: #export Resolver (Dict Variable Variable))
@@ -18,7 +17,7 @@
(def: #export fresh-resolver
Resolver
- (dict.new //reference.Hash<Variable>))
+ (dict.new ///reference.Hash<Variable>))
(def: #export init
State
@@ -88,8 +87,7 @@
(#Primitive Primitive)
(#Structure (Structure Synthesis))
(#Reference Reference)
- (#Control (Control Synthesis))
- (#Extension (Extension Synthesis)))
+ (#Control (Control Synthesis)))
(type: #export Path
(Path' Synthesis))
@@ -151,7 +149,7 @@
(do-template [<name> <value>]
[(def: #export <name>
(All [a] (-> (Operation ..State a) (Operation ..State a)))
- (//compiler.localized (set@ #direct? <value>)))]
+ (//.localized (set@ #direct? <value>)))]
[indirectly false]
[directly true]
@@ -160,7 +158,7 @@
(do-template [<name> <type> <tag>]
[(def: #export (<name> value)
(-> <type> (All [a] (-> (Operation ..State a) (Operation ..State a))))
- (//compiler.localized (set@ <tag> value)))]
+ (//.localized (set@ <tag> value)))]
[with-scope-arity Arity #scope-arity]
[with-resolver Resolver #resolver]
@@ -171,10 +169,10 @@
(All [o]
(-> Arity Resolver
(-> (Operation ..State o) (Operation ..State o))))
- (//compiler.with-state {#scope-arity arity
- #resolver resolver
- #direct? true
- #locals arity}))
+ (//.with-state {#scope-arity arity
+ #resolver resolver
+ #direct? true
+ #locals arity}))
(do-template [<name> <tag> <type>]
[(def: #export <name>
@@ -190,7 +188,7 @@
(def: #export with-new-local
(All [a] (-> (Operation ..State a) (Operation ..State a)))
- (<<| (do //compiler.Monad<Operation>
+ (<<| (do //.Monad<Operation>
[locals ..locals])
(..with-locals (inc locals))))
@@ -220,8 +218,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/lang/synthesis/case.lux b/stdlib/source/lux/lang/compiler/synthesis/case.lux
index b7f224168..b7f224168 100644
--- a/stdlib/source/lux/lang/synthesis/case.lux
+++ b/stdlib/source/lux/lang/compiler/synthesis/case.lux
diff --git a/stdlib/source/lux/lang/synthesis/expression.lux b/stdlib/source/lux/lang/compiler/synthesis/expression.lux
index 52ea33805..52ea33805 100644
--- a/stdlib/source/lux/lang/synthesis/expression.lux
+++ b/stdlib/source/lux/lang/compiler/synthesis/expression.lux
diff --git a/stdlib/source/lux/lang/synthesis/function.lux b/stdlib/source/lux/lang/compiler/synthesis/function.lux
index 35b9e047e..35b9e047e 100644
--- a/stdlib/source/lux/lang/synthesis/function.lux
+++ b/stdlib/source/lux/lang/compiler/synthesis/function.lux
diff --git a/stdlib/source/lux/lang/synthesis/loop.lux b/stdlib/source/lux/lang/compiler/synthesis/loop.lux
index eb57eb7ad..eb57eb7ad 100644
--- a/stdlib/source/lux/lang/synthesis/loop.lux
+++ b/stdlib/source/lux/lang/compiler/synthesis/loop.lux
diff --git a/stdlib/source/lux/lang/translation.lux b/stdlib/source/lux/lang/compiler/translation.lux
index c117bc019..c117bc019 100644
--- a/stdlib/source/lux/lang/translation.lux
+++ b/stdlib/source/lux/lang/compiler/translation.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux
index e5d12a005..e5d12a005 100644
--- a/stdlib/source/lux/lang/translation/scheme/case.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux
index 96bb17126..96bb17126 100644
--- a/stdlib/source/lux/lang/translation/scheme/expression.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/expression.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux
index 6475caf68..6475caf68 100644
--- a/stdlib/source/lux/lang/translation/scheme/extension.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux
index 140045aaf..140045aaf 100644
--- a/stdlib/source/lux/lang/translation/scheme/extension/common.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux
index 11c64076c..11c64076c 100644
--- a/stdlib/source/lux/lang/translation/scheme/function.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux
index 6f305336e..6f305336e 100644
--- a/stdlib/source/lux/lang/translation/scheme/loop.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux
index ac775fa82..ac775fa82 100644
--- a/stdlib/source/lux/lang/translation/scheme/primitive.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/primitive.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux
index 453d4edb6..453d4edb6 100644
--- a/stdlib/source/lux/lang/translation/scheme/reference.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/reference.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux
index b30aff3a2..b30aff3a2 100644
--- a/stdlib/source/lux/lang/translation/scheme/runtime.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux
diff --git a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux
index a11434594..a11434594 100644
--- a/stdlib/source/lux/lang/translation/scheme/structure.jvm.lux
+++ b/stdlib/source/lux/lang/compiler/translation/scheme/structure.jvm.lux
diff --git a/stdlib/source/lux/lang/extension.lux b/stdlib/source/lux/lang/extension.lux
deleted file mode 100644
index 7edac52c3..000000000
--- a/stdlib/source/lux/lang/extension.lux
+++ /dev/null
@@ -1,131 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data ["e" error]
- [text]
- (coll (dictionary ["dict" unordered #+ Dict]))))
- [// #+ Eval]
- [//compiler #+ Operation Compiler]
- [//analysis #+ Analyser]
- [//synthesis #+ Synthesizer]
- [//translation #+ Translator])
-
-(do-template [<name>]
- [(exception: #export (<name> {extension Text})
- extension)]
-
- [unknown-analysis]
- [unknown-synthesis]
- [unknown-translation]
- [unknown-statement]
-
- [cannot-define-analysis-more-than-once]
- [cannot-define-synthesis-more-than-once]
- [cannot-define-translation-more-than-once]
- [cannot-define-statement-more-than-once]
- )
-
-(type: #export Analysis
- (-> Analyser Eval
- (Compiler .Lux
- (List Code)
- //analysis.Analysis)))
-
-(type: #export Synthesis
- (-> Synthesizer
- (Compiler //synthesis.State
- (List //analysis.Analysis)
- //synthesis.Synthesis)))
-
-(type: #export (Translation anchor code)
- (-> (Translator anchor code)
- (Compiler (//translation.State anchor code)
- (List //synthesis.Synthesis)
- code)))
-
-(type: #export Statement
- (-> (List Code) (Meta Any)))
-
-(type: #export (Extension e)
- (Dict Text e))
-
-(type: #export Extensions
- {#analysis (Extension Analysis)
- #synthesis (Extension Synthesis)
- #translation (Extension Translation)
- #statement (Extension Statement)})
-
-(def: #export fresh
- Extensions
- {#analysis (dict.new text.Hash<Text>)
- #synthesis (dict.new text.Hash<Text>)
- #translation (dict.new text.Hash<Text>)
- #statement (dict.new text.Hash<Text>)})
-
-(def: get
- (Meta Extensions)
- (function (_ compiler)
- (#e.Success [compiler
- (|> compiler (get@ #.extensions) (:! Extensions))])))
-
-(def: (set extensions)
- (-> Extensions (Meta Any))
- (function (_ compiler)
- (#e.Success [(set@ #.extensions (:! Nothing extensions) compiler)
- []])))
-
-(do-template [<name> <type> <category> <exception>]
- [(def: #export (<name> name)
- (-> Text (Meta <type>))
- (do //compiler.Monad<Operation>
- [extensions ..get]
- (case (dict.get name (get@ <category> extensions))
- (#.Some extension)
- (wrap extension)
-
- #.None
- (//compiler.throw <exception> name))))]
-
- [find-analysis Analysis #analysis unknown-analysis]
- [find-synthesis Synthesis #synthesis unknown-synthesis]
- [find-translation Translation #translation unknown-translation]
- [find-statement Statement #statement unknown-statement]
- )
-
-(def: #export empty
- (All [e] (Extension e))
- (dict.new text.Hash<Text>))
-
-(do-template [<params> <all> <state> <type> <category>]
- [(def: #export <all>
- (All <params> (Operation <state> (Extension <type>)))
- (|> ..get
- (:: //compiler.Monad<Operation> map (get@ <category>))))]
-
- [[] all-analyses .Lux
- Analysis #analysis]
- [[] all-syntheses //synthesis.State
- Synthesis #synthesis]
- [[anchor code] all-translations (//translation.State anchor code)
- Translation #translation]
- [[] all-statements Any
- Statement #statement]
- )
-
-(do-template [<name> <type> <category> <exception>]
- [(def: #export (<name> name extension)
- (-> Text <type> (Meta Any))
- (do //compiler.Monad<Operation>
- [extensions ..get
- _ (if (not (dict.contains? name (get@ <category> extensions)))
- (wrap [])
- (//compiler.throw <exception> name))
- _ (..set (update@ <category> (dict.put name extension) extensions))]
- (wrap [])))]
-
- [install-analysis Analysis #analysis cannot-define-analysis-more-than-once]
- [install-synthesis Synthesis #synthesis cannot-define-synthesis-more-than-once]
- [install-translation Translation #translation cannot-define-translation-more-than-once]
- [install-statement Statement #statement cannot-define-statement-more-than-once]
- )
diff --git a/stdlib/source/lux/lang/extension/analysis/common.lux b/stdlib/source/lux/lang/extension/analysis/common.lux
deleted file mode 100644
index 3faae601b..000000000
--- a/stdlib/source/lux/lang/extension/analysis/common.lux
+++ /dev/null
@@ -1,444 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:]
- [thread])
- (concurrency [atom #+ Atom])
- (data [text]
- text/format
- (coll [list "list/" Functor<List>]
- [array]
- (dictionary ["dict" unordered #+ Dict])))
- [macro]
- (macro [code])
- [lang]
- (lang (type ["tc" check])
- [".L" analysis]
- (analysis [".A" type]
- [".A" case]
- [".A" function]))
- [io])
- [///])
-
-(exception: #export (incorrect-extension-arity {name Text} {arity Nat} {args Nat})
- (ex.report ["Extension" (%t name)]
- ["Expected arity" (|> arity .int %i)]
- ["Actual arity" (|> args .int %i)]))
-
-(exception: #export (invalid-syntax {name Text} {arguments (List Code)})
- (ex.report ["Extension" name]
- ["Inputs" (|> arguments
- list.enumerate
- (list/map (function (_ [idx argC])
- (format "\n " (%n idx) " " (%code argC))))
- (text.join-with ""))]))
-
-## [Utils]
-(type: #export Bundle
- (Dict Text (-> Text ///.Analysis)))
-
-(def: #export (install name unnamed)
- (-> Text (-> Text ///.Analysis)
- (-> Bundle Bundle))
- (dict.put name unnamed))
-
-(def: #export (prefix prefix bundle)
- (-> Text Bundle Bundle)
- (|> bundle
- dict.entries
- (list/map (function (_ [key val]) [(format prefix " " key) val]))
- (dict.from-list text.Hash<Text>)))
-
-(def: (simple proc inputsT+ outputT)
- (-> Text (List Type) Type ///.Analysis)
- (let [num-expected (list.size inputsT+)]
- (function (_ analyse eval args)
- (let [num-actual (list.size args)]
- (if (n/= num-expected num-actual)
- (do macro.Monad<Meta>
- [_ (typeA.infer outputT)
- argsA (monad.map @
- (function (_ [argT argC])
- (typeA.with-type argT
- (analyse argC)))
- (list.zip2 inputsT+ args))]
- (wrap (#analysisL.Extension proc argsA)))
- (lang.throw incorrect-extension-arity [proc num-expected num-actual]))))))
-
-(def: #export (nullary valueT proc)
- (-> Type Text ///.Analysis)
- (simple proc (list) valueT))
-
-(def: #export (unary inputT outputT proc)
- (-> Type Type Text ///.Analysis)
- (simple proc (list inputT) outputT))
-
-(def: #export (binary subjectT paramT outputT proc)
- (-> Type Type Type Text ///.Analysis)
- (simple proc (list subjectT paramT) outputT))
-
-(def: #export (trinary subjectT param0T param1T outputT proc)
- (-> Type Type Type Type Text ///.Analysis)
- (simple proc (list subjectT param0T param1T) outputT))
-
-## [Analysers]
-## "lux is" represents reference/pointer equality.
-(def: (lux//is proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)]
- ((binary varT varT Bool proc)
- analyse eval args))))
-
-## "lux try" provides a simple way to interact with the host platform's
-## error-handling facilities.
-(def: (lux//try proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list opC))
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)
- _ (typeA.infer (type (Either Text varT)))
- opA (typeA.with-type (type (io.IO varT))
- (analyse opC))]
- (wrap (#analysisL.Extension proc (list opA))))
-
- _
- (lang.throw incorrect-extension-arity [proc +1 (list.size args)]))))
-
-(def: (lux//function proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list [_ (#.Symbol ["" func-name])]
- [_ (#.Symbol ["" arg-name])]
- body))
- (functionA.function analyse func-name arg-name body)
-
- _
- (lang.throw incorrect-extension-arity [proc +3 (list.size args)]))))
-
-(def: (lux//case proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list input [_ (#.Record branches)]))
- (caseA.case analyse input branches)
-
- _
- (lang.throw incorrect-extension-arity [proc +2 (list.size args)]))))
-
-(def: (lux//in-module proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval argsC+)
- (case argsC+
- (^ (list [_ (#.Text module-name)] exprC))
- (lang.with-current-module module-name
- (analyse exprC))
-
- _
- (lang.throw invalid-syntax [proc argsC+]))))
-
-(do-template [<name> <type>]
- [(def: (<name> proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list typeC valueC))
- (do macro.Monad<Meta>
- [actualT (eval Type typeC)
- _ (typeA.infer (:! Type actualT))]
- (typeA.with-type <type>
- (analyse valueC)))
-
- _
- (lang.throw incorrect-extension-arity [proc +2 (list.size args)]))))]
-
- [lux//check (:! Type actualT)]
- [lux//coerce Any]
- )
-
-(def: (lux//check//type proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list valueC))
- (do macro.Monad<Meta>
- [_ (typeA.infer Type)
- valueA (typeA.with-type Type
- (analyse valueC))]
- (wrap valueA))
-
- _
- (lang.throw incorrect-extension-arity [proc +1 (list.size args)]))))
-
-(def: lux-procs
- Bundle
- (|> (dict.new text.Hash<Text>)
- (install "is" lux//is)
- (install "try" lux//try)
- (install "function" lux//function)
- (install "case" lux//case)
- (install "check" lux//check)
- (install "coerce" lux//coerce)
- (install "check type" lux//check//type)
- (install "in-module" lux//in-module)))
-
-(def: io-procs
- Bundle
- (<| (prefix "io")
- (|> (dict.new text.Hash<Text>)
- (install "log" (unary Text Any))
- (install "error" (unary Text Nothing))
- (install "exit" (unary Int Nothing))
- (install "current-time" (nullary Int)))))
-
-(def: bit-procs
- Bundle
- (<| (prefix "bit")
- (|> (dict.new text.Hash<Text>)
- (install "and" (binary Nat Nat Nat))
- (install "or" (binary Nat Nat Nat))
- (install "xor" (binary Nat Nat Nat))
- (install "left-shift" (binary Nat Nat Nat))
- (install "logical-right-shift" (binary Nat Nat Nat))
- (install "arithmetic-right-shift" (binary Int Nat Int))
- )))
-
-(def: int-procs
- Bundle
- (<| (prefix "int")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary Int Int Int))
- (install "-" (binary Int Int Int))
- (install "*" (binary Int Int Int))
- (install "/" (binary Int Int Int))
- (install "%" (binary Int Int Int))
- (install "=" (binary Int Int Bool))
- (install "<" (binary Int Int Bool))
- (install "min" (nullary Int))
- (install "max" (nullary Int))
- (install "to-nat" (unary Int Nat))
- (install "to-frac" (unary Int Frac))
- (install "char" (unary Int Text)))))
-
-(def: deg-procs
- Bundle
- (<| (prefix "deg")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary Deg Deg Deg))
- (install "-" (binary Deg Deg Deg))
- (install "*" (binary Deg Deg Deg))
- (install "/" (binary Deg Deg Deg))
- (install "%" (binary Deg Deg Deg))
- (install "=" (binary Deg Deg Bool))
- (install "<" (binary Deg Deg Bool))
- (install "scale" (binary Deg Nat Deg))
- (install "reciprocal" (binary Deg Nat Deg))
- (install "min" (nullary Deg))
- (install "max" (nullary Deg))
- (install "to-frac" (unary Deg Frac)))))
-
-(def: frac-procs
- Bundle
- (<| (prefix "frac")
- (|> (dict.new text.Hash<Text>)
- (install "+" (binary Frac Frac Frac))
- (install "-" (binary Frac Frac Frac))
- (install "*" (binary Frac Frac Frac))
- (install "/" (binary Frac Frac Frac))
- (install "%" (binary Frac Frac Frac))
- (install "=" (binary Frac Frac Bool))
- (install "<" (binary Frac Frac Bool))
- (install "smallest" (nullary Frac))
- (install "min" (nullary Frac))
- (install "max" (nullary Frac))
- (install "not-a-number" (nullary Frac))
- (install "positive-infinity" (nullary Frac))
- (install "negative-infinity" (nullary Frac))
- (install "to-deg" (unary Frac Deg))
- (install "to-int" (unary Frac Int))
- (install "encode" (unary Frac Text))
- (install "decode" (unary Text (type (Maybe Frac)))))))
-
-(def: text-procs
- Bundle
- (<| (prefix "text")
- (|> (dict.new text.Hash<Text>)
- (install "=" (binary Text Text Bool))
- (install "<" (binary Text Text Bool))
- (install "concat" (binary Text Text Text))
- (install "index" (trinary Text Text Nat (type (Maybe Nat))))
- (install "size" (unary Text Nat))
- (install "hash" (unary Text Nat))
- (install "replace-once" (trinary Text Text Text Text))
- (install "replace-all" (trinary Text Text Text Text))
- (install "char" (binary Text Nat (type (Maybe Nat))))
- (install "clip" (trinary Text Nat Nat (type (Maybe Text))))
- )))
-
-(def: (array//get proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)]
- ((binary (type (Array varT)) Nat (type (Maybe varT)) proc)
- analyse eval args))))
-
-(def: (array//put proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)]
- ((trinary (type (Array varT)) Nat varT (type (Array varT)) proc)
- analyse eval args))))
-
-(def: (array//remove proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)]
- ((binary (type (Array varT)) Nat (type (Array varT)) proc)
- analyse eval args))))
-
-(def: array-procs
- Bundle
- (<| (prefix "array")
- (|> (dict.new text.Hash<Text>)
- (install "new" (unary Nat Array))
- (install "get" array//get)
- (install "put" array//put)
- (install "remove" array//remove)
- (install "size" (unary (type (Ex [a] (Array a))) Nat))
- )))
-
-(def: math-procs
- Bundle
- (<| (prefix "math")
- (|> (dict.new text.Hash<Text>)
- (install "cos" (unary Frac Frac))
- (install "sin" (unary Frac Frac))
- (install "tan" (unary Frac Frac))
- (install "acos" (unary Frac Frac))
- (install "asin" (unary Frac Frac))
- (install "atan" (unary Frac Frac))
- (install "cosh" (unary Frac Frac))
- (install "sinh" (unary Frac Frac))
- (install "tanh" (unary Frac Frac))
- (install "exp" (unary Frac Frac))
- (install "log" (unary Frac Frac))
- (install "ceil" (unary Frac Frac))
- (install "floor" (unary Frac Frac))
- (install "round" (unary Frac Frac))
- (install "atan2" (binary Frac Frac Frac))
- (install "pow" (binary Frac Frac Frac))
- )))
-
-(def: (atom-new proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list initC))
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)
- _ (typeA.infer (type (Atom varT)))
- initA (typeA.with-type varT
- (analyse initC))]
- (wrap (#analysisL.Extension proc (list initA))))
-
- _
- (lang.throw incorrect-extension-arity [proc +1 (list.size args)]))))
-
-(def: (atom-read proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)]
- ((unary (type (Atom varT)) varT proc)
- analyse eval args))))
-
-(def: (atom//compare-and-swap proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)]
- ((trinary (type (Atom varT)) varT varT Bool proc)
- analyse eval args))))
-
-(def: atom-procs
- Bundle
- (<| (prefix "atom")
- (|> (dict.new text.Hash<Text>)
- (install "new" atom-new)
- (install "read" atom-read)
- (install "compare-and-swap" atom//compare-and-swap)
- )))
-
-(def: (box//new proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (case args
- (^ (list initC))
- (do macro.Monad<Meta>
- [[var-id varT] (typeA.with-env tc.var)
- _ (typeA.infer (type (All [!] (thread.Box ! varT))))
- initA (typeA.with-type varT
- (analyse initC))]
- (wrap (#analysisL.Extension proc (list initA))))
-
- _
- (lang.throw incorrect-extension-arity [proc +1 (list.size args)]))))
-
-(def: (box//read proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[thread-id threadT] (typeA.with-env tc.var)
- [var-id varT] (typeA.with-env tc.var)]
- ((unary (type (thread.Box threadT varT)) varT proc)
- analyse eval args))))
-
-(def: (box//write proc)
- (-> Text ///.Analysis)
- (function (_ analyse eval args)
- (do macro.Monad<Meta>
- [[thread-id threadT] (typeA.with-env tc.var)
- [var-id varT] (typeA.with-env tc.var)]
- ((binary varT (type (thread.Box threadT varT)) Any proc)
- analyse eval args))))
-
-(def: box-procs
- Bundle
- (<| (prefix "box")
- (|> (dict.new text.Hash<Text>)
- (install "new" box//new)
- (install "read" box//read)
- (install "write" box//write)
- )))
-
-(def: process-procs
- Bundle
- (<| (prefix "process")
- (|> (dict.new text.Hash<Text>)
- (install "parallelism-level" (nullary Nat))
- (install "schedule" (binary Nat (type (io.IO Any)) Any))
- )))
-
-(def: #export extensions
- Bundle
- (<| (prefix "lux")
- (|> (dict.new text.Hash<Text>)
- (dict.merge lux-procs)
- (dict.merge bit-procs)
- (dict.merge int-procs)
- (dict.merge deg-procs)
- (dict.merge frac-procs)
- (dict.merge text-procs)
- (dict.merge array-procs)
- (dict.merge math-procs)
- (dict.merge atom-procs)
- (dict.merge box-procs)
- (dict.merge process-procs)
- (dict.merge io-procs))))
diff --git a/stdlib/source/lux/lang/target.lux b/stdlib/source/lux/lang/host.lux
index ee0eee74d..218de67a4 100644
--- a/stdlib/source/lux/lang/target.lux
+++ b/stdlib/source/lux/lang/host.lux
@@ -1,10 +1,10 @@
(.module:
lux)
-(type: #export Target Text)
+(type: #export Host Text)
(do-template [<name> <value>]
- [(def: #export <name> Target <value>)]
+ [(def: #export <name> Host <value>)]
[common-lisp "Common Lisp"]
[js "JavaScript"]
diff --git a/stdlib/source/lux/lang/init.lux b/stdlib/source/lux/lang/init.lux
deleted file mode 100644
index 40a7fc69c..000000000
--- a/stdlib/source/lux/lang/init.lux
+++ /dev/null
@@ -1,61 +0,0 @@
-(.module:
- lux
- [//]
- (// ["//." target]
- [".L" extension]
- (extension [".E" analysis]
- [".E" synthesis]
- [".E" translation]
- ## [".E" statement]
- )))
-
-(def: #export (cursor file)
- (-> Text Cursor)
- [file +1 +0])
-
-(def: #export (source file code)
- (-> Text Text Source)
- [(cursor file) +0 code])
-
-(def: dummy-source
- Source
- [.dummy-cursor +0 ""])
-
-(def: #export type-context
- Type-Context
- {#.ex-counter +0
- #.var-counter +0
- #.var-bindings (list)})
-
-(`` (def: #export info
- Info
- {#.target (for {(~~ (static //target.common-lisp)) //target.common-lisp
- (~~ (static //target.js)) //target.js
- (~~ (static //target.jvm)) //target.jvm
- (~~ (static //target.lua)) //target.lua
- (~~ (static //target.php)) //target.php
- (~~ (static //target.python)) //target.python
- (~~ (static //target.r)) //target.r
- (~~ (static //target.ruby)) //target.ruby
- (~~ (static //target.scheme)) //target.scheme})
- #.version //.version
- #.mode #.Build}))
-
-(def: #export (compiler host)
- (-> Any Lux)
- {#.info ..info
- #.source dummy-source
- #.cursor .dummy-cursor
- #.current-module #.None
- #.modules (list)
- #.scopes (list)
- #.type-context ..type-context
- #.expected #.None
- #.seed +0
- #.scope-type-vars (list)
- #.extensions {#extensionL.analysis analysisE.defaults
- #extensionL.synthesis synthesisE.defaults
- #extensionL.translation translationE.defaults
- #extensionL.statement (:!! []) ## statementE.defaults
- }
- #.host host})
diff --git a/stdlib/source/lux/lang/module.lux b/stdlib/source/lux/lang/module.lux
index 161fd073a..d6b66da74 100644
--- a/stdlib/source/lux/lang/module.lux
+++ b/stdlib/source/lux/lang/module.lux
@@ -9,7 +9,8 @@
(coll [list "list/" Fold<List> Functor<List>]
(dictionary [plist])))
[macro])
- [//])
+ [//compiler]
+ (//compiler [analysis]))
(type: #export Tag Text)
@@ -17,13 +18,13 @@
module)
(exception: #export (cannot-declare-tag-twice {module Text} {tag Text})
- (format "Module: " module "\n"
- " Tag: " tag "\n"))
+ (ex.report ["Module" module]
+ ["Tag" tag]))
(do-template [<name>]
[(exception: #export (<name> {tags (List Text)} {owner Type})
- (format "Tags: " (text.join-with " " tags) "\n"
- "Type: " (%type owner) "\n"))]
+ (ex.report ["Tags" (text.join-with " " tags)]
+ ["Type" (%type owner)]))]
[cannot-declare-tags-for-unnamed-type]
[cannot-declare-tags-for-foreign-type]
@@ -33,16 +34,16 @@
(%ident name))
(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State})
- (format " Module: " module "\n"
- "Desired state: " (case state
- #.Active "Active"
- #.Compiled "Compiled"
- #.Cached "Cached") "\n"))
+ (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})
- (format " Module: " module "\n"
- "Old annotations: " (%code old) "\n"
- "New annotations: " (%code new) "\n"))
+ (ex.report ["Module" module]
+ ["Old annotations" (%code old)]
+ ["New annotations" (%code new)]))
(def: (new hash)
(-> Nat Module)
@@ -69,7 +70,7 @@
[]]))
(#.Some old)
- (//.throw cannot-set-module-annotations-more-than-once [self-name old annotations]))))
+ (//compiler.throw cannot-set-module-annotations-more-than-once [self-name old annotations]))))
(def: #export (import module)
(-> Text (Meta Any))
@@ -119,7 +120,7 @@
[]])
(#.Some already-existing)
- ((//.throw cannot-define-more-than-once [self-name name]) compiler)))))
+ ((//compiler.throw cannot-define-more-than-once [self-name name]) compiler)))))
(def: #export (create hash name)
(-> Nat Text (Meta []))
@@ -134,7 +135,7 @@
(All [a] (-> Nat Text (Meta a) (Meta [Module a])))
(do macro.Monad<Meta>
[_ (create hash name)
- output (//.with-current-module name
+ output (analysis.with-current-module name
action)
module (macro.find-module name)]
(wrap [module output])))
@@ -153,11 +154,11 @@
(plist.put module-name (set@ #.module-state <tag> module))
compiler)
[]])
- ((//.throw can-only-change-state-of-active-module [module-name <tag>])
+ ((//compiler.throw can-only-change-state-of-active-module [module-name <tag>])
compiler)))
#.None
- ((//.throw unknown-module module-name) compiler))))
+ ((//compiler.throw unknown-module module-name) compiler))))
(def: #export (<asker> module-name)
(-> Text (Meta Bool))
@@ -170,7 +171,7 @@
_ false)])
#.None
- ((//.throw unknown-module module-name) compiler))))]
+ ((//compiler.throw unknown-module module-name) compiler))))]
[set-active active? #.Active]
[set-compiled compiled? #.Compiled]
@@ -186,7 +187,7 @@
(#e.Success [compiler (get@ <tag> module)])
#.None
- ((//.throw unknown-module module-name) compiler))))]
+ ((//compiler.throw unknown-module module-name) compiler))))]
[tags #.tags (List [Text [Nat (List Ident) Bool Type]])]
[types #.types (List [Text [(List Ident) Bool Type]])]
@@ -204,7 +205,7 @@
(wrap [])
(#.Some _)
- (//.throw cannot-declare-tag-twice [module-name tag])))
+ (//compiler.throw cannot-declare-tag-twice [module-name tag])))
tags)]
(wrap [])))
@@ -217,10 +218,10 @@
(wrap type-ident)
_
- (//.throw cannot-declare-tags-for-unnamed-type [tags type]))
+ (//compiler.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))]
+ _ (//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)
@@ -236,4 +237,4 @@
compiler)
[]]))
#.None
- ((//.throw unknown-module self-name) compiler)))))
+ ((//compiler.throw unknown-module self-name) compiler)))))