diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/analyser.lux | 368 | ||||
| -rw-r--r-- | new-luxc/source/luxc/base.lux | 21 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler.lux | 95 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler/base.jvm.lux | 30 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler/expr.jvm.lux | 27 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler/runtime.jvm.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/compiler/statement.jvm.lux | 26 | ||||
| -rw-r--r-- | new-luxc/source/luxc/env.lux | 106 | ||||
| -rw-r--r-- | new-luxc/source/luxc/io.jvm.lux | 93 | ||||
| -rw-r--r-- | new-luxc/source/luxc/module.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/module/def.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/module/descriptor/annotation.lux | 83 | ||||
| -rw-r--r-- | new-luxc/source/luxc/module/descriptor/common.lux | 38 | ||||
| -rw-r--r-- | new-luxc/source/luxc/module/descriptor/type.lux | 145 | ||||
| -rw-r--r-- | new-luxc/source/luxc/parser.lux | 64 | ||||
| -rw-r--r-- | new-luxc/source/luxc/synthesizer.lux | 14 |
16 files changed, 1096 insertions, 32 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)) |