diff options
Diffstat (limited to '')
21 files changed, 450 insertions, 356 deletions
diff --git a/stdlib/source/lux/tool/compiler.lux b/stdlib/source/lux/tool/compiler.lux index b4fdd541e..e151c9e94 100644 --- a/stdlib/source/lux/tool/compiler.lux +++ b/stdlib/source/lux/tool/compiler.lux @@ -7,12 +7,12 @@ [collection ["." dictionary (#+ Dictionary)]]] [world - ["." file (#+ File)]]] + ["." file (#+ Path)]]] [/ [meta ["." archive (#+ Archive) [key (#+ Key)] - [descriptor (#+ Module)] + [descriptor (#+ Descriptor Module)] [document (#+ Document)]]]]) (type: #export Code @@ -23,7 +23,7 @@ (type: #export Input {#module Module - #file File + #file Path #hash Nat #code Code}) @@ -34,7 +34,7 @@ {#dependencies (List Module) #process (-> Archive (Error (Either (Compilation d o) - [(Document d) (Output o)])))}) + [[Descriptor (Document d)] (Output o)])))}) (type: #export (Compiler d o) (-> Input (Compilation d o))) diff --git a/stdlib/source/lux/tool/compiler/cli.lux b/stdlib/source/lux/tool/compiler/cli.lux index 7e92b2c34..e08c83c7e 100644 --- a/stdlib/source/lux/tool/compiler/cli.lux +++ b/stdlib/source/lux/tool/compiler/cli.lux @@ -4,27 +4,29 @@ ["p" parser]] ["." cli (#+ CLI)] [world - [file (#+ File)]]] - [/// - [importer (#+ Source)]]) + [file (#+ Path)]]] + ## [/// + ## [importer (#+ Source)]] + ) (type: #export Configuration - {#sources (List Source) - #target File + {## #sources (List Source) + #sources (List Path) + #target Path #module Text}) (type: #export Service (#Compilation Configuration) (#Interpretation Configuration)) -(do-template [<name> <short> <long>] +(do-template [<name> <long>] [(def: #export <name> (CLI Text) - (cli.parameter [<short> <long>]))] + (cli.named <long> cli.any))] - [source "-s" "--source"] - [target "-t" "--target"] - [module "-m" "--module"] + [source "--source"] + [target "--target"] + [module "--module"] ) (def: #export configuration diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index a416c0a3b..8375c4642 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -8,14 +8,15 @@ ["." error (#+ Error)] ["." text ("#/." hash)] [collection - ["." dictionary]]] + ["." dictionary] + ["." set]]] ["." macro] [world ["." file]]] ["." // ["." syntax (#+ Aliases)] ["." evaluation] - ["/." // (#+ Compiler) + ["/." // (#+ Instancer) ["." host] ["." phase ["." analysis @@ -168,7 +169,7 @@ (All [anchor expression statement] (-> Module (statement.State+ anchor expression statement) - (Compiler .Module))) + (Instancer .Module))) (function (_ key parameters input) (let [hash (text/hash (get@ #///.code input)) dependencies (default-dependencies prelude input)] @@ -186,9 +187,9 @@ #let [descriptor {#descriptor.hash hash #descriptor.name (get@ #///.module input) #descriptor.file (get@ #///.file input) - #descriptor.references dependencies + #descriptor.references (set.from-list text.hash dependencies) #descriptor.state #.Compiled}]] - (wrap (#.Right [(document.write key descriptor analysis-module) + (wrap (#.Right [[descriptor (document.write key analysis-module)] (dictionary.new text.hash)]))))}))) (def: #export key diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 7e3846c09..8711d20ec 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -1,10 +1,10 @@ (.module: [lux #* [control - [monad (#+ do)]] + [monad (#+ Monad do)]] [data ["." product] - ["." error]] + ["." error (#+ Error)]] [world ["." file (#+ File)]]] [// @@ -21,10 +21,11 @@ ["." context]]]]]) (type: #export (Platform ! anchor expression statement) - {#host (translation.Host expression statement) + {#&monad (Monad !) + #&file-system (file.System !) + #host (translation.Host expression statement) #phase (translation.Phase anchor expression statement) - #runtime (translation.Operation anchor expression statement Any) - #file-system (file.System !)}) + #runtime (translation.Operation anchor expression statement Any)}) ## (def: (write-module target-dir file-name module-name module outputs) ## (-> File Text Text Module Outputs (Process Any)) @@ -41,7 +42,7 @@ (def: #export (initialize platform translation-bundle) (All [! anchor expression statement] - (-> <Platform> <Bundle> (! <State+>))) + (-> <Platform> <Bundle> (! (Error <State+>)))) (|> platform (get@ #runtime) statement.lift-translation @@ -49,8 +50,8 @@ (get@ #phase platform) translation-bundle)) (:: error.functor map product.left) - (:: (get@ #file-system platform) lift)) - + (:: (get@ #&monad platform) wrap)) + ## (case (runtimeT.translate ## (initL.compiler (io.run js.init)) ## (initL.compiler (io.run hostL.init-host)) ## ) @@ -79,31 +80,37 @@ (def: #export (compile platform configuration state) (All [! anchor expression statement] - (-> <Platform> Configuration <State+> (! Any))) - (do (:: (get@ #file-system platform) &monad) - [input (context.read (get@ #file-system platform) - (get@ #cli.sources configuration) - (get@ #cli.module configuration)) - ## _ (&io.prepare-module target-dir (get@ #cli.module configuration)) - ## _ (write-module target-dir file-name (get@ #cli.module configuration) module outputs) - ] - ## (case (compiler input) - ## (#error.Failure error) - ## (:: (get@ #file-system platform) lift (#error.Failure error)) - - ## (#error.Success)) - (let [compiler (init.compiler syntax.prelude state) - compilation (compiler init.key (list) input)] - (case ((get@ #///.process compilation) - archive.empty) - (#error.Success more|done) - (case more|done - (#.Left more) - (:: (get@ #file-system platform) lift (#error.Failure "NOT DONE!")) - - (#.Right done) - (wrap [])) - - (#error.Failure error) - (:: (get@ #file-system platform) lift (#error.Failure error)))))) + (-> <Platform> Configuration <State+> (! (Error Any)))) + (let [monad (get@ #&monad platform)] + (do monad + [input (context.read monad + (get@ #&file-system platform) + (get@ #cli.sources configuration) + (get@ #cli.module configuration)) + ## _ (&io.prepare-module target-dir (get@ #cli.module configuration)) + ## _ (write-module target-dir file-name (get@ #cli.module configuration) module outputs) + ] + (wrap (do error.monad + [input input + #let [compiler (init.compiler syntax.prelude state) + compilation (compiler init.key (list) input)]] + (case ((get@ #///.process compilation) + archive.empty) + (#error.Success more|done) + (case more|done + (#.Left more) + (#error.Failure "NOT DONE!") + + (#.Right done) + (wrap [])) + + (#error.Failure error) + (#error.Failure error)))) + + ## (case (compiler input) + ## (#error.Failure error) + ## (:: monad wrap (#error.Failure error)) + + ## (#error.Success)) + ))) ) diff --git a/stdlib/source/lux/tool/compiler/default/syntax.lux b/stdlib/source/lux/tool/compiler/default/syntax.lux index c76857aab..19cfea706 100644 --- a/stdlib/source/lux/tool/compiler/default/syntax.lux +++ b/stdlib/source/lux/tool/compiler/default/syntax.lux @@ -356,7 +356,7 @@ (!number-output start g!end <codec> <tag>)))))] [!parse-nat nat.decimal #.Nat] - [!parse-rev rec.decimal #.Rev] + [!parse-rev rev.decimal #.Rev] ) (template: (!parse-signed source-code//size offset where source-code @end) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index c318bfaf7..e34edf0d4 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -34,44 +34,43 @@ ["Old key" (signature.description (document.signature old))] ["New key" (signature.description (document.signature new))])) -(with-expansions [<Document> (as-is (type (Ex [d] (Document d))))] - (abstract: #export Archive - {} - - (Dictionary Text [Descriptor <Document>]) +(abstract: #export Archive + {} + + (Dictionary Text [Descriptor (Document Any)]) - (def: #export empty - Archive - (:abstraction (dictionary.new text.hash))) + (def: #export empty + Archive + (:abstraction (dictionary.new text.hash))) - (def: #export (add name descriptor document archive) - (-> Module Descriptor <Document> Archive (Error Archive)) - (case (dictionary.get name (:representation archive)) - (#.Some existing) - (if (is? document existing) - (#error.Success archive) - (ex.throw cannot-replace-document [name existing document])) - - #.None - (#error.Success (|> archive - :representation - (dictionary.put name [descriptor document]) - :abstraction)))) + (def: #export (add name [descriptor document] archive) + (-> Module [Descriptor (Document Any)] Archive (Error Archive)) + (case (dictionary.get name (:representation archive)) + (#.Some [existing-descriptor existing-document]) + (if (is? document existing-document) + (#error.Success archive) + (ex.throw cannot-replace-document [name existing-document document])) + + #.None + (#error.Success (|> archive + :representation + (dictionary.put name [descriptor document]) + :abstraction)))) - (def: #export (find name archive) - (-> Module Archive (Error [Descriptor <Document>])) - (case (dictionary.get name (:representation archive)) - (#.Some document) - (#error.Success document) - - #.None - (ex.throw unknown-document [name]))) + (def: #export (find name archive) + (-> Module Archive (Error [Descriptor (Document Any)])) + (case (dictionary.get name (:representation archive)) + (#.Some document) + (#error.Success document) + + #.None + (ex.throw unknown-document [name]))) - (def: #export (merge additions archive) - (-> Archive Archive (Error Archive)) - (monad.fold error.monad - (function (_ [name' descriptor+document'] archive') - (..add name' descriptor+document' archive')) - archive - (dictionary.entries (:representation additions)))) - )) + (def: #export (merge additions archive) + (-> Archive Archive (Error Archive)) + (monad.fold error.monad + (function (_ [name' descriptor+document'] archive') + (..add name' descriptor+document' archive')) + archive + (dictionary.entries (:representation additions)))) + ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux index 328240e6c..5daf10016 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux @@ -4,13 +4,13 @@ [collection [set (#+ Set)]]] [world - [file (#+ File)]]]) + [file (#+ Path)]]]) (type: #export Module Text) (type: #export Descriptor {#hash Nat #name Module - #file File + #file Path #references (Set Module) #state Module-State}) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/lux/tool/compiler/meta/archive/document.lux index 5c077080f..505170efb 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/document.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/document.lux @@ -13,7 +13,6 @@ ["." key (#+ Key)] [descriptor (#+ Module)]]) -## Document (exception: #export (invalid-signature {expected Signature} {actual Signature}) (ex.report ["Expected" (signature.description expected)] ["Actual" (signature.description actual)])) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux index fb96aec58..b8b9c43b2 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux @@ -9,7 +9,6 @@ [//// [default (#+ Version)]]) -## Key (type: #export Signature {#name Name #version Version}) diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux index dd261a539..579164881 100644 --- a/stdlib/source/lux/tool/compiler/meta/io.lux +++ b/stdlib/source/lux/tool/compiler/meta/io.lux @@ -3,9 +3,9 @@ [data ["." text]] [world - [file (#+ File System)]]]) + [file (#+ Path System)]]]) -(type: #export Context File) +(type: #export Context Path) (type: #export Module Text) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux index be72e4ccc..f526a3738 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -1,16 +1,19 @@ (.module: [lux (#- Module Code) [control - monad - ["ex" exception (#+ Exception exception:)]] + [monad (#+ Monad do)] + ["ex" exception (#+ Exception exception:)] + [security + ["!" capability]]] [data - ["." error] - [text + ["." error (#+ Error)] + ["." text ("#/." hash) format ["." encoding]]] [world - ["." file (#+ File)] - [binary (#+ Binary)]]] + ["." file (#+ Path File)] + [binary (#+ Binary)]] + [type (#+ :share)]] ["." // (#+ Context Code) [// [archive @@ -48,60 +51,67 @@ Extension (format partial-host-extension lux-extension)) -(def: #export (file System<m> context module) - (All [m] (-> (file.System m) Context Module File)) +(def: #export (path system context module) + (All [m] (-> (file.System m) Context Module Path)) (|> module - (//.sanitize System<m>) - (format context (:: System<m> separator)))) + (//.sanitize system) + (format context (:: system separator)))) -(def: (find-source-file System<m> contexts module extension) +(def: (find-source-file monad system contexts module extension) (All [!] - (-> (file.System !) (List Context) Module Extension - (! (Maybe File)))) + (-> (Monad !) (file.System !) (List Context) Module Extension + (! (Error [Path (File !)])))) (case contexts #.Nil - (:: (:: System<m> &monad) wrap #.None) + (:: monad wrap (ex.throw ..cannot-find-module [module])) (#.Cons context contexts') - (do (:: System<m> &monad) - [#let [file (format (..file System<m> context module) extension)] - ? (file.exists? System<m> file)] - (if ? - (wrap (#.Some file)) - (find-source-file System<m> contexts' module extension))))) + (do monad + [#let [path (format (..path system context module) extension)] + file (!.use (:: system file) path)] + (case file + (#error.Success file) + (wrap (#error.Success [path file])) -(def: (try System<m> computations exception message) - (All [m a e] (-> (file.System m) (List (m (Maybe a))) (Exception e) e (m a))) - (case computations - #.Nil - (:: System<m> throw exception message) + (#error.Failure error) + (find-source-file monad system contexts' module extension))))) - (#.Cons computation computations') - (do (:: System<m> &monad) - [outcome computation] - (case outcome - (#.Some output) - (wrap output) +(def: #export (find-any-source-file monad system contexts module) + (All [!] + (-> (Monad !) (file.System !) (List Context) Module + (! (Error [Path (File !)])))) + (do monad + [outcome (find-source-file monad system contexts module ..full-host-extension)] + (case outcome + (#error.Success output) + (wrap outcome) - #.None - (try System<m> computations' exception message))))) + (#error.Failure error) + (find-source-file monad system contexts module ..lux-extension)))) -(def: #export (read System<m> contexts module) +(def: #export (read monad system contexts module) (All [!] - (-> (file.System !) (List Context) Module - (! Input))) - (let [find-source-file' (find-source-file System<m> contexts module)] - (do (:: System<m> &monad) - [file (try System<m> - (list (find-source-file' ..full-host-extension) - (find-source-file' ..lux-extension)) - ..cannot-find-module [module]) - binary (:: System<m> read file)] - (case (encoding.from-utf8 binary) - (#error.Success code) - (wrap {#////.module module - #////.file file - #////.code code}) - - (#error.Failure _) - (:: System<m> throw ..cannot-read-module [module]))))) + (-> (Monad !) (file.System !) (List Context) Module + (! (Error Input)))) + (do (error.with-error monad) + [## TODO: Get rid of both ":share"s ASAP + path,file (:share [!] + {(Monad !) + monad} + {(! (Error [Path (File !)])) + (find-any-source-file monad system contexts module)}) + #let [[path file] (:share [!] + {(Monad !) + monad} + {[Path (File !)] + path,file})] + binary (!.use (:: file content) [])] + (case (encoding.from-utf8 binary) + (#error.Success code) + (wrap {#////.module module + #////.file path + #////.hash (text/hash code) + #////.code code}) + + (#error.Failure _) + (:: monad wrap (ex.throw ..cannot-read-module [module]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux index cd6ccd83d..dc654fd40 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux @@ -6,9 +6,10 @@ equivalence] [data ["." bit ("#/." equivalence)] - ["." number] ["." error (#+ Error) ("#/." monad)] ["." maybe] + [number + ["." nat]] ["." text format] [collection @@ -144,7 +145,7 @@ (wrap (#Variant (if right? (#.Some idx) #.None) - (|> (dictionary.new number.hash) + (|> (dictionary.new nat.hash) (dictionary.put idx value-coverage))))))) (def: (xor left right) @@ -171,7 +172,7 @@ _ (list coverage))) -(structure: _ (Equivalence Coverage) +(structure: equivalence (Equivalence Coverage) (def: (= reference sample) (case [reference sample] [#Exhaustive #Exhaustive] diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux index 3ce70fe9b..82c9cd65b 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux @@ -24,86 +24,106 @@ (exception: #export (unrecognized-syntax {code Code}) (ex.report ["Code" (%code code)])) +## TODO: Had to split the 'compile' function due to compilation issues +## with old-luxc. Must re-combine all the code ASAP + +(type: (Fix a) + (-> a a)) + +(def: (compile|primitive else code') + (Fix (-> (Code' (Ann Cursor)) (Operation Analysis))) + (case code' + (^template [<tag> <analyser>] + (<tag> value) + (<analyser> value)) + ([#.Bit primitive.bit] + [#.Nat primitive.nat] + [#.Int primitive.int] + [#.Rev primitive.rev] + [#.Frac primitive.frac] + [#.Text primitive.text]) + + _ + (else code'))) + +(def: (compile|structure compile else code') + (-> Phase (Fix (-> (Code' (Ann Cursor)) (Operation Analysis)))) + (case code' + (^template [<tag> <analyser>] + (^ (#.Form (list& [_ (<tag> tag)] + values))) + (case values + (#.Cons value #.Nil) + (<analyser> compile tag value) + + _ + (<analyser> compile tag (` [(~+ values)])))) + ([#.Nat structure.sum] + [#.Tag structure.tagged-sum]) + + (#.Tag tag) + (structure.tagged-sum compile tag (' [])) + + (^ (#.Tuple (list))) + primitive.unit + + (^ (#.Tuple (list singleton))) + (compile singleton) + + (^ (#.Tuple elems)) + (structure.product compile elems) + + (^ (#.Record pairs)) + (structure.record compile pairs) + + _ + (else code'))) + +(def: (compile|others compile code') + (-> Phase (-> (Code' (Ann Cursor)) (Operation Analysis))) + (case code' + (#.Identifier reference) + (//reference.reference reference) + + (^ (#.Form (list [_ (#.Record branches)] input))) + (case.case compile input branches) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (extension.apply compile [extension-name extension-args]) + + (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] + [_ (#.Identifier ["" arg-name])]))] + body))) + (function.function compile function-name arg-name body) + + (^ (#.Form (list& functionC argsC+))) + (do ///.monad + [[functionT functionA] (type.with-inference + (compile functionC))] + (case functionA + (#//.Reference (#reference.Constant def-name)) + (do @ + [?macro (extension.lift (macro.find-macro def-name))] + (case ?macro + (#.Some macro) + (do @ + [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] + (compile expansion)) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (///.throw unrecognized-syntax [.dummy-cursor code']))) + (def: #export (compile code) Phase - (do ///.monad - [expectedT (extension.lift macro.expected-type)] - (let [[cursor code'] code] - ## The cursor must be set in the state for the sake - ## of having useful error messages. - (//.with-cursor cursor - (case code' - (^template [<tag> <analyser>] - (<tag> value) - (<analyser> value)) - ([#.Bit primitive.bit] - [#.Nat primitive.nat] - [#.Int primitive.int] - [#.Rev primitive.rev] - [#.Frac primitive.frac] - [#.Text primitive.text]) - - (^template [<tag> <analyser>] - (^ (#.Form (list& [_ (<tag> tag)] - values))) - (case values - (#.Cons value #.Nil) - (<analyser> compile tag value) - - _ - (<analyser> compile tag (` [(~+ values)])))) - ([#.Nat structure.sum] - [#.Tag structure.tagged-sum]) - - (#.Tag tag) - (structure.tagged-sum compile tag (' [])) - - (^ (#.Tuple (list))) - primitive.unit - - (^ (#.Tuple (list singleton))) - (compile singleton) - - (^ (#.Tuple elems)) - (structure.product compile elems) - - (^ (#.Record pairs)) - (structure.record compile pairs) - - (#.Identifier reference) - (//reference.reference reference) - - (^ (#.Form (list [_ (#.Record branches)] input))) - (case.case compile input branches) - - (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) - (extension.apply "Analysis" compile [extension-name extension-args]) - - (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] - [_ (#.Identifier ["" arg-name])]))] - body))) - (function.function compile function-name arg-name body) - - (^ (#.Form (list& functionC argsC+))) - (do @ - [[functionT functionA] (type.with-inference - (compile functionC))] - (case functionA - (#//.Reference (#reference.Constant def-name)) - (do @ - [?macro (extension.lift (macro.find-macro def-name))] - (case ?macro - (#.Some macro) - (do @ - [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] - (compile expansion)) - - _ - (function.apply compile functionT functionA argsC+))) - - _ - (function.apply compile functionT functionA argsC+))) - - _ - (///.throw unrecognized-syntax code) - ))))) + (let [[cursor code'] code] + ## The cursor must be set in the state for the sake + ## of having useful error messages. + (//.with-cursor cursor + (compile|primitive (compile|structure compile (compile|others compile)) + code')))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux b/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux index b46983293..b65b6bc96 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux @@ -6,7 +6,6 @@ [".A" type] ["/." //]]) -## [Analysers] (do-template [<name> <type> <tag>] [(def: #export (<name> value) (-> <type> (Operation Analysis)) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux index 6991c67f7..3fb066259 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux @@ -6,15 +6,16 @@ ["." state]] [data ["." name] - ["." number] ["." product] ["." maybe] ["." error] + [number + ["." nat]] [text format] [collection ["." list ("#/." functor)] - ["dict" dictionary (#+ Dictionary)]]] + ["." dictionary (#+ Dictionary)]]] ["." type ["." check]] ["." macro @@ -311,23 +312,23 @@ (wrap []) (///.throw record-size-mismatch [size-ts size-record recordT record])) #let [tuple-range (list.indices size-ts) - tag->idx (dict.from-list name.hash (list.zip2 tag-set tuple-range))] + tag->idx (dictionary.from-list name.hash (list.zip2 tag-set tuple-range))] idx->val (monad.fold @ (function (_ [key val] idx->val) (do @ [key (extension.lift (macro.normalize key))] - (case (dict.get key tag->idx) + (case (dictionary.get key tag->idx) (#.Some idx) - (if (dict.contains? idx idx->val) + (if (dictionary.contains? idx idx->val) (///.throw cannot-repeat-tag [key record]) - (wrap (dict.put idx val idx->val))) + (wrap (dictionary.put idx val idx->val))) #.None (///.throw tag-does-not-belong-to-record [key recordT])))) (: (Dictionary Nat Code) - (dict.new number.hash)) + (dictionary.new nat.hash)) record) - #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) + #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dictionary.get idx idx->val))) tuple-range)]] (wrap [ordered-tuple recordT])) )) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux index 0654e79c4..3e44b42f4 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux @@ -561,14 +561,18 @@ (def: (java-type-to-class jvm-type) (-> java/lang/reflect/Type (Operation Text)) - (cond (host.instance? Class jvm-type) - (/////wrap (Class::getName (:coerce Class jvm-type))) + (<| (case (host.check Class jvm-type) + (#.Some jvm-type) + (/////wrap (Class::getName jvm-type)) - (host.instance? ParameterizedType jvm-type) - (java-type-to-class (ParameterizedType::getRawType (:coerce ParameterizedType jvm-type))) + _) + (case (host.check ParameterizedType jvm-type) + (#.Some jvm-type) + (java-type-to-class (ParameterizedType::getRawType jvm-type)) - ## else - (////.throw cannot-convert-to-a-class jvm-type))) + _) + ## else + (////.throw cannot-convert-to-a-class jvm-type))) (type: Mappings (Dictionary Text Type)) @@ -577,8 +581,9 @@ (def: (java-type-to-lux-type mappings java-type) (-> Mappings java/lang/reflect/Type (Operation Type)) - (cond (host.instance? TypeVariable java-type) - (let [var-name (TypeVariable::getName (:coerce TypeVariable java-type))] + (<| (case (host.check TypeVariable java-type) + (#.Some java-type) + (let [var-name (TypeVariable::getName java-type)] (case (dictionary.get var-name mappings) (#.Some var-type) (/////wrap var-type) @@ -586,17 +591,20 @@ #.None (////.throw unknown-type-var var-name))) - (host.instance? WildcardType java-type) - (let [java-type (:coerce WildcardType java-type)] - (case [(array.read 0 (WildcardType::getUpperBounds java-type)) - (array.read 0 (WildcardType::getLowerBounds java-type))] - (^or [(#.Some bound) _] [_ (#.Some bound)]) - (java-type-to-lux-type mappings bound) - - _ - (/////wrap Any))) - - (host.instance? Class java-type) + _) + (case (host.check WildcardType java-type) + (#.Some java-type) + (case [(array.read 0 (WildcardType::getUpperBounds java-type)) + (array.read 0 (WildcardType::getLowerBounds java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) + (java-type-to-lux-type mappings bound) + + _ + (/////wrap Any)) + + _) + (case (host.check Class java-type) + (#.Some java-type) (let [java-type (:coerce (Class Object) java-type) class-name (Class::getName java-type)] (/////wrap (case (array.size (Class::getTypeParameters java-type)) @@ -609,11 +617,13 @@ (list/map (|>> (n/* 2) inc #.Parameter)) (#.Primitive class-name) (type.univ-q arity))))) - - (host.instance? ParameterizedType java-type) - (let [java-type (:coerce ParameterizedType java-type) - raw (ParameterizedType::getRawType java-type)] - (if (host.instance? Class raw) + + _) + (case (host.check ParameterizedType java-type) + (#.Some java-type) + (let [raw (ParameterizedType::getRawType java-type)] + (case (host.check Class raw) + (#.Some raw) (do ////.monad [paramsT (|> java-type ParameterizedType::getActualTypeArguments @@ -621,17 +631,22 @@ (monad.map @ (java-type-to-lux-type mappings)))] (/////wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) paramsT))) - (////.throw jvm-type-is-not-a-class raw))) - (host.instance? GenericArrayType java-type) + _ + (////.throw jvm-type-is-not-a-class raw))) + + _) + (case (host.check GenericArrayType java-type) + (#.Some java-type) (do ////.monad - [innerT (|> (:coerce GenericArrayType java-type) + [innerT (|> java-type GenericArrayType::getGenericComponentType (java-type-to-lux-type mappings))] (wrap (#.Primitive "#Array" (list innerT)))) - - ## else - (////.throw cannot-convert-to-a-lux-type java-type))) + + _) + ## else + (////.throw cannot-convert-to-a-lux-type java-type))) (def: (correspond-type-params class type) (-> (Class Object) Type (Operation Mappings)) @@ -900,23 +915,36 @@ (def: (java-type-to-parameter type) (-> java/lang/reflect/Type (Operation Text)) - (cond (host.instance? Class type) - (/////wrap (Class::getName (:coerce Class type))) - - (host.instance? ParameterizedType type) - (java-type-to-parameter (ParameterizedType::getRawType (:coerce ParameterizedType type))) - - (or (host.instance? TypeVariable type) - (host.instance? WildcardType type)) + (<| (case (host.check Class type) + (#.Some type) + (/////wrap (Class::getName type)) + + _) + (case (host.check ParameterizedType type) + (#.Some type) + (java-type-to-parameter (ParameterizedType::getRawType type)) + + _) + (case (host.check TypeVariable type) + (#.Some type) (/////wrap "java.lang.Object") - - (host.instance? GenericArrayType type) + + _) + (case (host.check WildcardType type) + (#.Some type) + (/////wrap "java.lang.Object") + + _) + (case (host.check GenericArrayType type) + (#.Some type) (do ////.monad - [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType (:coerce GenericArrayType type)))] + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType type))] (wrap (format componentP "[]"))) - - ## else - (////.throw cannot-convert-to-a-parameter type))) + + _) + + ## else + (////.throw cannot-convert-to-a-parameter type))) (type: Method-Style #Static diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux index 29602faf7..3d944b995 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux @@ -18,10 +18,25 @@ ["." analysis ["." module] ["." type]] - ["." synthesis] + ["." synthesis (#+ Synthesis)] ["." translation] ["." statement (#+ Operation Handler Bundle)]]]) +## TODO: Inline "evaluate!'" into "evaluate!" ASAP +(def: (evaluate!' translate code//type codeS) + (All [anchor expression statement] + (-> (translation.Phase anchor expression statement) + Type + Synthesis + (Operation anchor expression statement [Type expression Any]))) + (statement.lift-translation + (translation.with-buffer + (do ///.monad + [codeT (translate codeS) + count translation.next + codeV (translation.evaluate! (format "evaluate" (%n count)) codeT)] + (wrap [code//type codeT codeV]))))) + (def: (evaluate! type codeC) (All [anchor expression statement] (-> Type Code (Operation anchor expression statement [Type expression Any]))) @@ -39,15 +54,24 @@ (wrap [type codeA])))))) codeS (statement.lift-synthesis (synthesize codeA))] - (statement.lift-translation - (translation.with-buffer - (do @ - [codeT (translate codeS) - count translation.next - codeV (translation.evaluate! (format "evaluate" (%n count)) codeT)] - (wrap [code//type codeT codeV])))))) - -(def: (define! name ?type codeC) + (evaluate!' translate code//type codeS))) + +## TODO: Inline "definition'" into "definition" ASAP +(def: (definition' translate name code//type codeS) + (All [anchor expression statement] + (-> (translation.Phase anchor expression statement) + Name + Type + Synthesis + (Operation anchor expression statement [Type expression Text Any]))) + (statement.lift-translation + (translation.with-buffer + (do ///.monad + [codeT (translate codeS) + codeN+V (translation.define! name codeT)] + (wrap [code//type codeT codeN+V]))))) + +(def: (definition name ?type codeC) (All [anchor expression statement] (-> Name (Maybe Type) Code (Operation anchor expression statement [Type expression Text Any]))) @@ -74,12 +98,23 @@ (wrap [code//type codeA])))))) codeS (statement.lift-synthesis (synthesize codeA))] - (statement.lift-translation - (translation.with-buffer - (do @ - [codeT (translate codeS) - codeN+V (translation.define! name codeT)] - (wrap [code//type codeT codeN+V])))))) + (definition' translate name code//type codeS))) + +(def: (define short-name type annotations value) + (All [anchor expression statement] + (-> Text Type Code Any + (Operation anchor expression statement Any))) + (statement.lift-analysis + (do ///.monad + [_ (module.define short-name [type annotations value])] + (if (macro.type? annotations) + (case (macro.declared-tags annotations) + #.Nil + (wrap []) + + tags + (module.declare-tags tags (macro.export? annotations) (:coerce Type value))) + (wrap []))))) (def: lux::def Handler @@ -91,24 +126,13 @@ (//.lift macro.current-module-name)) #let [full-name [current-module short-name]] [_ annotationsT annotationsV] (evaluate! Code annotationsC) - #let [annotationsV (:coerce Code annotationsV) - type-definition? (macro.type? annotationsV)] - [value//type valueT valueN valueV] (define! full-name - (if type-definition? - (#.Some Type) - #.None) - valueC) - _ (statement.lift-analysis - (do @ - [_ (module.define short-name [value//type annotationsV valueV])] - (if type-definition? - (case (macro.declared-tags annotationsV) - #.Nil - (wrap []) - - tags - (module.declare-tags tags (macro.export? annotationsV) (:coerce Type valueV))) - (wrap [])))) + #let [annotationsV (:coerce Code annotationsV)] + [value//type valueT valueN valueV] (..definition full-name + (if (macro.type? annotationsV) + (#.Some Type) + #.None) + valueC) + _ (..define short-name value//type annotationsV valueV) #let [_ (log! (format "Definition " (%name full-name)))]] (statement.lift-translation (translation.learn full-name valueN))) diff --git a/stdlib/source/lux/tool/compiler/phase/statement/total.lux b/stdlib/source/lux/tool/compiler/phase/statement/total.lux index c494b01c6..542be5408 100644 --- a/stdlib/source/lux/tool/compiler/phase/statement/total.lux +++ b/stdlib/source/lux/tool/compiler/phase/statement/total.lux @@ -28,7 +28,7 @@ Phase (case code (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) - (extension.apply "Statement" phase [name inputs]) + (extension.apply phase [name inputs]) (^ [_ (#.Form (list& macro inputs))]) (do ///.monad diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux index b1890688d..7c3f2e3ed 100644 --- a/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux @@ -2,7 +2,7 @@ [lux #* [control [equivalence (#+ Equivalence)] - pipe + [pipe (#+ when> new> case>)] ["." monad (#+ do)]] [data ["." product] @@ -34,26 +34,26 @@ (^template [<from> <to>] (<from> value) - (///map (|>> (#//.Seq (#//.Test (|> value <to>)))) - thenC)) + (////map (|>> (#//.Seq (#//.Test (|> value <to>)))) + thenC)) ([#analysis.Bit #//.Bit] [#analysis.Nat (<| #//.I64 .i64)] [#analysis.Int (<| #//.I64 .i64)] [#analysis.Rev (<| #//.I64 .i64)] [#analysis.Frac #//.F64] [#analysis.Text #//.Text])) - + (#analysis.Bind register) (<| (:: ///.monad map (|>> (#//.Seq (#//.Bind register)))) //.with-new-local thenC) (#analysis.Complex (#analysis.Variant [lefts right? value-pattern])) - (<| (///map (|>> (#//.Seq (#//.Access (#//.Side (if right? - (#.Right lefts) - (#.Left lefts))))))) + (<| (////map (|>> (#//.Seq (#//.Access (#//.Side (if right? + (#.Right lefts) + (#.Left lefts))))))) (path' value-pattern end?) - (when (not end?) (///map ..clean-up)) + (when> [(new> (not end?) [])] [(////map ..clean-up)]) thenC) (#analysis.Complex (#analysis.Tuple tuple)) @@ -61,18 +61,19 @@ (list/fold (function (_ [tuple::lefts tuple::member] nextC) (let [right? (n/= tuple::last tuple::lefts) end?' (and end? right?)] - (<| (///map (|>> (#//.Seq (#//.Access (#//.Member (if right? - (#.Right (dec tuple::lefts)) - (#.Left tuple::lefts))))))) + (<| (////map (|>> (#//.Seq (#//.Access (#//.Member (if right? + (#.Right (dec tuple::lefts)) + (#.Left tuple::lefts))))))) (path' tuple::member end?') - (when (not end?') (///map ..clean-up)) + (when> [(new> (not end?') [])] [(////map ..clean-up)]) nextC))) thenC - (list.reverse (list.enumerate tuple)))))) + (list.reverse (list.enumerate tuple)))) + )) (def: #export (path synthesize pattern bodyA) (-> Phase Pattern Analysis (Operation Path)) - (path' pattern true (///map (|>> #//.Then) (synthesize bodyA)))) + (path' pattern true (////map (|>> #//.Then) (synthesize bodyA)))) (def: #export (weave leftP rightP) (-> Path Path Path) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux index ac6a82ab8..b19488235 100644 --- a/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux @@ -2,7 +2,7 @@ [lux (#- primitive) [control ["." monad (#+ do)] - pipe] + [pipe (#+ case>)]] [data ["." maybe] ["." error] @@ -42,7 +42,7 @@ Phase (case analysis (#analysis.Primitive analysis') - (///wrap (#//.Primitive (..primitive analysis'))) + (////wrap (#//.Primitive (..primitive analysis'))) (#analysis.Structure structure) (case structure @@ -54,10 +54,10 @@ (#analysis.Tuple tuple) (|> tuple (monad.map ///.monad phase) - (:: ///.monad map (|>> //.tuple)))) + (////map (|>> //.tuple)))) (#analysis.Reference reference) - (///wrap (#//.Reference reference)) + (////wrap (#//.Reference reference)) (#analysis.Case inputA branchesAB+) (case.synthesize phase inputA branchesAB+) @@ -73,7 +73,7 @@ (#analysis.Extension name args) (function (_ state) - (|> (extension.apply "Synthesis" phase [name args]) + (|> (extension.apply phase [name args]) (///.run' state) (case> (#error.Success output) (#error.Success output) @@ -83,4 +83,7 @@ (do ///.monad [argsS+ (monad.map @ phase args)] (wrap (#//.Extension [name argsS+]))))))) + + _ + (////wrap (undefined)) )) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux index ce9efe59b..49764fc08 100644 --- a/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux @@ -62,7 +62,7 @@ (-> Environment Register (Operation Variable)) (case (list.nth register environment) (#.Some aliased) - (///wrap aliased) + (////wrap aliased) #.None (///.throw cannot-find-foreign-variable-in-environment [register environment]))) @@ -71,7 +71,7 @@ (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) (case path (#//.Bind register) - (///wrap (#//.Bind (inc register))) + (////wrap (#//.Bind (inc register))) (^template [<tag>] (<tag> left right) @@ -84,10 +84,10 @@ (#//.Then thenS) (|> thenS grow - (///map (|>> #//.Then))) + (////map (|>> #//.Then))) _ - (///wrap path))) + (////wrap path))) (def: (grow-sub-environment super sub) (-> Environment Environment (Operation Environment)) @@ -95,7 +95,7 @@ (function (_ variable) (case variable (#reference.Local register) - (///wrap (#reference.Local (inc register))) + (////wrap (#reference.Local (inc register))) (#reference.Foreign register) (find-foreign super register))) @@ -109,30 +109,30 @@ (#analysis.Variant [lefts right? subS]) (|> subS (grow environment) - (///map (|>> [lefts right?] //.variant))) + (////map (|>> [lefts right?] //.variant))) (#analysis.Tuple membersS+) (|> membersS+ (monad.map ///.monad (grow environment)) - (///map (|>> //.tuple)))) + (////map (|>> //.tuple)))) (^ (..self-reference)) - (///wrap (//.function/apply [expression (list (//.variable/local 1))])) + (////wrap (//.function/apply [expression (list (//.variable/local 1))])) (#//.Reference reference) (case reference (#reference.Variable variable) (case variable (#reference.Local register) - (///wrap (//.variable/local (inc register))) + (////wrap (//.variable/local (inc register))) (#reference.Foreign register) (|> register (find-foreign environment) - (///map (|>> //.variable)))) + (////map (|>> //.variable)))) (#reference.Constant constant) - (///wrap expression)) + (////wrap expression)) (#//.Control control) (case control @@ -168,7 +168,7 @@ (#//.Recur argumentsS+) (|> argumentsS+ (monad.map ///.monad (grow environment)) - (///map (|>> //.loop/recur)))) + (////map (|>> //.loop/recur)))) (#//.Function function) (case function @@ -180,8 +180,8 @@ (#//.Apply funcS argsS+) (case funcS (^ (//.function/apply [(..self-reference) pre-argsS+])) - (///wrap (//.function/apply [(..self-reference) - (list/compose pre-argsS+ argsS+)])) + (////wrap (//.function/apply [(..self-reference) + (list/compose pre-argsS+ argsS+)])) _ (do ///.monad @@ -192,10 +192,10 @@ (#//.Extension name argumentsS+) (|> argumentsS+ (monad.map ///.monad (grow environment)) - (///map (|>> (#//.Extension name)))) + (////map (|>> (#//.Extension name)))) _ - (///wrap expression))) + (////wrap expression))) (def: #export (abstraction phase environment bodyA) (-> Phase Environment Analysis (Operation Synthesis)) |