diff options
Diffstat (limited to '')
31 files changed, 1807 insertions, 1028 deletions
diff --git a/lux-bootstrapper/src/lux/analyser/proc/jvm.clj b/lux-bootstrapper/src/lux/analyser/proc/jvm.clj index cc77bf72c..78362601d 100644 --- a/lux-bootstrapper/src/lux/analyser/proc/jvm.clj +++ b/lux-bootstrapper/src/lux/analyser/proc/jvm.clj @@ -854,7 +854,8 @@ =fields (&/map% (partial analyse-field analyse class-env) ?fields) _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) - _ (check-method-completion all-supers =methods) + ;; TODO: Uncomment + ;; _ (check-method-completion all-supers =methods) _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$Nil &/$None) _ &/pop-dummy-name :let [_ (println 'CLASS full-name)] @@ -869,7 +870,8 @@ (defn- analyse-methods [analyse class-decl all-supers methods] (|do [=methods (&/map% (partial analyse-method analyse class-decl &/$Nil all-supers) methods) - _ (check-method-completion all-supers =methods) + ;; TODO: Uncomment + ;; _ (check-method-completion all-supers =methods) =captured &&env/captured-vars] (return (&/T [=methods =captured])))) @@ -878,14 +880,16 @@ scope &/get-scope-name] (return (&/T [module scope])))) -(let [default-<init> (&/$ConstructorMethodSyntax (&/T [&/$PublicPM - false - &/$Nil - &/$Nil - &/$Nil - &/$Nil - &/$Nil - (&/$Tuple &/$Nil)])) +(let [default-<init> (fn [ctor-args] + (&/$ConstructorMethodSyntax (&/T [&/$PublicPM ;; privacy-modifier + false ;; strict + &/$Nil ;; anns + &/$Nil ;; gvars + &/$Nil ;; exceptions + &/$Nil ;; inputs + ctor-args ;; ctor-args + (&/$Tuple &/$Nil) ;; body + ]))) captured-slot-class "java.lang.Object" captured-slot-type (&/$GenericClass captured-slot-class &/$Nil)] (defn- analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] @@ -902,7 +906,7 @@ (return (&/T [arg-type =arg-term]))))) ctor-args) _ (->> methods - (&/$Cons default-<init>) + (&/$Cons (default-<init> =ctor-args)) (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$Nil)) [=methods =captured] (let [all-supers (&/$Cons super-class interfaces)] (analyse-methods analyse class-type-decl all-supers methods)) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj b/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj index 034d503a7..a1039f0b3 100644 --- a/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj +++ b/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj @@ -407,7 +407,7 @@ (let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") <init>-return "V"] (defn ^:private anon-class-<init>-signature [env] - (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + (str "(" (->> clo-field-sig (&/|repeat (&/|length env)) (&/fold str "")) ")" <init>-return)) (defn ^:private add-anon-class-<init> [^ClassWriter class-writer compile class-name super-class env ctor-args] diff --git a/lux-bootstrapper/src/lux/host.clj b/lux-bootstrapper/src/lux/host.clj index 562d582f6..4da818db2 100644 --- a/lux-bootstrapper/src/lux/host.clj +++ b/lux-bootstrapper/src/lux/host.clj @@ -273,15 +273,19 @@ (def init-method-name "<init>") (defn ^:private dummy-ctor [^MethodVisitor writer real-name store-name super-class ctor-args] - (|let [ctor-arg-types (->> ctor-args (&/|map (comp &host-generics/->type-signature (comp (partial ->dummy-type real-name store-name) &/|first))) (&/fold str ""))] + (|let [ctor-arg-types (->> ctor-args + (&/|map (comp &host-generics/gclass->signature (comp (partial ->dummy-type real-name store-name) &/|first))) + (&/fold str ""))] (doto writer (.visitVarInsn Opcodes/ALOAD 0) (-> (doto (dummy-value arg-type) - (-> (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name arg-type)) + (-> (.visitTypeInsn Opcodes/CHECKCAST arg-type) (->> (when (not (primitive-jvm-type? arg-type)))))) (->> (doseq [ctor-arg (&/->seq ctor-args) - :let [;; arg-term (&/|first ctor-arg) - arg-type (->dummy-type real-name store-name (&/|first ctor-arg))]]))) + :let [arg-type (->> ctor-arg + &/|first + (->dummy-type real-name store-name) + &host-generics/gclass->class-name)]]))) (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V")) (.visitInsn Opcodes/RETURN)))) @@ -289,7 +293,12 @@ (|case method-def (&/$ConstructorMethodSyntax =privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body) (|let [=output (&/$GenericClass "void" (&/|list)) - method-decl [init-method-name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + method-decl [init-method-name + =anns + =gvars + (&/|map (partial ->dummy-type real-name store-name) =exceptions) + (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) + (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method-name @@ -302,7 +311,12 @@ (.visitEnd))) (&/$VirtualMethodSyntax =name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + (|let [method-decl [=name + =anns + =gvars + (&/|map (partial ->dummy-type real-name store-name) =exceptions) + (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) + (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC (if =final? Opcodes/ACC_FINAL 0)) @@ -316,7 +330,12 @@ (.visitEnd))) (&/$OverridenMethodSyntax =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + (|let [method-decl [=name + =anns + =gvars + (&/|map (partial ->dummy-type real-name store-name) =exceptions) + (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) + (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class Opcodes/ACC_PUBLIC =name @@ -329,7 +348,12 @@ (.visitEnd))) (&/$StaticMethodSyntax =name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + (|let [method-decl [=name + =anns + =gvars + (&/|map (partial ->dummy-type real-name store-name) =exceptions) + (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) + (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) =name @@ -342,7 +366,12 @@ (.visitEnd))) (&/$AbstractMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + (|let [method-decl [=name + =anns + =gvars + (&/|map (partial ->dummy-type real-name store-name) =exceptions) + (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) + (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) =name @@ -352,7 +381,12 @@ (.visitEnd))) (&/$NativeMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) - (|let [method-decl [=name =anns =gvars (&/|map (partial ->dummy-type real-name store-name) =exceptions) (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) (->dummy-type real-name store-name =output)] + (|let [method-decl [=name + =anns + =gvars + (&/|map (partial ->dummy-type real-name store-name) =exceptions) + (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) + (->dummy-type real-name store-name =output)] [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE) =name diff --git a/lux-js/source/program.lux b/lux-js/source/program.lux index 171f92c6e..52e923892 100644 --- a/lux-js/source/program.lux +++ b/lux-js/source/program.lux @@ -35,7 +35,7 @@ ["_" js]] [tool [compiler - [phase (#+ Operation Phase)] + ["." phase (#+ Operation Phase)] [reference [variable (#+ Register)]] [language @@ -58,6 +58,7 @@ [default ["." platform (#+ Platform)]] [meta + [archive (#+ Archive)] ["." packager #_ ["#" script]]]]]] [program @@ -553,6 +554,19 @@ (..evaluate! context (_.var (reference.artifact context))))))))) )}) +(def: (phase_wrapper archive) + (-> Archive (runtime.Operation platform.Phase_Wrapper)) + (do phase.monad + [] + (wrap (:coerce platform.Phase_Wrapper + (for {## The implementation for @.old is technically incorrect. + ## However, the JS compiler runs fast enough on Node to be fully hosted there. + ## And running the JS compiler on the JVM (on top of Nashorn) is impractically slow. + ## This means that in practice, only the @.js implementation matters. + ## And since no cross-language boundary needs to be handled, it's a correct implementation. + @.old (|>>) + @.js (|>>)}))))) + (def: platform (IO (Platform [Register Text] _.Expression _.Statement)) (do io.monad @@ -561,6 +575,7 @@ #platform.host host #platform.phase js.generate #platform.runtime runtime.generate + #platform.phase_wrapper ..phase_wrapper #platform.write (|>> _.code (\ utf8.codec encode))}))) (def: (program context program) @@ -576,8 +591,8 @@ (_.string ""))))) (for {@.old - (def: extender - Extender + (def: (extender phase_wrapper) + (-> platform.Phase_Wrapper Extender) ## TODO: Stop relying on coercions ASAP. (<| (:coerce Extender) (function (@self handler)) @@ -598,7 +613,7 @@ (|> (array.new 5) (: (Array java/lang/Object)) (array.write! 0 name) - (array.write! 1 (to_js phase)) + (array.write! 1 (:coerce java/lang/Object (extender phase))) (array.write! 2 (to_js archive)) (array.write! 3 (to_js parameters)) (array.write! 4 (to_js state))) @@ -606,8 +621,8 @@ (lux_object (:coerce java/lang/Object output))))) @.js - (def: (extender handler) - Extender + (def: (extender phase_wrapper handler) + (-> platform.Phase_Wrapper Extender) (:assume handler))}) (def: (declare_success! _) @@ -630,7 +645,7 @@ analysis.bundle ..platform generation.bundle - extension/bundle.empty + (function.constant extension/bundle.empty) ..program [(& Register Text) _.Expression _.Statement] ..extender diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux index 4d5d88548..7b3235c06 100644 --- a/lux-jvm/source/luxc/lang/directive/jvm.lux +++ b/lux-jvm/source/luxc/lang/directive/jvm.lux @@ -369,7 +369,7 @@ (#/.Return instruction) (..return instruction))) (def: (instruction instruction) - (-> (/.Instruction org/objectweb/asm/Label) Inst) + (-> (/.Instruction Inst org/objectweb/asm/Label) Inst) (case instruction #/.NOP _.NOP (#/.Constant instruction) (..constant instruction) @@ -381,7 +381,8 @@ (#/.Local instruction) (..local instruction) (#/.Stack instruction) (..stack instruction) (#/.Comparison instruction) (..comparison instruction) - (#/.Control instruction) (..control instruction))) + (#/.Control instruction) (..control instruction) + (#/.Embedded embedded) embedded)) (type: Mapping (Dictionary /.Label org/objectweb/asm/Label)) @@ -460,9 +461,13 @@ )) (def: (relabel_instruction [mapping instruction]) - (Re_labeler /.Instruction) + (Re_labeler (/.Instruction Inst)) (case instruction - #/.NOP [mapping #/.NOP] + (#/.Embedded embedded) + [mapping (#/.Embedded embedded)] + + #/.NOP + [mapping #/.NOP] (^template [<tag>] [(<tag> instruction) @@ -482,10 +487,10 @@ [mapping (#/.Control instruction)]))) (def: (relabel_bytecode [mapping bytecode]) - (Re_labeler /.Bytecode) + (Re_labeler (/.Bytecode Inst)) (row@fold (function (_ input [mapping output]) - (let [[mapping input] (..relabel_instruction [mapping input])] - [mapping (row.add input output)])) + (let [[mapping input'] (..relabel_instruction [mapping input])] + [mapping (row.add input' output)])) [mapping (row.row)] bytecode)) @@ -494,7 +499,7 @@ (dictionary.new nat.hash)) (def: bytecode - (-> (/.Bytecode /.Label) jvm.Inst) + (-> (/.Bytecode Inst /.Label) jvm.Inst) (|>> [..fresh] ..relabel_bytecode product.right @@ -502,15 +507,28 @@ row.to_list _.fuse)) -(type: Handler - (generation.Handler jvm.Anchor (/.Bytecode /.Label) jvm.Definition)) +(with_expansions [<anchor> (as_is jvm.Anchor) + <expression> (as_is Inst) + <directive> (as_is jvm.Definition) + <type_vars> (as_is <anchor> <expression> <directive>)] + (type: Handler + ## (generation.Handler jvm.Anchor (/.Bytecode Inst /.Label) jvm.Definition) + (-> extension.Name + (phase.Phase [(extension.Bundle <type_vars>) + (generation.State <type_vars>)] + Synthesis + <expression>) + (phase.Phase [(extension.Bundle <type_vars>) + (generation.State <type_vars>)] + (List Synthesis) + (/.Bytecode Inst /.Label))))) (def: (true_handler extender pseudo) (-> jvm.Extender Any jvm.Handler) (function (_ extension_name phase archive inputs) (do phase.monad [bytecode ((extender pseudo) extension_name phase archive inputs)] - (wrap (..bytecode (:coerce (/.Bytecode /.Label) bytecode)))))) + (wrap (..bytecode (:coerce (/.Bytecode Inst /.Label) bytecode)))))) (def: (def::generation extender) (-> jvm.Extender diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux index dc579c970..96fa95363 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux @@ -7,8 +7,8 @@ ["." exception (#+ exception:)] ["." function] ["<>" parser ("#@." monad) - ["<t>" text] - ["<s>" synthesis (#+ Parser)]]] + ["<.>" text] + ["<.>" synthesis (#+ Parser)]]] [data ["." product] ["." maybe ("#@." functor)] @@ -66,7 +66,7 @@ (template [<name> <category> <parser>] [(def: #export <name> (Parser (Type <category>)) - (<t>.embed <parser> <s>.text))] + (<text>.embed <parser> <synthesis>.text))] [var Var parser.var] [class Class parser.class] @@ -82,7 +82,7 @@ (def: #export object_array (Parser (Type Object)) (do <>.monad - [arrayJT (<t>.embed parser.array <s>.text)] + [arrayJT (<text>.embed parser.array <synthesis>.text)] (case (parser.array? arrayJT) (#.Some elementJT) (case (parser.object? elementJT) @@ -339,7 +339,7 @@ (def: (primitive_array_length_handler jvm_primitive) (-> (Type Primitive) Handler) (..custom - [<s>.any + [<synthesis>.any (function (_ extension_name generate archive arrayS) (do phase.monad [arrayI (generate archive arrayS)] @@ -350,7 +350,7 @@ (def: array::length::object Handler (..custom - [($_ <>.and ..object_array <s>.any) + [($_ <>.and ..object_array <synthesis>.any) (function (_ extension_name generate archive [elementJT arrayS]) (do phase.monad [arrayI (generate archive arrayS)] @@ -374,7 +374,7 @@ (def: array::new::object Handler (..custom - [($_ <>.and ..object <s>.any) + [($_ <>.and ..object <synthesis>.any) (function (_ extension_name generate archive [objectJT lengthS]) (do phase.monad [lengthI (generate archive lengthS)] @@ -400,7 +400,7 @@ (def: array::read::object Handler (..custom - [($_ <>.and ..object_array <s>.any <s>.any) + [($_ <>.and ..object_array <synthesis>.any <synthesis>.any) (function (_ extension_name generate archive [elementJT idxS arrayS]) (do phase.monad [arrayI (generate archive arrayS) @@ -432,7 +432,7 @@ (def: array::write::object Handler (..custom - [($_ <>.and ..object_array <s>.any <s>.any <s>.any) + [($_ <>.and ..object_array <synthesis>.any <synthesis>.any <synthesis>.any) (function (_ extension_name generate archive [elementJT idxS valueS arrayS]) (do phase.monad [arrayI (generate archive arrayS) @@ -525,7 +525,8 @@ (|>> exceptionI _.ATHROW)) -(def: $Class (type.class "java.lang.Class" (list))) +(def: $Class + (type.class "java.lang.Class" (list))) (def: (object::class extension_name generate archive inputs) Handler @@ -542,7 +543,7 @@ (def: object::instance? Handler (..custom - [($_ <>.and <s>.text <s>.any) + [($_ <>.and <synthesis>.text <synthesis>.any) (function (_ extension_name generate archive [class objectS]) (do phase.monad [objectI (generate archive objectS)] @@ -611,7 +612,7 @@ (def: get::static Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text) + [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text) (function (_ extension_name generate archive [class field unboxed]) (do phase.monad [] @@ -625,7 +626,7 @@ (def: put::static Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any) (function (_ extension_name generate archive [class field unboxed valueS]) (do phase.monad [valueI (generate archive valueS) @@ -645,7 +646,7 @@ (def: get::virtual Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) + [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any) (function (_ extension_name generate archive [class field unboxed objectS]) (do phase.monad [objectI (generate archive objectS) @@ -663,7 +664,7 @@ (def: put::virtual Handler (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any) + [($_ <>.and <synthesis>.text <synthesis>.text <synthesis>.text <synthesis>.any <synthesis>.any) (function (_ extension_name generate archive [class field unboxed valueS objectS]) (do phase.monad [valueI (generate archive valueS) @@ -683,11 +684,12 @@ valueI putI))))])) -(type: Input (Typed Synthesis)) +(type: Input + (Typed Synthesis)) (def: input (Parser Input) - (<s>.tuple (<>.and ..value <s>.any))) + (<synthesis>.tuple (<>.and ..value <synthesis>.any))) (def: (generate_input generate archive [valueT valueS]) (-> Phase Archive Input @@ -702,7 +704,8 @@ (wrap [valueT (|>> valueI (_.CHECKCAST valueT))])))) -(def: voidI (_.string synthesis.unit)) +(def: voidI + (_.string synthesis.unit)) (def: (prepare_output outputT) (-> (Type Return) Inst) @@ -716,7 +719,7 @@ (def: invoke::static Handler (..custom - [($_ <>.and ..class <s>.text ..return (<>.some ..input)) + [($_ <>.and ..class <synthesis>.text ..return (<>.some ..input)) (function (_ extension_name generate archive [class method outputT inputsTS]) (do {@ phase.monad} [inputsTI (monad.map @ (generate_input generate archive) inputsTS)] @@ -728,7 +731,7 @@ [(def: <name> Handler (..custom - [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) + [($_ <>.and ..class <synthesis>.text ..return <synthesis>.any (<>.some ..input)) (function (_ extension_name generate archive [class method outputT objectS inputsTS]) (do {@ phase.monad} [objectI (generate archive objectS) @@ -782,37 +785,38 @@ (def: annotation_parameter (Parser (/.Annotation_Parameter Synthesis)) - (<s>.tuple (<>.and <s>.text <s>.any))) + (<synthesis>.tuple (<>.and <synthesis>.text <synthesis>.any))) (def: annotation (Parser (/.Annotation Synthesis)) - (<s>.tuple (<>.and <s>.text (<>.some ..annotation_parameter)))) + (<synthesis>.tuple (<>.and <synthesis>.text (<>.some ..annotation_parameter)))) (def: argument (Parser Argument) - (<s>.tuple (<>.and <s>.text ..value))) + (<synthesis>.tuple (<>.and <synthesis>.text ..value))) (def: overriden_method_definition (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)]) - (<s>.tuple (do <>.monad - [_ (<s>.text! /.overriden_tag) - ownerT ..class - name <s>.text - strict_fp? <s>.bit - annotations (<s>.tuple (<>.some ..annotation)) - vars (<s>.tuple (<>.some ..var)) - self_name <s>.text - arguments (<s>.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (<s>.tuple (<>.some ..class)) - [environment _ _ body] (<s>.function 1 - (<s>.loop (<>.exactly 0 <s>.any) - (<s>.tuple <s>.any)))] - (wrap [environment - [ownerT name - strict_fp? annotations vars - self_name arguments returnT exceptionsT - body]])))) + (<synthesis>.tuple + (do <>.monad + [_ (<synthesis>.text! /.overriden_tag) + ownerT ..class + name <synthesis>.text + strict_fp? <synthesis>.bit + annotations (<synthesis>.tuple (<>.some ..annotation)) + vars (<synthesis>.tuple (<>.some ..var)) + self_name <synthesis>.text + arguments (<synthesis>.tuple (<>.some ..argument)) + returnT ..return + exceptionsT (<synthesis>.tuple (<>.some ..class)) + [environment _ _ body] (<synthesis>.function 1 + (<synthesis>.loop (<>.exactly 0 <synthesis>.any) + (<synthesis>.tuple <synthesis>.any)))] + (wrap [environment + [ownerT name + strict_fp? annotations vars + self_name arguments returnT exceptionsT + body]])))) (def: (normalize_path normalize) (-> (-> Synthesis Synthesis) @@ -978,9 +982,9 @@ (..custom [($_ <>.and ..class - (<s>.tuple (<>.some ..class)) - (<s>.tuple (<>.some ..input)) - (<s>.tuple (<>.some ..overriden_method_definition))) + (<synthesis>.tuple (<>.some ..class)) + (<synthesis>.tuple (<>.some ..input)) + (<synthesis>.tuple (<>.some ..overriden_method_definition))) (function (_ extension_name generate archive [super_class super_interfaces inputsTS overriden_methods]) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/function.lux b/lux-jvm/source/luxc/lang/translation/jvm/function.lux index 0b441c92f..a3583155b 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/function.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/function.lux @@ -30,7 +30,7 @@ [lux [analysis (#+ Environment)] [synthesis (#+ Synthesis Abstraction Apply)] - ["." generation]]] + ["." generation (#+ Context)]]] [meta [archive (#+ Archive)]]]]] [luxc @@ -301,13 +301,22 @@ [instanceI (..instance generate archive classD arity env)] (wrap [functionD instanceI])))) -(def: #export (function generate archive [env arity bodyS]) - (Generator Abstraction) - (do phase.monad +(def: #export (function' forced_context generate archive [env arity bodyS]) + (-> (Maybe Context) (Generator Abstraction)) + (do {! phase.monad} [@begin _.make_label - [function_context bodyI] (generation.with_new_context archive - (generation.with_anchor [@begin 1] - (generate archive bodyS))) + [function_context bodyI] (case forced_context + (#.Some function_context) + (do ! + [without_context (generation.with_anchor [@begin 1] + (generate archive bodyS))] + (wrap [function_context + without_context])) + + #.None + (generation.with_new_context archive + (generation.with_anchor [@begin 1] + (generate archive bodyS)))) #let [function_class (//.class_name function_context)] [functionD instanceI] (..with_function generate archive @begin function_class env arity bodyI) #let [directive [function_class @@ -316,9 +325,18 @@ //.$Function (list) functionD)]] _ (generation.execute! directive) - _ (generation.save! (product.right function_context) directive)] + _ (case forced_context + #.None + (generation.save! (product.right function_context) directive) + + (#.Some function_context) + (wrap []))] (wrap instanceI))) +(def: #export function + (Generator Abstraction) + (..function' #.None)) + (def: #export (call generate archive [functionS argsS]) (Generator Apply) (do {@ phase.monad} diff --git a/lux-jvm/source/program.lux b/lux-jvm/source/program.lux index baa76ac31..9dc641d7f 100644 --- a/lux-jvm/source/program.lux +++ b/lux-jvm/source/program.lux @@ -21,17 +21,24 @@ ["." file] ["#/." program]] [target - [jvm - [bytecode (#+ Bytecode)]]] + ["." jvm #_ + [bytecode (#+ Bytecode)] + ["#/." type + ["#/." box]]]] [tool [compiler + [reference (#+)] + ["." phase] [default ["." platform (#+ Platform)]] [meta + [archive (#+ Archive)] ["." packager #_ ["#" jvm]]] [language [lux + ["$" synthesis (#+ Synthesis)] + ["." generation] [analysis [macro (#+ Expander)]] [phase @@ -62,6 +69,7 @@ ["." jvm ["." runtime] ["." expression] + ["." function] ["#/." program] ["translation" extension]]]]]) @@ -81,6 +89,11 @@ (java/lang/Class java/lang/Object) (ffi.class_for java/lang/Object)) +(def: _apply1_args + (Array (java/lang/Class java/lang/Object)) + (|> (ffi.array (java/lang/Class java/lang/Object) 1) + (ffi.array_write 0 _object_class))) + (def: _apply2_args (Array (java/lang/Class java/lang/Object)) (|> (ffi.array (java/lang/Class java/lang/Object) 2) @@ -111,6 +124,105 @@ (ffi.array_write 1 (:coerce java/lang/Object lux))) apply_method)))) +(def: how_to_wrap_a_phase + Synthesis + (let [java/lang/String (jvm/type.class "java.lang.String" (list)) + <java/lang/Class> (jvm/type.array (jvm/type.class "java.lang.Class" (list))) + java/lang/Object (jvm/type.class "java.lang.Object" (list)) + <java/lang/Object> (jvm/type.array java/lang/Object) + + jvm_type (: (All [c] (-> (jvm/type.Type c) Synthesis)) + (|>> jvm/type.format + $.text)) + class_type (: (-> Text Synthesis) + (function (_ name) + (|> (jvm/type.class name (list)) + jvm_type))) + unwrap_long (: (-> Synthesis Synthesis) + (|>> (list ($.text jvm/type/box.long) + ($.text "long")) + (#$.Extension "jvm object cast"))) + long_to_int (: (-> Synthesis Synthesis) + (|>> (list) + (#$.Extension "jvm conversion long-to-int"))) + literal_nat (: (-> Nat Synthesis) + (|>> .i64 $.i64 unwrap_long long_to_int)) + array_write (: (-> Text Nat Synthesis Synthesis Synthesis) + (function (_ element_class index value array) + ((#$.Extension "jvm array write object" + (list (jvm_type (jvm/type.array (jvm/type.class element_class (list)))) + (literal_nat index) + value + array))))) + object_array (: (-> Text Nat Synthesis) + (function (_ class_name size) + (#$.Extension "jvm array new object" + (list (class_type class_name) + (literal_nat size))))) + class_of (: (-> Synthesis Synthesis) + (function (_ object) + (#$.Extension "jvm member invoke virtual" + (list& (class_type "java.lang.Object") + ($.text "getClass") + (class_type "java.lang.Class") + object + (list))))) + input (: (All [c] (-> (jvm/type.Type c) Synthesis Synthesis)) + (function (_ value_type value) + ($.tuple (list (jvm_type value_type) value)))) + + example_object (#$.Extension "jvm member invoke constructor" + (list& (class_type "java.lang.Object") + (list))) + phase_arity 3 + $phase ($.variable/local 1) + $archive ($.variable/local 2) + $input ($.variable/local 3) + $state ($.variable/local 4) + apply_method (#$.Extension "jvm member invoke virtual" + (list& (class_type "java.lang.Class") + ($.text "getMethod") + (class_type "java.lang.reflect.Method") + (class_of $phase) + (list (input java/lang/String + ($.text runtime.apply_method)) + (input <java/lang/Class> + (|> (object_array "java.lang.Class" phase_arity) + (array_write "java.lang.Class" 0 (class_of example_object)) + (array_write "java.lang.Class" 1 (class_of example_object)) + (array_write "java.lang.Class" 2 (class_of example_object)))))))] + (#$.Extension "jvm member invoke virtual" + (list& (class_type "java.lang.reflect.Method") + ($.text "invoke") + (class_type "java.lang.Object") + apply_method + (list (input java/lang/Object + $phase) + (input <java/lang/Object> + (|> (object_array "java.lang.Object" phase_arity) + (array_write "java.lang.Object" 0 $archive) + (array_write "java.lang.Object" 1 $input) + (array_write "java.lang.Object" 2 $state)))))))) + +(def: (phase_wrapper archive) + (-> Archive (generation.Operation _.Anchor _.Inst _.Definition platform.Phase_Wrapper)) + (do phase.monad + [instanceG (function.function' (#.Some [0 (.nat -1)]) expression.translate archive [(list) 4 ..how_to_wrap_a_phase]) + phase_wrapper (generation.evaluate! [0 (.nat -2)] instanceG)] + (wrap (function (_ phase) + (<| try.assume + (: (Try java/lang/Object)) + (do try.monad + [apply_method (|> phase_wrapper + (:coerce java/lang/Object) + (java/lang/Object::getClass) + (java/lang/Class::getMethod runtime.apply_method _apply1_args))] + (java/lang/reflect/Method::invoke + (:coerce java/lang/Object phase_wrapper) + (|> (ffi.array java/lang/Object 1) + (ffi.array_write 0 (:coerce java/lang/Object phase))) + apply_method))))))) + (def: #export platform ## (IO (Platform Anchor (Bytecode Any) Definition)) (IO (Platform _.Anchor _.Inst _.Definition)) @@ -123,10 +235,11 @@ #platform.phase expression.translate ## #platform.runtime runtime.generate #platform.runtime runtime.translate + #platform.phase_wrapper ..phase_wrapper #platform.write product.right}))) -(def: extender - Extender +(def: (extender phase_wrapper) + (-> platform.Phase_Wrapper Extender) ## TODO: Stop relying on coercions ASAP. (<| (:coerce Extender) (function (@self handler)) @@ -148,7 +261,7 @@ (:coerce java/lang/Object handler) (|> (ffi.array java/lang/Object 5) (ffi.array_write 0 (:coerce java/lang/Object name)) - (ffi.array_write 1 (:coerce java/lang/Object phase)) + (ffi.array_write 1 (:coerce java/lang/Object (phase_wrapper phase))) (ffi.array_write 2 (:coerce java/lang/Object archive)) (ffi.array_write 3 (:coerce java/lang/Object parameters)) (ffi.array_write 4 (:coerce java/lang/Object state))) @@ -173,7 +286,7 @@ ..platform ## generation.bundle translation.bundle - (directive.bundle ..extender) + (|>> ..extender directive.bundle) (jvm/program.program jvm/runtime.class_name) [_.Anchor _.Inst _.Definition] ..extender diff --git a/lux-lua/source/program.lux b/lux-lua/source/program.lux index 40a076e27..6eb8d8485 100644 --- a/lux-lua/source/program.lux +++ b/lux-lua/source/program.lux @@ -8,6 +8,7 @@ ["." try (#+ Try)] ["." exception (#+ exception:)] ["." io (#+ IO io)] + ["." function] [concurrency ["." promise (#+ Promise)]]] [data @@ -17,7 +18,8 @@ [encoding ["." utf8]]] [collection - ["." array (#+ Array)]]] + ["." array (#+ Array)] + ["." list]]] [macro ["." template]] [math @@ -31,7 +33,7 @@ ["_" lua]] [tool [compiler - [phase (#+ Operation Phase)] + ["." phase (#+ Operation Phase)] [reference [variable (#+ Register)]] [language @@ -54,6 +56,7 @@ [default ["." platform (#+ Platform)]] [meta + [archive (#+ Archive)] ["." packager #_ ["#" script]]]]]] [program @@ -115,6 +118,14 @@ ["#::." (new [java/lang/Object])]) + (ffi.import: net/sandius/rembulan/runtime/ReturnBuffer + ["#::." + (setTo [java/lang/Object] void)]) + + (ffi.import: net/sandius/rembulan/runtime/ExecutionContext + ["#::." + (getReturnBuffer [] net/sandius/rembulan/runtime/ReturnBuffer)]) + (ffi.import: net/sandius/rembulan/runtime/LuaFunction) (ffi.import: net/sandius/rembulan/load/ChunkLoader @@ -606,6 +617,153 @@ [_ (run! content)] (run! (_.return (_.var (reference.artifact context))))))))))))}) +(for {@.old + (as_is (exception: #export (invaid_phase_application {partial_application (List Any)} + {arity Nat}) + (exception.report + ["Partial Application" (%.nat (list.size partial_application))] + ["Arity" (%.nat arity)])) + + (def: to_host + (-> Any java/lang/Object) + (|>> (:coerce (Array java/lang/Object)) ..lux_structure (:coerce java/lang/Object))) + + (def: (return ec value) + (-> net/sandius/rembulan/runtime/ExecutionContext Any Any) + (|> ec + net/sandius/rembulan/runtime/ExecutionContext::getReturnBuffer + (net/sandius/rembulan/runtime/ReturnBuffer::setTo (:coerce java/lang/Object value)))) + + (def: (host_phase partial_application phase) + (All [s i o] + (-> (List Any) (Phase [extension.Bundle s] i o) + java/lang/Object)) + (ffi.object [] net/sandius/rembulan/runtime/LuaFunction [] + [] + ## Methods + (net/sandius/rembulan/runtime/LuaFunction + [] (invoke self + {% net/sandius/rembulan/runtime/ExecutionContext}) + void + (<| (..return %) + (host_phase partial_application phase))) + + (net/sandius/rembulan/runtime/LuaFunction + [] (invoke self + {% net/sandius/rembulan/runtime/ExecutionContext} + {input/0 java/lang/Object}) + void + (<| (..return %) + try.assume + (do try.monad + [input/0 (..read input/0)] + (case partial_application + (^ (list partial/0 partial/1)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + partial/0 + partial/1 + input/0))) + + (^ (list partial/0)) + (wrap (host_phase (list partial/0 input/0) phase)) + + (^ (list)) + (wrap (host_phase (list input/0) phase)) + + _ + (exception.throw ..invaid_phase_application [partial_application 2]))))) + + (net/sandius/rembulan/runtime/LuaFunction + [] (invoke self + {% net/sandius/rembulan/runtime/ExecutionContext} + {input/0 java/lang/Object} + {input/1 java/lang/Object}) + void + (<| (..return %) + try.assume + (do try.monad + [input/0 (..read input/0) + input/1 (..read input/1)] + (case partial_application + (^ (list partial/0)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + partial/0 + input/0 + input/1))) + + (^ (list)) + (wrap (host_phase (list input/0 input/1) phase)) + + _ + (exception.throw ..invaid_phase_application [partial_application 2]))))) + + (net/sandius/rembulan/runtime/LuaFunction + [] (invoke self + {% net/sandius/rembulan/runtime/ExecutionContext} + {input/0 java/lang/Object} + {input/1 java/lang/Object} + {input/2 java/lang/Object}) + void + (<| (..return %) + try.assume + (do try.monad + [input/0 (..read input/0) + input/1 (..read input/1) + input/2 (..read input/2)] + (case partial_application + (^ (list)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + input/0 + input/1 + input/2))) + + _ + (exception.throw ..invaid_phase_application [partial_application 3]))))))) + + (def: (extender [state_context executor] phase_wrapper) + (-> Baggage (-> platform.Phase_Wrapper Extender)) + ## TODO: Stop relying on coercions ASAP. + (<| (:coerce Extender) + (function (@self handler)) + (:coerce Handler) + (function (@self name phase)) + (:coerce Phase) + (function (@self archive parameters)) + (:coerce Operation) + (function (@self state)) + (:coerce Try) + try.assume + (:coerce Try) + (do try.monad + [handler (try.from_maybe (..ensure_function handler)) + output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context + (:coerce java/lang/Object handler) + (|> (array.new 5) + (array.write! 0 name) + (array.write! 1 (:coerce java/lang/Object (phase_wrapper phase))) + (array.write! 2 (..to_host archive)) + (array.write! 3 (..to_host parameters)) + (array.write! 4 (..to_host state))) + executor)] + (|> output + (array.read 0) + maybe.assume + (:coerce java/lang/Object) + ..read))))) + + @.lua + (def: (extender phase_wrapper handler) + (-> platform.Phase_Wrapper Extender) + (:assume handler))}) + +(def: (phase_wrapper archive) + (-> Archive (runtime.Operation platform.Phase_Wrapper)) + (do phase.monad + [] + (wrap (:coerce platform.Phase_Wrapper + (for {@.old (..host_phase (list)) + @.lua (|>>)}))))) + (for {@.old (def: platform (IO [Baggage (Platform [Register _.Label] _.Expression _.Statement)]) (do io.monad @@ -615,6 +773,7 @@ #platform.host host #platform.phase lua.generate #platform.runtime runtime.generate + #platform.phase_wrapper ..phase_wrapper #platform.write (|>> _.code (\ utf8.codec encode))}]))) @.lua (def: platform (IO (Platform [Register _.Label] _.Expression _.Statement)) @@ -624,6 +783,7 @@ #platform.host host #platform.phase lua.generate #platform.runtime runtime.generate + #platform.phase_wrapper ..phase_wrapper #platform.write (|>> _.code (\ utf8.codec encode))})))}) (def: (program context program) @@ -633,45 +793,6 @@ runtime.unit) program)))) -(for {@.old - (def: (extender [state_context executor]) - (-> Baggage Extender) - ## TODO: Stop relying on coercions ASAP. - (<| (:coerce Extender) - (function (@self handler)) - (:coerce Handler) - (function (@self name phase)) - (:coerce Phase) - (function (@self archive parameters)) - (:coerce Operation) - (function (@self state)) - (:coerce Try) - try.assume - (:coerce Try) - (do try.monad - [handler (try.from_maybe (..ensure_function handler)) - #let [to_lua (: (-> Any java/lang/Object) - (|>> (:coerce (Array java/lang/Object)) lux_structure (:coerce java/lang/Object)))] - output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context - (:coerce java/lang/Object handler) - (|> (array.new 5) - (array.write! 0 name) - (array.write! 1 (to_lua phase)) - (array.write! 2 (to_lua archive)) - (array.write! 3 (to_lua parameters)) - (array.write! 4 (to_lua state))) - executor)] - (|> output - (array.read 0) - maybe.assume - (:coerce java/lang/Object) - ..read)))) - - @.lua - (def: (extender handler) - Extender - (:assume handler))}) - (def: (declare_success! _) (-> Any (Promise Any)) (promise.future (\ world/program.default exit +0))) @@ -692,7 +813,7 @@ analysis.bundle (io.io platform) generation.bundle - extension/bundle.empty + (function.constant extension/bundle.empty) ..program [(& Register _.Label) _.Expression _.Statement] (for {@.old (..extender baggage) diff --git a/lux-python/source/program.lux b/lux-python/source/program.lux index c014e8386..e1e3e48a3 100644 --- a/lux-python/source/program.lux +++ b/lux-python/source/program.lux @@ -9,6 +9,7 @@ ["." try (#+ Try)] ["." exception (#+ exception:)] ["." io (#+ IO io)] + ["." function] [concurrency ["." promise (#+ Promise)]]] [data @@ -18,7 +19,8 @@ [encoding ["." utf8]]] [collection - ["." array (#+ Array)]]] + ["." array (#+ Array)] + ["." list]]] [macro ["." template]] [math @@ -32,7 +34,7 @@ ["_" python]] [tool [compiler - [phase (#+ Operation Phase)] + ["." phase (#+ Operation Phase)] [reference [variable (#+ Register)]] [language @@ -43,7 +45,7 @@ [analysis [macro (#+ Expander)]] [phase - ["." extension (#+ Bundle Extender Handler) + ["." extension (#+ Extender Handler) ["#/." bundle] ["." analysis #_ ["#" python]] @@ -56,6 +58,7 @@ [default ["." platform (#+ Platform)]] [meta + [archive (#+ Archive)] ["." packager #_ ["#" script]]]]]] [program @@ -334,97 +337,95 @@ [_ (execute! content)] (evaluate! context (_.var (reference.artifact context)))))))))))}) -(def: platform - (IO (Platform Register (_.Expression Any) (_.Statement Any))) - (do io.monad - [host ..host] - (wrap {#platform.&file_system (file.async file.default) - #platform.host host - #platform.phase python.generate - #platform.runtime runtime.generate - #platform.write (|>> _.code (\ utf8.codec encode))}))) - -(def: (program context program) - (Program (_.Expression Any) (_.Statement Any)) - ($_ _.then - (_.import "sys") - (_.when (_.= (_.string "__main__") (_.var "__name__")) - (_.statement (_.apply/2 program - (|> (_.var "sys") (_.the "argv") - ## The first entry in the list will be the program.py file itself - ## so, it must be removed so only the program's arguments are left. - (_.slice_from (_.int +1)) - runtime.lux::program_args) - _.none))))) - (for {@.old - (as_is (exception: #export (cannot_parse_phase_inputs {arity Nat}) + (as_is (exception: #export (invaid_phase_application {partial_application (List Any)} + {arity Nat}) (exception.report + ["Partial Application" (%.nat (list.size partial_application))] ["Arity" (%.nat arity)])) - (def: (host_phase phase) + (def: (host_phase partial_application phase) (All [s i o] - (-> (Phase [Bundle s] i o) + (-> (List Any) (Phase [extension.Bundle s] i o) org/python/core/PyObject)) (ffi.object [] org/python/core/PyObject [] [] ## Methods (org/python/core/PyObject [] (__call__ self - {_ org/python/core/ThreadState} - {input/0 org/python/core/PyObject}) + {inputs [org/python/core/PyObject]} + {keywords [java/lang/String]}) org/python/core/PyObject - (case [(..read input/0)] - [(#try.Success input/0)] - (host_phase (:assume ((:coerce (-> Nat Nat Nat []) phase) - (:coerce Nat input/0)))) - - _ - (error! (exception.construct ..cannot_parse_phase_inputs [1])))) - - (org/python/core/PyObject - [] (__call__ self - {_ org/python/core/ThreadState} - {input/0 org/python/core/PyObject} - {input/1 org/python/core/PyObject}) - org/python/core/PyObject - (case [(..read input/0) (..read input/1)] - [(#try.Success input/0) (#try.Success input/1)] - (host_phase (:assume ((:coerce (-> Nat Nat Nat []) phase) - (:coerce Nat input/0) - (:coerce Nat input/1)))) - - _ - (error! (exception.construct ..cannot_parse_phase_inputs [2])))) + (try.assume + (case (array.to_list inputs) + (^ (list)) + (\ try.monad wrap (host_phase (list) phase)) + + (^ (list input/0)) + (do try.monad + [input/0 (..read input/0)] + (case partial_application + (^ (list partial/0 partial/1)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + partial/0 + partial/1 + input/0))) + + (^ (list partial/0)) + (wrap (host_phase (list partial/0 input/0) phase)) + + (^ (list)) + (wrap (host_phase (list input/0) phase)) + + _ + (exception.throw ..invaid_phase_application [partial_application (array.size inputs)]))) + + (^ (list input/0 input/1)) + (do try.monad + [input/0 (..read input/0) + input/1 (..read input/1)] + (case partial_application + (^ (list partial/0)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + partial/0 + input/0 + input/1))) + + (^ (list)) + (wrap (host_phase (list input/0 input/1) phase)) + + _ + (exception.throw ..invaid_phase_application [partial_application (array.size inputs)]))) + + (^ (list input/0 input/1 input/2)) + (do try.monad + [input/0 (..read input/0) + input/1 (..read input/1) + input/2 (..read input/2)] + (case partial_application + (^ (list)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + input/0 + input/1 + input/2))) + + _ + (exception.throw ..invaid_phase_application [partial_application (array.size inputs)]))) - (org/python/core/PyObject - [] (__call__ self - {_ org/python/core/ThreadState} - {input/0 org/python/core/PyObject} - {input/1 org/python/core/PyObject} - {input/2 org/python/core/PyObject}) - org/python/core/PyObject - (case [(..read input/0) (..read input/1) (..read input/2)] - [(#try.Success input/0) (#try.Success input/1) (#try.Success input/2)] - (..to_host ((:coerce (-> Nat Nat Nat []) phase) - (:coerce Nat input/0) - (:coerce Nat input/1) - (:coerce Nat input/2))) - - _ - (error! (exception.construct ..cannot_parse_phase_inputs [3])))))) + _ + (exception.throw ..invaid_phase_application [partial_application (array.size inputs)])))))) - (def: extender - Extender + (def: (extender phase_wrapper) + (-> platform.Phase_Wrapper Extender) ## TODO: Stop relying on coercions ASAP. (<| (:coerce Extender) - (function (@self handler)) + (function (_ handler)) (:coerce Handler) - (function (@self name phase)) + (function (_ name phase)) (:coerce Phase) - (function (@self archive parameters)) + (function (_ archive parameters)) (:coerce Operation) - (function (@self state)) + (function (_ state)) (:coerce Try) try.assume (:coerce Try) @@ -432,7 +433,7 @@ [handler (try.from_maybe (..ensure_function handler)) output (org/python/core/PyFunction::__call__ (|> (ffi.array org/python/core/PyObject 5) (ffi.array_write 0 (org/python/core/PyString::new name)) - (ffi.array_write 1 (..host_phase phase)) + (ffi.array_write 1 (:coerce org/python/core/PyObject (phase_wrapper phase))) (ffi.array_write 2 (..to_host archive)) (ffi.array_write 3 (..to_host parameters)) (ffi.array_write 4 (..to_host state))) @@ -440,10 +441,41 @@ (..read output))))) @.python - (def: (extender handler) - Extender + (def: (extender phase_wrapper handler) + (-> platform.Phase_Wrapper Extender) (:assume handler))}) +(def: (phase_wrapper archive) + (-> Archive (runtime.Operation platform.Phase_Wrapper)) + (do phase.monad + [] + (wrap (:coerce platform.Phase_Wrapper + (..host_phase (list)))))) + +(def: platform + (IO (Platform Register (_.Expression Any) (_.Statement Any))) + (do io.monad + [host ..host] + (wrap {#platform.&file_system (file.async file.default) + #platform.host host + #platform.phase python.generate + #platform.runtime runtime.generate + #platform.phase_wrapper ..phase_wrapper + #platform.write (|>> _.code (\ utf8.codec encode))}))) + +(def: (program context program) + (Program (_.Expression Any) (_.Statement Any)) + ($_ _.then + (_.import "sys") + (_.when (_.= (_.string "__main__") (_.var "__name__")) + (_.statement (_.apply/2 program + (|> (_.var "sys") (_.the "argv") + ## The first entry in the list will be the program.py file itself + ## so, it must be removed so only the program's arguments are left. + (_.slice_from (_.int +1)) + runtime.lux::program_args) + _.none))))) + (def: (declare_success! _) (-> Any (Promise Any)) (promise.future (\ world/program.default exit +0))) @@ -472,7 +504,7 @@ analysis.bundle ..platform generation.bundle - extension/bundle.empty + (function.constant extension/bundle.empty) ..program [Register (type (_.Expression Any)) diff --git a/lux-ruby/commands.md b/lux-ruby/commands.md index a610080dd..741772d2e 100644 --- a/lux-ruby/commands.md +++ b/lux-ruby/commands.md @@ -28,7 +28,7 @@ cd ~/lux/lux-ruby/ \ ## Compile Lux's Standard Library's tests using a JVM-based compiler. cd ~/lux/stdlib/ \ && lein clean \ -&& time java -jar ~/lux/lux-ruby/jvm_based_compiler.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux \ +&& java -jar ~/lux/lux-ruby/jvm_based_compiler.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux \ && RUBY_THREAD_VM_STACK_SIZE=15700000 ruby ~/lux/stdlib/target/program.rb ``` diff --git a/lux-ruby/source/program.lux b/lux-ruby/source/program.lux index 534a59e70..46ea78666 100644 --- a/lux-ruby/source/program.lux +++ b/lux-ruby/source/program.lux @@ -11,6 +11,7 @@ ["." try (#+ Try)] ["." exception (#+ exception:)] ["." io (#+ IO io)] + ["." function] [concurrency ["." promise (#+ Promise)]] ["<>" parser @@ -22,13 +23,14 @@ [encoding ["." utf8]]] [collection - ["." array (#+ Array)]]] + ["." array (#+ Array)] + ["." list]]] ["." macro [syntax (#+ syntax:)] ["." template] ["." code]] [math - [number + [number (#+ hex) ["n" nat] ["i" int] ["." i64]]] @@ -39,7 +41,7 @@ ["_" ruby]] [tool [compiler - [phase (#+ Operation Phase)] + ["." phase (#+ Operation Phase)] [reference [variable (#+ Register)]] [language @@ -50,7 +52,7 @@ [analysis [macro (#+ Expander)]] [phase - ["." extension (#+ Bundle Extender Handler) + ["." extension (#+ Extender Handler) ["#/." bundle] ["." analysis #_ ["#" ruby]] @@ -63,6 +65,7 @@ [default ["." platform (#+ Platform)]] [meta + [archive (#+ Archive)] ["." packager #_ ["#" script]]]]]] [program @@ -173,7 +176,8 @@ (import: org/jruby/java/proxies/JavaProxy ["#::." - (new [org/jruby/Ruby org/jruby/RubyClass java/lang/Object])]) + (new [org/jruby/Ruby org/jruby/RubyClass java/lang/Object]) + (getObject [] java/lang/Object)]) (import: org/jruby/internal/runtime/methods/DynamicMethod) @@ -198,8 +202,32 @@ ["#::." (new [org/jruby/Ruby])]) +(import: org/jruby/runtime/Block$Type + ["#::." + (#enum PROC)]) + +(import: org/jruby/runtime/Signature + ["#::." + (#static THREE_ARGUMENTS org/jruby/runtime/Signature)]) + +(import: org/jruby/parser/StaticScope) + +(import: org/jruby/parser/StaticScopeFactory + ["#::." + (new [org/jruby/Ruby]) + (getDummyScope [] org/jruby/parser/StaticScope)]) + +(import: org/jruby/runtime/BlockBody) + +(import: org/jruby/runtime/Block + ["#::." + (#static NULL_BLOCK org/jruby/runtime/Block) + (type org/jruby/runtime/Block$Type) + (getBody [] org/jruby/runtime/BlockBody)]) + (import: org/jruby/RubyProc ["#::." + (#static newProc [org/jruby/Ruby org/jruby/runtime/Block org/jruby/runtime/Block$Type] org/jruby/RubyProc) (call [org/jruby/runtime/ThreadContext [org/jruby/runtime/builtin/IRubyObject]] #try org/jruby/runtime/builtin/IRubyObject)]) @@ -248,7 +276,7 @@ value]) _ - (exception.throw ..unknown_kind_of_object host_object))) + (exception.throw ..unknown_kind_of_object [host_object]))) (exception: #export nil_has_no_lux_representation) @@ -259,21 +287,22 @@ (~~ (template [<class> <post_processing>] [(case (ffi.check <class> host_object) (#.Some typed_object) - (|> typed_object <post_processing>) + (`` (|> typed_object (~~ (template.splice <post_processing>)))) _)] - [java/lang/Boolean #try.Success] - [java/lang/Long #try.Success] - [java/lang/Double #try.Success] - [java/lang/String #try.Success] - [[java/lang/Object] #try.Success] - [org/jruby/RubyArray (read_tuple read)] - [org/jruby/RubyHash (read_variant read)] - [org/jruby/RubySymbol #try.Success] - [org/jruby/RubyProc #try.Success] + [java/lang/Boolean [#try.Success]] + [java/lang/Long [#try.Success]] + [java/lang/Double [#try.Success]] + [java/lang/String [#try.Success]] + [[java/lang/Object] [#try.Success]] + [org/jruby/RubyArray [(read_tuple read)]] + [org/jruby/RubyHash [(read_variant read)]] + [org/jruby/RubySymbol [#try.Success]] + [org/jruby/RubyProc [#try.Success]] + [org/jruby/java/proxies/JavaProxy [org/jruby/java/proxies/JavaProxy::getObject #try.Success]] )) - (exception.throw ..unknown_kind_of_object host_object) + (exception.throw ..unknown_kind_of_object [host_object]) ))) (def: ruby_nil @@ -576,9 +605,7 @@ (#try.Failure error)) #.None - (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro)))) - -(def: separator "___") + (exception.throw ..cannot_apply_a_non_function [(:coerce java/lang/Object macro)]))) (def: host (IO (Host _.Expression _.Statement)) @@ -617,6 +644,158 @@ [_ (run! content)] (run! (_.global (reference.artifact context)))))))))) +(for {@.old + (as_is (exception: #export (invaid_phase_application {partial_application (List Any)} + {arity Nat}) + (exception.report + ["Partial Application" (%.nat (list.size partial_application))] + ["Arity" (%.nat arity)])) + + (def: proc_type + org/jruby/runtime/Block$Type + (|> (org/jruby/runtime/Block::NULL_BLOCK) + (org/jruby/runtime/Block::type))) + + (def: phase_block_signature + org/jruby/runtime/Signature + (org/jruby/runtime/Signature::THREE_ARGUMENTS)) + + (def: dummy_static_scope + org/jruby/parser/StaticScope + (|> (org/jruby/parser/StaticScopeFactory::new (!ruby_runtime)) + (org/jruby/parser/StaticScopeFactory::getDummyScope))) + + (def: phase_block_body + org/jruby/runtime/BlockBody + (ffi.object [] org/jruby/runtime/BlockBody [] + [{org/jruby/runtime/Signature ..phase_block_signature}] + ## Methods + (org/jruby/runtime/BlockBody + [] (getFile self) + java/lang/String + "YOLO") + (org/jruby/runtime/BlockBody + [] (getLine self) + int + (ffi.long_to_int (hex "+ABC,123"))) + (org/jruby/runtime/BlockBody + [] (getStaticScope self) + org/jruby/parser/StaticScope + ..dummy_static_scope))) + + (def: (host_phase partial_application phase) + (All [s i o] + (-> (List Any) (Phase [extension.Bundle s] i o) + org/jruby/RubyProc)) + (let [block (ffi.object [] org/jruby/runtime/Block [] + [{org/jruby/runtime/BlockBody ..phase_block_body}] + ## Methods + (org/jruby/runtime/Block + [] (call self + {_ org/jruby/runtime/ThreadContext} + {inputs [org/jruby/runtime/builtin/IRubyObject]} + {_ org/jruby/runtime/Block}) + org/jruby/runtime/builtin/IRubyObject + (<| try.assume + (let [inputs (array.to_list inputs)]) + (case inputs + (^ (list)) + (#try.Success (host_phase partial_application phase)) + + (^ (list input/0)) + (do try.monad + [input/0 (..read (:coerce java/lang/Object input/0))] + (case partial_application + (^ (list)) + (wrap (host_phase (list input/0) phase)) + + (^ (list partial/0)) + (wrap (host_phase (list partial/0 input/0) phase)) + + (^ (list partial/0 partial/1)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + partial/0 + partial/1 + input/0))) + + _ + (exception.throw ..invaid_phase_application [partial_application (list.size inputs)]))) + + (^ (list input/0 input/1)) + (do try.monad + [input/0 (..read (:coerce java/lang/Object input/0)) + input/1 (..read (:coerce java/lang/Object input/1))] + (case partial_application + (^ (list)) + (wrap (host_phase (list input/0 input/1) phase)) + + (^ (list partial/0)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + partial/0 + input/0 + input/1))) + + _ + (exception.throw ..invaid_phase_application [partial_application (list.size inputs)]))) + + (^ (list input/0 input/1 input/2)) + (do try.monad + [input/0 (..read (:coerce java/lang/Object input/0)) + input/1 (..read (:coerce java/lang/Object input/1)) + input/2 (..read (:coerce java/lang/Object input/2))] + (case partial_application + (^ (list)) + (wrap (..to_host ((:coerce (-> Any Any Any Any) phase) + input/0 + input/1 + input/2))) + + _ + (exception.throw ..invaid_phase_application [partial_application (list.size inputs)]))) + + _ + (exception.throw ..invaid_phase_application [partial_application (list.size inputs)])))))] + (org/jruby/RubyProc::newProc (!ruby_runtime) block ..proc_type))) + + (def: (extender phase_wrapper) + (-> platform.Phase_Wrapper Extender) + ## TODO: Stop relying on coercions ASAP. + (<| (:coerce Extender) + (function (@self handler)) + (:coerce Handler) + (function (@self name phase)) + (:coerce Phase) + (function (@self archive parameters)) + (:coerce Operation) + (function (@self state)) + (:coerce Try) + try.assume + (:coerce Try) + (do try.monad + [handler (try.from_maybe (..ensure_macro handler)) + output (org/jruby/RubyProc::call (!ruby_thread_context) + (|> (ffi.array org/jruby/runtime/builtin/IRubyObject 5) + (ffi.array_write 0 (org/jruby/RubyString::newInternalFromJavaExternal (!ruby_runtime) name)) + (ffi.array_write 1 (:coerce org/jruby/runtime/builtin/IRubyObject (phase_wrapper phase))) + (ffi.array_write 2 (..to_host archive)) + (ffi.array_write 3 (..to_host parameters)) + (ffi.array_write 4 (..to_host state))) + handler)] + (..read (:coerce java/lang/Object output)))))) + + @.ruby + (def: (extender phase_wrapper handler) + (-> platform.Phase_Wrapper Extender) + (:assume handler))}) + +(def: (phase_wrapper archive) + (-> Archive (runtime.Operation platform.Phase_Wrapper)) + (do phase.monad + [] + (wrap (:coerce platform.Phase_Wrapper + (for {@.old (..host_phase (list)) + @.ruby (|>>)}))))) + (def: platform (IO (Platform Register _.Expression _.Statement)) (do io.monad @@ -625,6 +804,7 @@ #platform.host host #platform.phase ruby.generate #platform.runtime runtime.generate + #platform.phase_wrapper ..phase_wrapper #platform.write (|>> _.code (\ utf8.codec encode))}))) (def: (program context program) @@ -633,32 +813,6 @@ _.nil) program))) -(def: extender - Extender - ## TODO: Stop relying on coercions ASAP. - (<| (:coerce Extender) - (function (@self handler)) - (:coerce Handler) - (function (@self name phase)) - (:coerce Phase) - (function (@self archive parameters)) - (:coerce Operation) - (function (@self state)) - (:coerce Try) - try.assume - (:coerce Try) - (do try.monad - [handler (try.from_maybe (..ensure_macro handler)) - output (org/jruby/RubyProc::call (!ruby_thread_context) - (|> (ffi.array org/jruby/runtime/builtin/IRubyObject 5) - (ffi.array_write 0 (org/jruby/RubyString::newInternalFromJavaExternal (!ruby_runtime) name)) - (ffi.array_write 1 (..to_host phase)) - (ffi.array_write 2 (..to_host archive)) - (ffi.array_write 3 (..to_host parameters)) - (ffi.array_write 4 (..to_host state))) - handler)] - (..read (:coerce java/lang/Object output))))) - (def: (declare_success! _) (-> Any (Promise Any)) (promise.future (\ world/program.default exit +0))) @@ -674,7 +828,7 @@ analysis.bundle ..platform generation.bundle - extension/bundle.empty + (function.constant extension/bundle.empty) ..program [Register _.Expression _.Statement] ..extender diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux index d22627fb5..4c95b5ee6 100644 --- a/stdlib/source/lux/control/parser.lux +++ b/stdlib/source/lux/control/parser.lux @@ -276,7 +276,7 @@ (All [s a] (-> (-> a Bit) (Parser s a) (Parser s a))) (do ..monad [output parser - _ (assert "Constraint failed." (test output))] + _ (..assert "Constraint failed." (test output))] (wrap output))) (def: #export (parses? parser) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index 4409c3ab5..5d4252cfc 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -98,11 +98,14 @@ (def: tag^ namespaced_symbol^) (def: attr_name^ namespaced_symbol^) +(def: white_space^ + (Parser Text) + (<text>.some <text>.space)) + (def: spaced^ (All [a] (-> (Parser a) (Parser a))) - (let [white_space^ (<>.some <text>.space)] - (|>> (<>.before white_space^) - (<>.after white_space^)))) + (|>> (<>.before ..white_space^) + (<>.after ..white_space^))) (def: attr_value^ (Parser Text) @@ -114,15 +117,15 @@ (Parser Attrs) (<| (\ <>.monad map (dictionary.from_list name.hash)) <>.some - (<>.and (spaced^ attr_name^)) + (<>.and (..spaced^ attr_name^)) (<>.after (<text>.this "=")) - (spaced^ attr_value^))) + (..spaced^ attr_value^))) (def: (close_tag^ expected) (-> Tag (Parser [])) (do <>.monad [actual (|> tag^ - spaced^ + ..spaced^ (<>.after (<text>.this "/")) (<text>.enclosed ["<" ">"]))] (<>.assert ($_ text\compose "Close tag does not match open tag." text.new_line @@ -135,14 +138,14 @@ (|> (<text>.not (<text>.this "--")) <text>.some (<text>.enclosed ["<!--" "-->"]) - spaced^)) + ..spaced^)) (def: xml_header^ (Parser Attrs) - (|> (spaced^ attrs^) + (|> (..spaced^ attrs^) (<>.before (<text>.this "?>")) (<>.after (<text>.this "<?xml")) - spaced^)) + ..spaced^)) (def: cdata^ (Parser Text) @@ -150,7 +153,7 @@ (|> (<text>.some (<text>.not end)) (<>.after end) (<>.after (<text>.this "<![CDATA[")) - spaced^))) + ..spaced^))) (def: text^ (Parser XML) @@ -166,34 +169,36 @@ (Parser XML) (|> (<>.rec (function (_ node^) - (|> (spaced^ - (do <>.monad - [_ (<text>.this "<") - tag (spaced^ tag^) - attrs (spaced^ attrs^) - #let [no_children^ (do <>.monad - [_ (<text>.this "/>")] - (wrap (#Node tag attrs (list)))) - ## TODO: Find a way to make do without this hack. Without it, some POM files fail when parsing them in Aedifex. Something like this fails: <configuration> </configuration> - alternative_no_children^ (do <>.monad - [_ (<text>.this ">") - _ (<>.some <text>.space) - _ (..close_tag^ tag)] - (wrap (#Node tag attrs (list)))) - with_children^ (do <>.monad - [_ (<text>.this ">") - children (<>.some node^) - _ (..close_tag^ tag)] - (wrap (#Node tag attrs children)))]] - ($_ <>.either - no_children^ - alternative_no_children^ - with_children^))) + (|> (do <>.monad + [_ (<text>.this "<") + tag (..spaced^ tag^) + attrs (..spaced^ attrs^) + #let [no_children^ (do <>.monad + [_ (<text>.this "/>")] + (wrap (#Node tag attrs (list)))) + ## TODO: Find a way to make do without this hack. Without it, some POM files fail when parsing them in Aedifex. Something like this fails: <configuration> </configuration> + alternative_no_children^ (do <>.monad + [_ (<text>.this ">") + _ (<>.some <text>.space) + _ (..close_tag^ tag)] + (wrap (#Node tag attrs (list)))) + with_children^ (do <>.monad + [_ (<text>.this ">") + children (<>.either (<>.many node^) + (<>.after (<>.some ..comment^) + (wrap (: (List XML) (list))))) + _ (..close_tag^ tag)] + (wrap (#Node tag attrs children)))]] + ($_ <>.either + no_children^ + alternative_no_children^ + with_children^)) + ..spaced^ (<>.before (<>.some ..comment^)) (<>.after (<>.some ..comment^)) - (<>.either text^)))) + (<>.either ..text^)))) (<>.before (<>.some ..null^)) - (<>.after (<>.maybe xml_header^)))) + (<>.after (<>.maybe ..xml_header^)))) (def: read (-> Text (Try XML)) diff --git a/stdlib/source/lux/target/jvm.lux b/stdlib/source/lux/target/jvm.lux index 3cc306cd9..4250bf705 100644 --- a/stdlib/source/lux/target/jvm.lux +++ b/stdlib/source/lux/target/jvm.lux @@ -265,7 +265,7 @@ (#Concurrency Concurrency) (#Return Return)) -(type: #export (Instruction label) +(type: #export (Instruction embedded label) #NOP (#Constant Constant) (#Arithmetic Arithmetic) @@ -276,7 +276,8 @@ (#Local Local) (#Stack Stack) (#Comparison Comparison) - (#Control (Control label))) + (#Control (Control label)) + (#Embedded embedded)) -(type: #export (Bytecode label) - (Row (Instruction label))) +(type: #export (Bytecode embedded label) + (Row (Instruction embedded label))) diff --git a/stdlib/source/lux/time.lux b/stdlib/source/lux/time.lux index f1600bc56..3a737f113 100644 --- a/stdlib/source/lux/time.lux +++ b/stdlib/source/lux/time.lux @@ -7,10 +7,11 @@ [codec (#+ Codec)] [monad (#+ Monad do)]] [control + [pipe (#+ case>)] ["." try (#+ Try)] ["." exception (#+ exception:)] ["<>" parser - ["<t>" text (#+ Parser)]]] + ["<.>" text (#+ Parser)]]] [data ["." text ("#\." monoid)]] [math @@ -45,13 +46,13 @@ (def: parse_section (Parser Nat) - (<>.codec n.decimal (<t>.exactly 2 <t>.decimal))) + (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))) -(def: parse_millis' +(def: parse_millis (Parser Nat) - (<>.either (|> (<t>.at_most 3 <t>.decimal) + (<>.either (|> (<text>.at_most 3 <text>.decimal) (<>.codec n.decimal) - (<>.after (<t>.this "."))) + (<>.after (<text>.this "."))) (\ <>.monad wrap 0))) (template [<maximum> <parser> <exception> <sub_parser>] @@ -65,15 +66,13 @@ (Parser Nat) (do <>.monad [value <sub_parser>] - (if (and (n.>= 0 value) - (n.< <maximum> value)) + (if (n.< <maximum> value) (wrap value) (<>.lift (exception.throw <exception> [value])))))] [..hours parse_hour invalid_hour ..parse_section] [..minutes parse_minute invalid_minute ..parse_section] [..seconds parse_second invalid_second ..parse_section] - [..milli_seconds parse_millis invalid_milli_second ..parse_millis'] ) (abstract: #export Time @@ -116,12 +115,14 @@ (def: &order ..order) (def: succ - (|>> :representation (n.% ..limit) :abstraction)) + (|>> :representation inc (n.% ..limit) :abstraction)) - (def: (pred time) - (:abstraction (dec (case (:representation time) - 0 ..limit - millis millis)))))) + (def: pred + (|>> :representation + (case> 0 ..limit + millis millis) + dec + :abstraction)))) (def: #export parser (Parser Time) @@ -133,9 +134,9 @@ millis (to_millis duration.milli_second)] (do {! <>.monad} [utc_hour ..parse_hour - _ (<t>.this ..separator) + _ (<text>.this ..separator) utc_minute ..parse_minute - _ (<t>.this ..separator) + _ (<text>.this ..separator) utc_second ..parse_second utc_millis ..parse_millis] (wrap (:abstraction @@ -212,4 +213,4 @@ (Codec Text Time) (def: encode ..encode) - (def: decode (<t>.run ..parser))) + (def: decode (<text>.run ..parser))) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index e697f62a9..2803398e0 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -49,7 +49,7 @@ ["." artifact] ["." document]]]]]) -(def: #export (state target module expander host_analysis host generate generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender) +(def: #export (state target module expander host_analysis host generate generation_bundle) (All [anchor expression directive] (-> Target Module @@ -58,17 +58,13 @@ (///generation.Host expression directive) (///generation.Phase anchor expression directive) (///generation.Bundle anchor expression directive) - (///directive.Bundle anchor expression directive) - (Program expression directive) - [Type Type Type] Extender (///directive.State+ anchor expression directive))) (let [synthesis_state [synthesisE.bundle ///synthesis.init] generation_state [generation_bundle (///generation.state host module)] eval (///analysis/evaluation.evaluator expander synthesis_state generation_state generate) analysis_state [(analysisE.bundle eval host_analysis) (///analysis.state (///analysis.info ///version.version target))]] - [(dictionary.merge host_directive_bundle - (luxD.bundle expander host_analysis program anchorT,expressionT,directiveT extender)) + [extension.empty {#///directive.analysis {#///directive.state analysis_state #///directive.phase (analysisP.phase expander)} #///directive.synthesis {#///directive.state synthesis_state @@ -76,6 +72,20 @@ #///directive.generation {#///directive.state generation_state #///directive.phase generate}}])) +(def: #export (with_default_directives expander host_analysis program anchorT,expressionT,directiveT extender) + (All [anchor expression directive] + (-> Expander + ///analysis.Bundle + (Program expression directive) + [Type Type Type] + Extender + (-> (///directive.State+ anchor expression directive) + (///directive.State+ anchor expression directive)))) + (function (_ [directive_extensions sub_state]) + [(dictionary.merge directive_extensions + (luxD.bundle expander host_analysis program anchorT,expressionT,directiveT extender)) + sub_state])) + (type: Reader (-> Source (Either [Source Text] [Source Code]))) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index d43259443..1e7f643ac 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -7,7 +7,7 @@ ["." monad (#+ Monad do)]] [control ["." function] - ["." try (#+ Try)] + ["." try (#+ Try) ("#\." functor)] ["." exception (#+ exception:)] [concurrency ["." promise (#+ Promise Resolver) ("#\." monad)] @@ -31,7 +31,7 @@ ["." // #_ ["#." init] ["/#" // - ["#." phase] + ["#." phase (#+ Phase)] [language [lux [program (#+ Program)] @@ -61,499 +61,541 @@ ["." static (#+ Static)] ["." import (#+ Import)]]]) -(type: #export (Platform anchor expression directive) - {#&file_system (file.System Promise) - #host (///generation.Host expression directive) - #phase (///generation.Phase anchor expression directive) - #runtime (///generation.Operation anchor expression directive [Registry Output]) - #write (-> directive Binary)}) - -## TODO: Get rid of this -(type: (Action a) - (Promise (Try a))) - -## TODO: Get rid of this -(def: monad - (:coerce (Monad Action) - (try.with promise.monad))) - (with_expansions [<type_vars> (as_is anchor expression directive) - <Platform> (as_is (Platform <type_vars>)) - <State+> (as_is (///directive.State+ <type_vars>)) - <Bundle> (as_is (///generation.Bundle <type_vars>))] - - (def: writer - (Writer [Descriptor (Document .Module)]) - (_.and descriptor.writer - (document.writer $.writer))) - - (def: (cache_module static platform module_id [descriptor document output]) - (All [<type_vars>] - (-> Static <Platform> archive.ID [Descriptor (Document Any) Output] - (Promise (Try Any)))) - (let [system (get@ #&file_system platform) - write_artifact! (: (-> [artifact.ID Binary] (Action Any)) - (function (_ [artifact_id content]) - (ioW.write system static module_id artifact_id content)))] - (do {! ..monad} - [_ (ioW.prepare system static module_id) - _ (for {@.python (|> output - row.to_list - (list.chunk 128) - (monad.map ! (monad.map ! write_artifact!)) - (: (Action (List (List Any)))))} - (|> output - row.to_list - (monad.map ..monad write_artifact!) - (: (Action (List Any))))) - document (\ promise.monad wrap - (document.check $.key document))] - (ioW.cache system static module_id - (_.run ..writer [descriptor document]))))) - - ## TODO: Inline ASAP - (def: initialize_buffer! - (All [<type_vars>] - (///generation.Operation <type_vars> Any)) - (///generation.set_buffer ///generation.empty_buffer)) - - ## TODO: Inline ASAP - (def: (compile_runtime! platform) - (All [<type_vars>] - (-> <Platform> (///generation.Operation <type_vars> [Registry Output]))) - (do ///phase.monad - [_ ..initialize_buffer!] - (get@ #runtime platform))) - - (def: (runtime_descriptor registry) - (-> Registry Descriptor) - {#descriptor.hash 0 - #descriptor.name archive.runtime_module - #descriptor.file "" - #descriptor.references (set.new text.hash) - #descriptor.state #.Compiled - #descriptor.registry registry}) + <Operation> (as_is ///generation.Operation <type_vars>)] + (type: #export Phase_Wrapper + (All [s i o] (-> (Phase s i o) Any))) - (def: runtime_document - (Document .Module) - (document.write $.key (module.new 0))) - - (def: (process_runtime archive platform) - (All [<type_vars>] - (-> Archive <Platform> - (///directive.Operation <type_vars> - [Archive [Descriptor (Document .Module) Output]]))) - (do ///phase.monad - [[registry payload] (///directive.lift_generation - (..compile_runtime! platform)) - #let [[descriptor document] [(..runtime_descriptor registry) ..runtime_document]] - archive (///phase.lift (if (archive.reserved? archive archive.runtime_module) - (archive.add archive.runtime_module [descriptor document payload] archive) - (do try.monad - [[_ archive] (archive.reserve archive.runtime_module archive)] - (archive.add archive.runtime_module [descriptor document payload] archive))))] - (wrap [archive [descriptor document payload]]))) - - (def: (initialize_state extender - [analysers - synthesizers - generators - directives] - analysis_state - state) - (All [<type_vars>] - (-> Extender - [(Dictionary Text ///analysis.Handler) - (Dictionary Text ///synthesis.Handler) - (Dictionary Text ///generation.Handler) - (Dictionary Text ///directive.Handler)] - .Lux - <State+> - (Try <State+>))) - (|> (:share [<type_vars>] - <State+> - state - - (///directive.Operation <type_vars> Any) - (do ///phase.monad - [_ (///directive.lift_analysis - (///analysis.install analysis_state)) - _ (///directive.lift_analysis - (extension.with extender analysers)) - _ (///directive.lift_synthesis - (extension.with extender synthesizers)) - _ (///directive.lift_generation - (extension.with extender (:assume generators))) - _ (extension.with extender (:assume directives))] - (wrap []))) - (///phase.run' state) - (\ try.monad map product.left))) - - (def: #export (initialize static module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender - import compilation_sources) - (All [<type_vars>] - (-> Static - Module - Expander - ///analysis.Bundle - <Platform> - <Bundle> - (///directive.Bundle <type_vars>) - (Program expression directive) - [Type Type Type] Extender - Import (List Context) - (Promise (Try [<State+> Archive])))) - (do (try.with promise.monad) - [#let [state (//init.state (get@ #static.host static) - module - expander - host_analysis - (get@ #host platform) - (get@ #phase platform) - generation_bundle - host_directive_bundle - program - anchorT,expressionT,directiveT - extender)] - _ (ioW.enable (get@ #&file_system platform) static) - [archive analysis_state bundles] (ioW.thaw (get@ #host platform) (get@ #&file_system platform) static import compilation_sources) - state (promise\wrap (initialize_state extender bundles analysis_state state))] - (if (archive.archived? archive archive.runtime_module) - (wrap [state archive]) - (do (try.with promise.monad) - [[state [archive payload]] (|> (..process_runtime archive platform) - (///phase.run' state) - promise\wrap) - _ (..cache_module static platform 0 payload)] - (wrap [state archive]))))) - - (def: compilation_log_separator - (format text.new_line text.tab)) - - (def: (module_compilation_log module) - (All [<type_vars>] - (-> Module <State+> Text)) - (|>> (get@ [#extension.state - #///directive.generation - #///directive.state - #extension.state - #///generation.log]) - (row\fold (function (_ right left) - (format left ..compilation_log_separator right)) - module))) - - (def: with_reset_log - (All [<type_vars>] - (-> <State+> <State+>)) - (set@ [#extension.state - #///directive.generation - #///directive.state - #extension.state - #///generation.log] - row.empty)) - - (def: empty - (Set Module) - (set.new text.hash)) - - (type: Mapping - (Dictionary Module (Set Module))) - - (type: Dependence - {#depends_on Mapping - #depended_by Mapping}) - - (def: independence - Dependence - (let [empty (dictionary.new text.hash)] - {#depends_on empty - #depended_by empty})) - - (def: (depend module import dependence) - (-> Module Module Dependence Dependence) - (let [transitive_dependency (: (-> (-> Dependence Mapping) Module (Set Module)) - (function (_ lens module) - (|> dependence - lens - (dictionary.get module) - (maybe.default ..empty)))) - transitive_depends_on (transitive_dependency (get@ #depends_on) import) - transitive_depended_by (transitive_dependency (get@ #depended_by) module) - update_dependence (: (-> [Module (Set Module)] [Module (Set Module)] - (-> Mapping Mapping)) - (function (_ [source forward] [target backward]) - (function (_ mapping) - (let [with_dependence+transitives - (|> mapping - (dictionary.upsert source ..empty (set.add target)) - (dictionary.update source (set.union forward)))] - (list\fold (function (_ previous) - (dictionary.upsert previous ..empty (set.add target))) - with_dependence+transitives - (set.to_list backward))))))] - (|> dependence - (update@ #depends_on - (update_dependence - [module transitive_depends_on] - [import transitive_depended_by])) - (update@ #depended_by - ((function.flip update_dependence) - [module transitive_depends_on] - [import transitive_depended_by]))))) - - (def: (circular_dependency? module import dependence) - (-> Module Module Dependence Bit) - (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit) - (function (_ from relationship to) - (let [targets (|> dependence - relationship - (dictionary.get from) - (maybe.default ..empty))] - (set.member? targets to))))] - (or (dependence? import (get@ #depends_on) module) - (dependence? module (get@ #depended_by) import)))) - - (exception: #export (module_cannot_import_itself {module Module}) - (exception.report - ["Module" (%.text module)])) - - (exception: #export (cannot_import_circular_dependency {importer Module} - {importee Module}) - (exception.report - ["Importer" (%.text importer)] - ["importee" (%.text importee)])) - - (def: (verify_dependencies importer importee dependence) - (-> Module Module Dependence (Try Any)) - (cond (text\= importer importee) - (exception.throw ..module_cannot_import_itself [importer]) - - (..circular_dependency? importer importee dependence) - (exception.throw ..cannot_import_circular_dependency [importer importee]) - - ## else - (#try.Success []))) - - (with_expansions [<Context> (as_is [Archive <State+>]) - <Result> (as_is (Try <Context>)) - <Return> (as_is (Promise <Result>)) - <Signal> (as_is (Resolver <Result>)) - <Pending> (as_is [<Return> <Signal>]) - <Importer> (as_is (-> Module Module <Return>)) - <Compiler> (as_is (-> Module <Importer> archive.ID <Context> Module <Return>))] - (def: (parallel initial) + (type: #export (Platform <type_vars>) + {#&file_system (file.System Promise) + #host (///generation.Host expression directive) + #phase (///generation.Phase <type_vars>) + #runtime (<Operation> [Registry Output]) + #phase_wrapper (-> Archive (<Operation> Phase_Wrapper)) + #write (-> directive Binary)}) + + ## TODO: Get rid of this + (type: (Action a) + (Promise (Try a))) + + ## TODO: Get rid of this + (def: monad + (:coerce (Monad Action) + (try.with promise.monad))) + + (with_expansions [<Platform> (as_is (Platform <type_vars>)) + <State+> (as_is (///directive.State+ <type_vars>)) + <Bundle> (as_is (///generation.Bundle <type_vars>))] + + (def: writer + (Writer [Descriptor (Document .Module)]) + (_.and descriptor.writer + (document.writer $.writer))) + + (def: (cache_module static platform module_id [descriptor document output]) (All [<type_vars>] - (-> <Context> - (-> <Compiler> <Importer>))) - (let [current (stm.var initial) - pending (:share [<type_vars>] - <Context> - initial - - (Var (Dictionary Module <Pending>)) - (:assume (stm.var (dictionary.new text.hash)))) - dependence (: (Var Dependence) - (stm.var ..independence))] - (function (_ compile) - (function (import! importer module) - (do {! promise.monad} - [[return signal] (:share [<type_vars>] - <Context> - initial - - (Promise [<Return> (Maybe [<Context> - archive.ID - <Signal>])]) - (:assume - (stm.commit - (do {! stm.monad} - [dependence (if (text\= archive.runtime_module importer) - (stm.read dependence) - (do ! - [[_ dependence] (stm.update (..depend importer module) dependence)] - (wrap dependence)))] - (case (..verify_dependencies importer module dependence) - (#try.Failure error) - (wrap [(promise.resolved (#try.Failure error)) - #.None]) - - (#try.Success _) - (do ! - [[archive state] (stm.read current)] - (if (archive.archived? archive module) - (wrap [(promise\wrap (#try.Success [archive state])) - #.None]) - (do ! - [@pending (stm.read pending)] - (case (dictionary.get module @pending) - (#.Some [return signal]) - (wrap [return - #.None]) - - #.None - (case (if (archive.reserved? archive module) - (do try.monad - [module_id (archive.id module archive)] - (wrap [module_id archive])) - (archive.reserve module archive)) - (#try.Success [module_id archive]) - (do ! - [_ (stm.write [archive state] current) - #let [[return signal] (:share [<type_vars>] - <Context> - initial - - <Pending> - (promise.promise []))] - _ (stm.update (dictionary.put module [return signal]) pending)] - (wrap [return - (#.Some [[archive state] - module_id - signal])])) - - (#try.Failure error) - (wrap [(promise\wrap (#try.Failure error)) - #.None]))))))))))) - _ (case signal - #.None - (wrap []) - - (#.Some [context module_id resolver]) - (do ! - [result (compile importer import! module_id context module) - result (case result - (#try.Failure error) - (wrap result) - - (#try.Success [resulting_archive resulting_state]) - (stm.commit (do stm.monad - [[_ [merged_archive _]] (stm.update (function (_ [archive state]) - [(archive.merge resulting_archive archive) - state]) - current)] - (wrap (#try.Success [merged_archive resulting_state]))))) - _ (promise.future (resolver result))] - (wrap [])))] - return))))) - - ## TODO: Find a better way, as this only works for the Lux compiler. - (def: (updated_state archive state) + (-> Static <Platform> archive.ID [Descriptor (Document Any) Output] + (Promise (Try Any)))) + (let [system (get@ #&file_system platform) + write_artifact! (: (-> [artifact.ID Binary] (Action Any)) + (function (_ [artifact_id content]) + (ioW.write system static module_id artifact_id content)))] + (do {! ..monad} + [_ (ioW.prepare system static module_id) + _ (for {@.python (|> output + row.to_list + (list.chunk 128) + (monad.map ! (monad.map ! write_artifact!)) + (: (Action (List (List Any)))))} + (|> output + row.to_list + (monad.map ..monad write_artifact!) + (: (Action (List Any))))) + document (\ promise.monad wrap + (document.check $.key document))] + (ioW.cache system static module_id + (_.run ..writer [descriptor document]))))) + + ## TODO: Inline ASAP + (def: initialize_buffer! (All [<type_vars>] - (-> Archive <State+> (Try <State+>))) - (do {! try.monad} - [modules (monad.map ! (function (_ module) - (do ! - [[descriptor document output] (archive.find module archive) - lux_module (document.read $.key document)] - (wrap [module lux_module]))) - (archive.archived archive)) - #let [additions (|> modules - (list\map product.left) - (set.from_list text.hash))]] - (wrap (update@ [#extension.state - #///directive.analysis - #///directive.state - #extension.state] - (function (_ analysis_state) - (|> analysis_state - (:coerce .Lux) - (update@ #.modules (function (_ current) - (list\compose (list.filter (|>> product.left - (set.member? additions) - not) - current) - modules))) - :assume)) - state)))) - - (def: (set_current_module module state) + (///generation.Operation <type_vars> Any)) + (///generation.set_buffer ///generation.empty_buffer)) + + ## TODO: Inline ASAP + (def: (compile_runtime! platform) + (All [<type_vars>] + (-> <Platform> (///generation.Operation <type_vars> [Registry Output]))) + (do ///phase.monad + [_ ..initialize_buffer!] + (get@ #runtime platform))) + + (def: (runtime_descriptor registry) + (-> Registry Descriptor) + {#descriptor.hash 0 + #descriptor.name archive.runtime_module + #descriptor.file "" + #descriptor.references (set.new text.hash) + #descriptor.state #.Compiled + #descriptor.registry registry}) + + (def: runtime_document + (Document .Module) + (document.write $.key (module.new 0))) + + (def: (process_runtime archive platform) + (All [<type_vars>] + (-> Archive <Platform> + (///directive.Operation <type_vars> + [Archive [Descriptor (Document .Module) Output]]))) + (do ///phase.monad + [[registry payload] (///directive.lift_generation + (..compile_runtime! platform)) + #let [[descriptor document] [(..runtime_descriptor registry) ..runtime_document]] + archive (///phase.lift (if (archive.reserved? archive archive.runtime_module) + (archive.add archive.runtime_module [descriptor document payload] archive) + (do try.monad + [[_ archive] (archive.reserve archive.runtime_module archive)] + (archive.add archive.runtime_module [descriptor document payload] archive))))] + (wrap [archive [descriptor document payload]]))) + + (def: (initialize_state extender + [analysers + synthesizers + generators + directives] + analysis_state + state) (All [<type_vars>] - (-> Module <State+> <State+>)) - (|> (///directive.set_current_module module) + (-> Extender + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///directive.Handler <type_vars>))] + .Lux + <State+> + (Try <State+>))) + (|> (:share [<type_vars>] + <State+> + state + + (///directive.Operation <type_vars> Any) + (do ///phase.monad + [_ (///directive.lift_analysis + (///analysis.install analysis_state)) + _ (///directive.lift_analysis + (extension.with extender analysers)) + _ (///directive.lift_synthesis + (extension.with extender synthesizers)) + _ (///directive.lift_generation + (extension.with extender (:assume generators))) + _ (extension.with extender (:assume directives))] + (wrap []))) (///phase.run' state) - try.assume - product.left)) + (\ try.monad map product.left))) - (def: #export (compile import static expander platform compilation context) + (def: (phase_wrapper archive platform state) (All [<type_vars>] - (-> Import Static Expander <Platform> Compilation <Context> <Return>)) - (let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation - base_compiler (:share [<type_vars>] - <Context> - context - - (///.Compiler <State+> .Module Any) - (:assume - ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))) - compiler (..parallel - context - (function (_ importer import! module_id [archive state] module) - (do {! (try.with promise.monad)} - [#let [state (..set_current_module module state)] - input (context.read (get@ #&file_system platform) - importer - import - compilation_sources - (get@ #static.host_module_extension static) - module)] - (loop [[archive state] [archive state] - compilation (base_compiler (:coerce ///.Input input)) - all_dependencies (: (List Module) - (list))] - (let [new_dependencies (get@ #///.dependencies compilation) - all_dependencies (list\compose new_dependencies all_dependencies) - continue! (:share [<type_vars>] - <Platform> - platform - - (-> <Context> (///.Compilation <State+> .Module Any) (List Module) - (Action [Archive <State+>])) - (:assume - recur))] - (do ! - [[archive state] (case new_dependencies - #.Nil - (wrap [archive state]) - - (#.Cons _) - (do ! - [archive,document+ (|> new_dependencies - (list\map (import! module)) - (monad.seq ..monad)) - #let [archive (|> archive,document+ - (list\map product.left) - (list\fold archive.merge archive))]] - (wrap [archive (try.assume - (..updated_state archive state))])))] - (case ((get@ #///.process compilation) - ## TODO: The "///directive.set_current_module" below shouldn't be necessary. Remove it ASAP. - ## TODO: The context shouldn't need to be re-set either. - (|> (///directive.set_current_module module) + (-> Archive <Platform> <State+> (Try [<State+> Phase_Wrapper]))) + (let [phase_wrapper (get@ #phase_wrapper platform)] + (|> archive + phase_wrapper + ///directive.lift_generation + (///phase.run' state)))) + + (def: (complete_extensions host_directive_bundle phase_wrapper [analysers synthesizers generators directives]) + (All [<type_vars>] + (-> (-> Phase_Wrapper (///directive.Bundle <type_vars>)) + Phase_Wrapper + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///directive.Handler <type_vars>))] + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///directive.Handler <type_vars>))])) + [analysers + synthesizers + generators + (dictionary.merge directives (host_directive_bundle phase_wrapper))]) + + (def: #export (initialize static module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender + import compilation_sources) + (All [<type_vars>] + (-> Static + Module + Expander + ///analysis.Bundle + <Platform> + <Bundle> + (-> Phase_Wrapper (///directive.Bundle <type_vars>)) + (Program expression directive) + [Type Type Type] (-> Phase_Wrapper Extender) + Import (List Context) + (Promise (Try [<State+> Archive])))) + (do {! (try.with promise.monad)} + [#let [state (//init.state (get@ #static.host static) + module + expander + host_analysis + (get@ #host platform) + (get@ #phase platform) + generation_bundle)] + _ (ioW.enable (get@ #&file_system platform) static) + [archive analysis_state bundles] (ioW.thaw (get@ #host platform) (get@ #&file_system platform) static import compilation_sources) + #let [with_missing_extensions + (: (All [<type_vars>] + (-> <Platform> (Program expression directive) <State+> (Promise (Try <State+>)))) + (function (_ platform program state) + (promise\wrap + (do try.monad + [[state phase_wrapper] (..phase_wrapper archive platform state)] + (|> state + (initialize_state (extender phase_wrapper) + (:assume (..complete_extensions host_directive_bundle phase_wrapper (:assume bundles))) + analysis_state) + (try\map (//init.with_default_directives expander host_analysis program anchorT,expressionT,directiveT (extender phase_wrapper))))))))]] + (if (archive.archived? archive archive.runtime_module) + (do ! + [state (with_missing_extensions platform program state)] + (wrap [state archive])) + (do ! + [[state [archive payload]] (|> (..process_runtime archive platform) (///phase.run' state) - try.assume - product.left) - archive) - (#try.Success [state more|done]) - (case more|done - (#.Left more) - (continue! [archive state] more all_dependencies) - - (#.Right [descriptor document output]) - (do ! - [#let [_ (debug.log! (..module_compilation_log module state)) - descriptor (set@ #descriptor.references (set.from_list text.hash all_dependencies) descriptor)] - _ (..cache_module static platform module_id [descriptor document output])] - (case (archive.add module [descriptor document output] archive) - (#try.Success archive) - (wrap [archive - (..with_reset_log state)]) - - (#try.Failure error) - (promise\wrap (#try.Failure error))))) - - (#try.Failure error) + promise\wrap) + _ (..cache_module static platform 0 payload) + + state (with_missing_extensions platform program state)] + (wrap [state archive]))))) + + (def: compilation_log_separator + (format text.new_line text.tab)) + + (def: (module_compilation_log module) + (All [<type_vars>] + (-> Module <State+> Text)) + (|>> (get@ [#extension.state + #///directive.generation + #///directive.state + #extension.state + #///generation.log]) + (row\fold (function (_ right left) + (format left ..compilation_log_separator right)) + module))) + + (def: with_reset_log + (All [<type_vars>] + (-> <State+> <State+>)) + (set@ [#extension.state + #///directive.generation + #///directive.state + #extension.state + #///generation.log] + row.empty)) + + (def: empty + (Set Module) + (set.new text.hash)) + + (type: Mapping + (Dictionary Module (Set Module))) + + (type: Dependence + {#depends_on Mapping + #depended_by Mapping}) + + (def: independence + Dependence + (let [empty (dictionary.new text.hash)] + {#depends_on empty + #depended_by empty})) + + (def: (depend module import dependence) + (-> Module Module Dependence Dependence) + (let [transitive_dependency (: (-> (-> Dependence Mapping) Module (Set Module)) + (function (_ lens module) + (|> dependence + lens + (dictionary.get module) + (maybe.default ..empty)))) + transitive_depends_on (transitive_dependency (get@ #depends_on) import) + transitive_depended_by (transitive_dependency (get@ #depended_by) module) + update_dependence (: (-> [Module (Set Module)] [Module (Set Module)] + (-> Mapping Mapping)) + (function (_ [source forward] [target backward]) + (function (_ mapping) + (let [with_dependence+transitives + (|> mapping + (dictionary.upsert source ..empty (set.add target)) + (dictionary.update source (set.union forward)))] + (list\fold (function (_ previous) + (dictionary.upsert previous ..empty (set.add target))) + with_dependence+transitives + (set.to_list backward))))))] + (|> dependence + (update@ #depends_on + (update_dependence + [module transitive_depends_on] + [import transitive_depended_by])) + (update@ #depended_by + ((function.flip update_dependence) + [module transitive_depends_on] + [import transitive_depended_by]))))) + + (def: (circular_dependency? module import dependence) + (-> Module Module Dependence Bit) + (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit) + (function (_ from relationship to) + (let [targets (|> dependence + relationship + (dictionary.get from) + (maybe.default ..empty))] + (set.member? targets to))))] + (or (dependence? import (get@ #depends_on) module) + (dependence? module (get@ #depended_by) import)))) + + (exception: #export (module_cannot_import_itself {module Module}) + (exception.report + ["Module" (%.text module)])) + + (exception: #export (cannot_import_circular_dependency {importer Module} + {importee Module}) + (exception.report + ["Importer" (%.text importer)] + ["importee" (%.text importee)])) + + (def: (verify_dependencies importer importee dependence) + (-> Module Module Dependence (Try Any)) + (cond (text\= importer importee) + (exception.throw ..module_cannot_import_itself [importer]) + + (..circular_dependency? importer importee dependence) + (exception.throw ..cannot_import_circular_dependency [importer importee]) + + ## else + (#try.Success []))) + + (with_expansions [<Context> (as_is [Archive <State+>]) + <Result> (as_is (Try <Context>)) + <Return> (as_is (Promise <Result>)) + <Signal> (as_is (Resolver <Result>)) + <Pending> (as_is [<Return> <Signal>]) + <Importer> (as_is (-> Module Module <Return>)) + <Compiler> (as_is (-> Module <Importer> archive.ID <Context> Module <Return>))] + (def: (parallel initial) + (All [<type_vars>] + (-> <Context> + (-> <Compiler> <Importer>))) + (let [current (stm.var initial) + pending (:share [<type_vars>] + <Context> + initial + + (Var (Dictionary Module <Pending>)) + (:assume (stm.var (dictionary.new text.hash)))) + dependence (: (Var Dependence) + (stm.var ..independence))] + (function (_ compile) + (function (import! importer module) + (do {! promise.monad} + [[return signal] (:share [<type_vars>] + <Context> + initial + + (Promise [<Return> (Maybe [<Context> + archive.ID + <Signal>])]) + (:assume + (stm.commit + (do {! stm.monad} + [dependence (if (text\= archive.runtime_module importer) + (stm.read dependence) + (do ! + [[_ dependence] (stm.update (..depend importer module) dependence)] + (wrap dependence)))] + (case (..verify_dependencies importer module dependence) + (#try.Failure error) + (wrap [(promise.resolved (#try.Failure error)) + #.None]) + + (#try.Success _) + (do ! + [[archive state] (stm.read current)] + (if (archive.archived? archive module) + (wrap [(promise\wrap (#try.Success [archive state])) + #.None]) + (do ! + [@pending (stm.read pending)] + (case (dictionary.get module @pending) + (#.Some [return signal]) + (wrap [return + #.None]) + + #.None + (case (if (archive.reserved? archive module) + (do try.monad + [module_id (archive.id module archive)] + (wrap [module_id archive])) + (archive.reserve module archive)) + (#try.Success [module_id archive]) + (do ! + [_ (stm.write [archive state] current) + #let [[return signal] (:share [<type_vars>] + <Context> + initial + + <Pending> + (promise.promise []))] + _ (stm.update (dictionary.put module [return signal]) pending)] + (wrap [return + (#.Some [[archive state] + module_id + signal])])) + + (#try.Failure error) + (wrap [(promise\wrap (#try.Failure error)) + #.None]))))))))))) + _ (case signal + #.None + (wrap []) + + (#.Some [context module_id resolver]) + (do ! + [result (compile importer import! module_id context module) + result (case result + (#try.Failure error) + (wrap result) + + (#try.Success [resulting_archive resulting_state]) + (stm.commit (do stm.monad + [[_ [merged_archive _]] (stm.update (function (_ [archive state]) + [(archive.merge resulting_archive archive) + state]) + current)] + (wrap (#try.Success [merged_archive resulting_state]))))) + _ (promise.future (resolver result))] + (wrap [])))] + return))))) + + ## TODO: Find a better way, as this only works for the Lux compiler. + (def: (updated_state archive state) + (All [<type_vars>] + (-> Archive <State+> (Try <State+>))) + (do {! try.monad} + [modules (monad.map ! (function (_ module) (do ! - [_ (ioW.freeze (get@ #&file_system platform) static archive)] - (promise\wrap (#try.Failure error))))))))))] - (compiler archive.runtime_module compilation_module))) - )) + [[descriptor document output] (archive.find module archive) + lux_module (document.read $.key document)] + (wrap [module lux_module]))) + (archive.archived archive)) + #let [additions (|> modules + (list\map product.left) + (set.from_list text.hash))]] + (wrap (update@ [#extension.state + #///directive.analysis + #///directive.state + #extension.state] + (function (_ analysis_state) + (|> analysis_state + (:coerce .Lux) + (update@ #.modules (function (_ current) + (list\compose (list.filter (|>> product.left + (set.member? additions) + not) + current) + modules))) + :assume)) + state)))) + + (def: (set_current_module module state) + (All [<type_vars>] + (-> Module <State+> <State+>)) + (|> (///directive.set_current_module module) + (///phase.run' state) + try.assume + product.left)) + + (def: #export (compile import static expander platform compilation context) + (All [<type_vars>] + (-> Import Static Expander <Platform> Compilation <Context> <Return>)) + (let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation + base_compiler (:share [<type_vars>] + <Context> + context + + (///.Compiler <State+> .Module Any) + (:assume + ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))) + compiler (..parallel + context + (function (_ importer import! module_id [archive state] module) + (do {! (try.with promise.monad)} + [#let [state (..set_current_module module state)] + input (context.read (get@ #&file_system platform) + importer + import + compilation_sources + (get@ #static.host_module_extension static) + module)] + (loop [[archive state] [archive state] + compilation (base_compiler (:coerce ///.Input input)) + all_dependencies (: (List Module) + (list))] + (let [new_dependencies (get@ #///.dependencies compilation) + all_dependencies (list\compose new_dependencies all_dependencies) + continue! (:share [<type_vars>] + <Platform> + platform + + (-> <Context> (///.Compilation <State+> .Module Any) (List Module) + (Action [Archive <State+>])) + (:assume + recur))] + (do ! + [[archive state] (case new_dependencies + #.Nil + (wrap [archive state]) + + (#.Cons _) + (do ! + [archive,document+ (|> new_dependencies + (list\map (import! module)) + (monad.seq ..monad)) + #let [archive (|> archive,document+ + (list\map product.left) + (list\fold archive.merge archive))]] + (wrap [archive (try.assume + (..updated_state archive state))])))] + (case ((get@ #///.process compilation) + ## TODO: The "///directive.set_current_module" below shouldn't be necessary. Remove it ASAP. + ## TODO: The context shouldn't need to be re-set either. + (|> (///directive.set_current_module module) + (///phase.run' state) + try.assume + product.left) + archive) + (#try.Success [state more|done]) + (case more|done + (#.Left more) + (continue! [archive state] more all_dependencies) + + (#.Right [descriptor document output]) + (do ! + [#let [_ (debug.log! (..module_compilation_log module state)) + descriptor (set@ #descriptor.references (set.from_list text.hash all_dependencies) descriptor)] + _ (..cache_module static platform module_id [descriptor document output])] + (case (archive.add module [descriptor document output] archive) + (#try.Success archive) + (wrap [archive + (..with_reset_log state)]) + + (#try.Failure error) + (promise\wrap (#try.Failure error))))) + + (#try.Failure error) + (do ! + [_ (ioW.freeze (get@ #&file_system platform) static archive)] + (promise\wrap (#try.Failure error))))))))))] + (compiler archive.runtime_module compilation_module))) + ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux index 9803de0e4..7004b8d1a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux @@ -45,6 +45,10 @@ (type: #export (Bundle s i o) <Bundle>)) +(def: #export empty + Bundle + (dictionary.new text.hash)) + (type: #export (State s i o) {#bundle (Bundle s i o) #state s}) @@ -95,7 +99,7 @@ (def: #export (with extender extensions) (All [s i o] - (-> Extender (Dictionary Text (Handler s i o)) (Operation s i o Any))) + (-> Extender (Bundle s i o) (Operation s i o Any))) (|> extensions dictionary.entries (monad.fold //.monad diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index bb5587dfe..0c88ae795 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -9,8 +9,8 @@ ["." try (#+ Try) ("#\." monad)] ["." exception (#+ exception:)] ["<>" parser - ["<c>" code (#+ Parser)] - ["<t>" text]]] + ["<.>" code (#+ Parser)] + ["<.>" text]]] [data ["." maybe] ["." product] @@ -191,7 +191,7 @@ (def: member (Parser Member) - ($_ <>.and <c>.text <c>.text)) + ($_ <>.and <code>.text <code>.text)) (type: Method_Signature {#method .Type @@ -397,7 +397,7 @@ [objectJ (jvm_type objectT)] (|> objectJ ..signature - (<t>.run jvm_parser.array) + (<text>.run jvm_parser.array) phase.lift))) (def: (primitive_array_length_handler primitive_type) @@ -826,7 +826,7 @@ (def: object::instance? Handler (..custom - [($_ <>.and <c>.text <c>.any) + [($_ <>.and <code>.text <code>.any) (function (_ extension_name analyse archive [sub_class objectC]) (do phase.monad [_ (..ensure_fresh_class! sub_class) @@ -842,7 +842,7 @@ (template [<name> <category> <parser>] [(def: (<name> mapping typeJ) (-> Mapping (Type <category>) (Operation .Type)) - (case (|> typeJ ..signature (<t>.run (<parser> mapping))) + (case (|> typeJ ..signature (<text>.run (<parser> mapping))) (#try.Success check) (typeA.with_env check) @@ -998,7 +998,7 @@ (def: put::static Handler (..custom - [($_ <>.and ..member <c>.any) + [($_ <>.and ..member <code>.any) (function (_ extension_name analyse archive [[class field] valueC]) (do phase.monad [_ (..ensure_fresh_class! class) @@ -1022,7 +1022,7 @@ (def: get::virtual Handler (..custom - [($_ <>.and ..member <c>.any) + [($_ <>.and ..member <code>.any) (function (_ extension_name analyse archive [[class field] objectC]) (do phase.monad [_ (..ensure_fresh_class! class) @@ -1046,7 +1046,7 @@ (def: put::virtual Handler (..custom - [($_ <>.and ..member <c>.any <c>.any) + [($_ <>.and ..member <code>.any <code>.any) (function (_ extension_name analyse archive [[class field] valueC objectC]) (do phase.monad [_ (..ensure_fresh_class! class) @@ -1339,7 +1339,7 @@ (template [<name> <category> <parser>] [(def: #export <name> (Parser (Type <category>)) - (<t>.embed <parser> <c>.text))] + (<text>.embed <parser> <code>.text))] [var Var jvm_parser.var] [class Class jvm_parser.class] @@ -1349,7 +1349,7 @@ (def: input (Parser (Typed Code)) - (<c>.tuple (<>.and ..type <c>.any))) + (<code>.tuple (<>.and ..type <code>.any))) (def: (decorate_inputs typesT inputsA) (-> (List (Type Value)) (List Analysis) (List Analysis)) @@ -1358,7 +1358,8 @@ (list\map (function (_ [type value]) (/////analysis.tuple (list type value)))))) -(def: type_vars (<c>.tuple (<>.some ..var))) +(def: type_vars + (<code>.tuple (<>.some ..var))) (def: invoke::static Handler @@ -1381,7 +1382,7 @@ (def: invoke::virtual Handler (..custom - [($_ <>.and ..type_vars ..member ..type_vars <c>.any (<>.some ..input)) + [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC]) (do phase.monad [_ (..ensure_fresh_class! class) @@ -1406,7 +1407,7 @@ (def: invoke::special Handler (..custom - [($_ <>.and ..type_vars ..member ..type_vars <c>.any (<>.some ..input)) + [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC]) (do phase.monad [_ (..ensure_fresh_class! class) @@ -1424,7 +1425,7 @@ (def: invoke::interface Handler (..custom - [($_ <>.and ..type_vars ..member ..type_vars <c>.any (<>.some ..input)) + [($_ <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) (function (_ extension_name analyse archive [class_tvars [class_name method] method_tvars objectC argsTC]) (do phase.monad [_ (..ensure_fresh_class! class_name) @@ -1452,7 +1453,7 @@ (def: invoke::constructor (..custom - [($_ <>.and ..type_vars <c>.text ..type_vars (<>.some ..input)) + [($_ <>.and ..type_vars <code>.text ..type_vars (<>.some ..input)) (function (_ extension_name analyse archive [class_tvars class method_tvars argsTC]) (do phase.monad [_ (..ensure_fresh_class! class) @@ -1491,18 +1492,18 @@ (def: annotation_parameter (Parser (Annotation_Parameter Code)) - (<c>.tuple (<>.and <c>.text <c>.any))) + (<code>.tuple (<>.and <code>.text <code>.any))) (type: #export (Annotation a) [Text (List (Annotation_Parameter a))]) (def: #export annotation (Parser (Annotation Code)) - (<c>.form (<>.and <c>.text (<>.some ..annotation_parameter)))) + (<code>.form (<>.and <code>.text (<>.some ..annotation_parameter)))) (def: #export argument (Parser Argument) - (<c>.tuple (<>.and <c>.text ..type))) + (<code>.tuple (<>.and <code>.text ..type))) (def: (annotation_parameter_analysis [name value]) (-> (Annotation_Parameter Analysis) Analysis) @@ -1603,10 +1604,10 @@ (def: #export visibility (Parser Visibility) ($_ <>.or - (<c>.text! ..public_tag) - (<c>.text! ..private_tag) - (<c>.text! ..protected_tag) - (<c>.text! ..default_tag))) + (<code>.text! ..public_tag) + (<code>.text! ..private_tag) + (<code>.text! ..protected_tag) + (<code>.text! ..default_tag))) (def: #export (visibility_analysis visibility) (-> Visibility Analysis) @@ -1631,18 +1632,18 @@ (def: #export constructor_definition (Parser (Constructor Code)) - (<| <c>.form - (<>.after (<c>.text! ..constructor_tag)) + (<| <code>.form + (<>.after (<code>.text! ..constructor_tag)) ($_ <>.and ..visibility - <c>.bit - (<c>.tuple (<>.some ..annotation)) - (<c>.tuple (<>.some ..var)) - (<c>.tuple (<>.some ..class)) - <c>.text - (<c>.tuple (<>.some ..argument)) - (<c>.tuple (<>.some ..input)) - <c>.any))) + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..class)) + <code>.text + (<code>.tuple (<>.some ..argument)) + (<code>.tuple (<>.some ..input)) + <code>.any))) (def: #export (analyse_constructor_method analyse archive selfT mapping method) (-> Phase Archive .Type Mapping (Constructor Code) (Operation Analysis)) @@ -1710,20 +1711,20 @@ (def: #export virtual_method_definition (Parser (Virtual_Method Code)) - (<| <c>.form - (<>.after (<c>.text! ..virtual_tag)) + (<| <code>.form + (<>.after (<code>.text! ..virtual_tag)) ($_ <>.and - <c>.text + <code>.text ..visibility - <c>.bit - <c>.bit - (<c>.tuple (<>.some ..annotation)) - (<c>.tuple (<>.some ..var)) - <c>.text - (<c>.tuple (<>.some ..argument)) + <code>.bit + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + <code>.text + (<code>.tuple (<>.some ..argument)) ..return - (<c>.tuple (<>.some ..class)) - <c>.any))) + (<code>.tuple (<>.some ..class)) + <code>.any))) (def: #export (analyse_virtual_method analyse archive selfT mapping method) (-> Phase Archive .Type Mapping (Virtual_Method Code) (Operation Analysis)) @@ -1786,18 +1787,18 @@ (def: #export static_method_definition (Parser (Static_Method Code)) - (<| <c>.form - (<>.after (<c>.text! ..static_tag)) + (<| <code>.form + (<>.after (<code>.text! ..static_tag)) ($_ <>.and - <c>.text + <code>.text ..visibility - <c>.bit - (<c>.tuple (<>.some ..annotation)) - (<c>.tuple (<>.some ..var)) - (<c>.tuple (<>.some ..class)) - (<c>.tuple (<>.some ..argument)) + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..class)) + (<code>.tuple (<>.some ..argument)) ..return - <c>.any))) + <code>.any))) (def: #export (analyse_static_method analyse archive mapping method) (-> Phase Archive Mapping (Static_Method Code) (Operation Analysis)) @@ -1859,19 +1860,19 @@ (def: #export overriden_method_definition (Parser (Overriden_Method Code)) - (<| <c>.form - (<>.after (<c>.text! ..overriden_tag)) + (<| <code>.form + (<>.after (<code>.text! ..overriden_tag)) ($_ <>.and ..class - <c>.text - <c>.bit - (<c>.tuple (<>.some ..annotation)) - (<c>.tuple (<>.some ..var)) - <c>.text - (<c>.tuple (<>.some ..argument)) + <code>.text + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + <code>.text + (<code>.tuple (<>.some ..argument)) ..return - (<c>.tuple (<>.some ..class)) - <c>.any + (<code>.tuple (<>.some ..class)) + <code>.any ))) (def: #export (analyse_overriden_method analyse archive selfT mapping method) @@ -1984,11 +1985,11 @@ Handler (..custom [($_ <>.and - (<c>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..var)) ..class - (<c>.tuple (<>.some ..class)) - (<c>.tuple (<>.some ..input)) - (<c>.tuple (<>.some ..overriden_method_definition))) + (<code>.tuple (<>.some ..class)) + (<code>.tuple (<>.some ..input)) + (<code>.tuple (<>.some ..overriden_method_definition))) (function (_ extension_name analyse archive [parameters super_class super_interfaces diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 400cdacb2..ade8e367f 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -925,10 +925,8 @@ ## ..default_separator) ## )) ## ) - - @.scheme - (as_is) - })) + } + (as_is))) (def: #export (exists? monad fs path) (All [!] (-> (Monad !) (System !) Path (! Bit))) diff --git a/stdlib/source/program/aedifex/artifact.lux b/stdlib/source/program/aedifex/artifact.lux index 9e87988ea..e5d37f7bb 100644 --- a/stdlib/source/program/aedifex/artifact.lux +++ b/stdlib/source/program/aedifex/artifact.lux @@ -2,10 +2,11 @@ [lux (#- Name) [abstract [equivalence (#+ Equivalence)] + [order (#+ Order)] [hash (#+ Hash)]] [data ["." product] - ["." text + ["." text ("#\." order) ["%" format (#+ Format)]] [collection ["." list ("#\." monoid)]]] @@ -40,6 +41,26 @@ (Equivalence Artifact) (\ ..hash &equivalence)) +(implementation: #export order + (Order Artifact) + + (def: &equivalence + ..equivalence) + + (def: (< reference subject) + (<| (or (text\< (get@ #group reference) + (get@ #group subject))) + + (and (text\= (get@ #group reference) + (get@ #group subject))) + (or (text\< (get@ #name reference) + (get@ #name subject))) + + (and (text\= (get@ #name reference) + (get@ #name subject))) + (text\< (get@ #version reference) + (get@ #version subject))))) + (template [<separator> <definition>] [(def: <definition> Text diff --git a/stdlib/source/program/aedifex/command/deps.lux b/stdlib/source/program/aedifex/command/deps.lux index de4817ba8..4dcc9d6e1 100644 --- a/stdlib/source/program/aedifex/command/deps.lux +++ b/stdlib/source/program/aedifex/command/deps.lux @@ -46,13 +46,20 @@ (list\fold dictionary.remove resolution) (///dependency/deployment.all local)) _ (console.write_line (exception.report - ["Local successes" (exception.enumerate ..format local_successes)] - ["Local failures" (exception.enumerate ..format local_failures)] - ["Remote successes" (let [remote_successes (|> remote_successes - (set.from_list ///dependency.hash) - (set.difference (set.from_list ///dependency.hash local_successes)) - set.to_list)] - (exception.enumerate ..format remote_successes))] - ["Remote failures" (exception.enumerate ..format remote_failures)]) + ["Local successes" (|> local_successes + (list.sort (\ ///dependency.order <)) + (exception.enumerate ..format))] + ["Local failures" (|> local_failures + (list.sort (\ ///dependency.order <)) + (exception.enumerate ..format))] + ["Remote successes" (|> remote_successes + (set.from_list ///dependency.hash) + (set.difference (set.from_list ///dependency.hash local_successes)) + set.to_list + (list.sort (\ ///dependency.order <)) + (exception.enumerate ..format))] + ["Remote failures" (|> remote_failures + (list.sort (\ ///dependency.order <)) + (exception.enumerate ..format))]) console)] (wrap resolution)))) diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux index b7b605447..f06b00260 100644 --- a/stdlib/source/program/aedifex/dependency.lux +++ b/stdlib/source/program/aedifex/dependency.lux @@ -2,13 +2,14 @@ [lux (#- Type) [abstract [equivalence (#+ Equivalence)] + [order (#+ Order)] [hash (#+ Hash)]] [data ["." product] - ["." text + ["." text ("#\." order) ["%" format (#+ format)]]]] ["." // #_ - ["#" artifact (#+ Artifact) + ["#" artifact (#+ Artifact) ("#\." order) [type (#+ Type)]]]) (type: #export Dependency @@ -25,3 +26,18 @@ (def: #export equivalence (Equivalence Dependency) (\ hash &equivalence)) + +(implementation: #export order + (Order Dependency) + + (def: &equivalence + ..equivalence) + + (def: (< reference subject) + (<| (or (//\< (get@ #artifact reference) + (get@ #artifact subject))) + + (and (//\= (get@ #artifact reference) + (get@ #artifact subject))) + (text\< (get@ #type reference) + (get@ #type subject))))) diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux index 326f2ac2d..63c3e930d 100644 --- a/stdlib/source/program/aedifex/dependency/resolution.lux +++ b/stdlib/source/program/aedifex/dependency/resolution.lux @@ -169,8 +169,8 @@ text.new_line)))] ["?" announce_fetching "Fetching" "from"] - ["Y" announce_success "Found" "at"] - ["N" announce_failure "Missed" "from"] + ["O" announce_success "Found" "at"] + ["X" announce_failure "Missed" "from"] ) (def: #export (any console repositories dependency) diff --git a/stdlib/source/program/aedifex/metadata.lux b/stdlib/source/program/aedifex/metadata.lux index 7fbe88cbc..843f2e056 100644 --- a/stdlib/source/program/aedifex/metadata.lux +++ b/stdlib/source/program/aedifex/metadata.lux @@ -17,7 +17,7 @@ (def: #export (remote_artifact_uri artifact) (-> Artifact URI) (let [/ uri.separator] - (format (get@ #//artifact.group artifact) + (format (//artifact.directory / (get@ #//artifact.group artifact)) / (get@ #//artifact.name artifact) / (get@ #//artifact.version artifact) / ..remote_file))) @@ -25,7 +25,7 @@ (def: #export (remote_project_uri artifact) (-> Artifact URI) (let [/ uri.separator] - (format (get@ #//artifact.group artifact) + (format (//artifact.directory / (get@ #//artifact.group artifact)) / (get@ #//artifact.name artifact) / ..remote_file))) diff --git a/stdlib/source/program/aedifex/metadata/snapshot.lux b/stdlib/source/program/aedifex/metadata/snapshot.lux index 6eec0c32c..518e0404a 100644 --- a/stdlib/source/program/aedifex/metadata/snapshot.lux +++ b/stdlib/source/program/aedifex/metadata/snapshot.lux @@ -41,7 +41,8 @@ ["#/." type (#+ Type)] ["#/." versioning (#+ Versioning)] ["#/." snapshot - ["#/." version]]]]]) + ["#/." version] + ["#/." stamp]]]]]) (type: #export Metadata {#artifact Artifact @@ -93,18 +94,22 @@ [group (<xml>.somewhere (..text ..<group>)) name (<xml>.somewhere (..text ..<name>)) version (<xml>.somewhere (..text ..<version>)) - versioning (\ ! map - (update@ #///artifact/versioning.versions - (: (-> (List ///artifact/snapshot/version.Version) - (List ///artifact/snapshot/version.Version)) - (|>> (case> (^ (list)) - (list {#///artifact/snapshot/version.extension ///artifact/type.jvm_library - #///artifact/snapshot/version.value version - #///artifact/snapshot/version.updated ///artifact/time.epoch}) + versioning (with_expansions [<default_version> {#///artifact/snapshot/version.extension ///artifact/type.jvm_library + #///artifact/snapshot/version.value version + #///artifact/snapshot/version.updated ///artifact/time.epoch}] + (|> (<xml>.somewhere ///artifact/versioning.parser) + (\ ! map + (update@ #///artifact/versioning.versions + (: (-> (List ///artifact/snapshot/version.Version) + (List ///artifact/snapshot/version.Version)) + (|>> (case> (^ (list)) + (list <default_version>) - versions - versions)))) - (<xml>.somewhere ///artifact/versioning.parser))] + versions + versions))))) + (<>.default {#///artifact/versioning.snapshot #///artifact/snapshot.Local + #///artifact/versioning.last_updated ///artifact/time.epoch + #///artifact/versioning.versions (list <default_version>)})))] (wrap {#artifact {#///artifact.group group #///artifact.name name #///artifact.version version} diff --git a/stdlib/source/program/aedifex/parser.lux b/stdlib/source/program/aedifex/parser.lux index 60e491dac..835b03729 100644 --- a/stdlib/source/program/aedifex/parser.lux +++ b/stdlib/source/program/aedifex/parser.lux @@ -4,7 +4,7 @@ [monad (#+ do)]] [control ["<>" parser - ["<c>" code (#+ Parser)]]] + ["<.>" code (#+ Parser)]]] [data ["." text] [collection @@ -37,25 +37,25 @@ (def: (singular input tag parser) (All [a] (-> (Dictionary Text Code) Text (Parser a) (Parser a))) - (<c>.local (..as_input (dictionary.get tag input)) - parser)) + (<code>.local (..as_input (dictionary.get tag input)) + parser)) (def: (plural input tag parser) (All [a] (-> (Dictionary Text Code) Text (Parser a) (Parser (List a)))) - (<c>.local (..as_input (dictionary.get tag input)) - (<c>.tuple (<>.some parser)))) + (<code>.local (..as_input (dictionary.get tag input)) + (<code>.tuple (<>.some parser)))) (def: group (Parser //artifact.Group) - <c>.text) + <code>.text) (def: name (Parser //artifact.Name) - <c>.text) + <code>.text) (def: version (Parser //artifact.Version) - <c>.text) + <code>.text) (def: artifact' (Parser //artifact.Artifact) @@ -63,11 +63,11 @@ (def: artifact (Parser //artifact.Artifact) - (<c>.tuple ..artifact')) + (<code>.tuple ..artifact')) (def: url (Parser URL) - <c>.text) + <code>.text) (def: scm (Parser /.SCM) @@ -75,30 +75,30 @@ (def: description (Parser Text) - <c>.text) + <code>.text) (def: license (Parser /.License) (do {! <>.monad} [input (\ ! map (dictionary.from_list text.hash) - (<c>.record (<>.some (<>.and <c>.local_tag - <c>.any))))] + (<code>.record (<>.some (<>.and <code>.local_tag + <code>.any))))] ($_ <>.and (..singular input "name" ..name) (..singular input "url" ..url) (<>.default #/.Repo (..singular input "type" - (<>.or (<c>.this! (' #repo)) - (<c>.this! (' #manual)))))))) + (<>.or (<code>.this! (' #repo)) + (<code>.this! (' #manual)))))))) (def: organization (Parser /.Organization) (do {! <>.monad} [input (\ ! map (dictionary.from_list text.hash) - (<c>.record (<>.some (<>.and <c>.local_tag - <c>.any))))] + (<code>.record (<>.some (<>.and <code>.local_tag + <code>.any))))] ($_ <>.and (..singular input "name" ..name) (..singular input "url" ..url)))) @@ -108,8 +108,8 @@ (do {! <>.monad} [input (\ ! map (dictionary.from_list text.hash) - (<c>.record (<>.some (<>.and <c>.local_tag - <c>.any))))] + (<code>.record (<>.some (<>.and <code>.local_tag + <code>.any))))] ($_ <>.and (..singular input "name" ..name) (..singular input "url" ..url) @@ -125,8 +125,8 @@ (do {! <>.monad} [input (\ ! map (dictionary.from_list text.hash) - (<c>.record (<>.some (<>.and <c>.local_tag - <c>.any))))] + (<code>.record (<>.some (<>.and <code>.local_tag + <code>.any))))] ($_ <>.and (<>.maybe (..singular input "url" ..url)) (<>.maybe (..singular input "scm" ..scm)) @@ -143,11 +143,11 @@ (def: type (Parser //artifact/type.Type) - <c>.text) + <code>.text) (def: dependency (Parser //dependency.Dependency) - (<c>.tuple + (<code>.tuple ($_ <>.and ..artifact' (<>.default //artifact/type.lux_library ..type) @@ -155,32 +155,32 @@ (def: source (Parser /.Source) - <c>.text) + <code>.text) (def: target (Parser /.Target) - <c>.text) + <code>.text) (def: module (Parser Module) - <c>.text) + <code>.text) (def: deploy_repository (Parser (List [Text //repository.Address])) - (<c>.record (<>.some - (<>.and <c>.text - ..repository)))) + (<code>.record (<>.some + (<>.and <code>.text + ..repository)))) (def: profile (Parser /.Profile) (do {! <>.monad} [input (\ ! map (dictionary.from_list text.hash) - (<c>.record (<>.some (<>.and <c>.local_tag - <c>.any)))) + (<code>.record (<>.some (<>.and <code>.local_tag + <code>.any)))) #let [^parents (: (Parser (List /.Name)) (<>.default (list) - (..plural input "parents" <c>.text))) + (..plural input "parents" <code>.text))) ^identity (: (Parser (Maybe Artifact)) (<>.maybe (..singular input "identity" ..artifact))) @@ -236,7 +236,7 @@ multi_profile (: (Parser Project) (\ <>.monad map (dictionary.from_list text.hash) - (<c>.record (<>.many (<>.and <c>.text - ..profile)))))] + (<code>.record (<>.many (<>.and <code>.text + ..profile)))))] (<>.either multi_profile default_profile))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 8b577ec09..b964e6502 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -102,10 +102,10 @@ analysis.Bundle (IO (Platform <parameters>)) (generation.Bundle <parameters>) - (directive.Bundle <parameters>) + (-> platform.Phase_Wrapper (directive.Bundle <parameters>)) (Program expression artifact) [Type Type Type] - Extender + (-> platform.Phase_Wrapper Extender) Service [Packager file.Path] (Promise Any))) diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index 8ff1cdc00..e20189fa3 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -10,18 +10,24 @@ ["." php] ["." scheme]] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control ["." try] ["<>" parser - ["<c>" code] - ["<a>" analysis] - ["<s>" synthesis]]] + ["<.>" code] + ["<.>" analysis] + ["<.>" synthesis]]] [data + ["." product] ["." text ("#\." equivalence) ["%" format (#+ format)]] [collection - ["." row]]] + ["." row] + ["." list ("#\." functor)]]] + [math + ["." random] + [number + ["n" nat]]] [tool [compiler ["." phase] @@ -40,81 +46,96 @@ (def: my_analysis "my analysis") (def: my_synthesis "my synthesis") (def: my_generation "my generation") +(def: dummy_generation "dummy generation") (def: my_directive "my directive") ## Generation (for {@.old (as_is)} - (as_is (analysis: (..my_generation self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [_ (type.infer .Text)] - (wrap (#analysis.Extension self (list))))) + (as_is + ## Analysis + (analysis: (..my_analysis self phase archive {pass_through <code>.any}) + (phase archive pass_through)) - (synthesis: (..my_generation self phase archive {parameters (<>.some <a>.any)}) - (do phase.monad - [] - (wrap (#synthesis.Extension self (list))))) - )) + ## Synthesis + (analysis: (..my_synthesis self phase archive {parameters (<>.some <code>.any)}) + (let [! phase.monad] + (|> parameters + (monad.map ! (phase archive)) + (\ ! map (|>> (#analysis.Extension self)))))) -(for {@.old - (as_is)} - - (generation: (..my_generation self phase archive {parameters (<>.some <s>.any)}) - (do phase.monad - [] - (wrap (for {@.jvm - (row.row (#jvm.Constant (#jvm.LDC (#jvm.String self)))) + (synthesis: (..my_synthesis self phase archive {pass_through <analysis>.any}) + (phase archive pass_through)) - @.js (js.string self) - @.python (python.unicode self) - @.lua (lua.string self) - @.ruby (ruby.string self) - @.php (php.string self) - @.scheme (scheme.string self)}))))) + ## Generation + (analysis: (..my_generation self phase archive {parameters (<>.some <code>.any)}) + (let [! phase.monad] + (|> parameters + (monad.map ! (phase archive)) + (\ ! map (|>> (#analysis.Extension self)))))) -(for {@.old - (as_is)} - - (as_is (analysis: (..my_analysis self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [_ (type.infer .Text)] - (wrap (#analysis.Primitive (#analysis.Text self))))) + (synthesis: (..my_generation self phase archive {parameters (<>.some <analysis>.any)}) + (let [! phase.monad] + (|> parameters + (monad.map ! (phase archive)) + (\ ! map (|>> (#synthesis.Extension self)))))) + + (generation: (..my_generation self phase archive {pass_through <synthesis>.any}) + (for {@.jvm + (\ phase.monad map (|>> #jvm.Embedded row.row) + (phase archive pass_through))} + (phase archive pass_through))) + + (analysis: (..dummy_generation self phase archive) + (\ phase.monad wrap (#analysis.Extension self (list)))) + + (synthesis: (..dummy_generation self phase archive) + (\ phase.monad wrap (#synthesis.Extension self (list)))) + + (generation: (..dummy_generation self phase archive) + (\ phase.monad wrap + (for {@.jvm + (row.row (#jvm.Constant (#jvm.LDC (#jvm.String self)))) - ## Synthesis - (analysis: (..my_synthesis self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [_ (type.infer .Text)] - (wrap (#analysis.Extension self (list))))) + @.js (js.string self) + @.python (python.unicode self) + @.lua (lua.string self) + @.ruby (ruby.string self) + @.php (php.string self) + @.scheme (scheme.string self)}))) - (synthesis: (..my_synthesis self phase archive {parameters (<>.some <a>.any)}) - (do phase.monad - [] - (wrap (synthesis.text self)))) - - ## Directive - (directive: (..my_directive self phase archive {parameters (<>.some <c>.any)}) - (do phase.monad - [#let [_ (debug.log! (format "Successfully installed directive " (%.text self) "!"))]] - (wrap directive.no_requirements))) + ## Directive + (directive: (..my_directive self phase archive {parameters (<>.some <code>.any)}) + (do phase.monad + [#let [_ (debug.log! (format "Successfully installed directive " (%.text self) "!"))]] + (wrap directive.no_requirements))) - (`` ((~~ (static ..my_directive)))) - )) + (`` ((~~ (static ..my_directive)))) + )) (def: #export test Test (<| (_.covering /._) - (`` ($_ _.and - (~~ (template [<macro> <extension>] - [(_.cover [<macro>] - (for {@.old - false} - (text\= (`` ((~~ (static <extension>)))) - <extension>)))] + (do random.monad + [expected random.nat] + (`` ($_ _.and + (~~ (template [<macro> <extension>] + [(_.cover [<macro>] + (for {@.old + false} + (n.= expected + (`` ((~~ (static <extension>)) expected)))))] - [/.analysis: ..my_analysis] - [/.synthesis: ..my_synthesis] - [/.generation: ..my_generation])) - (_.cover [/.directive:] - true) - )))) + [/.analysis: ..my_analysis] + [/.synthesis: ..my_synthesis])) + (_.cover [/.generation:] + (for {@.old + false} + (and (n.= expected + (`` ((~~ (static ..my_generation)) expected))) + (text\= ..dummy_generation + (`` ((~~ (static ..dummy_generation)))))))) + (_.cover [/.directive:] + true) + ))))) diff --git a/stdlib/source/test/lux/time.lux b/stdlib/source/test/lux/time.lux index cc18c20e0..b22823626 100644 --- a/stdlib/source/test/lux/time.lux +++ b/stdlib/source/test/lux/time.lux @@ -1,21 +1,155 @@ (.module: [lux #* - ["_" test (#+ Test)]] + ["_" test (#+ Test)] + [abstract + [monad (#+ do)] + {[0 #spec] + [/ + ["$." equivalence] + ["$." order] + ["$." enum] + ["$." codec]]}] + [control + [pipe (#+ case>)] + ["." try ("#\." functor)] + ["." exception] + [parser + ["<.>" text]]] + [data + ["." text + ["%" format (#+ format)]]] + [math + ["." random] + [number + ["n" nat]]]] ["." / #_ ["#." date] ["#." day] ["#." duration] ["#." instant] ["#." month] - ["#." year]]) + ["#." year]] + {1 + ["." / + ["." duration]]}) -(def: #export test +(def: for_implementation Test ($_ _.and - /date.test - /day.test - /duration.test - /instant.test - /month.test - /year.test - )) + (_.for [/.equivalence] + ($equivalence.spec /.equivalence random.time)) + (_.for [/.order] + ($order.spec /.order random.time)) + (_.for [/.enum] + ($enum.spec /.enum random.time)) + (_.for [/.codec] + ($codec.spec /.equivalence /.codec random.time)))) + +(def: for_clock + Test + (do {! random.monad} + [expected random.time] + (_.cover [/.clock /.time] + (|> expected + /.clock + /.time + (try\map (\ /.equivalence = expected)) + (try.default false))))) + +(def: for_ranges + Test + (do {! random.monad} + [valid_hour (\ ! map (|>> (n.% /.hours) (n.max 10)) random.nat) + valid_minute (\ ! map (|>> (n.% /.minutes) (n.max 10)) random.nat) + valid_second (\ ! map (|>> (n.% /.seconds) (n.max 10)) random.nat) + valid_milli_second (\ ! map (n.% /.milli_seconds) random.nat) + + #let [invalid_hour (|> valid_hour (n.+ /.hours)) + invalid_minute (|> valid_minute (n.+ /.minutes) (n.min 99)) + invalid_second (|> valid_second (n.+ /.seconds) (n.min 99))]] + (`` ($_ _.and + (~~ (template [<cap> <exception> <prefix> <suffix> <valid> <invalid>] + [(_.cover [<cap> <exception>] + (let [valid! + (|> <valid> + %.nat + (text.prefix <prefix>) + (text.suffix <suffix>) + (\ /.codec decode) + (case> (#try.Success _) true + (#try.Failure error) false)) + + invalid! + (|> <invalid> + %.nat + (text.prefix <prefix>) + (text.suffix <suffix>) + (\ /.codec decode) + (case> (#try.Success _) + false + + (#try.Failure error) + (exception.match? <exception> error)))] + (and valid! + invalid!)))] + + [/.hours /.invalid_hour "" ":00:00.000" valid_hour invalid_hour] + [/.minutes /.invalid_minute "00:" ":00.000" valid_minute invalid_minute] + [/.seconds /.invalid_second "00:00:" ".000" valid_second invalid_second] + )) + (_.cover [/.milli_seconds] + (|> valid_milli_second + %.nat + (format "00:00:00.") + (\ /.codec decode) + (case> (#try.Success _) true + (#try.Failure error) false))) + )))) + +(def: #export test + Test + (<| (_.covering /._) + (_.for [/.Time]) + (do {! random.monad} + [#let [day (.nat (duration.to_millis duration.day))] + expected random.time + + out_of_bounds (\ ! map (|>> /.to_millis (n.+ day)) + random.time)] + (`` ($_ _.and + ..for_implementation + + (_.cover [/.to_millis /.from_millis] + (|> expected + /.to_millis + /.from_millis + (try\map (\ /.equivalence = expected)) + (try.default false))) + (_.cover [/.time_exceeds_a_day] + (case (/.from_millis out_of_bounds) + (#try.Success _) + false + + (#try.Failure error) + (exception.match? /.time_exceeds_a_day error))) + (_.cover [/.midnight] + (|> /.midnight + /.to_millis + (n.= 0))) + (_.cover [/.parser] + (|> expected + (\ /.codec encode) + (<text>.run /.parser) + (try\map (\ /.equivalence = expected)) + (try.default false))) + ..for_ranges + (_.for [/.Clock] + ..for_clock) + + /date.test + /day.test + /duration.test + /instant.test + /month.test + /year.test + ))))) |