aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser.lux21
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux24
-rw-r--r--new-luxc/source/luxc/base.lux53
-rw-r--r--new-luxc/source/luxc/generator.lux181
-rw-r--r--new-luxc/source/luxc/generator/common.jvm.lux56
-rw-r--r--new-luxc/source/luxc/generator/eval.jvm.lux11
-rw-r--r--new-luxc/source/luxc/generator/expr.jvm.lux6
-rw-r--r--new-luxc/source/luxc/generator/host/jvm.lux4
-rw-r--r--new-luxc/source/luxc/generator/reference.jvm.lux12
-rw-r--r--new-luxc/source/luxc/generator/runtime.jvm.lux8
-rw-r--r--new-luxc/source/luxc/generator/statement.jvm.lux97
-rw-r--r--new-luxc/source/luxc/host.jvm.lux11
-rw-r--r--new-luxc/source/luxc/io.jvm.lux169
-rw-r--r--new-luxc/source/luxc/parser.lux51
-rw-r--r--new-luxc/source/luxc/synthesizer.lux14
-rw-r--r--new-luxc/source/program.lux87
16 files changed, 501 insertions, 304 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 _)
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
index ecf5cdd6f..3e94c7521 100644
--- a/new-luxc/source/program.lux
+++ b/new-luxc/source/program.lux
@@ -1,40 +1,53 @@
(;module:
lux
- (lux (control monad)
+ (lux (control monad
+ ["p" parser])
+ (concurrency ["P" promise]
+ ["T" task])
+ (data ["e" error])
[io #- run]
- [cli #+ program: CLI Monad<CLI>])
- (luxc ["&" base]
- ["&;" parser]
- ["&;" compiler]
- (module (descriptor ["&;" type]))
- ))
-
-(type: Compilation
- {#program &;Path
- #target &;Path})
-
-(def: (marker tokens)
- (-> (List Text) (CLI Unit))
- (cli;after (cli;option tokens)
- (:: Monad<CLI> wrap [])))
-
-(def: (tagged tags)
- (-> (List Text) (CLI Text))
- (cli;after (cli;option tags)
- cli;any))
-
-(def: compilation^
- (CLI Compilation)
- ($_ cli;seq
- (tagged (list "-p" "--program"))
- (tagged (list "-t" "--target"))))
-
-(program: ([command (cli;opt compilation^)]
- [sources (cli;some (tagged (list "-s" "--source")))])
- (case command
- #;None
- (io (log! "No REPL for you!"))
-
- (#;Some [program target])
- (exec (&compiler;compile-program program target sources)
- (io []))))
+ [cli #+ program: CLI])
+ (luxc ["&;" generator]))
+
+## (type: Compilation
+## {#program &;Path
+## #target &;Path})
+
+## (def: (marker tokens)
+## (-> (List Text) (CLI Unit))
+## (cli;after (cli;option tokens)
+## (:: Monad<CLI> wrap [])))
+
+## (def: (tagged tags)
+## (-> (List Text) (CLI Text))
+## (cli;after (cli;option tags)
+## cli;any))
+
+## (def: compilation^
+## (CLI Compilation)
+## ($_ cli;seq
+## (tagged (list "-p" "--program"))
+## (tagged (list "-t" "--target"))))
+
+## (program: ([command (cli;opt compilation^)]
+## [sources (cli;some (tagged (list "-s" "--source")))])
+## (case command
+## #;None
+## (io (log! "No REPL for you!"))
+
+## (#;Some [program target])
+## (exec (&compiler;compile-program program target sources)
+## (io []))))
+
+(def: (or-crash! action)
+ (All [a] (-> (T;Task a) (P;Promise a)))
+ (do P;Monad<Promise>
+ [?output action]
+ (case ?output
+ (#e;Error error)
+ (error! error)
+
+ (#e;Success output)
+ (wrap output))))
+
+