diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/analyser.lux | 21 | ||||
| -rw-r--r-- | new-luxc/source/luxc/analyser/structure.lux | 24 | ||||
| -rw-r--r-- | new-luxc/source/luxc/base.lux | 53 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator.lux | 181 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/common.jvm.lux | 56 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/eval.jvm.lux | 11 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/expr.jvm.lux | 6 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/host/jvm.lux | 4 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/reference.jvm.lux | 12 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/runtime.jvm.lux | 8 | ||||
| -rw-r--r-- | new-luxc/source/luxc/generator/statement.jvm.lux | 97 | ||||
| -rw-r--r-- | new-luxc/source/luxc/host.jvm.lux | 11 | ||||
| -rw-r--r-- | new-luxc/source/luxc/io.jvm.lux | 169 | ||||
| -rw-r--r-- | new-luxc/source/luxc/parser.lux | 51 | ||||
| -rw-r--r-- | new-luxc/source/luxc/synthesizer.lux | 14 |
15 files changed, 451 insertions, 267 deletions
diff --git a/new-luxc/source/luxc/analyser.lux b/new-luxc/source/luxc/analyser.lux index 97312b805..b10f29369 100644 --- a/new-luxc/source/luxc/analyser.lux +++ b/new-luxc/source/luxc/analyser.lux @@ -67,28 +67,28 @@ (#;Symbol reference) (&&reference;analyse-reference reference) - (^ (#;Form (list [_ (#;Symbol ["" "_lux_function"])] + (^ (#;Form (list [_ (#;Text "lux function")] [_ (#;Symbol ["" func-name])] [_ (#;Symbol ["" arg-name])] body))) (&&function;analyse-function analyse func-name arg-name body) - (^template [<proc> <analyser>] - (^ (#;Form (list [_ (#;Symbol ["" <proc>])] type value))) + (^template [<special> <analyser>] + (^ (#;Form (list [_ (#;Text <special>)] type value))) (<analyser> analyse eval type value)) - (["_lux_check" &&type;analyse-check] - ["_lux_coerce" &&type;analyse-coerce]) + (["lux check" &&type;analyse-check] + ["lux coerce" &&type;analyse-coerce]) - (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) - (&&procedure;analyse-procedure analyse proc-name proc-args) - - (^ (#;Form (list& [_ (#;Symbol ["" "_lux_case"])] + (^ (#;Form (list& [_ (#;Text "lux case")] input branches))) (do meta;Monad<Meta> [paired (to-branches branches)] (&&case;analyse-case analyse input paired)) + (^ (#;Form (list& [_ (#;Text proc-name)] proc-args))) + (&&procedure;analyse-procedure analyse proc-name proc-args) + (^template [<tag> <analyser>] (^ (#;Form (list& [_ (<tag> tag)] values))) @@ -101,6 +101,9 @@ ([#;Nat &&structure;analyse-sum] [#;Tag &&structure;analyse-tagged-sum]) + (#;Tag tag) + (&&structure;analyse-tagged-sum analyse tag (' [])) + (^ (#;Form (list& func args))) (do meta;Monad<Meta> [[funcT =func] (&&common;with-unknown-type diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux index 3bcc04d7e..8c1f7118c 100644 --- a/new-luxc/source/luxc/analyser/structure.lux +++ b/new-luxc/source/luxc/analyser/structure.lux @@ -206,19 +206,25 @@ (&;fail "") )))) -(def: #export (analyse-tagged-sum analyse tag value) +(def: #export (analyse-tagged-sum analyse tag valueC) (-> &;Analyser Ident Code (Meta la;Analysis)) (do meta;Monad<Meta> [tag (meta;normalize tag) [idx group variantT] (meta;resolve-tag tag) - #let [case-size (list;size group)] - inferenceT (&inference;variant-inference-type idx case-size variantT) - [inferredT valueA+] (&inference;apply-function analyse inferenceT (list value)) - expectedT meta;expected-type - _ (&;with-type-env - (tc;check expectedT inferredT)) - temp &scope;next-local] - (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume))))) + expectedT meta;expected-type] + (case expectedT + (#;Var _) + (do @ + [#let [case-size (list;size group)] + inferenceT (&inference;variant-inference-type idx case-size variantT) + [inferredT valueA+] (&inference;apply-function analyse inferenceT (list valueC)) + _ (&;with-type-env + (tc;check expectedT inferredT)) + temp &scope;next-local] + (wrap (la;sum idx case-size temp (|> valueA+ list;head maybe;assume)))) + + _ + (analyse-sum analyse idx valueC)))) ## There cannot be any ambiguity or improper syntax when analysing ## records, so they must be normalized for further analysis. diff --git a/new-luxc/source/luxc/base.lux b/new-luxc/source/luxc/base.lux index 4c6202db1..28b5437e9 100644 --- a/new-luxc/source/luxc/base.lux +++ b/new-luxc/source/luxc/base.lux @@ -2,10 +2,12 @@ lux (lux (control [monad #+ do] ["ex" exception #+ exception:]) - (data [text "text/" Eq<Text>] - text/format + (data [maybe] [product] - ["e" error]) + ["e" error] + [text "text/" Eq<Text>] + text/format + (coll [list])) [meta] (meta (type ["tc" check]))) (luxc (lang ["la" analysis]))) @@ -16,8 +18,6 @@ (type: #export Analyser (-> Code (Meta la;Analysis))) -(type: #export Path Text) - (def: #export version Text "0.6.0") (def: #export (fail message) @@ -115,7 +115,7 @@ (#;Cons [k' v'] (pl-update key f table'))))) (def: #export (with-source-code source action) - (All [a] (-> [Cursor Text] (Meta a) (Meta a))) + (All [a] (-> Source (Meta a) (Meta a))) (function [compiler] (let [old-source (get@ #;source compiler)] (case (action (set@ #;source source compiler)) @@ -145,7 +145,7 @@ (def: fresh-scope Scope - {#;name (list) + {#;name (list "lux") #;inner +0 #;locals fresh-bindings #;captured fresh-bindings}) @@ -179,3 +179,42 @@ (#e;Error error) (#e;Error error)))))) + +(def: (normalize-char char) + (-> Nat Text) + (case char + (^ (char "*")) "_ASTER_" + (^ (char "+")) "_PLUS_" + (^ (char "-")) "_DASH_" + (^ (char "/")) "_SLASH_" + (^ (char "\\")) "_BSLASH_" + (^ (char "_")) "_UNDERS_" + (^ (char "%")) "_PERCENT_" + (^ (char "$")) "_DOLLAR_" + (^ (char "'")) "_QUOTE_" + (^ (char "`")) "_BQUOTE_" + (^ (char "@")) "_AT_" + (^ (char "^")) "_CARET_" + (^ (char "&")) "_AMPERS_" + (^ (char "=")) "_EQ_" + (^ (char "!")) "_BANG_" + (^ (char "?")) "_QM_" + (^ (char ":")) "_COLON_" + (^ (char ".")) "_PERIOD_" + (^ (char ",")) "_COMMA_" + (^ (char "<")) "_LT_" + (^ (char ">")) "_GT_" + (^ (char "~")) "_TILDE_" + (^ (char "|")) "_PIPE_" + _ + (text;from-code char))) + +(def: underflow Nat (n.dec +0)) + +(def: #export (normalize-name name) + (-> Text Text) + (loop [idx (n.dec (text;size name)) + output ""] + (if (n.= underflow idx) + output + (recur (n.dec idx) (format (|> (text;nth idx name) maybe;assume normalize-char) output))))) diff --git a/new-luxc/source/luxc/generator.lux b/new-luxc/source/luxc/generator.lux index 107b2f3f9..f64ca333e 100644 --- a/new-luxc/source/luxc/generator.lux +++ b/new-luxc/source/luxc/generator.lux @@ -1,52 +1,83 @@ (;module: lux - (lux (control monad) - (concurrency ["A" atom] - ["P" promise]) + (lux (control [monad #+ do]) + (concurrency ["T" task]) (data ["e" error] - [text "T/" Hash<Text>] + [text "text/" Hash<Text>] text/format - (coll ["D" dict] - [array])) - [meta #+ Monad<Meta>] + (coll [dict])) + [meta] [host] - [io]) + [io] + (world [file #+ File])) (luxc ["&" base] ["&;" io] ["&;" module] ["&;" parser] ["&;" host] - (compiler ["&&;" runtime] - ["&&;" statement] - ["&&;" common]) + ["&;" analyser] + ["&;" analyser/common] + ["&;" synthesizer] + ["&;" eval] + (generator ["&&;" runtime] + ["&&;" statement] + ["&&;" common] + ["&&;" expr] + ["&&;" eval]) )) -(def: (compile ast) +(def: analyse + (&;Analyser) + (&analyser;analyser &eval;eval)) + +(def: (generate code) (-> Code (Meta Unit)) - (case ast - (^ [_ (#;Form (list [_ (#;Symbol ["" "_lux_def"])] + (case code + (^ [_ (#;Form (list [_ (#;Text "lux def")] [_ (#;Symbol ["" def-name])] - def-value - def-meta))]) - (&&statement;compile-def def-name def-value def-meta) - - (^ [_ (#;Form (list [_ (#;Symbol ["" "_lux_program"])] - [_ (#;Symbol ["" prog-args])] - prog-body))]) - (&&statement;compile-program prog-args prog-body) + valueC + metaC))]) + (do meta;Monad<Meta> + [[_ metaA] (&;with-scope + (&;with-expected-type Code + (analyse metaC))) + metaI (&&expr;generate (&synthesizer;synthesize metaA)) + metaV (&&eval;eval metaI) + [_ valueT valueA] (&;with-scope + (if (meta;type? (:! Code metaV)) + (&;with-expected-type Type + (do @ + [valueA (analyse valueC)] + (wrap [Type valueA]))) + (&analyser/common;with-unknown-type + (analyse valueC)))) + valueI (&&expr;generate (&synthesizer;synthesize valueA)) + _ (&;with-scope + (&&statement;generate-def def-name valueT valueI metaI (:! Code metaV)))] + (wrap [])) + + (^ [_ (#;Form (list [_ (#;Text "lux program")] + [_ (#;Symbol ["" program-args])] + programC))]) + (do meta;Monad<Meta> + [[_ programA] (&;with-scope + (&;with-expected-type (type (io;IO Unit)) + (analyse programC))) + programI (&&expr;generate (&synthesizer;synthesize programA))] + (&&statement;generate-program program-args programI)) _ - (&;fail (format "Unrecognized statement: " (%code ast))))) + (&;fail (format "Unrecognized statement: " (%code code))))) (def: (exhaust action) (All [a] (-> (Meta a) (Meta Unit))) - (do Monad<Meta> + (do meta;Monad<Meta> [result action] (exhaust action))) (def: (ensure-new-module! file-hash module-name) (-> Nat Text (Meta Unit)) - (do Monad<Meta> + (do meta;Monad<Meta> [module-exists? (meta;module-exists? module-name) _ (: (Meta Unit) (if module-exists? @@ -59,10 +90,10 @@ (def: (with-active-compilation [module-name file-name source-code] action) (All [a] (-> [Text Text Text] (Meta a) (Meta a))) - (do Monad<Meta> - [_ (ensure-new-module! (T/hash source-code) module-name) + (do meta;Monad<Meta> + [_ (ensure-new-module! (text/hash source-code) module-name) #let [init-cursor [file-name +0 +0]] - output (&;with-source-code [init-cursor source-code] + output (&;with-source-code [init-cursor +0 source-code] action) _ (&module;flag-compiled! module-name)] (wrap output))) @@ -78,37 +109,35 @@ (#e;Success [(set@ #;source source' compiler) output])))) -(def: (compile-module source-dirs module-name compiler) - (-> (List &;Path) Text Compiler (P;Promise (e;Error Compiler))) - (do P;Monad<Promise> - [?input (&io;read-module source-dirs module-name)] - (case ?input - (#e;Success [file-name file-content]) - (let [compilation (do Monad<Meta> - [_ (with-active-compilation [module-name - file-name - file-content] - (exhaust - (do @ - [ast parse] - (compile ast))))] - (wrap []) - ## (&module;generate-descriptor module-name) - )] - (case (meta;run' compiler compilation) - (#e;Success [compiler module-descriptor]) - (do @ - [## _ (&io;write-module module-name module-descriptor) - ] - (wrap (#e;Success compiler))) - - (#e;Error error) - (wrap (#e;Error error)))) - +(def: (generate-module source-dirs module-name target-dir compiler) + (-> (List File) Text File Compiler (T;Task Compiler)) + (do T;Monad<Task> + [_ (&io;prepare-module target-dir module-name) + [file-name file-content] (&io;read-module source-dirs module-name)] + (case (meta;run' compiler + (do meta;Monad<Meta> + [[artifacts _] (&&common;with-artifacts + (with-active-compilation [module-name + file-name + file-content] + (exhaust + (do @ + [code parse] + (generate code)))))] + (wrap artifacts) + ## (&module;generate-descriptor module-name) + )) + (#e;Success [compiler artifacts ## module-descriptor + ]) + (do @ + [## _ (&io;write-module module-name module-descriptor) + _ (monad;map @ (function [[class-name class-bytecode]] + (&io;write-file target-dir class-name class-bytecode)) + (dict;entries artifacts))] + (wrap compiler)) + (#e;Error error) - (wrap (#e;Error error))))) - -(host;import org.objectweb.asm.MethodVisitor) + (T;fail error)))) (def: init-cursor Cursor ["" +0 +0]) @@ -127,7 +156,7 @@ (def: #export (init-compiler host) (-> &&common;Host Compiler) {#;info init-info - #;source [init-cursor ""] + #;source [init-cursor +0 ""] #;cursor init-cursor #;modules (list) #;scopes (list) @@ -137,23 +166,21 @@ #;scope-type-vars (list) #;host (:! Void host)}) -(def: (or-crash! action) - (All [a] (-> (P;Promise (e;Error a)) (P;Promise a))) - (do P;Monad<Promise> - [?output action] - (case ?output - (#e;Error error) - (error! error) - - (#e;Success output) - (wrap output)))) - -(def: #export (compile-program program target sources) - (-> &;Path &;Path (List &;Path) (P;Promise Unit)) - (do P;Monad<Promise> - [#let [compiler (init-compiler (&host;init-host []))] - compiler (or-crash! (&&runtime;compile-runtime compiler)) - compiler (or-crash! (compile-module sources prelude compiler)) - compiler (or-crash! (compile-module sources program compiler)) +(def: #export (generate-program program target sources) + (-> Text File (List File) (T;Task Unit)) + (do T;Monad<Task> + [compiler (|> (case (&&runtime;generate (init-compiler (io;run &host;init-host))) + (#e;Error error) + (T;fail error) + + (#e;Success [compiler [runtime-bc function-bc]]) + (do @ + [_ (&io;prepare-target target) + _ (&io;write-file target &&runtime;runtime-class runtime-bc) + _ (&io;write-file target &&runtime;function-class function-bc)] + (wrap compiler))) + (: (T;Task Compiler)) + (:: @ map (generate-module sources prelude target)) (:: @ join) + (:: @ map (generate-module sources program target)) (:: @ join)) #let [_ (log! "Compilation complete!")]] (wrap []))) diff --git a/new-luxc/source/luxc/generator/common.jvm.lux b/new-luxc/source/luxc/generator/common.jvm.lux index 150e68e4f..4439ae51d 100644 --- a/new-luxc/source/luxc/generator/common.jvm.lux +++ b/new-luxc/source/luxc/generator/common.jvm.lux @@ -4,8 +4,11 @@ [io] (concurrency ["A" atom]) (data ["e" error] - (coll ["d" dict])) - [host]) + [text] + text/format + (coll [dict #+ Dict])) + [host] + (world [blob #+ Blob])) (luxc (generator (host ["$" jvm] (jvm ["$t" type] ["$d" def] @@ -23,16 +26,52 @@ (type: #export Bytecode (host;type (Array byte))) -(type: #export Class-Store (A;Atom (d;Dict Text Bytecode))) +(type: #export Class-Store (A;Atom (Dict Text Bytecode))) + +(type: #export Artifacts (Dict Text Blob)) (type: #export Host {#loader ClassLoader #store Class-Store - #function-class (Maybe Text)}) + #function-class (Maybe Text) + #artifacts Artifacts}) (exception: Unknown-Class) (exception: Class-Already-Stored) (exception: No-Function-Being-Compiled) +(exception: Cannot-Overwrite-Artifact) + +(def: #export (with-artifacts action) + (All [a] (-> (Meta a) (Meta [Artifacts a]))) + (;function [compiler] + (case (action (update@ #;host + (|>. (:! Host) + (set@ #artifacts (dict;new text;Hash<Text>)) + (:! Void)) + compiler)) + (#e;Success [compiler' output]) + (#e;Success [(update@ #;host + (|>. (:! Host) + (set@ #artifacts (|> (get@ #;host compiler) (:! Host) (get@ #artifacts))) + (:! Void)) + compiler') + [(|> compiler' (get@ #;host) (:! Host) (get@ #artifacts)) + output]]) + + (#e;Error error) + (#e;Error error)))) + +(def: #export (record-artifact name content) + (-> Text Blob (Meta Unit)) + (;function [compiler] + (if (|> compiler (get@ #;host) (:! Host) (get@ #artifacts) (dict;contains? name)) + (ex;throw Cannot-Overwrite-Artifact name) + (#e;Success [(update@ #;host + (|>. (:! Host) + (update@ #artifacts (dict;put name content)) + (:! Void)) + compiler) + []])))) (def: #export (store-class name byte-code) (-> Text Bytecode (Meta Unit)) @@ -40,9 +79,9 @@ (let [store (|> (get@ #;host compiler) (:! Host) (get@ #store))] - (if (d;contains? name (|> store A;get io;run)) + (if (dict;contains? name (|> store A;get io;run)) (ex;throw Class-Already-Stored name) - (#e;Success [compiler (io;run (A;update (d;put name byte-code) store))]) + (#e;Success [compiler (io;run (A;update (dict;put name byte-code) store))]) )))) (def: #export (load-class name) @@ -50,7 +89,7 @@ (;function [compiler] (let [host (:! Host (get@ #;host compiler)) store (|> host (get@ #store) A;get io;run)] - (if (d;contains? name store) + (if (dict;contains? name store) (#e;Success [compiler (ClassLoader.loadClass [name] (get@ #loader host))]) (ex;throw Unknown-Class name))))) @@ -87,3 +126,6 @@ (#e;Success [compiler function-class]))))) (def: #export bytecode-version Int Opcodes.V1_6) + +(def: #export value-field Text "_value") +(def: #export $Object $;Type ($t;class "java.lang.Object" (list))) diff --git a/new-luxc/source/luxc/generator/eval.jvm.lux b/new-luxc/source/luxc/generator/eval.jvm.lux index 20c02af4c..842199a47 100644 --- a/new-luxc/source/luxc/generator/eval.jvm.lux +++ b/new-luxc/source/luxc/generator/eval.jvm.lux @@ -56,9 +56,6 @@ (visitMethod [int String String String (Array String)] MethodVisitor) (toByteArray [] (Array byte))) -(def: eval-field Text "_value") -(def: $Object $;Type ($t;class "java.lang.Object" (list))) - (def: #export (eval valueI) (-> $;Inst (Meta Top)) (do Monad<Meta> @@ -70,17 +67,17 @@ (host;null) "java/lang/Object" (host;null)])) - ($d;field #$;Public $;staticF - eval-field $Object) + ($d;field #$;Public ($_ $;++F $;finalF $;staticF) + &common;value-field &common;$Object) ($d;method #$;Public ($_ $;++M $;staticM $;strictM) "<clinit>" ($t;method (list) #;None (list)) (|>. valueI - ($i;PUTSTATIC class-name eval-field $Object) + ($i;PUTSTATIC class-name &common;value-field &common;$Object) $i;RETURN))) bytecode (ClassWriter.toByteArray [] (do-to writer (ClassWriter.visitEnd [])))] _ (&common;store-class class-name bytecode) class (&common;load-class class-name)] (wrap (|> class - (Class.getField [eval-field]) + (Class.getField [&common;value-field]) (Field.get (host;null)))))) diff --git a/new-luxc/source/luxc/generator/expr.jvm.lux b/new-luxc/source/luxc/generator/expr.jvm.lux index c7fdcf2af..116c29fb5 100644 --- a/new-luxc/source/luxc/generator/expr.jvm.lux +++ b/new-luxc/source/luxc/generator/expr.jvm.lux @@ -44,6 +44,9 @@ (&reference;generate-captured var) (&reference;generate-variable var)) + (#ls;Definition definition) + (&reference;generate-definition definition) + (#ls;Function arity env body) (&function;generate-function generate env arity body) @@ -54,7 +57,8 @@ (&procedure;generate-procedure generate name args) _ - (meta;fail "Unrecognized synthesis."))) + (meta;fail "Unrecognized synthesis.") + )) ## (def: #export (eval type code) ## (-> Type Code (Meta Top)) diff --git a/new-luxc/source/luxc/generator/host/jvm.lux b/new-luxc/source/luxc/generator/host/jvm.lux index c985efc9a..24d4a9ea9 100644 --- a/new-luxc/source/luxc/generator/host/jvm.lux +++ b/new-luxc/source/luxc/generator/host/jvm.lux @@ -109,8 +109,8 @@ (` (def: (~' #export) ((~ (code;local-symbol ++)) (~ g!_left) (~ g!_right)) (-> (~ g!type) (~ g!type) (~ g!type)) (~ (code;record (list/map (function [tag] - [tag (` (and (get@ (~ tag) (~ g!_left)) - (get@ (~ tag) (~ g!_right))))]) + [tag (` (or (get@ (~ tag) (~ g!_left)) + (get@ (~ tag) (~ g!_right))))]) g!tags+))))) g!options+)))) diff --git a/new-luxc/source/luxc/generator/reference.jvm.lux b/new-luxc/source/luxc/generator/reference.jvm.lux index 063994bac..0e77b1819 100644 --- a/new-luxc/source/luxc/generator/reference.jvm.lux +++ b/new-luxc/source/luxc/generator/reference.jvm.lux @@ -3,15 +3,14 @@ (lux (control [monad #+ do]) (data text/format) [meta "meta/" Monad<Meta>]) - (luxc (lang ["ls" synthesis]) + (luxc ["&" base] + (lang ["ls" synthesis]) (generator [";G" common] [";G" function] (host ["$" jvm] (jvm ["$t" type] ["$i" inst]))))) -(def: $Object $;Type ($t;class "java.lang.Object" (list))) - (def: #export (generate-captured variable) (-> ls;Variable (Meta $;Inst)) (do meta;Monad<Meta> @@ -19,8 +18,13 @@ (wrap (|>. ($i;ALOAD +0) ($i;GETFIELD function-class (|> variable i.inc (i.* -1) int-to-nat functionG;captured) - $Object))))) + commonG;$Object))))) (def: #export (generate-variable variable) (-> ls;Variable (Meta $;Inst)) (meta/wrap ($i;ALOAD (int-to-nat variable)))) + +(def: #export (generate-definition [def-module def-name]) + (-> Ident (Meta $;Inst)) + (let [bytecode-name (format def-module "/" (&;normalize-name def-name))] + (meta/wrap ($i;GETSTATIC bytecode-name commonG;value-field commonG;$Object)))) diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux index 32e792638..66dd43019 100644 --- a/new-luxc/source/luxc/generator/runtime.jvm.lux +++ b/new-luxc/source/luxc/generator/runtime.jvm.lux @@ -504,8 +504,8 @@ (wrap bytecode))) (def: #export generate - (Meta Unit) + (Meta [&common;Bytecode &common;Bytecode]) (do Monad<Meta> - [_ generate-runtime - _ generate-function] - (wrap []))) + [runtime-bc generate-runtime + function-bc generate-function] + (wrap [runtime-bc function-bc]))) diff --git a/new-luxc/source/luxc/generator/statement.jvm.lux b/new-luxc/source/luxc/generator/statement.jvm.lux index ed66f3ecb..830935dda 100644 --- a/new-luxc/source/luxc/generator/statement.jvm.lux +++ b/new-luxc/source/luxc/generator/statement.jvm.lux @@ -1,25 +1,84 @@ (;module: lux - (lux (control monad) - [io #- run] - (data [text "T/" Eq<Text>] - text/format) - [meta #+ Monad<Meta>]) + (lux (control monad + ["ex" exception #+ exception:]) + (concurrency ["T" task]) + (data ["e" error] + [maybe] + [text "text/" Monoid<Text>] + text/format + (coll [list "list/" Functor<List> Fold<List>])) + [meta] + [host]) (luxc ["&" base] - ["&;" module] ["&;" scope] - (compiler ["&;" expr]))) + ["&;" module] + ["&;" io] + (generator ["&;" expr] + ["&;" eval] + ["&;" common] + (host ["$" jvm] + (jvm ["$t" type] + ["$d" def] + ["$i" inst]))))) + +(exception: #export Invalid-Definition-Value) + +(host;import java.lang.Object + (toString [] String)) + +(host;import java.lang.reflect.Field + (get [#? Object] #try #? Object)) + +(host;import (java.lang.Class c) + (getField [String] #try Field)) + +(def: #export (generate-def def-name valueT valueI metaI metaV) + (-> Text Type $;Inst $;Inst Code (Meta Unit)) + (do meta;Monad<Meta> + [current-module meta;current-module-name + #let [def-ident [current-module def-name] + normal-name (&;normalize-name def-name) + bytecode-name (format current-module "/" normal-name) + class-name (format current-module "." normal-name) + bytecode ($d;class #$;V1.6 + #$;Public $;finalC + bytecode-name + (list) ["java.lang.Object" (list)] + (list) + (|>. ($d;field #$;Public ($;++F $;finalF $;staticF) &common;value-field &common;$Object) + ($d;method #$;Public $;staticM "<clinit>" ($t;method (list) #;None (list)) + (|>. valueI + ($i;PUTSTATIC bytecode-name &common;value-field &common;$Object) + $i;RETURN))))] + _ (&common;store-class class-name bytecode) + class (&common;load-class class-name) + valueV (: (Meta Top) + (case (do e;Monad<Error> + [field (Class.getField [&common;value-field] class)] + (Field.get [#;None] field)) + (#e;Success #;None) + (&;throw Invalid-Definition-Value (format current-module ";" def-name)) + + (#e;Success (#;Some valueV)) + (wrap valueV) + + (#e;Error error) + (&;fail error))) + _ (&module;define [current-module def-name] [valueT metaV valueV]) + _ (if (meta;type? metaV) + (case (meta;declared-tags metaV) + #;Nil + (wrap []) -(def: #export (compile-def def-name def-value def-meta) - (-> Text Code Code (Meta Unit)) - (do Monad<Meta> - [=def-value (&expr;compile def-value) - =def-meta (&expr;compile def-meta)] - (undefined))) + tags + (&module;declare-tags tags (meta;export? metaV) (:! Type valueV))) + (wrap [])) + #let [_ (log! (format "DEF " current-module ";" def-name))]] + (&common;record-artifact bytecode-name bytecode))) -(def: #export (compile-program prog-args prog-body) - (-> Text Code (Meta Unit)) - (do Monad<Meta> - [=prog-body (&scope;with-local [prog-args (type (List Text))] - (&expr;compile prog-body))] - (undefined))) +(def: #export (generate-program program-args programI) + (-> Text $;Inst (Meta Unit)) + (do meta;Monad<Meta> + [] + (&;fail "'lux program' is unimplemented."))) diff --git a/new-luxc/source/luxc/host.jvm.lux b/new-luxc/source/luxc/host.jvm.lux index 6c8eaa350..f118deed2 100644 --- a/new-luxc/source/luxc/host.jvm.lux +++ b/new-luxc/source/luxc/host.jvm.lux @@ -5,7 +5,7 @@ (data ["e" error] [text] text/format - (coll ["d" dict] + (coll [dict] [array])) [meta #+ Monad<Meta>] [host #+ do-to object] @@ -58,7 +58,7 @@ (def: (fetch-byte-code class-name store) (-> Text &&common;Class-Store (Maybe &&common;Bytecode)) - (|> store A;get io;run (d;get class-name))) + (|> store A;get io;run (dict;get class-name))) (def: (memory-class-loader store) (-> &&common;Class-Store ClassLoader) @@ -72,7 +72,7 @@ (:!! class) (#e;Error error) - (error! (format "Class definiton error: " class-name "\n" + (error! (format "Class definition error: " class-name "\n" error))) #;None @@ -81,10 +81,11 @@ (def: #export init-host (io;IO &&common;Host) (io;io (let [store (: &&common;Class-Store - (A;atom (d;new text;Hash<Text>)))] + (A;atom (dict;new text;Hash<Text>)))] {#&&common;loader (memory-class-loader store) #&&common;store store - #&&common;function-class #;None}))) + #&&common;function-class #;None + #&&common;artifacts (dict;new text;Hash<Text>)}))) (def: #export class-loader (Meta ClassLoader) diff --git a/new-luxc/source/luxc/io.jvm.lux b/new-luxc/source/luxc/io.jvm.lux index 9ca8aebf3..599fde359 100644 --- a/new-luxc/source/luxc/io.jvm.lux +++ b/new-luxc/source/luxc/io.jvm.lux @@ -1,94 +1,95 @@ (;module: lux - (lux (control monad) + (lux (control monad + ["ex" exception #+ exception:]) [io #- run] - (concurrency ["P" promise]) + (concurrency ["P" promise] + ["T" task]) (data ["e" error] - [text "T/" Eq<Text>] + [text "text/" Eq<Text>] text/format) [meta] - [host]) + [host] + (world [file #+ File] + [blob #+ Blob])) (luxc ["&" base])) -(host;import java.io.File - (new [String String]) - (exists [] #io #try boolean)) - -(host;import java.io.Reader - (close [] #io #try void)) - -(host;import java.io.FileReader - (new [File])) - -(host;import java.io.BufferedReader - (new [Reader]) - (readLine [] #io #try #? String)) +(host;import java.lang.String + (new [(Array byte)])) (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")] - (with-expansions - [<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)) +(def: lux-extension Text ".lux") + +(exception: #export File-Not-Found) +(exception: #export Module-Not-Found) + +(def: (find-source path dirs) + (-> Text (List File) (T;Task [Text File])) + (case dirs + #;Nil + (T;throw File-Not-Found path) + + (#;Cons dir dirs') + (do T;Monad<Task> + [#let [file (format dir "/" path)] + ? (file;exists? file)] + (if ? + (wrap [path file]) + (find-source path dirs'))))) + +(def: (either left right) + (All [a] (-> (T;Task a) (T;Task a) (T;Task a))) + (do P;Monad<Promise> + [?output left] + (case ?output + (#e;Success output) + (wrap (#e;Success output)) + + (#e;Error error) + right))) + +(def: #export (read-module dirs name) + (-> (List File) Text (T;Task [File Text])) + (let [host-path (format name host-extension lux-extension) + lux-path (format name lux-extension)] + (do T;Monad<Task> + [[path file] (: (T;Task [Text File]) + ($_ either + (find-source host-path dirs) + (find-source lux-path dirs) + (T;throw Module-Not-Found name))) + blob (file;read file)] + (wrap [path (String.new blob)])))) + +(def: #export (write-module name descriptor) + (-> Text Text (T;Task Unit)) + (T;fail "'write-module' is undefined.")) + +(def: (platform-target root-target) + (-> File File) + (format root-target "/" (for {"JVM" "jvm" + "JS" "js"}))) + +(def: (platform-file root-file) + (-> File File) + (format root-file (for {"JVM" ".class" + "JS" ".js"}))) + +(def: #export (prepare-target target-dir) + (-> File (T;Task Unit)) + (do T;Monad<Task> + [_ (file;make-dir target-dir) + _ (file;make-dir (platform-target target-dir))] + (wrap []))) + +(def: #export (prepare-module target-dir module-name) + (-> File Text (T;Task Unit)) + (do T;Monad<Task> + [_ (file;make-dir (format (platform-target target-dir) "/" module-name))] + (wrap []))) + +(def: #export (write-file target-dir file-name content) + (-> File Text Blob (T;Task Unit)) + (file;write content + (format (platform-target target-dir) + "/" (platform-file file-name)))) diff --git a/new-luxc/source/luxc/parser.lux b/new-luxc/source/luxc/parser.lux index b58038e7d..93800c1b7 100644 --- a/new-luxc/source/luxc/parser.lux +++ b/new-luxc/source/luxc/parser.lux @@ -48,19 +48,19 @@ ## chunk of white-space. (def: (space^ where) (-> Cursor (l;Lexer [Cursor Text])) - (do p;Monad<Parser> - [head (l;some (l;one-of white-space))] - ## New-lines must be handled as a separate case to ensure line - ## information is handled properly. - (p;either (p;after (l;one-of new-line) - (do @ - [[end tail] (space^ (|> where - (update@ #;line n.inc) - (set@ #;column +0)))] - (wrap [end - (format head tail)]))) - (wrap [(update@ #;column (n.+ (text;size head)) where) - head])))) + (p;either (do p;Monad<Parser> + [content (l;many (l;one-of white-space))] + (wrap [(update@ #;column (n.+ (text;size content)) where) + content])) + ## New-lines must be handled as a separate case to ensure line + ## information is handled properly. + (do p;Monad<Parser> + [content (l;many (l;one-of new-line))] + (wrap [(|> where + (update@ #;line (n.+ (text;size content))) + (set@ #;column +0)) + content])) + )) ## Single-line comments can start anywhere, but only go up to the ## next new-line. @@ -144,13 +144,14 @@ ## The cursor gets updated, but the padding gets ignored. (def: (left-padding^ where) (-> Cursor (l;Lexer Cursor)) - (p;either (do p;Monad<Parser> - [[where comment] (comment^ where)] - (left-padding^ where)) - (do p;Monad<Parser> - [[where white-space] (space^ where)] - (wrap where)) - )) + ($_ p;either + (do p;Monad<Parser> + [[where comment] (comment^ where)] + (left-padding^ where)) + (do p;Monad<Parser> + [[where white-space] (space^ where)] + (left-padding^ where)) + (:: p;Monad<Parser> wrap where))) ## Escaped character sequences follow the usual syntax of ## back-slash followed by a letter (e.g. \n). @@ -599,11 +600,11 @@ (text where) ))) -(def: #export (parse [where code]) - (-> [Cursor Text] (e;Error [[Cursor Text] Code])) - (case (p;run [+0 code] (ast where)) +(def: #export (parse [where offset source]) + (-> Source (e;Error [Source Code])) + (case (p;run [offset source] (ast where)) (#e;Error error) (#e;Error error) - (#e;Success [[_ remaining] [where' output]]) - (#e;Success [[where' remaining] output]))) + (#e;Success [[offset' remaining] [where' output]]) + (#e;Success [[where' offset' remaining] output]))) diff --git a/new-luxc/source/luxc/synthesizer.lux b/new-luxc/source/luxc/synthesizer.lux index 651da82a7..011dfd8ae 100644 --- a/new-luxc/source/luxc/synthesizer.lux +++ b/new-luxc/source/luxc/synthesizer.lux @@ -34,13 +34,13 @@ (^template [<from> <to>] (<from> value) (<to> value)) - ([#la;Unit #ls;Unit] - [#la;Bool #ls;Bool] - [#la;Nat #ls;Nat] - [#la;Int #ls;Int] - [#la;Deg #ls;Deg] - [#la;Frac #ls;Frac] - [#la;Text #ls;Text] + ([#la;Unit #ls;Unit] + [#la;Bool #ls;Bool] + [#la;Nat #ls;Nat] + [#la;Int #ls;Int] + [#la;Deg #ls;Deg] + [#la;Frac #ls;Frac] + [#la;Text #ls;Text] [#la;Definition #ls;Definition]) (#la;Product _) |