aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc')
-rw-r--r--new-luxc/source/luxc/analyser.lux368
-rw-r--r--new-luxc/source/luxc/base.lux21
-rw-r--r--new-luxc/source/luxc/compiler.lux95
-rw-r--r--new-luxc/source/luxc/compiler/base.jvm.lux30
-rw-r--r--new-luxc/source/luxc/compiler/expr.jvm.lux27
-rw-r--r--new-luxc/source/luxc/compiler/runtime.jvm.lux6
-rw-r--r--new-luxc/source/luxc/compiler/statement.jvm.lux26
-rw-r--r--new-luxc/source/luxc/env.lux106
-rw-r--r--new-luxc/source/luxc/io.jvm.lux93
-rw-r--r--new-luxc/source/luxc/module.lux6
-rw-r--r--new-luxc/source/luxc/module/def.lux6
-rw-r--r--new-luxc/source/luxc/module/descriptor/annotation.lux83
-rw-r--r--new-luxc/source/luxc/module/descriptor/common.lux38
-rw-r--r--new-luxc/source/luxc/module/descriptor/type.lux145
-rw-r--r--new-luxc/source/luxc/parser.lux64
-rw-r--r--new-luxc/source/luxc/synthesizer.lux14
-rw-r--r--new-luxc/source/program.lux51
17 files changed, 1109 insertions, 70 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux
new file mode 100644
index 000000000..84719738e
--- /dev/null
+++ b/new-luxc/source/luxc/analyser.lux
@@ -0,0 +1,368 @@
+(;module:
+ lux
+ (lux (control monad
+ pipe)
+ [io #- run]
+ (concurrency ["A" atom])
+ (data ["E" error]
+ [text "T/" Eq<Text>]
+ text/format
+ (coll [list "L/" Fold<List> Monoid<List> Monad<List>]
+ ["D" dict])
+ [number]
+ [product])
+ [macro #+ Monad<Lux>]
+ [type]
+ (type ["TC" check]))
+ (luxc ["&" base]
+ ["&;" module]
+ ["&;" env]
+ (module ["&;" def])))
+
+(type: #export Pattern Void)
+
+(type: #export (Analysis' Analysis)
+ (#Bool Bool)
+ (#Nat Nat)
+ (#Int Int)
+ (#Deg Deg)
+ (#Real Real)
+ (#Char Char)
+ (#Text Text)
+ (#Variant Nat Bool Analysis)
+ #Unit
+ (#Tuple (List Analysis))
+ (#Call Analysis (List Analysis))
+ (#Case (List [Pattern Analysis]))
+ (#Function Scope Analysis)
+ (#Var Ref)
+ (#Def Ident)
+ (#Procedure Text (List Analysis))
+ )
+
+(type: #export #rec Analysis
+ (Meta [Type Cursor]
+ (Analysis' Analysis)))
+
+(def: (with-expected-type expected action)
+ (All [a] (-> Type (Lux a) (Lux a)))
+ (function [compiler]
+ (case (action (set@ #;expected (#;Some expected) compiler))
+ (#E;Success [compiler' output])
+ (let [old-expected (get@ #;expected compiler)]
+ (#E;Success [(set@ #;expected old-expected compiler')
+ output]))
+
+ (#E;Error error)
+ (#E;Error error))))
+
+(def: (analyse-typed-tuple analyse cursor members)
+ (-> (-> AST (Lux Analysis)) Cursor
+ (List AST)
+ (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (let [member-types (type;flatten-tuple expected)
+ num-types (list;size member-types)
+ num-members (list;size members)]
+ (cond (n.= num-types num-members)
+ (do @
+ [=tuple (: (Lux (List Analysis))
+ (mapM @
+ (function [[expected member]]
+ (with-expected-type expected
+ (analyse member)))
+ (list;zip2 member-types members)))]
+ (wrap [[expected cursor]
+ (#Tuple =tuple)]))
+
+ (n.< num-types num-members)
+ (do @
+ [#let [[head-ts tail-ts] (list;split (n.- +2 num-members)
+ member-types)]
+ =prevs (mapM @
+ (function [[expected member]]
+ (with-expected-type expected
+ (analyse member)))
+ (list;zip2 head-ts members))
+ =last (with-expected-type (type;tuple tail-ts)
+ (analyse (default (undefined)
+ (list;last members))))]
+ (wrap [[expected cursor]
+ (#Tuple (L/append =prevs (list =last)))]))
+
+ ## (n.> num-types num-members)
+ (do @
+ [#let [[head-xs tail-xs] (list;split (n.- +2 num-types)
+ members)]
+ =prevs (mapM @
+ (function [[expected member]]
+ (with-expected-type expected
+ (analyse member)))
+ (list;zip2 member-types head-xs))
+ =last (with-expected-type (default (undefined)
+ (list;last member-types))
+ (analyse-typed-tuple analyse cursor tail-xs))]
+ (wrap [[expected cursor]
+ (#Tuple (L/append =prevs (list =last)))]))
+ ))))
+
+(def: (within-type-env action)
+ (All [a] (-> (TC;Check a) (Lux a)))
+ (function [compiler]
+ (case (action (get@ #;type-context compiler))
+ (#E;Error error)
+ (#E;Error error)
+
+ (#E;Success [context' output])
+ (#E;Success [(set@ #;type-context context' compiler)
+ output]))))
+
+(def: get-type
+ (-> Analysis Type)
+ (|>. product;left
+ product;left))
+
+(def: (replace-type replacement analysis)
+ (-> Type Analysis Analysis)
+ (let [[[_type _cursor] _analysis] analysis]
+ (: Analysis
+ [[(: Type replacement)
+ (: Cursor _cursor)]
+ (: (Analysis' Analysis)
+ _analysis)])))
+
+(def: (clean-analysis type analysis)
+ (-> Type Analysis (Lux Analysis))
+ (case type
+ (#;VarT id)
+ (do Monad<Lux>
+ [=type (within-type-env
+ (TC;clean id type))]
+ (wrap (replace-type =type analysis)))
+
+ (#;ExT id)
+ (undefined)
+
+ _
+ (&;fail (format "Cannot clean type: " (%type type)))))
+
+(def: (with-unknown-type action)
+ (All [a] (-> (Lux Analysis) (Lux Analysis)))
+ (do Monad<Lux>
+ [[var-id var-type] (within-type-env
+ TC;create-var)
+ analysis (|> (wrap action)
+ (%> @
+ [(with-expected-type var-type)]
+ [(clean-analysis var-type)]))
+ _ (within-type-env
+ (TC;delete-var var-id))]
+ (wrap analysis)))
+
+(def: (tuple cursor members)
+ (-> Cursor (List Analysis) Analysis)
+ (let [tuple-type (type;tuple (L/map get-type members))]
+ [[tuple-type cursor]
+ (#Tuple members)]))
+
+(def: (realize expected)
+ (-> Type (TC;Check [(List Type) Type]))
+ (case expected
+ (#;NamedT [module name] _expected)
+ (realize _expected)
+
+ (#;UnivQ env body)
+ (do TC;Monad<Check>
+ [[var-id var-type] TC;create-var
+ [tail =expected] (realize (default (undefined)
+ (type;apply-type expected var-type)))]
+ (wrap [(list& var-type tail)
+ =expected]))
+
+ (#;ExQ env body)
+ (do TC;Monad<Check>
+ [[ex-id ex-type] TC;existential
+ [tail =expected] (realize (default (undefined)
+ (type;apply-type expected ex-type)))]
+ (wrap [(list& ex-type tail)
+ =expected]))
+
+ _
+ (:: TC;Monad<Check> wrap [(list) expected])))
+
+(def: (analyse-tuple analyse cursor members)
+ (-> (-> AST (Lux Analysis)) Cursor
+ (List AST)
+ (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (case expected
+ (#;ProdT _)
+ (analyse-typed-tuple analyse cursor members)
+
+ (#;VarT id)
+ (do @
+ [bound? (within-type-env
+ (TC;bound? id))]
+ (if bound?
+ (do @
+ [expected' (within-type-env
+ (TC;read-var id))
+ =tuple (with-expected-type expected'
+ (analyse-tuple analyse cursor members))]
+ (wrap (replace-type expected =tuple)))
+ (do @
+ [=members (mapM @ (<|. with-unknown-type
+ analyse)
+ members)
+ #let [=tuple (tuple cursor =members)]
+ _ (within-type-env
+ (TC;check expected (get-type =tuple)))]
+ (wrap (replace-type expected =tuple)))))
+
+ _
+ (if (type;quantified? expected)
+ (do @
+ [[bindings expected'] (within-type-env
+ (realize expected))
+ =tuple (with-expected-type expected'
+ (analyse-tuple analyse cursor members))
+ =tuple (foldM @ clean-analysis =tuple bindings)
+ _ (within-type-env
+ (TC;check expected (get-type =tuple)))]
+ (wrap (replace-type expected =tuple)))
+ (&;fail (format "Invalid type for tuple: " (%type expected))))
+ )))
+
+(def: (analyse-variant analyse cursor tag value)
+ (-> (-> AST (Lux Analysis)) Cursor
+ Nat AST
+ (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (case expected
+ (#;SumT _)
+ (let [flat (type;flatten-variant expected)
+ type-size (list;size flat)]
+ (if (n.< type-size tag)
+ (do @
+ [#let [last? (n.= tag (n.dec type-size))
+ variant-type (default (undefined)
+ (list;nth tag flat))]
+ =value (with-expected-type variant-type
+ (analyse value))]
+ (wrap [[expected cursor]
+ (#Variant tag last? =value)]))
+ (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n"
+ "Tag: " (%n tag) "\n"
+ "Type size: " (%n type-size) "\n"
+ "Type: " (%type expected) "\n"))))
+
+ _
+ (if (type;quantified? expected)
+ (do @
+ [[bindings expected'] (within-type-env
+ (realize expected))
+ =variant (with-expected-type expected'
+ (analyse-variant analyse cursor tag value))
+ =variant (foldM @ clean-analysis =variant bindings)
+ _ (within-type-env
+ (TC;check expected (get-type =variant)))]
+ (wrap (replace-type expected =variant)))
+ (&;fail (format "Invalid type for variant: " (%type expected)))))))
+
+(def: (analyse eval ast)
+ (-> (-> Type AST (Lux Top)) AST (Lux Analysis))
+ (do Monad<Lux>
+ []
+ (case ast
+ (^template [<ast-tag> <analysis-tag> <type>]
+ [cursor (<ast-tag> value)]
+ (do @
+ [expected macro;expected-type
+ _ (within-type-env
+ (TC;check expected <type>))]
+ (wrap [[<type> cursor]
+ (<analysis-tag> value)])))
+ ([#;BoolS #Bool Bool]
+ [#;NatS #Nat Nat]
+ [#;IntS #Int Int]
+ [#;DegS #Deg Deg]
+ [#;RealS #Real Real]
+ [#;CharS #Char Char]
+ [#;TextS #Text Text])
+
+ (^ [cursor (#;TupleS (list))])
+ (do @
+ [expected macro;expected-type
+ _ (within-type-env
+ (TC;check expected Unit))]
+ (wrap [[Unit cursor]
+ #Unit]))
+
+ (^ [cursor (#;TupleS (list singleton))])
+ (analyse eval singleton)
+
+ (^ [cursor (#;TupleS elems)])
+ (do @
+ [expected macro;expected-type]
+ (with-expected-type expected
+ (analyse-tuple (analyse eval) cursor elems)))
+
+ [cursor (#;SymbolS ["" local-name])]
+ (do @
+ [?local (&env;find local-name)]
+ (case ?local
+ (#;Some [actual index])
+ (do @
+ [expected macro;expected-type
+ _ (within-type-env
+ (TC;check expected actual))]
+ (wrap [[expected cursor]
+ (#Var index)]))
+
+ #;None
+ (do @
+ [this-module macro;current-module-name]
+ (analyse eval [cursor (#;SymbolS [this-module local-name])]))))
+
+ [cursor (#;SymbolS def-name)]
+ (do @
+ [expected macro;expected-type
+ actual (&def;find def-name)
+ _ (within-type-env
+ (TC;check expected actual))]
+ (wrap [[expected cursor]
+ (#Def def-name)]))
+
+ (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_check"])]
+ type
+ value))])
+ (do @
+ [expected macro;expected-type
+ actual (eval Type type)
+ _ (within-type-env
+ (TC;check expected actual))]
+ (with-expected-type actual
+ (analyse eval value)))
+
+ (^ [cursor (#;FormS (list [_ (#;SymbolS ["" "_lux_coerce"])]
+ type
+ value))])
+ (do @
+ [expected macro;expected-type
+ actual (eval Type type)
+ _ (within-type-env
+ (TC;check expected actual))
+ =value (with-expected-type Top
+ (analyse eval value))]
+ (wrap (replace-type actual =value)))
+
+ (^ [cursor (#;FormS (list [_ (#;NatS tag)]
+ value))])
+ (analyse-variant (analyse eval) cursor tag value)
+
+ _
+ (&;fail (format "Unrecognized syntax: " (%ast ast)))
+ )))
diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux
new file mode 100644
index 000000000..ce872e9da
--- /dev/null
+++ b/new-luxc/source/luxc/base.lux
@@ -0,0 +1,21 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data text/format)
+ [macro #+ Monad<Lux>]))
+
+(type: #export Path Text)
+
+(type: #export Mode
+ #Release
+ #Debug)
+
+(def: #export (fail message)
+ (All [a] (-> Text (Lux a)))
+ (do Monad<Lux>
+ [[file line col] macro;cursor
+ #let [location (format file
+ "," (|> line nat-to-int %i)
+ "," (|> col nat-to-int %i))]]
+ (macro;fail (format "@ " location
+ "\n" message))))
diff --git a/new-luxc/source/luxc/compiler.lux b/new-luxc/source/luxc/compiler.lux
new file mode 100644
index 000000000..205c62df0
--- /dev/null
+++ b/new-luxc/source/luxc/compiler.lux
@@ -0,0 +1,95 @@
+(;module:
+ lux
+ (lux (control monad)
+ [io #- run]
+ (data ["E" error]
+ [text "T/" Eq<Text>]
+ text/format)
+ [macro #+ Monad<Lux>])
+ (luxc ["&" base]
+ ["&;" io]
+ ["&;" module]
+ (compiler ["&&;" runtime]
+ ["&&;" statement])
+ ))
+
+(def: (compile ast)
+ (-> AST (Lux Unit))
+ (case ast
+ (^ [_ (#;FormS (list [_ (#;SymbolS ["" "_lux_def"])]
+ [_ (#;SymbolS ["" def-name])]
+ def-value
+ def-meta))])
+ (&&statement;compile-def def-name def-value def-meta)
+
+ (^ [_ (#;FormS (list [_ (#;SymbolS ["" "_lux_program"])]
+ [_ (#;SymbolS ["" prog-args])]
+ prog-body))])
+ (&&statement;compile-program prog-args prog-body)
+
+ _
+ (&;fail (format "Unrecognized statement: " (%ast ast)))))
+
+(def: (exhaust action)
+ (All [a] (-> (Lux a) (Lux Unit)))
+ (do Monad<Lux>
+ [result action]
+ (exhaust action)))
+
+(def: (compile-module source-dirs module-name compiler-state)
+ (-> (List &;Path) Text Compiler (IO (Error Compiler)))
+ (do Monad<IO>
+ [[file-name file-content] (&io;read-module source-dirs module-name)
+ #let [file-hash (T/hash file-content)]
+ #let [result (macro;run compiler-state
+ (do Monad<Lux>
+ [module-exists? (&module;exists? module-name)]
+ (if module-exists?
+ (&;fail (format "Cannot re-define a module: " module-name))
+ (wrap []))))]]
+ (case result
+ (#E;Success [compiler-state _])
+ (let [result (macro;run compiler-state
+ (do Monad<Lux>
+ [_ (&module;create module-name file-hash)
+ _ (&module;flag-active module-name)
+ _ (if (T/= "lux" module-name)
+ &&runtime;compile-runtime
+ (wrap []))
+ _ (exhaust
+ (do @
+ [ast parse]
+ (compile ast)))
+ _ (&module;flag-compiled module-name)]
+ (&module;generate-module file-hash module-name)))]
+ (case result
+ (#E;Success [compiler-state module-descriptor])
+ (do @
+ [_ (&io;write-module module-name module-descriptor)]
+ (wrap (#E;Success compiler-state)))
+
+ (#E;Error error)
+ (wrap (#E;Error error))))
+
+ (#E;Error error)
+ (wrap (#E;Error error)))))
+
+(def: (or-crash! action)
+ (All [a] (-> (IO (E;Error a)) (IO a)))
+ (do Monad<IO>
+ [result action]
+ (case result
+ (#E;Success output)
+ (wrap output)
+
+ (#E;Error error)
+ (error! (format "Compilation failed:\n" error)))))
+
+(def: #export (compile-program mode program target sources)
+ (-> &;Mode &;Path &;Path (List &;Path) (IO Unit))
+ (do Monad<IO>
+ [#let [compiler-state (init-compiler-state mode host-state)]
+ compiler-state (or-crash! (compile-module source-dirs "lux" compiler-state))
+ compiler-state (or-crash! (compile-module source-dirs program compiler-state))
+ #let [_ (log! "Compilation complete!")]]
+ (wrap [])))
diff --git a/new-luxc/source/luxc/compiler/base.jvm.lux b/new-luxc/source/luxc/compiler/base.jvm.lux
new file mode 100644
index 000000000..f5784319a
--- /dev/null
+++ b/new-luxc/source/luxc/compiler/base.jvm.lux
@@ -0,0 +1,30 @@
+(;module:
+ lux
+ (lux (control monad)
+ [io #- run]
+ (concurrency ["A" atom])
+ (data ["E" error]
+ [text]
+ text/format)
+ host)
+ (luxc ["&" base]))
+
+(jvm-import java.lang.Class)
+(jvm-import java.lang.ClassLoader)
+(jvm-import org.objectweb.asm.MethodVisitor)
+
+(type: Blob Byte-Array)
+
+(type: JVM-State
+ {#visitor (Maybe MethodVisitor)
+ #loader ClassLoader
+ #store (A;Atom (D;Dict Text Blob))
+ })
+
+(def: host-state
+ JVM-State
+ (let [store (A;new (D;new text;Hash<Text>))]
+ {#visitor #;None
+ #loader (memory-class-loader store)
+ #store store
+ }))
diff --git a/new-luxc/source/luxc/compiler/expr.jvm.lux b/new-luxc/source/luxc/compiler/expr.jvm.lux
new file mode 100644
index 000000000..6655abd5f
--- /dev/null
+++ b/new-luxc/source/luxc/compiler/expr.jvm.lux
@@ -0,0 +1,27 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data text/format)
+ [macro #+ Monad<Lux>])
+ (luxc ["&" base]
+ ["&;" module]
+ ["&;" env]
+ ["&;" analyser]
+ ["&;" synthesizer #+ Synthesis]))
+
+(type: #export JVM-Bytecode
+ Void)
+
+(type: Compiled
+ JVM-Bytecode)
+
+(def: (compile-synthesis synthesis)
+ (-> Synthesis Compiled)
+ (undefined))
+
+(def: #export (compile input)
+ (-> AST (Lux Compiled))
+ (|> input
+ &analyser;analyse
+ (Lux/map &synthesizer;synthesize)
+ (Lux/map compile-synthesis)))
diff --git a/new-luxc/source/luxc/compiler/runtime.jvm.lux b/new-luxc/source/luxc/compiler/runtime.jvm.lux
new file mode 100644
index 000000000..2d48b3617
--- /dev/null
+++ b/new-luxc/source/luxc/compiler/runtime.jvm.lux
@@ -0,0 +1,6 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data text/format))
+ (luxc ["&" base]))
+
diff --git a/new-luxc/source/luxc/compiler/statement.jvm.lux b/new-luxc/source/luxc/compiler/statement.jvm.lux
new file mode 100644
index 000000000..c4c23746e
--- /dev/null
+++ b/new-luxc/source/luxc/compiler/statement.jvm.lux
@@ -0,0 +1,26 @@
+(;module:
+ lux
+ (lux (control monad)
+ [io #- run]
+ (data ["E" error]
+ [text "T/" Eq<Text>]
+ text/format)
+ [macro #+ Monad<Lux>])
+ (luxc ["&" base]
+ ["&;" module]
+ ["&;" env]
+ (compiler ["&;" expr])))
+
+(def: (compile-def def-name def-value def-meta)
+ (-> Text AST AST (Lux Unit))
+ (do Monad<Lux>
+ [=def-value (&expr;compile def-value)
+ =def-meta (&expr;compile def-meta)]
+ (undefined)))
+
+(def: (compile-program prog-args prog-body)
+ (-> Text AST (Lux Unit))
+ (do Monad<Lux>
+ [=prog-body (&env;with-local [prog-args (type (List Text))]
+ (&expr;compile prog-body))]
+ (undefined)))
diff --git a/new-luxc/source/luxc/env.lux b/new-luxc/source/luxc/env.lux
new file mode 100644
index 000000000..be68f84e9
--- /dev/null
+++ b/new-luxc/source/luxc/env.lux
@@ -0,0 +1,106 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data [text "T/" Eq<Text>]
+ text/format
+ [maybe #+ Monad<Maybe> "Maybe/" Monad<Maybe>]
+ [product]
+ (coll [list "L/" Fold<List> Monoid<List>])))
+ (luxc ["&" base]))
+
+(type: Captured (Bindings Text [Type Ref]))
+
+(def: (pl::contains? key mappings)
+ (All [a] (-> Text (List [Text a]) Bool))
+ (case mappings
+ #;Nil
+ false
+
+ (#;Cons [k v] mappings')
+ (or (T/= key k)
+ (pl::contains? key mappings'))))
+
+(def: (pl::get key mappings)
+ (All [a] (-> Text (List [Text a]) (Maybe a)))
+ (case mappings
+ #;Nil
+ #;None
+
+ (#;Cons [k v] mappings')
+ (if (T/= key k)
+ (#;Some v)
+ (pl::get key mappings'))))
+
+(def: (pl::put key value mappings)
+ (All [a] (-> Text a (List [Text a]) (List [Text a])))
+ (case mappings
+ #;Nil
+ (list [key value])
+
+ (#;Cons [k v] mappings')
+ (if (T/= key k)
+ (#;Cons [key value] mappings')
+ (#;Cons [k v]
+ (pl::put key value mappings')))))
+
+(do-template [<slot> <is> <get> <then>]
+ [(def: (<is> name scope)
+ (-> Text Scope Bool)
+ (|> scope
+ (get@ [<slot> #;mappings])
+ (pl::contains? name)))
+
+ (def: (<get> name scope)
+ (-> Text Scope (Maybe [Type Ref]))
+ (|> scope
+ (get@ [<slot> #;mappings])
+ (pl::get name)
+ (Maybe/map (function [[type value]]
+ [type (<then> value)]))))]
+
+ [#;locals is-local? get-local #;Local]
+ [#;captured is-captured? get-captured id]
+ )
+
+(def: (is-ref? name scope)
+ (-> Text Scope Bool)
+ (or (is-local? name scope)
+ (is-captured? name scope)))
+
+(def: (get-ref name scope)
+ (-> Text Scope (Maybe [Type Ref]))
+ (case (get-local name scope)
+ (#;Some type)
+ (#;Some type)
+
+ _
+ (get-captured name scope)))
+
+(def: #export (find name)
+ (-> Text (Lux (Maybe [Type Ref])))
+ (function [compiler]
+ (let [[inner outer] (|> compiler
+ (get@ #;scopes)
+ (list;split-with (|>. (is-ref? name) not)))]
+ (case outer
+ #;Nil
+ (#;Right [compiler #;None])
+
+ (#;Cons top-outer _)
+ (let [[ref-type init-ref] (default (undefined)
+ (get-ref name top-outer))
+ [ref inner'] (L/fold (: (-> Scope [Ref (List Scope)] [Ref (List Scope)])
+ (function [scope [ref inner]]
+ [(#;Captured (get@ [#;captured #;counter] scope))
+ (#;Cons (update@ #;captured
+ (: (-> Captured Captured)
+ (|>. (update@ #;counter n.inc)
+ (update@ #;mappings (pl::put name [ref-type ref]))))
+ scope)
+ inner)]))
+ [init-ref #;Nil]
+ (list;reverse inner))
+ scopes (L/append inner' outer)]
+ (#;Right [(set@ #;scopes scopes compiler)
+ (#;Some [ref-type ref])]))
+ ))))
diff --git a/new-luxc/source/luxc/io.jvm.lux b/new-luxc/source/luxc/io.jvm.lux
new file mode 100644
index 000000000..ab62b8f43
--- /dev/null
+++ b/new-luxc/source/luxc/io.jvm.lux
@@ -0,0 +1,93 @@
+(;module:
+ lux
+ (lux (control monad)
+ [io #- run]
+ (concurrency ["P" promise])
+ (data ["E" error]
+ [text "T/" Eq<Text>]
+ text/format)
+ [macro]
+ host)
+ (luxc ["&" base]))
+
+(jvm-import java.io.File
+ (new [String String])
+ (exists [] #io #try boolean))
+
+(jvm-import java.io.Reader
+ (close [] #io #try void))
+
+(jvm-import java.io.FileReader
+ (new [File]))
+
+(jvm-import java.io.BufferedReader
+ (new [Reader])
+ (readLine [] #io #try #? String))
+
+(def: host-extension Text ".jvm")
+
+(def: (find-in-sources path source-dirs)
+ (-> &;Path (List &;Path) (P;Promise (Maybe File)))
+ (loop [source-dirs source-dirs]
+ (case source-dirs
+ #;Nil
+ (:: P;Monad<Promise> wrap #;None)
+
+ (#;Cons dir source-dirs')
+ (do P;Monad<Promise>
+ [#let [file (File.new [dir path])]
+ ?? (P;future (File.exists [] file))]
+ (case ??
+ (#;Right true)
+ (wrap (#;Some file))
+
+ _
+ (recur source-dirs'))))))
+
+(def: (read-source-code lux-file)
+ (-> File (P;Promise (E;Error Text)))
+ (P;future
+ (let [reader (|> lux-file FileReader.new BufferedReader.new)]
+ (loop [total ""]
+ (do Monad<IO>
+ [?line (BufferedReader.readLine [] reader)]
+ (case ?line
+ (#E;Error error)
+ (wrap (#E;Error error))
+
+ (#E;Success #;None)
+ (wrap (#E;Success total))
+
+ (#E;Success (#;Some line))
+ (if (T/= "" total)
+ (recur line)
+ (recur (format total "\n" line)))))))))
+
+(def: #export (read-module source-dirs module-name)
+ (-> (List &;Path) Text (P;Promise (E;Error [&;Path Text])))
+ (let [host-path (format module-name host-extension ".lux")
+ lux-path (format module-name ".lux")]
+ (let% [<tries> (do-template [<path>]
+ [(do P;Monad<Promise>
+ [?file (find-in-sources <path> source-dirs)])
+ (case ?file
+ (#;Some file)
+ (do @
+ [?code (read-source-code file)]
+ (case ?code
+ (#E;Error error)
+ (wrap (#E;Error error))
+
+ (#E;Success code)
+ (wrap (#E;Success [<path> code]))))
+
+ #;None)]
+
+ [host-path]
+ [lux-path])]
+ (<| <tries>
+ (wrap (#E;Error (format "Module cannot be found: " module-name)))))))
+
+(def: #export (write-module module-name module-descriptor)
+ (-> Text Text (P;Promise Unit))
+ (undefined))
diff --git a/new-luxc/source/luxc/module.lux b/new-luxc/source/luxc/module.lux
new file mode 100644
index 000000000..2d48b3617
--- /dev/null
+++ b/new-luxc/source/luxc/module.lux
@@ -0,0 +1,6 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data text/format))
+ (luxc ["&" base]))
+
diff --git a/new-luxc/source/luxc/module/def.lux b/new-luxc/source/luxc/module/def.lux
new file mode 100644
index 000000000..2d48b3617
--- /dev/null
+++ b/new-luxc/source/luxc/module/def.lux
@@ -0,0 +1,6 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data text/format))
+ (luxc ["&" base]))
+
diff --git a/new-luxc/source/luxc/module/descriptor/annotation.lux b/new-luxc/source/luxc/module/descriptor/annotation.lux
new file mode 100644
index 000000000..9a687e02a
--- /dev/null
+++ b/new-luxc/source/luxc/module/descriptor/annotation.lux
@@ -0,0 +1,83 @@
+(;module:
+ lux
+ (lux (control codec
+ monad)
+ (data [text]
+ (text format
+ ["l" lexer "l/" Monad<Lexer>])
+ [char]
+ [number]
+ error
+ (coll [list "L/" Functor<List>])))
+ ["&" ../common]
+ [luxc ["&;" parser]])
+
+(def: dummy-cursor Cursor ["" +0 +0])
+
+(do-template [<name> <code>]
+ [(def: <name> &;Signal <code>)]
+
+ [ident-signal "@"]
+ [bool-signal "B"]
+ [nat-signal "N"]
+ [int-signal "I"]
+ [deg-signal "D"]
+ [real-signal "R"]
+ [char-signal "C"]
+ [text-signal "T"]
+ [list-signal "%"]
+ [dict-signal "#"]
+ )
+
+(def: (encode-ident [module name])
+ (-> Ident Text)
+ (format ident-signal
+ module &;ident-separator name
+ &;stop-signal))
+
+(def: (encode-text value)
+ (-> Text Text)
+ (format text-signal
+ (%t value)
+ &;stop-signal))
+
+(def: (encode-ann-value value)
+ (-> Ann-Value Text)
+ (case value
+ (^template [<tag> <signal> <encoder>]
+ (<tag> value)
+ (format <signal>
+ (<encoder> value)
+ &;stop-signal))
+ ([#;BoolA bool-signal %b]
+ [#;NatA nat-signal %n]
+ [#;IntA int-signal %i]
+ [#;DegA deg-signal %d]
+ [#;RealA real-signal %r]
+ [#;CharA char-signal %c]
+ [#;TextA text-signal %t]
+ [#;IdentA ident-signal %ident]
+ [#;ListA list-signal (&;encode-list encode-ann-value)]
+ [#;DictA dict-signal (&;encode-list (function [[k v]]
+ (format (encode-text k)
+ (encode-ann-value v))))])))
+
+(def: ann-value-decoder
+ (l;Lexer Ann-Value)
+ (let% [<simple> (do-template [<tag> <lexer> <signal>]
+ [(do l;Monad<Lexer>
+ [])])]
+ ($_ l;either
+ <simple>
+ (|> ... (l;after (l;text bool-signal)))
+ )))
+
+(def: encode-anns
+ (-> Anns Text)
+ (&;encode-list (function [[ident value]]
+ (format (encode-ident ident)
+ (encode-ann-value value)))))
+
+(struct: #export _ (Codec Text Anns)
+ (def: encode encode-anns)
+ (def: decode decode-anns))
diff --git a/new-luxc/source/luxc/module/descriptor/common.lux b/new-luxc/source/luxc/module/descriptor/common.lux
new file mode 100644
index 000000000..60a313115
--- /dev/null
+++ b/new-luxc/source/luxc/module/descriptor/common.lux
@@ -0,0 +1,38 @@
+(;module:
+ lux
+ (lux (data [text]
+ (text format
+ ["l" lexer "l/" Monad<Lexer>])
+ [char]
+ (coll [list "L/" Functor<List>]))))
+
+(type: #export Signal Text)
+
+(do-template [<name> <code>]
+ [(def: #export <name> Signal (|> <code> char;char char;as-text))]
+
+ [cons-signal +5]
+ [nil-signal +6]
+ [stop-signal +7]
+ )
+
+(do-template [<name> <code>]
+ [(def: #export <name> Signal <code>)]
+
+ [ident-separator ";"]
+ )
+
+(def: #export (encode-list encode-elem types)
+ (All [a] (-> (-> a Text) (List a) Text))
+ (format (|> (L/map encode-elem types)
+ (text;join-with cons-signal))
+ nil-signal))
+
+(def: #export (decode-list decode-elem)
+ (All [a] (-> (l;Lexer a) (l;Lexer (List a))))
+ (l;alt (<| (l;after (l;text nil-signal))
+ (l/wrap []))
+ (<| (l;seq decode-elem)
+ (l;after (l;text cons-signal))
+ (decode-list decode-elem))))
+
diff --git a/new-luxc/source/luxc/module/descriptor/type.lux b/new-luxc/source/luxc/module/descriptor/type.lux
new file mode 100644
index 000000000..c4078ec0e
--- /dev/null
+++ b/new-luxc/source/luxc/module/descriptor/type.lux
@@ -0,0 +1,145 @@
+(;module:
+ lux
+ (lux (control codec
+ monad)
+ (data [text]
+ (text format
+ ["l" lexer "l/" Monad<Lexer>])
+ [char]
+ [number]
+ error
+ (coll [list "L/" Functor<List>]))
+ [type "Type/" Eq<Type>])
+ ["&" ../common])
+
+(do-template [<name> <code>]
+ [(def: <name> &;Signal <code>)]
+
+ [type-signal "T"]
+ [host-signal "^"]
+ [void-signal "0"]
+ [unit-signal "1"]
+ [product-signal "*"]
+ [sum-signal "+"]
+ [function-signal ">"]
+ [application-signal "%"]
+ [uq-signal "U"]
+ [eq-signal "E"]
+ [bound-signal "$"]
+ [ex-signal "!"]
+ [var-signal "?"]
+ [named-signal "@"]
+ )
+
+(def: (encode-type type)
+ (-> Type Text)
+ (if (or (is Type type)
+ (Type/= Type type))
+ type-signal
+ (case type
+ (#;HostT name params)
+ (format host-signal name &;stop-signal (&;encode-list encode-type params))
+
+ #;VoidT
+ void-signal
+
+ #;UnitT
+ unit-signal
+
+ (^template [<tag> <prefix>]
+ (<tag> left right)
+ (format <prefix> (encode-type left) (encode-type right)))
+ ([#;ProdT product-signal]
+ [#;SumT sum-signal]
+ [#;FunctionT function-signal]
+ [#;AppT application-signal])
+
+
+ (^template [<tag> <prefix>]
+ (<tag> env body)
+ (format <prefix> (&;encode-list encode-type env) (encode-type body)))
+ ([#;UnivQ uq-signal]
+ [#;ExQ eq-signal])
+
+ (^template [<tag> <prefix>]
+ (<tag> idx)
+ (format <prefix> (%i (nat-to-int idx)) &;stop-signal))
+ ([#;BoundT bound-signal]
+ [#;ExT ex-signal]
+ [#;VarT var-signal])
+
+ (#;NamedT [module name] type*)
+ (format named-signal module &;ident-separator name &;stop-signal (encode-type type*))
+ )))
+
+(def: type-decoder
+ (l;Lexer Type)
+ (l;rec
+ (function [type-decoder]
+ (let% [<simple> (do-template [<type> <signal>]
+ [(|> (l/wrap <type>) (l;after (l;text <signal>)))]
+
+ [Type type-signal]
+ [#;VoidT void-signal]
+ [#;UnitT unit-signal])
+ <combinators> (do-template [<tag> <prefix>]
+ [(do l;Monad<Lexer>
+ [_ (l;text <prefix>)
+ left type-decoder
+ right type-decoder]
+ (wrap (<tag> left right)))]
+
+ [#;ProdT product-signal]
+ [#;SumT sum-signal]
+ [#;FunctionT function-signal]
+ [#;AppT application-signal])
+ <abstractions> (do-template [<tag> <prefix>]
+ [(do l;Monad<Lexer>
+ [_ (l;text <prefix>)
+ env (&;decode-list type-decoder)
+ body type-decoder]
+ (wrap (<tag> env body)))]
+
+ [#;UnivQ uq-signal]
+ [#;ExQ eq-signal])
+ <wildcards> (do-template [<tag> <prefix>]
+ [(do l;Monad<Lexer>
+ [_ (l;text <prefix>)
+ id (l;codec number;Codec<Text,Int>
+ (l;some' l;digit))
+ _ (l;text &;stop-signal)]
+ (wrap (<tag> (int-to-nat id))))]
+
+ [#;BoundT bound-signal]
+ [#;ExT ex-signal]
+ [#;VarT var-signal])]
+ ($_ l;either
+ (do l;Monad<Lexer>
+ [_ (l;text host-signal)
+ name (l;many' (l;none-of &;stop-signal))
+ _ (l;text &;stop-signal)
+ params (&;decode-list type-decoder)]
+ (wrap (#;HostT name params)))
+ <simple>
+ <combinators>
+ <abstractions>
+ <wildcards>
+ (do l;Monad<Lexer>
+ [_ (l;text named-signal)
+ module (l;some' (l;none-of &;ident-separator))
+ _ (l;text &;ident-separator)
+ name (l;many' (l;none-of &;stop-signal))
+ _ (l;text &;stop-signal)
+ unnamed type-decoder]
+ (wrap (#;NamedT [module name] unnamed)))
+ )))))
+
+(def: (decode-type input)
+ (-> Text (Error Type))
+ (|> type-decoder
+ (l;before l;end)
+ (l;run input)))
+
+(struct: #export _ (Codec Text Type)
+ (def: encode encode-type)
+ (def: decode decode-type))
diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux
index cac3cb862..4ca97a80a 100644
--- a/new-luxc/source/luxc/parser.lux
+++ b/new-luxc/source/luxc/parser.lux
@@ -210,7 +210,7 @@
## specific shapes and then use decoders already present in the
## standard library to actually produce the values from the literals.
(do-template [<name> <tag> <lexer> <codec>]
- [(def: (<name> where)
+ [(def: #export (<name> where)
(-> Cursor (Lexer [AST Cursor]))
(do Monad<Lexer>
[chunk <lexer>]
@@ -223,20 +223,20 @@
(|> where
(update@ #;column (n.+ (text;size chunk))))]))))]
- [bool^ #;BoolS
+ [parse-bool #;BoolS
(l;either (l;text "true") (l;text "false"))
bool;Codec<Text,Bool>]
- [nat^ #;NatS
+ [parse-nat #;NatS
(l;seq' (l;text "+") (l;many' l;digit))
number;Codec<Text,Nat>]
- [int^ #;IntS
+ [parse-int #;IntS
(l;seq' (l;default "" (l;text "-"))
(l;many' l;digit))
number;Codec<Text,Int>]
- [real^ #;RealS
+ [parse-real #;RealS
($_ l;seq'
(l;default "" (l;text "-"))
(l;many' l;digit)
@@ -244,7 +244,7 @@
(l;many' l;digit))
number;Codec<Text,Real>]
- [deg^ #;DegS
+ [parse-deg #;DegS
(l;seq' (l;text ".")
(l;many' l;digit))
number;Codec<Text,Deg>]
@@ -252,7 +252,7 @@
## This parser doesn't delegate the work of producing the value to a
## codec, since the raw-char^ parser already takes care of that magic.
-(def: (char^ where)
+(def: #export (parse-char where)
(-> Cursor (Lexer [AST Cursor]))
(do Monad<Lexer>
[[chunk value] (l;enclosed ["#\"" "\""]
@@ -263,7 +263,7 @@
## This parser looks so complex because text in Lux can be multi-line
## and there are rules regarding how this is handled.
-(def: (text^ where)
+(def: #export (parse-text where)
(-> Cursor (Lexer [AST Cursor]))
(do Monad<Lexer>
[## Lux text "is delimited by double-quotes", as usual in most
@@ -354,7 +354,7 @@
## delimiters involved.
## They may have an arbitrary number of arbitrary AST nodes as elements.
(do-template [<name> <tag> <open> <close>]
- [(def: (<name> where ast^)
+ [(def: (<name> where parse-ast)
(-> Cursor
(-> Cursor (Lexer [AST Cursor]))
(Lexer [AST Cursor]))
@@ -366,7 +366,7 @@
(l;either (do @
[## Must update the cursor as I
## go along, to keep things accurate.
- [elem where'] (ast^ where)]
+ [elem where'] (parse-ast where)]
(recur (V;add elem elems)
where'))
(do @
@@ -381,8 +381,8 @@
(wrap [[where (<tag> elems)]
where'])))]
- [form^ #;FormS "(" ")"]
- [tuple^ #;TupleS "[" "]"]
+ [parse-form #;FormS "(" ")"]
+ [parse-tuple #;TupleS "[" "]"]
)
## Records are almost (syntactically) the same as forms and tuples,
@@ -394,7 +394,7 @@
## AST node, however, record AST nodes allow any AST node to occupy
## this position, since it may be useful when processing AST syntax in
## macros.
-(def: (record^ where ast^)
+(def: (parse-record where parse-ast)
(-> Cursor
(-> Cursor (Lexer [AST Cursor]))
(Lexer [AST Cursor]))
@@ -404,8 +404,8 @@
V;empty)
where where]
(l;either (do @
- [[key where'] (ast^ where)
- [val where'] (ast^ where')]
+ [[key where'] (parse-ast where)
+ [val where'] (parse-ast where')]
(recur (V;add [key val] elems)
where'))
(do @
@@ -505,7 +505,7 @@
## provide the compiler with information related to data-structure
## construction and de-structuring (during pattern-matching).
(do-template [<name> <tag> <lexer> <extra>]
- [(def: (<name> where)
+ [(def: #export (<name> where)
(-> Cursor (Lexer [AST Cursor]))
(do Monad<Lexer>
[[value length] <lexer>]
@@ -513,29 +513,29 @@
(|> where
(update@ #;column (|>. ($_ n.+ <extra> length))))])))]
- [symbol^ #;SymbolS ident^ +0]
- [tag^ #;TagS (l;after (l;char #"#") ident^) +1]
+ [parse-symbol #;SymbolS ident^ +0]
+ [parse-tag #;TagS (l;after (l;char #"#") ident^) +1]
)
-(def: (ast^ where)
+(def: (parse-ast where)
(-> Cursor (Lexer [AST Cursor]))
(do Monad<Lexer>
[where (left-padding^ where)]
($_ l;either
- (form^ where ast^)
- (tuple^ where ast^)
- (record^ where ast^)
- (bool^ where)
- (nat^ where)
- (real^ where)
- (int^ where)
- (deg^ where)
- (symbol^ where)
- (tag^ where)
- (char^ where)
- (text^ where)
+ (parse-form where parse-ast)
+ (parse-tuple where parse-ast)
+ (parse-record where parse-ast)
+ (parse-bool where)
+ (parse-nat where)
+ (parse-real where)
+ (parse-int where)
+ (parse-deg where)
+ (parse-symbol where)
+ (parse-tag where)
+ (parse-char where)
+ (parse-text where)
)))
(def: #export (parse where code)
(-> Cursor Text (Error [Text AST Cursor]))
- (l;run' code (ast^ where)))
+ (l;run' code (parse-ast where)))
diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux
new file mode 100644
index 000000000..682bbe3ec
--- /dev/null
+++ b/new-luxc/source/luxc/synthesizer.lux
@@ -0,0 +1,14 @@
+(;module:
+ lux
+ (lux (control monad)
+ (data text/format)
+ [macro #+ Monad<Lux>])
+ (luxc ["&" base]
+ ["&;" analyser #+ Analysis]))
+
+(type: #export Synthesis
+ Unit)
+
+(def: #export (synthesize analysis)
+ (-> Analysis Synthesis)
+ (undefined))
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
index b1619e830..07f21962b 100644
--- a/new-luxc/source/program.lux
+++ b/new-luxc/source/program.lux
@@ -3,27 +3,16 @@
(lux (control monad)
[io #- run]
[cli #+ program: CLI Monad<CLI>])
- (luxc ["&;" parser]))
-
-(type: Path Text)
-
-(type: Platform
- #JVM
- #JS)
-
-(type: Mode
- #Release
- #Debug)
+ (luxc ["&" base]
+ ["&;" parser]
+ ["&;" compiler]
+ (module (descriptor ["&;" type]))
+ ))
(type: Compilation
- {#mode Mode
- #platform Platform
- #program Path
- #target Path})
-
-(type: Inputs
- {#resources (List Path)
- #sources (List Path)})
+ {#mode &;Mode
+ #program &;Path
+ #target &;Path})
(def: (marker tokens)
(-> (List Text) (CLI Unit))
@@ -36,37 +25,23 @@
cli;any))
(def: mode^
- (CLI Mode)
+ (CLI &;Mode)
($_ cli;alt
(marker (list "release"))
(marker (list "debug"))))
-(def: platform^
- (CLI Platform)
- ($_ cli;alt
- (marker (list "jvm"))
- (marker (list "js"))))
-
(def: compilation^
(CLI Compilation)
($_ cli;seq
mode^
- platform^
(tagged (list "-p" "--program"))
(tagged (list "-t" "--target"))))
-(def: inputs^
- (CLI Inputs)
- ($_ cli;seq
- (cli;some (tagged (list "-r" "--resource")))
- (cli;some (tagged (list "-s" "--source")))))
-
-(program: ([[command [resources sources]]
- (cli;seq (cli;opt compilation^)
- inputs^)])
+(program: ([command (cli;opt compilation^)]
+ [sources (cli;some (tagged (list "-s" "--source")))])
(case command
#;None
(io (log! "Hello, REPL!"))
- (#;Some [mode platform program target])
- (io (log! "Hello, compilation!"))))
+ (#;Some [mode program target])
+ (&compiler;compile-program mode program target sources)))