diff options
Diffstat (limited to '')
40 files changed, 636 insertions, 530 deletions
diff --git a/new-luxc/project.clj b/new-luxc/project.clj index 0a09f24aa..a6f3510f2 100644 --- a/new-luxc/project.clj +++ b/new-luxc/project.clj @@ -1,22 +1,25 @@ -(defproject com.github.luxlang/new-luxc "0.6.0-SNAPSHOT" +(def version "0.6.0-SNAPSHOT") +(def repo "https://github.com/LuxLang/lux") +(def sonatype-releases "https://oss.sonatype.org/service/local/staging/deploy/maven2/") +(def sonatype-snapshots "https://oss.sonatype.org/content/repositories/snapshots/") + +(defproject com.github.luxlang/new-luxc #=(identity version) :description "A re-written compiler for Lux." - :url "https://github.com/LuxLang/lux" + :url ~repo :license {:name "Lux License v0.1" - :url "https://github.com/LuxLang/lux/blob/master/license.txt"} - :plugins [[com.github.luxlang/lein-luxc "0.6.0-SNAPSHOT"]] - :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" - :creds :gpg}] - ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" - :creds :gpg}]] + :url ~(str repo "/blob/master/license.txt")} + :plugins [[com.github.luxlang/lein-luxc ~version]] + :deploy-repositories [["releases" {:url ~sonatype-releases :creds :gpg}] + ["snapshots" {:url ~sonatype-snapshots :creds :gpg}]] :pom-addition [:developers [:developer [:name "Eduardo Julian"] [:url "https://github.com/eduardoejp"]]] - :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"] - ["releases" "https://oss.sonatype.org/service/local/staging/deploy/maven2/"] + :repositories [["releases" ~sonatype-releases] + ["snapshots" ~sonatype-snapshots] ["bedatadriven" "https://nexus.bedatadriven.com/content/groups/public/"] ["jitpack" "https://jitpack.io"]] :scm {:name "git" - :url "https://github.com/LuxLang/lux.git"} + :url ~(str repo ".git")} :dependencies [;; JVM Bytecode [org.ow2.asm/asm-all "5.0.3"] diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index 656d07d21..32a24452d 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -5,14 +5,14 @@ ["p" parser]] [data [collection - [list ("list/." Functor<List>)]]] + ["." list ("#/." functor)]]] [macro ["." code] ["s" syntax (#+ syntax:)]] [host (#+ import:)] [world [binary (#+ Binary)]] - [platform + [tool [compiler [reference (#+ Register)] [phase diff --git a/new-luxc/source/luxc/lang/host/jvm/def.lux b/new-luxc/source/luxc/lang/host/jvm/def.lux index e8efe306b..db6bfe07b 100644 --- a/new-luxc/source/luxc/lang/host/jvm/def.lux +++ b/new-luxc/source/luxc/lang/host/jvm/def.lux @@ -6,7 +6,7 @@ ["." product] [collection ["." array (#+ Array)] - ["." list ("list/." Functor<List>)]]] + ["." list ("#/." functor)]]] ["." host (#+ import: do-to)] ["." function]] ["$" // @@ -266,22 +266,22 @@ (FieldVisitor::visitEnd))] writer)))] - [boolean-field Bit $t.boolean id] + [boolean-field Bit $t.boolean function.identity] [byte-field Int $t.byte host.long-to-byte] [short-field Int $t.short host.long-to-short] [int-field Int $t.int host.long-to-int] - [long-field Int $t.long id] + [long-field Int $t.long function.identity] [float-field Frac $t.float host.double-to-float] - [double-field Frac $t.double id] + [double-field Frac $t.double function.identity] [char-field Nat $t.char (|>> .int host.long-to-int host.int-to-char)] - [string-field Text ($t.class "java.lang.String" (list)) id] + [string-field Text ($t.class "java.lang.String" (list)) function.identity] ) (def: #export (fuse defs) (-> (List $.Def) $.Def) (case defs #.Nil - id + function.identity (#.Cons singleton #.Nil) singleton diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux index 9a26f8df0..5311f39d9 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -9,13 +9,13 @@ [text format] [collection - ["." list ("list/." Functor<List>)]]] + ["." list ("#/." functor)]]] ["." host (#+ import: do-to)] [macro ["." code] ["s" syntax (#+ syntax:)]] ["." function] - [platform + [tool [compiler [phase (#+ Operation)]]]] ["." // (#+ Primitive Inst) @@ -134,12 +134,12 @@ (do-to visitor (MethodVisitor::visitLdcInsn (<prepare> value)))))] - [boolean Bit id] + [boolean Bit function.identity] [int Int host.long-to-int] - [long Int id] - [double Frac id] + [long Int function.identity] + [double Frac function.identity] [char Nat (|>> .int host.long-to-int host.int-to-char)] - [string Text id] + [string Text function.identity] ) (syntax: (prefix {base s.local-identifier}) @@ -380,7 +380,7 @@ (-> (List Inst) Inst) (case insts #.Nil - id + function.identity (#.Cons singleton #.Nil) singleton diff --git a/new-luxc/source/luxc/lang/host/jvm/type.lux b/new-luxc/source/luxc/lang/host/jvm/type.lux index 57374337d..523944b44 100644 --- a/new-luxc/source/luxc/lang/host/jvm/type.lux +++ b/new-luxc/source/luxc/lang/host/jvm/type.lux @@ -4,7 +4,7 @@ ["." text format] [collection - ["." list ("list/." Functor<List>)]]]] + ["." list ("#/." functor)]]]] ["." //]) ## Types diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index 9a6eb25ed..88e607217 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -1,26 +1,26 @@ (.module: [lux (#- Definition) [control + pipe [monad (#+ do)] ["ex" exception (#+ exception:)] - pipe] - [concurrency - ["." atom (#+ Atom atom)]] + [concurrency + ["." atom (#+ Atom atom)]]] [data ["." error (#+ Error)] - ["." text ("text/." Hash<Text>) + ["." text ("#/." hash) format] [collection ["." array] - [list ("list/." Functor<List>)] + [list ("#/." functor)] ["." dictionary (#+ Dictionary)]]] ["." host (#+ import: do-to object) [jvm - ["." loader]]] + ["." loader (#+ Library)]]] ["." io (#+ IO io)] [world [binary (#+ Binary)]] - [platform + [tool [compiler ["." name] [phase @@ -76,18 +76,17 @@ #.None (ex.throw invalid-value class-name)) - (#error.Error error) + (#error.Failure error) (ex.throw cannot-load [class-name error])) - (#error.Error error) + (#error.Failure error) (ex.throw invalid-field [class-name ..value-field error]))) -(def: module-separator "/") (def: class-path-separator ".") -(def: (evaluate! store loader eval-class valueI) - (-> Store ClassLoader Text Inst (Error Any)) - (let [bytecode-name (text.replace-all class-path-separator module-separator eval-class) +(def: (evaluate! library loader eval-class valueI) + (-> Library ClassLoader Text Inst (Error Any)) + (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class) bytecode (def.class #jvm.V1_6 #jvm.Public jvm.noneC bytecode-name @@ -101,24 +100,24 @@ (|>> valueI (inst.PUTSTATIC bytecode-name ..value-field ..$Object) inst.RETURN))))] - (io.run (do (error.ErrorT io.Monad<IO>) - [_ (loader.store eval-class bytecode store) + (io.run (do (error.with-error io.monad) + [_ (loader.store eval-class bytecode library) class (loader.load eval-class loader)] - (:: io.Monad<IO> wrap (class-value eval-class class)))))) + (:: io.monad wrap (class-value eval-class class)))))) -(def: (execute! store loader temp-label [class-name class-bytecode]) - (-> Store ClassLoader Text Definition (Error Any)) - (io.run (do (error.ErrorT io.Monad<IO>) - [_ (loader.store class-name class-bytecode store)] +(def: (execute! library loader temp-label [class-name class-bytecode]) + (-> Library ClassLoader Text Definition (Error Any)) + (io.run (do (error.with-error io.monad) + [_ (loader.store class-name class-bytecode library)] (loader.load class-name loader)))) -(def: (define! store loader [module name] valueI) - (-> Store ClassLoader Name Inst (Error [Text Any])) - (let [class-name (format (text.replace-all module-separator class-path-separator module) +(def: (define! library loader [module name] valueI) + (-> Library ClassLoader Name Inst (Error [Text Any])) + (let [class-name (format (text.replace-all .module-separator class-path-separator module) class-path-separator (name.normalize name) "___" (%n (text/hash name)))] - (do error.Monad<Error> - [value (evaluate! store loader class-name valueI)] + (do error.monad + [value (evaluate! library loader class-name valueI)] (wrap [class-name value])))) (def: #export init diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux index 78ef508e8..72c316d83 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux @@ -1,14 +1,15 @@ (.module: [lux (#- if let case) + ["." function] [control [monad (#+ do)] ["ex" exception (#+ exception:)]] [data [text format]] - [platform + [tool [compiler - ["." phase ("operation/." Monad<Operation>) + ["." phase ("operation/." monad) ["." synthesis (#+ Path Synthesis)]]]]] [luxc [lang @@ -22,7 +23,7 @@ (def: (pop-altI stack-depth) (-> Nat Inst) (.case stack-depth - 0 id + 0 function.identity 1 _.POP 2 _.POP2 _ ## (n/> 2) @@ -99,7 +100,7 @@ (_.IFEQ @else))) (#synthesis.Then bodyS) - (do phase.Monad<Operation> + (do phase.monad [bodyI (phase bodyS)] (wrap (|>> (pop-altI stack-depth) bodyI @@ -127,7 +128,7 @@ (_.GOTO @else) (_.label @success) pushI)))) - ([synthesis.side/left _.NULL .id] + ([synthesis.side/left _.NULL function.identity] [synthesis.side/right (_.string "") .inc]) (^template [<pattern> <method> <prepare>] @@ -151,11 +152,11 @@ (list)) #0) pushI)))) - ([synthesis.member/left "pm_left" id] + ([synthesis.member/left "pm_left" function.identity] [synthesis.member/right "pm_right" inc]) (#synthesis.Alt leftP rightP) - (do phase.Monad<Operation> + (do phase.monad [@alt-else _.make-label leftI (path' phase (inc stack-depth) @alt-else @end leftP) rightI (path' phase stack-depth @else @end rightP)] @@ -166,7 +167,7 @@ rightI))) (#synthesis.Seq leftP rightP) - (do phase.Monad<Operation> + (do phase.monad [leftI (path' phase stack-depth @else @end leftP) rightI (path' phase stack-depth @else @end rightP)] (wrap (|>> leftI @@ -175,7 +176,7 @@ (def: (path phase path @end) (-> Phase Path Label (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [@else _.make-label pathI (..path' phase 1 @else @end path)] (wrap (|>> pathI @@ -190,7 +191,7 @@ (def: #export (if phase testS thenS elseS) (-> Phase Synthesis Synthesis Synthesis (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [testI (phase testS) thenI (phase thenS) elseI (phase elseS)] @@ -207,7 +208,7 @@ (def: #export (let phase inputS register exprS) (-> Phase Synthesis Nat Synthesis (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [inputI (phase inputS) exprI (phase exprS)] (wrap (|>> inputI @@ -216,7 +217,7 @@ (def: #export (case phase valueS path) (-> Phase Synthesis Path (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [@end _.make-label valueI (phase valueS) pathI (..path phase path @end)] diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux index f0b73ac23..57fc576fa 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux @@ -6,7 +6,7 @@ ["." io] [data ["." error (#+ Error)] - ["." text ("text/." Hash<Text>) + ["." text ("#/." hash) format] [collection ["." dictionary (#+ Dictionary)]]] @@ -14,7 +14,7 @@ [host (#+ import:)] [world [binary (#+ Binary)]] - [platform + [tool [compiler ["." name] [reference (#+ Register)] @@ -31,7 +31,7 @@ ## (function (_ state) ## (case (action (update@ #.host ## (|>> (:coerce Host) -## (set@ #artifacts (dictionary.new text.Hash<Text>)) +## (set@ #artifacts (dictionary.new text.hash)) ## (:coerce Nothing)) ## state)) ## (#error.Success [state' output]) @@ -52,10 +52,10 @@ ## (let [normal-name (format (name.normalize def-name) (%n (text/hash def-name))) ## class-name (format (text.replace-all "/" "." def-module) "." normal-name)] ## (<| (macro.run state) -## (do macro.Monad<Meta> +## (do macro.monad ## [_ (..store-class class-name def-bytecode) ## class (..load-class class-name)] -## (case (do error.Monad<Error> +## (case (do error.monad ## [field (Class::getField [..value-field] class)] ## (Field::get [#.None] field)) ## (#error.Success (#.Some def-value)) diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux index 7af459900..ba96731a8 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux @@ -1,6 +1,6 @@ (.module: [lux #* - [platform + [tool [compiler [phase ["." synthesis] @@ -67,4 +67,4 @@ (function.function translate abstraction) (#synthesis.Extension extension) - (extension.apply "Translation" translate extension))) + (extension.apply translate extension))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux index 8e5fe30b3..65a66e65a 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux @@ -1,13 +1,15 @@ (.module: [lux (#- function) + ["." function] [control + [pipe (#+ when> new>)] ["." monad (#+ do)]] [data ["." text format] [collection - ["." list ("list/." Functor<List> Monoid<List>)]]] - [platform + ["." list ("#/." functor monoid)]]] + [tool [compiler ["_." reference (#+ Register Variable)] ["." phase @@ -75,7 +77,7 @@ (let [max-args (n/min amount runtime.num-apply-variants) later-applysI (if (n/> runtime.num-apply-variants amount) (applysI (n/+ runtime.num-apply-variants start) (n/- runtime.num-apply-variants amount)) - id)] + function.identity)] (|>> (_.CHECKCAST //.function-class) (inputsI start max-args) (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature max-args) #0) @@ -106,17 +108,17 @@ (list/map (.function (_ idx) (def.field #$.Private $.finalF (reference.partial-name idx) $Object))) def.fuse) - id)) + function.identity)) (def: (instance class arity env) (-> Text Arity (List Variable) (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [captureI+ (monad.map @ reference.variable env) #let [argsI (if (poly-arg? arity) (|> (nullsI (dec arity)) (list (_.int +0)) _.fuse) - id)]] + function.identity)]] (wrap (|>> (_.NEW class) _.DUP (_.fuse captureI+) @@ -187,7 +189,7 @@ (_.ALOAD (inc register)) (_.PUTFIELD class (reference.partial-name idx) $Object))))) _.fuse) - id)] + function.identity)] (def.method #$.Public $.noneM "<init>" (init-method env arity) (|>> (_.ALOAD 0) (function-init arity env-size) @@ -209,12 +211,12 @@ (|> (list.n/range 0 (dec stage)) (list/map (|>> reference.partial-name (load-fieldI class))) _.fuse) - id)] + function.identity)] (cond (i/= arity-over-extent (.int stage)) (|>> (_.label @label) (_.ALOAD 0) - (when (n/> 0 stage) - (_.INVOKEVIRTUAL class "reset" (reset-method class) #0)) + (when> [(new> (n/> 0 stage) [])] + [(_.INVOKEVIRTUAL class "reset" (reset-method class) #0)]) load-partialsI (inputsI 1 apply-arity) (_.INVOKEVIRTUAL class "impl" (implementation-method function-arity) #0) @@ -285,13 +287,13 @@ (with-reset class arity env) applyD ))] - (do phase.Monad<Operation> + (do phase.monad [instanceI (instance class arity env)] (wrap [functionD instanceI])))) (def: #export (function translate [env arity bodyS]) (-> Phase Abstraction (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [@begin _.make-label [function-class bodyI] (translation.with-context (translation.with-anchor [@begin 1] @@ -314,7 +316,7 @@ (def: #export (call translate [functionS argsS]) (-> Phase Apply (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [functionI (translate functionS) argsI (monad.map @ translate argsS) #let [applyI (|> (segment runtime.num-apply-variants argsI) diff --git a/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux index 40f4decd9..5e01a4ea0 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux @@ -1,13 +1,14 @@ (.module: [lux #* + ["." function] [control ["." monad (#+ do)]] [data ["." text format] [collection - ["." list ("list/." Functor<List> Monoid<List>)]]] - [platform + ["." list ("#/." functor monoid)]]] + [tool [compiler [reference (#+ Register)] ["." phase @@ -31,7 +32,7 @@ (def: #export (recur translate argsS) (-> Phase (List Synthesis) (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [[@begin start] translation.anchor #let [end (|> argsS list.size dec (n/+ start)) pairs (list.zip2 (list.n/range start end) @@ -47,13 +48,13 @@ valuesI+ (monad.map @ (function (_ [register argS]) (: (Operation Inst) (if (constant? register argS) - (wrap id) + (wrap function.identity) (translate argS)))) pairs) #let [storesI+ (list/map (function (_ [register argS]) (: Inst (if (constant? register argS) - id + function.identity (_.ASTORE register)))) (list.reverse pairs))]] (wrap (|>> (_.fuse valuesI+) @@ -62,7 +63,7 @@ (def: #export (scope translate [start initsS+ iterationS]) (-> Phase [Nat (List Synthesis) Synthesis] (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [@begin _.make-label initsI+ (monad.map @ translate initsS+) iterationI (translation.with-anchor [@begin start] diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux index 7129a3887..628edff49 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux @@ -5,9 +5,9 @@ [data [text format]] - [platform + [tool [compiler - [phase ("operation/." Monad<Operation>)]]]] + [phase ("operation/." monad)]]]] [luxc [lang [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux index 154dcbdcf..afd140997 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -8,12 +8,12 @@ ["." text format] [collection - ["." list ("list/." Functor<List>)] + ["." list ("#/." functor)] ["." dictionary]]] ["." macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax:)]] - [platform + [tool [compiler ["." phase [synthesis (#+ Synthesis)] @@ -58,7 +58,7 @@ (function ((~ g!_) (~ g!extension-name) (~ g!phase) (~ g!inputs)) (case (~ g!inputs) (^ (list (~+ g!inputC+))) - (do phase.Monad<Operation> + (do phase.monad [(~+ (|> g!inputC+ (list/map (function (_ g!input) (list g!input (` ((~ g!phase) (~ g!input)))))) @@ -77,7 +77,7 @@ (def: #export (variadic extension) (-> Variadic Handler) (function (_ extension-name phase inputsS) - (do phase.Monad<Operation> + (do phase.monad [inputsH (monad.map @ phase inputsS)] (wrap (extension inputsH))))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux index 370f07f82..483f810e2 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux @@ -1,16 +1,16 @@ (.module: lux (lux (control [monad #+ do] - ["p" parser "parser/" Monad<Parser>] + ["p" parser ("#/." monad)] ["ex" exception #+ exception:]) (data [product] ["e" error] - [text "text/" Eq<Text>] + [text ("#/." equivalence)] (text format ["l" lexer]) - (coll [list "list/" Functor<List>] + (coll [list ("#/." functor)] (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>] + [macro ("#/." monad)] (macro [code] ["s" syntax #+ syntax:]) [host]) @@ -84,7 +84,7 @@ (def: conversion-procs @.Bundle (<| (@.prefix "convert") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "double-to-float" (@.unary convert//double-to-float)) (@.install "double-to-int" (@.unary convert//double-to-int)) (@.install "double-to-long" (@.unary convert//double-to-long)) @@ -209,7 +209,7 @@ (def: int-procs @.Bundle (<| (@.prefix "int") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "+" (@.binary int//+)) (@.install "-" (@.binary int//-)) (@.install "*" (@.binary int//*)) @@ -228,7 +228,7 @@ (def: long-procs @.Bundle (<| (@.prefix "long") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "+" (@.binary long//+)) (@.install "-" (@.binary long//-)) (@.install "*" (@.binary long//*)) @@ -247,7 +247,7 @@ (def: float-procs @.Bundle (<| (@.prefix "float") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "+" (@.binary float//+)) (@.install "-" (@.binary float//-)) (@.install "*" (@.binary float//*)) @@ -260,7 +260,7 @@ (def: double-procs @.Bundle (<| (@.prefix "double") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "+" (@.binary double//+)) (@.install "-" (@.binary double//-)) (@.install "*" (@.binary double//*)) @@ -273,7 +273,7 @@ (def: char-procs @.Bundle (<| (@.prefix "char") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "=" (@.binary char//=)) (@.install "<" (@.binary char//<)) ))) @@ -289,7 +289,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS)) - (do macro.Monad<Meta> + (do macro.monad [lengthI (translate lengthS) #let [arrayJT ($t.array level (case class "boolean" $t.boolean @@ -313,7 +313,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Text class)] idxS arrayS)) - (do macro.Monad<Meta> + (do macro.monad [arrayI (translate arrayS) idxI (translate idxS) #let [loadI (case class @@ -339,7 +339,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Text class)] idxS valueS arrayS)) - (do macro.Monad<Meta> + (do macro.monad [arrayI (translate arrayS) idxI (translate idxS) valueI (translate valueS) @@ -367,7 +367,7 @@ (def: array-procs @.Bundle (<| (@.prefix "array") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "length" (@.unary array//length)) (@.install "new" array//new) (@.install "read" array//read) @@ -408,7 +408,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Text class)])) - (do macro.Monad<Meta> + (do macro.monad [] (wrap (|>> (_.string class) (_.INVOKESTATIC "java.lang.Class" "forName" @@ -424,7 +424,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Text class)] objectS)) - (do macro.Monad<Meta> + (do macro.monad [objectI (translate objectS)] (wrap (|>> objectI (_.INSTANCEOF class) @@ -437,7 +437,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Text from)] [_ (#.Text to)] valueS)) - (do macro.Monad<Meta> + (do macro.monad [valueI (translate valueS)] (case [from to] ## Wrap @@ -465,7 +465,7 @@ (def: object-procs @.Bundle (<| (@.prefix "object") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "null" (@.nullary object//null)) (@.install "null?" (@.unary object//null?)) (@.install "synchronized" (@.binary object//synchronized)) @@ -485,13 +485,13 @@ ["float" #$.Float] ["double" #$.Double] ["char" #$.Char]) - (dict.from-list text.Hash<Text>))) + (dict.from-list text.hash))) (def: (static//get proc translate inputs) (-> Text @.Proc) (case inputs (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)])) - (do macro.Monad<Meta> + (do macro.monad [] (case (dict.get unboxed primitives) (#.Some primitive) @@ -518,7 +518,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS)) - (do macro.Monad<Meta> + (do macro.monad [valueI (translate valueS)] (case (dict.get unboxed primitives) (#.Some primitive) @@ -550,7 +550,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS)) - (do macro.Monad<Meta> + (do macro.monad [objectI (translate objectS)] (case (dict.get unboxed primitives) (#.Some primitive) @@ -581,7 +581,7 @@ (-> Text @.Proc) (case inputs (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS)) - (do macro.Monad<Meta> + (do macro.monad [valueI (translate valueS) objectI (translate objectS)] (case (dict.get unboxed primitives) @@ -632,7 +632,7 @@ (def: java-type (l.Lexer $.Type) - (do p.Monad<Parser> + (do p.monad [raw base-type nesting (p.some (l.this "[]"))] (wrap ($t.array (list.size nesting) raw)))) @@ -651,7 +651,7 @@ (Meta [$.Type $.Inst])) (case argS (^ [_ (#.Tuple (list [_ (#.Text argD)] argS))]) - (do macro.Monad<Meta> + (do macro.monad [argT (translate-type argD) argI (translate argS)] (wrap [argT argI])) @@ -673,7 +673,7 @@ (case inputs (^ (list& [_ (#.Text class)] [_ (#.Text method)] [_ (#.Text unboxed)] argsS)) - (do macro.Monad<Meta> + (do macro.monad [argsTI (monad.map @ (translate-arg translate) argsS) returnT (method-return-type unboxed)] (wrap (|>> (_.fuse (list/map product.right argsTI)) @@ -690,7 +690,7 @@ (case inputs (^ (list& [_ (#.Text class)] [_ (#.Text method)] [_ (#.Text unboxed)] objectS argsS)) - (do macro.Monad<Meta> + (do macro.monad [objectI (translate objectS) argsTI (monad.map @ (translate-arg translate) argsS) returnT (method-return-type unboxed)] @@ -713,7 +713,7 @@ (-> Text @.Proc) (case inputs (^ (list& [_ (#.Text class)] argsS)) - (do macro.Monad<Meta> + (do macro.monad [argsTI (monad.map @ (translate-arg translate) argsS)] (wrap (|>> (_.NEW class) _.DUP @@ -728,17 +728,17 @@ (def: member-procs @.Bundle (<| (@.prefix "member") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (dict.merge (<| (@.prefix "static") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "get" static//get) (@.install "put" static//put)))) (dict.merge (<| (@.prefix "virtual") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "get" virtual//get) (@.install "put" virtual//put)))) (dict.merge (<| (@.prefix "invoke") - (|> (dict.new text.Hash<Text>) + (|> (dict.new text.hash) (@.install "static" invoke//static) (@.install "virtual" invoke//virtual) (@.install "special" invoke//special) diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux index 175338ba4..fe4a58b36 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux @@ -5,11 +5,11 @@ [data [text format]] - [platform + [tool [compiler ["." name] ["." reference (#+ Register Variable)] - ["." phase ("operation/." Monad<Operation>) + ["." phase ("operation/." monad) ["." translation]]]]] [luxc [lang @@ -30,7 +30,7 @@ (def: (foreign variable) (-> Register (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [function-class translation.context] (wrap (|>> (_.ALOAD 0) (_.GETFIELD function-class @@ -52,6 +52,6 @@ (def: #export (constant name) (-> Name (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [bytecode-name (translation.remember name)] (operation/wrap (_.GETSTATIC bytecode-name //.value-field //.$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux index a22ed2b07..81bae4cd2 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -6,9 +6,9 @@ [text format] [collection - ["." list ("list/." Functor<List>)]]] + ["." list ("#/." functor)]]] ["." math] - [platform + [tool [compiler ["." phase [analysis (#+ Arity)] @@ -309,7 +309,7 @@ frac-methods pm-methods io-methods))] - (do phase.Monad<Operation> + (do phase.monad [_ (translation.execute! //.runtime-class [//.runtime-class bytecode])] (wrap bytecode)))) @@ -339,13 +339,13 @@ (_.PUTFIELD //.function-class partials-field $t.int) _.RETURN)) applyI))] - (do phase.Monad<Operation> + (do phase.monad [_ (translation.execute! //.function-class [//.function-class bytecode])] (wrap bytecode)))) (def: #export translate (Operation Any) - (do phase.Monad<Operation> + (do phase.monad [runtime-bc translate-runtime function-bc translate-function] (wrap []))) diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux index 9f69b1edd..a8d135f7a 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux @@ -8,7 +8,7 @@ format] [collection ["." list]]] - [platform + [tool [compiler ["." phase [synthesis (#+ Synthesis)]]]]] @@ -28,7 +28,7 @@ (def: #export (tuple translate members) (-> Phase (List Synthesis) (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [#let [size (list.size members)] _ (phase.assert not-a-tuple size (n/>= 2 size)) @@ -54,7 +54,7 @@ (def: #export (variant translate lefts right? member) (-> Phase Nat Bit Synthesis (Operation Inst)) - (do phase.Monad<Operation> + (do phase.monad [memberI (translate member)] (wrap (|>> (_.int (.int (if right? (.inc lefts) diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index 4fa032f7f..cee627708 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -1,19 +1,19 @@ (.module: [lux #* + [cli (#+ program:)] [control [monad (#+ do)]] [data - ["." error] + ["." error (#+ Error)] ["." text format]] - ["." io (#+ IO Process io)] + ["." io (#+ IO io)] [time - ["." instant]] - [cli (#+ program:)] + ["." instant (#+ Instant)]] [world ["." file (#+ File)] ["." console]] - [platform + [tool ["." compiler ["." cli (#+ Configuration)] [meta @@ -26,9 +26,9 @@ [default ["." platform (#+ Platform)] ["." init] - ["." syntax]]]] - ## ["." interpreter] - ] + ["." syntax]]] + ## ["." interpreter] + ]] [luxc [lang ["." host/jvm] @@ -41,11 +41,11 @@ (def: (or-crash! failure-description action) (All [a] - (-> Text (Process a) (IO a))) - (do io.Monad<IO> + (-> Text (IO (Error a)) (IO a))) + (do io.monad [?output action] (case ?output - (#error.Error error) + (#error.Failure error) (exec (log! (format text.new-line failure-description text.new-line error text.new-line)) @@ -56,38 +56,44 @@ (def: (timed action) (All [a] - (-> (-> Any (Process a)) (Process a))) - (do io.Monad<Process> - [start (io.from-io instant.now) + (-> (-> Any (IO (Error a))) (IO (Error a)))) + (do (error.with-error io.monad) + [start (: (IO (Error Instant)) + (error.lift io.monad instant.now)) result (action []) - finish (io.from-io instant.now) + finish (: (IO (Error Instant)) + (error.lift io.monad instant.now)) #let [elapsed-time (instant.span start finish) _ (log! (format text.new-line "Elapsed time: " (%duration elapsed-time)))]] (wrap result))) (def: jvm-platform - (IO (Platform Process host/jvm.Anchor host/jvm.Inst host/jvm.Definition)) - (do io.Monad<IO> + (IO (Platform IO host/jvm.Anchor host/jvm.Inst host/jvm.Definition)) + (do io.monad [host jvm.init] - (wrap {#platform.host host + (wrap {#platform.&monad io.monad + #platform.&file-system file.system + #platform.host host #platform.phase expression.translate - #platform.runtime runtime.translate - #platform.file-system file.JVM@System}))) + #platform.runtime runtime.translate}))) (program: [{service cli.service}] - (do io.Monad<IO> - [platform ..jvm-platform - console (:: @ map error.assume console.open)] + (do io.monad + [platform (: (IO (Platform IO host/jvm.Anchor host/jvm.Inst host/jvm.Definition)) + ..jvm-platform) + console (:: @ map error.assume console.system)] (case service (#cli.Compilation configuration) (<| (or-crash! "Compilation failed:") ..timed (function (_ _) - (do (:: (get@ #platform.file-system platform) &monad) - [state (platform.initialize platform common.bundle) - _ (platform.compile platform (set@ #cli.module syntax.prelude configuration) state) - ## _ (compile platform configuration state) + (do (error.with-error io.monad) + [state (: (IO (Error (statement.State+ host/jvm.Anchor host/jvm.Inst host/jvm.Definition))) + (platform.initialize platform common.bundle)) + ## _ (platform.compile platform (set@ #cli.module syntax.prelude configuration) state) + _ (: (IO (Error Any)) + (platform.compile platform configuration state)) ## _ (cache/io.clean target ...) ] (wrap (log! "Compilation complete!"))))) @@ -96,5 +102,5 @@ ## TODO: Fix the interpreter... (undefined) ## (<| (or-crash! "Interpretation failed:") - ## (interpreter.run io.Monad<Process> console platform configuration common.bundle)) + ## (interpreter.run (error.with-error io.monad) console platform configuration common.bundle)) ))) diff --git a/stdlib/project.clj b/stdlib/project.clj index 9497165ab..97d1e2901 100644 --- a/stdlib/project.clj +++ b/stdlib/project.clj @@ -1,20 +1,20 @@ (def version "0.6.0-SNAPSHOT") (def repo "https://github.com/LuxLang/lux") -(def sonetype-releases "https://oss.sonatype.org/service/local/staging/deploy/maven2/") -(def sonetype-snapshots "https://oss.sonatype.org/content/repositories/snapshots/") +(def sonatype-releases "https://oss.sonatype.org/service/local/staging/deploy/maven2/") +(def sonatype-snapshots "https://oss.sonatype.org/content/repositories/snapshots/") (defproject com.github.luxlang/stdlib #=(identity version) :url ~repo :license {:name "Lux License v0.1" :url ~(str repo "/blob/master/license.txt")} :plugins [[com.github.luxlang/lein-luxc ~version]] - :deploy-repositories [["releases" {:url ~sonetype-releases :creds :gpg}] - ["snapshots" {:url ~sonetype-snapshots :creds :gpg}]] + :deploy-repositories [["releases" {:url ~sonatype-releases :creds :gpg}] + ["snapshots" {:url ~sonatype-snapshots :creds :gpg}]] :pom-addition [:developers [:developer [:name "Eduardo Julian"] [:url "https://github.com/eduardoejp"]]] - :repositories [["releases" ~sonetype-releases] - ["snapshots" ~sonetype-snapshots]] + :repositories [["releases" ~sonatype-releases] + ["snapshots" ~sonatype-snapshots]] :scm {:name "git" :url ~(str repo ".git")} diff --git a/stdlib/source/lux/tool/compiler.lux b/stdlib/source/lux/tool/compiler.lux index b4fdd541e..e151c9e94 100644 --- a/stdlib/source/lux/tool/compiler.lux +++ b/stdlib/source/lux/tool/compiler.lux @@ -7,12 +7,12 @@ [collection ["." dictionary (#+ Dictionary)]]] [world - ["." file (#+ File)]]] + ["." file (#+ Path)]]] [/ [meta ["." archive (#+ Archive) [key (#+ Key)] - [descriptor (#+ Module)] + [descriptor (#+ Descriptor Module)] [document (#+ Document)]]]]) (type: #export Code @@ -23,7 +23,7 @@ (type: #export Input {#module Module - #file File + #file Path #hash Nat #code Code}) @@ -34,7 +34,7 @@ {#dependencies (List Module) #process (-> Archive (Error (Either (Compilation d o) - [(Document d) (Output o)])))}) + [[Descriptor (Document d)] (Output o)])))}) (type: #export (Compiler d o) (-> Input (Compilation d o))) diff --git a/stdlib/source/lux/tool/compiler/cli.lux b/stdlib/source/lux/tool/compiler/cli.lux index 7e92b2c34..e08c83c7e 100644 --- a/stdlib/source/lux/tool/compiler/cli.lux +++ b/stdlib/source/lux/tool/compiler/cli.lux @@ -4,27 +4,29 @@ ["p" parser]] ["." cli (#+ CLI)] [world - [file (#+ File)]]] - [/// - [importer (#+ Source)]]) + [file (#+ Path)]]] + ## [/// + ## [importer (#+ Source)]] + ) (type: #export Configuration - {#sources (List Source) - #target File + {## #sources (List Source) + #sources (List Path) + #target Path #module Text}) (type: #export Service (#Compilation Configuration) (#Interpretation Configuration)) -(do-template [<name> <short> <long>] +(do-template [<name> <long>] [(def: #export <name> (CLI Text) - (cli.parameter [<short> <long>]))] + (cli.named <long> cli.any))] - [source "-s" "--source"] - [target "-t" "--target"] - [module "-m" "--module"] + [source "--source"] + [target "--target"] + [module "--module"] ) (def: #export configuration diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index a416c0a3b..8375c4642 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -8,14 +8,15 @@ ["." error (#+ Error)] ["." text ("#/." hash)] [collection - ["." dictionary]]] + ["." dictionary] + ["." set]]] ["." macro] [world ["." file]]] ["." // ["." syntax (#+ Aliases)] ["." evaluation] - ["/." // (#+ Compiler) + ["/." // (#+ Instancer) ["." host] ["." phase ["." analysis @@ -168,7 +169,7 @@ (All [anchor expression statement] (-> Module (statement.State+ anchor expression statement) - (Compiler .Module))) + (Instancer .Module))) (function (_ key parameters input) (let [hash (text/hash (get@ #///.code input)) dependencies (default-dependencies prelude input)] @@ -186,9 +187,9 @@ #let [descriptor {#descriptor.hash hash #descriptor.name (get@ #///.module input) #descriptor.file (get@ #///.file input) - #descriptor.references dependencies + #descriptor.references (set.from-list text.hash dependencies) #descriptor.state #.Compiled}]] - (wrap (#.Right [(document.write key descriptor analysis-module) + (wrap (#.Right [[descriptor (document.write key analysis-module)] (dictionary.new text.hash)]))))}))) (def: #export key diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 7e3846c09..8711d20ec 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -1,10 +1,10 @@ (.module: [lux #* [control - [monad (#+ do)]] + [monad (#+ Monad do)]] [data ["." product] - ["." error]] + ["." error (#+ Error)]] [world ["." file (#+ File)]]] [// @@ -21,10 +21,11 @@ ["." context]]]]]) (type: #export (Platform ! anchor expression statement) - {#host (translation.Host expression statement) + {#&monad (Monad !) + #&file-system (file.System !) + #host (translation.Host expression statement) #phase (translation.Phase anchor expression statement) - #runtime (translation.Operation anchor expression statement Any) - #file-system (file.System !)}) + #runtime (translation.Operation anchor expression statement Any)}) ## (def: (write-module target-dir file-name module-name module outputs) ## (-> File Text Text Module Outputs (Process Any)) @@ -41,7 +42,7 @@ (def: #export (initialize platform translation-bundle) (All [! anchor expression statement] - (-> <Platform> <Bundle> (! <State+>))) + (-> <Platform> <Bundle> (! (Error <State+>)))) (|> platform (get@ #runtime) statement.lift-translation @@ -49,8 +50,8 @@ (get@ #phase platform) translation-bundle)) (:: error.functor map product.left) - (:: (get@ #file-system platform) lift)) - + (:: (get@ #&monad platform) wrap)) + ## (case (runtimeT.translate ## (initL.compiler (io.run js.init)) ## (initL.compiler (io.run hostL.init-host)) ## ) @@ -79,31 +80,37 @@ (def: #export (compile platform configuration state) (All [! anchor expression statement] - (-> <Platform> Configuration <State+> (! Any))) - (do (:: (get@ #file-system platform) &monad) - [input (context.read (get@ #file-system platform) - (get@ #cli.sources configuration) - (get@ #cli.module configuration)) - ## _ (&io.prepare-module target-dir (get@ #cli.module configuration)) - ## _ (write-module target-dir file-name (get@ #cli.module configuration) module outputs) - ] - ## (case (compiler input) - ## (#error.Failure error) - ## (:: (get@ #file-system platform) lift (#error.Failure error)) - - ## (#error.Success)) - (let [compiler (init.compiler syntax.prelude state) - compilation (compiler init.key (list) input)] - (case ((get@ #///.process compilation) - archive.empty) - (#error.Success more|done) - (case more|done - (#.Left more) - (:: (get@ #file-system platform) lift (#error.Failure "NOT DONE!")) - - (#.Right done) - (wrap [])) - - (#error.Failure error) - (:: (get@ #file-system platform) lift (#error.Failure error)))))) + (-> <Platform> Configuration <State+> (! (Error Any)))) + (let [monad (get@ #&monad platform)] + (do monad + [input (context.read monad + (get@ #&file-system platform) + (get@ #cli.sources configuration) + (get@ #cli.module configuration)) + ## _ (&io.prepare-module target-dir (get@ #cli.module configuration)) + ## _ (write-module target-dir file-name (get@ #cli.module configuration) module outputs) + ] + (wrap (do error.monad + [input input + #let [compiler (init.compiler syntax.prelude state) + compilation (compiler init.key (list) input)]] + (case ((get@ #///.process compilation) + archive.empty) + (#error.Success more|done) + (case more|done + (#.Left more) + (#error.Failure "NOT DONE!") + + (#.Right done) + (wrap [])) + + (#error.Failure error) + (#error.Failure error)))) + + ## (case (compiler input) + ## (#error.Failure error) + ## (:: monad wrap (#error.Failure error)) + + ## (#error.Success)) + ))) ) diff --git a/stdlib/source/lux/tool/compiler/default/syntax.lux b/stdlib/source/lux/tool/compiler/default/syntax.lux index c76857aab..19cfea706 100644 --- a/stdlib/source/lux/tool/compiler/default/syntax.lux +++ b/stdlib/source/lux/tool/compiler/default/syntax.lux @@ -356,7 +356,7 @@ (!number-output start g!end <codec> <tag>)))))] [!parse-nat nat.decimal #.Nat] - [!parse-rev rec.decimal #.Rev] + [!parse-rev rev.decimal #.Rev] ) (template: (!parse-signed source-code//size offset where source-code @end) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index c318bfaf7..e34edf0d4 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -34,44 +34,43 @@ ["Old key" (signature.description (document.signature old))] ["New key" (signature.description (document.signature new))])) -(with-expansions [<Document> (as-is (type (Ex [d] (Document d))))] - (abstract: #export Archive - {} - - (Dictionary Text [Descriptor <Document>]) +(abstract: #export Archive + {} + + (Dictionary Text [Descriptor (Document Any)]) - (def: #export empty - Archive - (:abstraction (dictionary.new text.hash))) + (def: #export empty + Archive + (:abstraction (dictionary.new text.hash))) - (def: #export (add name descriptor document archive) - (-> Module Descriptor <Document> Archive (Error Archive)) - (case (dictionary.get name (:representation archive)) - (#.Some existing) - (if (is? document existing) - (#error.Success archive) - (ex.throw cannot-replace-document [name existing document])) - - #.None - (#error.Success (|> archive - :representation - (dictionary.put name [descriptor document]) - :abstraction)))) + (def: #export (add name [descriptor document] archive) + (-> Module [Descriptor (Document Any)] Archive (Error Archive)) + (case (dictionary.get name (:representation archive)) + (#.Some [existing-descriptor existing-document]) + (if (is? document existing-document) + (#error.Success archive) + (ex.throw cannot-replace-document [name existing-document document])) + + #.None + (#error.Success (|> archive + :representation + (dictionary.put name [descriptor document]) + :abstraction)))) - (def: #export (find name archive) - (-> Module Archive (Error [Descriptor <Document>])) - (case (dictionary.get name (:representation archive)) - (#.Some document) - (#error.Success document) - - #.None - (ex.throw unknown-document [name]))) + (def: #export (find name archive) + (-> Module Archive (Error [Descriptor (Document Any)])) + (case (dictionary.get name (:representation archive)) + (#.Some document) + (#error.Success document) + + #.None + (ex.throw unknown-document [name]))) - (def: #export (merge additions archive) - (-> Archive Archive (Error Archive)) - (monad.fold error.monad - (function (_ [name' descriptor+document'] archive') - (..add name' descriptor+document' archive')) - archive - (dictionary.entries (:representation additions)))) - )) + (def: #export (merge additions archive) + (-> Archive Archive (Error Archive)) + (monad.fold error.monad + (function (_ [name' descriptor+document'] archive') + (..add name' descriptor+document' archive')) + archive + (dictionary.entries (:representation additions)))) + ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux index 328240e6c..5daf10016 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux @@ -4,13 +4,13 @@ [collection [set (#+ Set)]]] [world - [file (#+ File)]]]) + [file (#+ Path)]]]) (type: #export Module Text) (type: #export Descriptor {#hash Nat #name Module - #file File + #file Path #references (Set Module) #state Module-State}) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/lux/tool/compiler/meta/archive/document.lux index 5c077080f..505170efb 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/document.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/document.lux @@ -13,7 +13,6 @@ ["." key (#+ Key)] [descriptor (#+ Module)]]) -## Document (exception: #export (invalid-signature {expected Signature} {actual Signature}) (ex.report ["Expected" (signature.description expected)] ["Actual" (signature.description actual)])) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux index fb96aec58..b8b9c43b2 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux @@ -9,7 +9,6 @@ [//// [default (#+ Version)]]) -## Key (type: #export Signature {#name Name #version Version}) diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux index dd261a539..579164881 100644 --- a/stdlib/source/lux/tool/compiler/meta/io.lux +++ b/stdlib/source/lux/tool/compiler/meta/io.lux @@ -3,9 +3,9 @@ [data ["." text]] [world - [file (#+ File System)]]]) + [file (#+ Path System)]]]) -(type: #export Context File) +(type: #export Context Path) (type: #export Module Text) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux index be72e4ccc..f526a3738 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -1,16 +1,19 @@ (.module: [lux (#- Module Code) [control - monad - ["ex" exception (#+ Exception exception:)]] + [monad (#+ Monad do)] + ["ex" exception (#+ Exception exception:)] + [security + ["!" capability]]] [data - ["." error] - [text + ["." error (#+ Error)] + ["." text ("#/." hash) format ["." encoding]]] [world - ["." file (#+ File)] - [binary (#+ Binary)]]] + ["." file (#+ Path File)] + [binary (#+ Binary)]] + [type (#+ :share)]] ["." // (#+ Context Code) [// [archive @@ -48,60 +51,67 @@ Extension (format partial-host-extension lux-extension)) -(def: #export (file System<m> context module) - (All [m] (-> (file.System m) Context Module File)) +(def: #export (path system context module) + (All [m] (-> (file.System m) Context Module Path)) (|> module - (//.sanitize System<m>) - (format context (:: System<m> separator)))) + (//.sanitize system) + (format context (:: system separator)))) -(def: (find-source-file System<m> contexts module extension) +(def: (find-source-file monad system contexts module extension) (All [!] - (-> (file.System !) (List Context) Module Extension - (! (Maybe File)))) + (-> (Monad !) (file.System !) (List Context) Module Extension + (! (Error [Path (File !)])))) (case contexts #.Nil - (:: (:: System<m> &monad) wrap #.None) + (:: monad wrap (ex.throw ..cannot-find-module [module])) (#.Cons context contexts') - (do (:: System<m> &monad) - [#let [file (format (..file System<m> context module) extension)] - ? (file.exists? System<m> file)] - (if ? - (wrap (#.Some file)) - (find-source-file System<m> contexts' module extension))))) + (do monad + [#let [path (format (..path system context module) extension)] + file (!.use (:: system file) path)] + (case file + (#error.Success file) + (wrap (#error.Success [path file])) -(def: (try System<m> computations exception message) - (All [m a e] (-> (file.System m) (List (m (Maybe a))) (Exception e) e (m a))) - (case computations - #.Nil - (:: System<m> throw exception message) + (#error.Failure error) + (find-source-file monad system contexts' module extension))))) - (#.Cons computation computations') - (do (:: System<m> &monad) - [outcome computation] - (case outcome - (#.Some output) - (wrap output) +(def: #export (find-any-source-file monad system contexts module) + (All [!] + (-> (Monad !) (file.System !) (List Context) Module + (! (Error [Path (File !)])))) + (do monad + [outcome (find-source-file monad system contexts module ..full-host-extension)] + (case outcome + (#error.Success output) + (wrap outcome) - #.None - (try System<m> computations' exception message))))) + (#error.Failure error) + (find-source-file monad system contexts module ..lux-extension)))) -(def: #export (read System<m> contexts module) +(def: #export (read monad system contexts module) (All [!] - (-> (file.System !) (List Context) Module - (! Input))) - (let [find-source-file' (find-source-file System<m> contexts module)] - (do (:: System<m> &monad) - [file (try System<m> - (list (find-source-file' ..full-host-extension) - (find-source-file' ..lux-extension)) - ..cannot-find-module [module]) - binary (:: System<m> read file)] - (case (encoding.from-utf8 binary) - (#error.Success code) - (wrap {#////.module module - #////.file file - #////.code code}) - - (#error.Failure _) - (:: System<m> throw ..cannot-read-module [module]))))) + (-> (Monad !) (file.System !) (List Context) Module + (! (Error Input)))) + (do (error.with-error monad) + [## TODO: Get rid of both ":share"s ASAP + path,file (:share [!] + {(Monad !) + monad} + {(! (Error [Path (File !)])) + (find-any-source-file monad system contexts module)}) + #let [[path file] (:share [!] + {(Monad !) + monad} + {[Path (File !)] + path,file})] + binary (!.use (:: file content) [])] + (case (encoding.from-utf8 binary) + (#error.Success code) + (wrap {#////.module module + #////.file path + #////.hash (text/hash code) + #////.code code}) + + (#error.Failure _) + (:: monad wrap (ex.throw ..cannot-read-module [module]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux index cd6ccd83d..dc654fd40 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux @@ -6,9 +6,10 @@ equivalence] [data ["." bit ("#/." equivalence)] - ["." number] ["." error (#+ Error) ("#/." monad)] ["." maybe] + [number + ["." nat]] ["." text format] [collection @@ -144,7 +145,7 @@ (wrap (#Variant (if right? (#.Some idx) #.None) - (|> (dictionary.new number.hash) + (|> (dictionary.new nat.hash) (dictionary.put idx value-coverage))))))) (def: (xor left right) @@ -171,7 +172,7 @@ _ (list coverage))) -(structure: _ (Equivalence Coverage) +(structure: equivalence (Equivalence Coverage) (def: (= reference sample) (case [reference sample] [#Exhaustive #Exhaustive] diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux index 3ce70fe9b..82c9cd65b 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux @@ -24,86 +24,106 @@ (exception: #export (unrecognized-syntax {code Code}) (ex.report ["Code" (%code code)])) +## TODO: Had to split the 'compile' function due to compilation issues +## with old-luxc. Must re-combine all the code ASAP + +(type: (Fix a) + (-> a a)) + +(def: (compile|primitive else code') + (Fix (-> (Code' (Ann Cursor)) (Operation Analysis))) + (case code' + (^template [<tag> <analyser>] + (<tag> value) + (<analyser> value)) + ([#.Bit primitive.bit] + [#.Nat primitive.nat] + [#.Int primitive.int] + [#.Rev primitive.rev] + [#.Frac primitive.frac] + [#.Text primitive.text]) + + _ + (else code'))) + +(def: (compile|structure compile else code') + (-> Phase (Fix (-> (Code' (Ann Cursor)) (Operation Analysis)))) + (case code' + (^template [<tag> <analyser>] + (^ (#.Form (list& [_ (<tag> tag)] + values))) + (case values + (#.Cons value #.Nil) + (<analyser> compile tag value) + + _ + (<analyser> compile tag (` [(~+ values)])))) + ([#.Nat structure.sum] + [#.Tag structure.tagged-sum]) + + (#.Tag tag) + (structure.tagged-sum compile tag (' [])) + + (^ (#.Tuple (list))) + primitive.unit + + (^ (#.Tuple (list singleton))) + (compile singleton) + + (^ (#.Tuple elems)) + (structure.product compile elems) + + (^ (#.Record pairs)) + (structure.record compile pairs) + + _ + (else code'))) + +(def: (compile|others compile code') + (-> Phase (-> (Code' (Ann Cursor)) (Operation Analysis))) + (case code' + (#.Identifier reference) + (//reference.reference reference) + + (^ (#.Form (list [_ (#.Record branches)] input))) + (case.case compile input branches) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (extension.apply compile [extension-name extension-args]) + + (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] + [_ (#.Identifier ["" arg-name])]))] + body))) + (function.function compile function-name arg-name body) + + (^ (#.Form (list& functionC argsC+))) + (do ///.monad + [[functionT functionA] (type.with-inference + (compile functionC))] + (case functionA + (#//.Reference (#reference.Constant def-name)) + (do @ + [?macro (extension.lift (macro.find-macro def-name))] + (case ?macro + (#.Some macro) + (do @ + [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] + (compile expansion)) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (///.throw unrecognized-syntax [.dummy-cursor code']))) + (def: #export (compile code) Phase - (do ///.monad - [expectedT (extension.lift macro.expected-type)] - (let [[cursor code'] code] - ## The cursor must be set in the state for the sake - ## of having useful error messages. - (//.with-cursor cursor - (case code' - (^template [<tag> <analyser>] - (<tag> value) - (<analyser> value)) - ([#.Bit primitive.bit] - [#.Nat primitive.nat] - [#.Int primitive.int] - [#.Rev primitive.rev] - [#.Frac primitive.frac] - [#.Text primitive.text]) - - (^template [<tag> <analyser>] - (^ (#.Form (list& [_ (<tag> tag)] - values))) - (case values - (#.Cons value #.Nil) - (<analyser> compile tag value) - - _ - (<analyser> compile tag (` [(~+ values)])))) - ([#.Nat structure.sum] - [#.Tag structure.tagged-sum]) - - (#.Tag tag) - (structure.tagged-sum compile tag (' [])) - - (^ (#.Tuple (list))) - primitive.unit - - (^ (#.Tuple (list singleton))) - (compile singleton) - - (^ (#.Tuple elems)) - (structure.product compile elems) - - (^ (#.Record pairs)) - (structure.record compile pairs) - - (#.Identifier reference) - (//reference.reference reference) - - (^ (#.Form (list [_ (#.Record branches)] input))) - (case.case compile input branches) - - (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) - (extension.apply "Analysis" compile [extension-name extension-args]) - - (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] - [_ (#.Identifier ["" arg-name])]))] - body))) - (function.function compile function-name arg-name body) - - (^ (#.Form (list& functionC argsC+))) - (do @ - [[functionT functionA] (type.with-inference - (compile functionC))] - (case functionA - (#//.Reference (#reference.Constant def-name)) - (do @ - [?macro (extension.lift (macro.find-macro def-name))] - (case ?macro - (#.Some macro) - (do @ - [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] - (compile expansion)) - - _ - (function.apply compile functionT functionA argsC+))) - - _ - (function.apply compile functionT functionA argsC+))) - - _ - (///.throw unrecognized-syntax code) - ))))) + (let [[cursor code'] code] + ## The cursor must be set in the state for the sake + ## of having useful error messages. + (//.with-cursor cursor + (compile|primitive (compile|structure compile (compile|others compile)) + code')))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux b/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux index b46983293..b65b6bc96 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux @@ -6,7 +6,6 @@ [".A" type] ["/." //]]) -## [Analysers] (do-template [<name> <type> <tag>] [(def: #export (<name> value) (-> <type> (Operation Analysis)) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux index 6991c67f7..3fb066259 100644 --- a/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux +++ b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux @@ -6,15 +6,16 @@ ["." state]] [data ["." name] - ["." number] ["." product] ["." maybe] ["." error] + [number + ["." nat]] [text format] [collection ["." list ("#/." functor)] - ["dict" dictionary (#+ Dictionary)]]] + ["." dictionary (#+ Dictionary)]]] ["." type ["." check]] ["." macro @@ -311,23 +312,23 @@ (wrap []) (///.throw record-size-mismatch [size-ts size-record recordT record])) #let [tuple-range (list.indices size-ts) - tag->idx (dict.from-list name.hash (list.zip2 tag-set tuple-range))] + tag->idx (dictionary.from-list name.hash (list.zip2 tag-set tuple-range))] idx->val (monad.fold @ (function (_ [key val] idx->val) (do @ [key (extension.lift (macro.normalize key))] - (case (dict.get key tag->idx) + (case (dictionary.get key tag->idx) (#.Some idx) - (if (dict.contains? idx idx->val) + (if (dictionary.contains? idx idx->val) (///.throw cannot-repeat-tag [key record]) - (wrap (dict.put idx val idx->val))) + (wrap (dictionary.put idx val idx->val))) #.None (///.throw tag-does-not-belong-to-record [key recordT])))) (: (Dictionary Nat Code) - (dict.new number.hash)) + (dictionary.new nat.hash)) record) - #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) + #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dictionary.get idx idx->val))) tuple-range)]] (wrap [ordered-tuple recordT])) )) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux index 0654e79c4..3e44b42f4 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux @@ -561,14 +561,18 @@ (def: (java-type-to-class jvm-type) (-> java/lang/reflect/Type (Operation Text)) - (cond (host.instance? Class jvm-type) - (/////wrap (Class::getName (:coerce Class jvm-type))) + (<| (case (host.check Class jvm-type) + (#.Some jvm-type) + (/////wrap (Class::getName jvm-type)) - (host.instance? ParameterizedType jvm-type) - (java-type-to-class (ParameterizedType::getRawType (:coerce ParameterizedType jvm-type))) + _) + (case (host.check ParameterizedType jvm-type) + (#.Some jvm-type) + (java-type-to-class (ParameterizedType::getRawType jvm-type)) - ## else - (////.throw cannot-convert-to-a-class jvm-type))) + _) + ## else + (////.throw cannot-convert-to-a-class jvm-type))) (type: Mappings (Dictionary Text Type)) @@ -577,8 +581,9 @@ (def: (java-type-to-lux-type mappings java-type) (-> Mappings java/lang/reflect/Type (Operation Type)) - (cond (host.instance? TypeVariable java-type) - (let [var-name (TypeVariable::getName (:coerce TypeVariable java-type))] + (<| (case (host.check TypeVariable java-type) + (#.Some java-type) + (let [var-name (TypeVariable::getName java-type)] (case (dictionary.get var-name mappings) (#.Some var-type) (/////wrap var-type) @@ -586,17 +591,20 @@ #.None (////.throw unknown-type-var var-name))) - (host.instance? WildcardType java-type) - (let [java-type (:coerce WildcardType java-type)] - (case [(array.read 0 (WildcardType::getUpperBounds java-type)) - (array.read 0 (WildcardType::getLowerBounds java-type))] - (^or [(#.Some bound) _] [_ (#.Some bound)]) - (java-type-to-lux-type mappings bound) - - _ - (/////wrap Any))) - - (host.instance? Class java-type) + _) + (case (host.check WildcardType java-type) + (#.Some java-type) + (case [(array.read 0 (WildcardType::getUpperBounds java-type)) + (array.read 0 (WildcardType::getLowerBounds java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) + (java-type-to-lux-type mappings bound) + + _ + (/////wrap Any)) + + _) + (case (host.check Class java-type) + (#.Some java-type) (let [java-type (:coerce (Class Object) java-type) class-name (Class::getName java-type)] (/////wrap (case (array.size (Class::getTypeParameters java-type)) @@ -609,11 +617,13 @@ (list/map (|>> (n/* 2) inc #.Parameter)) (#.Primitive class-name) (type.univ-q arity))))) - - (host.instance? ParameterizedType java-type) - (let [java-type (:coerce ParameterizedType java-type) - raw (ParameterizedType::getRawType java-type)] - (if (host.instance? Class raw) + + _) + (case (host.check ParameterizedType java-type) + (#.Some java-type) + (let [raw (ParameterizedType::getRawType java-type)] + (case (host.check Class raw) + (#.Some raw) (do ////.monad [paramsT (|> java-type ParameterizedType::getActualTypeArguments @@ -621,17 +631,22 @@ (monad.map @ (java-type-to-lux-type mappings)))] (/////wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) paramsT))) - (////.throw jvm-type-is-not-a-class raw))) - (host.instance? GenericArrayType java-type) + _ + (////.throw jvm-type-is-not-a-class raw))) + + _) + (case (host.check GenericArrayType java-type) + (#.Some java-type) (do ////.monad - [innerT (|> (:coerce GenericArrayType java-type) + [innerT (|> java-type GenericArrayType::getGenericComponentType (java-type-to-lux-type mappings))] (wrap (#.Primitive "#Array" (list innerT)))) - - ## else - (////.throw cannot-convert-to-a-lux-type java-type))) + + _) + ## else + (////.throw cannot-convert-to-a-lux-type java-type))) (def: (correspond-type-params class type) (-> (Class Object) Type (Operation Mappings)) @@ -900,23 +915,36 @@ (def: (java-type-to-parameter type) (-> java/lang/reflect/Type (Operation Text)) - (cond (host.instance? Class type) - (/////wrap (Class::getName (:coerce Class type))) - - (host.instance? ParameterizedType type) - (java-type-to-parameter (ParameterizedType::getRawType (:coerce ParameterizedType type))) - - (or (host.instance? TypeVariable type) - (host.instance? WildcardType type)) + (<| (case (host.check Class type) + (#.Some type) + (/////wrap (Class::getName type)) + + _) + (case (host.check ParameterizedType type) + (#.Some type) + (java-type-to-parameter (ParameterizedType::getRawType type)) + + _) + (case (host.check TypeVariable type) + (#.Some type) (/////wrap "java.lang.Object") - - (host.instance? GenericArrayType type) + + _) + (case (host.check WildcardType type) + (#.Some type) + (/////wrap "java.lang.Object") + + _) + (case (host.check GenericArrayType type) + (#.Some type) (do ////.monad - [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType (:coerce GenericArrayType type)))] + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType type))] (wrap (format componentP "[]"))) - - ## else - (////.throw cannot-convert-to-a-parameter type))) + + _) + + ## else + (////.throw cannot-convert-to-a-parameter type))) (type: Method-Style #Static diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux index 29602faf7..3d944b995 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux @@ -18,10 +18,25 @@ ["." analysis ["." module] ["." type]] - ["." synthesis] + ["." synthesis (#+ Synthesis)] ["." translation] ["." statement (#+ Operation Handler Bundle)]]]) +## TODO: Inline "evaluate!'" into "evaluate!" ASAP +(def: (evaluate!' translate code//type codeS) + (All [anchor expression statement] + (-> (translation.Phase anchor expression statement) + Type + Synthesis + (Operation anchor expression statement [Type expression Any]))) + (statement.lift-translation + (translation.with-buffer + (do ///.monad + [codeT (translate codeS) + count translation.next + codeV (translation.evaluate! (format "evaluate" (%n count)) codeT)] + (wrap [code//type codeT codeV]))))) + (def: (evaluate! type codeC) (All [anchor expression statement] (-> Type Code (Operation anchor expression statement [Type expression Any]))) @@ -39,15 +54,24 @@ (wrap [type codeA])))))) codeS (statement.lift-synthesis (synthesize codeA))] - (statement.lift-translation - (translation.with-buffer - (do @ - [codeT (translate codeS) - count translation.next - codeV (translation.evaluate! (format "evaluate" (%n count)) codeT)] - (wrap [code//type codeT codeV])))))) - -(def: (define! name ?type codeC) + (evaluate!' translate code//type codeS))) + +## TODO: Inline "definition'" into "definition" ASAP +(def: (definition' translate name code//type codeS) + (All [anchor expression statement] + (-> (translation.Phase anchor expression statement) + Name + Type + Synthesis + (Operation anchor expression statement [Type expression Text Any]))) + (statement.lift-translation + (translation.with-buffer + (do ///.monad + [codeT (translate codeS) + codeN+V (translation.define! name codeT)] + (wrap [code//type codeT codeN+V]))))) + +(def: (definition name ?type codeC) (All [anchor expression statement] (-> Name (Maybe Type) Code (Operation anchor expression statement [Type expression Text Any]))) @@ -74,12 +98,23 @@ (wrap [code//type codeA])))))) codeS (statement.lift-synthesis (synthesize codeA))] - (statement.lift-translation - (translation.with-buffer - (do @ - [codeT (translate codeS) - codeN+V (translation.define! name codeT)] - (wrap [code//type codeT codeN+V])))))) + (definition' translate name code//type codeS))) + +(def: (define short-name type annotations value) + (All [anchor expression statement] + (-> Text Type Code Any + (Operation anchor expression statement Any))) + (statement.lift-analysis + (do ///.monad + [_ (module.define short-name [type annotations value])] + (if (macro.type? annotations) + (case (macro.declared-tags annotations) + #.Nil + (wrap []) + + tags + (module.declare-tags tags (macro.export? annotations) (:coerce Type value))) + (wrap []))))) (def: lux::def Handler @@ -91,24 +126,13 @@ (//.lift macro.current-module-name)) #let [full-name [current-module short-name]] [_ annotationsT annotationsV] (evaluate! Code annotationsC) - #let [annotationsV (:coerce Code annotationsV) - type-definition? (macro.type? annotationsV)] - [value//type valueT valueN valueV] (define! full-name - (if type-definition? - (#.Some Type) - #.None) - valueC) - _ (statement.lift-analysis - (do @ - [_ (module.define short-name [value//type annotationsV valueV])] - (if type-definition? - (case (macro.declared-tags annotationsV) - #.Nil - (wrap []) - - tags - (module.declare-tags tags (macro.export? annotationsV) (:coerce Type valueV))) - (wrap [])))) + #let [annotationsV (:coerce Code annotationsV)] + [value//type valueT valueN valueV] (..definition full-name + (if (macro.type? annotationsV) + (#.Some Type) + #.None) + valueC) + _ (..define short-name value//type annotationsV valueV) #let [_ (log! (format "Definition " (%name full-name)))]] (statement.lift-translation (translation.learn full-name valueN))) diff --git a/stdlib/source/lux/tool/compiler/phase/statement/total.lux b/stdlib/source/lux/tool/compiler/phase/statement/total.lux index c494b01c6..542be5408 100644 --- a/stdlib/source/lux/tool/compiler/phase/statement/total.lux +++ b/stdlib/source/lux/tool/compiler/phase/statement/total.lux @@ -28,7 +28,7 @@ Phase (case code (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) - (extension.apply "Statement" phase [name inputs]) + (extension.apply phase [name inputs]) (^ [_ (#.Form (list& macro inputs))]) (do ///.monad diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux index b1890688d..7c3f2e3ed 100644 --- a/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux @@ -2,7 +2,7 @@ [lux #* [control [equivalence (#+ Equivalence)] - pipe + [pipe (#+ when> new> case>)] ["." monad (#+ do)]] [data ["." product] @@ -34,26 +34,26 @@ (^template [<from> <to>] (<from> value) - (///map (|>> (#//.Seq (#//.Test (|> value <to>)))) - thenC)) + (////map (|>> (#//.Seq (#//.Test (|> value <to>)))) + thenC)) ([#analysis.Bit #//.Bit] [#analysis.Nat (<| #//.I64 .i64)] [#analysis.Int (<| #//.I64 .i64)] [#analysis.Rev (<| #//.I64 .i64)] [#analysis.Frac #//.F64] [#analysis.Text #//.Text])) - + (#analysis.Bind register) (<| (:: ///.monad map (|>> (#//.Seq (#//.Bind register)))) //.with-new-local thenC) (#analysis.Complex (#analysis.Variant [lefts right? value-pattern])) - (<| (///map (|>> (#//.Seq (#//.Access (#//.Side (if right? - (#.Right lefts) - (#.Left lefts))))))) + (<| (////map (|>> (#//.Seq (#//.Access (#//.Side (if right? + (#.Right lefts) + (#.Left lefts))))))) (path' value-pattern end?) - (when (not end?) (///map ..clean-up)) + (when> [(new> (not end?) [])] [(////map ..clean-up)]) thenC) (#analysis.Complex (#analysis.Tuple tuple)) @@ -61,18 +61,19 @@ (list/fold (function (_ [tuple::lefts tuple::member] nextC) (let [right? (n/= tuple::last tuple::lefts) end?' (and end? right?)] - (<| (///map (|>> (#//.Seq (#//.Access (#//.Member (if right? - (#.Right (dec tuple::lefts)) - (#.Left tuple::lefts))))))) + (<| (////map (|>> (#//.Seq (#//.Access (#//.Member (if right? + (#.Right (dec tuple::lefts)) + (#.Left tuple::lefts))))))) (path' tuple::member end?') - (when (not end?') (///map ..clean-up)) + (when> [(new> (not end?') [])] [(////map ..clean-up)]) nextC))) thenC - (list.reverse (list.enumerate tuple)))))) + (list.reverse (list.enumerate tuple)))) + )) (def: #export (path synthesize pattern bodyA) (-> Phase Pattern Analysis (Operation Path)) - (path' pattern true (///map (|>> #//.Then) (synthesize bodyA)))) + (path' pattern true (////map (|>> #//.Then) (synthesize bodyA)))) (def: #export (weave leftP rightP) (-> Path Path Path) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux index ac6a82ab8..b19488235 100644 --- a/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux @@ -2,7 +2,7 @@ [lux (#- primitive) [control ["." monad (#+ do)] - pipe] + [pipe (#+ case>)]] [data ["." maybe] ["." error] @@ -42,7 +42,7 @@ Phase (case analysis (#analysis.Primitive analysis') - (///wrap (#//.Primitive (..primitive analysis'))) + (////wrap (#//.Primitive (..primitive analysis'))) (#analysis.Structure structure) (case structure @@ -54,10 +54,10 @@ (#analysis.Tuple tuple) (|> tuple (monad.map ///.monad phase) - (:: ///.monad map (|>> //.tuple)))) + (////map (|>> //.tuple)))) (#analysis.Reference reference) - (///wrap (#//.Reference reference)) + (////wrap (#//.Reference reference)) (#analysis.Case inputA branchesAB+) (case.synthesize phase inputA branchesAB+) @@ -73,7 +73,7 @@ (#analysis.Extension name args) (function (_ state) - (|> (extension.apply "Synthesis" phase [name args]) + (|> (extension.apply phase [name args]) (///.run' state) (case> (#error.Success output) (#error.Success output) @@ -83,4 +83,7 @@ (do ///.monad [argsS+ (monad.map @ phase args)] (wrap (#//.Extension [name argsS+]))))))) + + _ + (////wrap (undefined)) )) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux index ce9efe59b..49764fc08 100644 --- a/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux @@ -62,7 +62,7 @@ (-> Environment Register (Operation Variable)) (case (list.nth register environment) (#.Some aliased) - (///wrap aliased) + (////wrap aliased) #.None (///.throw cannot-find-foreign-variable-in-environment [register environment]))) @@ -71,7 +71,7 @@ (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) (case path (#//.Bind register) - (///wrap (#//.Bind (inc register))) + (////wrap (#//.Bind (inc register))) (^template [<tag>] (<tag> left right) @@ -84,10 +84,10 @@ (#//.Then thenS) (|> thenS grow - (///map (|>> #//.Then))) + (////map (|>> #//.Then))) _ - (///wrap path))) + (////wrap path))) (def: (grow-sub-environment super sub) (-> Environment Environment (Operation Environment)) @@ -95,7 +95,7 @@ (function (_ variable) (case variable (#reference.Local register) - (///wrap (#reference.Local (inc register))) + (////wrap (#reference.Local (inc register))) (#reference.Foreign register) (find-foreign super register))) @@ -109,30 +109,30 @@ (#analysis.Variant [lefts right? subS]) (|> subS (grow environment) - (///map (|>> [lefts right?] //.variant))) + (////map (|>> [lefts right?] //.variant))) (#analysis.Tuple membersS+) (|> membersS+ (monad.map ///.monad (grow environment)) - (///map (|>> //.tuple)))) + (////map (|>> //.tuple)))) (^ (..self-reference)) - (///wrap (//.function/apply [expression (list (//.variable/local 1))])) + (////wrap (//.function/apply [expression (list (//.variable/local 1))])) (#//.Reference reference) (case reference (#reference.Variable variable) (case variable (#reference.Local register) - (///wrap (//.variable/local (inc register))) + (////wrap (//.variable/local (inc register))) (#reference.Foreign register) (|> register (find-foreign environment) - (///map (|>> //.variable)))) + (////map (|>> //.variable)))) (#reference.Constant constant) - (///wrap expression)) + (////wrap expression)) (#//.Control control) (case control @@ -168,7 +168,7 @@ (#//.Recur argumentsS+) (|> argumentsS+ (monad.map ///.monad (grow environment)) - (///map (|>> //.loop/recur)))) + (////map (|>> //.loop/recur)))) (#//.Function function) (case function @@ -180,8 +180,8 @@ (#//.Apply funcS argsS+) (case funcS (^ (//.function/apply [(..self-reference) pre-argsS+])) - (///wrap (//.function/apply [(..self-reference) - (list/compose pre-argsS+ argsS+)])) + (////wrap (//.function/apply [(..self-reference) + (list/compose pre-argsS+ argsS+)])) _ (do ///.monad @@ -192,10 +192,10 @@ (#//.Extension name argumentsS+) (|> argumentsS+ (monad.map ///.monad (grow environment)) - (///map (|>> (#//.Extension name)))) + (////map (|>> (#//.Extension name)))) _ - (///wrap expression))) + (////wrap expression))) (def: #export (abstraction phase environment bodyA) (-> Phase Environment Analysis (Operation Synthesis)) |