diff options
| -rw-r--r-- | luxc/src/lux/analyser.clj | 10 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/lux.clj | 34 | ||||
| -rw-r--r-- | luxc/src/lux/analyser/meta.clj | 1 | ||||
| -rw-r--r-- | luxc/src/lux/compiler/jvm/lux.clj | 37 | ||||
| -rw-r--r-- | stdlib/source/lux.lux | 720 | ||||
| -rw-r--r-- | stdlib/source/lux/macro.lux | 1 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/statement.lux | 139 |
7 files changed, 446 insertions, 496 deletions
diff --git a/luxc/src/lux/analyser.clj b/luxc/src/lux/analyser.clj index 4d4a2c1a0..de5ff8725 100644 --- a/luxc/src/lux/analyser.clj +++ b/luxc/src/lux/analyser.clj @@ -144,6 +144,16 @@ (&/with-cursor cursor (&&lux/analyse-def-alias ?alias ?original))) + "lux def type tagged" + (|let [(&/$Cons [_ (&/$Identifier "" ?name)] + (&/$Cons ?value + (&/$Cons ?meta + (&/$Cons [_ (&/$Tuple ?tags)] + (&/$Nil))) + )) parameters] + (&/with-cursor cursor + (&&lux/analyse-def-type-tagged analyse optimize eval! compile-def ?name ?value ?meta ?tags))) + "lux def program" (|let [(&/$Cons ?program (&/$Nil)) parameters] (&/with-cursor cursor diff --git a/luxc/src/lux/analyser/lux.clj b/luxc/src/lux/analyser/lux.clj index 149bd4a99..8b2428ef0 100644 --- a/luxc/src/lux/analyser/lux.clj +++ b/luxc/src/lux/analyser/lux.clj @@ -542,7 +542,7 @@ (|do [output (analyse-function** analyse exo-type ?self ?arg ?body)] (return (&/|list output)))) -(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta] +(defn analyse-def* [analyse optimize eval! compile-def ?name ?value ?meta & [?expected-type]] (|do [_ &/ensure-statement module-name &/get-module-name ? (&&module/defined? module-name ?name) @@ -550,11 +550,39 @@ (str "[Analyser Error] Cannot re-define " (str module-name &/+name-separator+ ?name))) =value (&/without-repl-closure (&/with-scope ?name - (&&/analyse-1+ analyse ?value))) + (if ?expected-type + (&/with-expected-type ?expected-type + (&&/analyse-1 analyse ?expected-type ?value)) + (&&/analyse-1+ analyse ?value)))) =meta (&&/analyse-1 analyse &type/Code ?meta) ==meta (eval! (optimize =meta)) - _ (compile-def ?name (optimize =value) ==meta) + def-value (compile-def ?name (optimize =value) ==meta) _ &type/reset-mappings] + (return (&/T [module-name (&&/expr-type* =value) def-value ==meta])))) + +(defn analyse-def [analyse optimize eval! compile-def ?name ?value ?meta] + (|do [_ (analyse-def* analyse optimize eval! compile-def ?name ?value ?meta)] + (return &/$Nil))) + +(defn analyse-def-type-tagged [analyse optimize eval! compile-def ?name ?value ?meta tags*] + (|do [[module-name def-type def-value ==meta] (analyse-def* analyse optimize eval! compile-def ?name ?value ?meta &type/Type) + _ (&/assert! (&type/type= &type/Type def-type) + "[Analyser Error] Cannot define tags for non-type.") + :let [was-exported? (|case (&&meta/meta-get &&meta/export?-tag ==meta) + (&/$Some _) + true + + _ + false)] + tags (&/map% (fn [tag*] + (|case tag* + [_ (&/$Text tag)] + (return tag) + + _ + (&/fail-with-loc "[Analyser Error] Incorrect format for tags."))) + tags*) + _ (&&module/declare-tags module-name tags was-exported? def-value)] (return &/$Nil))) (def ^:private dummy-cursor diff --git a/luxc/src/lux/analyser/meta.clj b/luxc/src/lux/analyser/meta.clj index 07ec470f3..fde261b0b 100644 --- a/luxc/src/lux/analyser/meta.clj +++ b/luxc/src/lux/analyser/meta.clj @@ -42,5 +42,4 @@ alias-tag "alias" export?-tag "export?" - tags-tag "tags" ) diff --git a/luxc/src/lux/compiler/jvm/lux.clj b/luxc/src/lux/compiler/jvm/lux.clj index 0fec62e8e..4af29d2f6 100644 --- a/luxc/src/lux/compiler/jvm/lux.clj +++ b/luxc/src/lux/compiler/jvm/lux.clj @@ -261,34 +261,7 @@ (throwable->text t))))) _ (&/without-repl-closure (&a-module/define module-name ?name def-type ?meta def-value))] - (|case (&/T [(&type/type= &type/Type def-type) - (&a-meta/meta-get &a-meta/tags-tag ?meta)]) - [true (&/$Some [_ (&/$Tuple tags*)])] - (|do [:let [was-exported? (|case (&a-meta/meta-get &a-meta/export?-tag ?meta) - (&/$Some _) - true - - _ - false)] - tags (&/map% (fn [tag*] - (|case tag* - [_ (&/$Text tag)] - (return tag) - - _ - (&/fail-with-loc "[Compiler Error] Incorrect format for tags."))) - tags*) - _ (&a-module/declare-tags module-name tags was-exported? def-value)] - (return nil)) - - [false (&/$Some _)] - (&/fail-with-loc "[Compiler Error] Cannot define tags for non-type.") - - [true (&/$Some _)] - (&/fail-with-loc "[Compiler Error] Incorrect format for tags.") - - [_ (&/$None)] - (return nil)))) + (return def-value))) (let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] @@ -341,9 +314,9 @@ (return nil))) :let [_ (.visitEnd =class)] _ (&&/save-class! def-name (.toByteArray =class)) - _ (install-def! class-loader current-class module-name ?name ?body ?meta) + def-value (install-def! class-loader current-class module-name ?name ?body ?meta) :let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]] - (return nil))) + (return def-value))) _ (|do [[file-name _ _] &/cursor @@ -368,9 +341,9 @@ (return nil))) :let [_ (.visitEnd =class)] _ (&&/save-class! def-name (.toByteArray =class)) - _ (install-def! class-loader current-class module-name ?name ?body ?meta) + def-value (install-def! class-loader current-class module-name ?name ?body ?meta) :let [_ (println 'DEF (str module-name &/+name-separator+ ?name))]] - (return nil))) + (return def-value))) )))) (defn compile-program [compile ?program] diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 392fede3a..91ee40db9 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -50,25 +50,23 @@ ## (type: (List a) ## #Nil ## (#Cons a (List a))) -("lux def" List - ("lux check type" - (10 ["lux" "List"] - (7 (0) - (1 ## "lux.Nil" - Any - ## "lux.Cons" - (2 (4 1) - (9 (4 1) (4 0))))))) +("lux def type tagged" List + (10 ["lux" "List"] + (7 (0) + (1 ## "lux.Nil" + Any + ## "lux.Cons" + (2 (4 1) + (9 (4 1) (4 0)))))) [dummy-cursor (10 (1 [[dummy-cursor (7 ["lux" "export?"])] [dummy-cursor (0 #1)]] - (1 [[dummy-cursor (7 ["lux" "tags"])] - [dummy-cursor (9 (1 [dummy-cursor (5 "Nil")] (1 [dummy-cursor (5 "Cons")] (0))))]] - (1 [[dummy-cursor (7 ["lux" "type-args"])] - [dummy-cursor (9 (1 [dummy-cursor (5 "a")] (0)))]] - (1 [[dummy-cursor (7 ["lux" "doc"])] - [dummy-cursor (5 "A potentially empty list of values.")]] - (0))))))]) + (1 [[dummy-cursor (7 ["lux" "type-args"])] + [dummy-cursor (9 (1 [dummy-cursor (5 "a")] (0)))]] + (1 [[dummy-cursor (7 ["lux" "doc"])] + [dummy-cursor (5 "A potentially empty list of values.")]] + (0)))))] + ["Nil" "Cons"]) ("lux def" Bit ("lux check type" @@ -166,24 +164,22 @@ ## (type: (Maybe a) ## #None ## (#Some a)) -("lux def" Maybe - ("lux check type" - (10 ["lux" "Maybe"] - (7 #Nil - (1 ## "lux.None" - Any - ## "lux.Some" - (4 1))))) +("lux def type tagged" Maybe + (10 ["lux" "Maybe"] + (7 #Nil + (1 ## "lux.None" + Any + ## "lux.Some" + (4 1)))) [dummy-cursor (10 (#Cons [[dummy-cursor (7 ["lux" "export?"])] [dummy-cursor (0 #1)]] - (#Cons [[dummy-cursor (7 ["lux" "tags"])] - [dummy-cursor (9 (#Cons [dummy-cursor (5 "None")] (#Cons [dummy-cursor (5 "Some")] #Nil)))]] - (#Cons [[dummy-cursor (7 ["lux" "type-args"])] - [dummy-cursor (9 (#Cons [dummy-cursor (5 "a")] #Nil))]] - (#Cons [[dummy-cursor (7 ["lux" "doc"])] - [dummy-cursor (5 "A potentially missing value.")]] - #Nil)))))]) + (#Cons [[dummy-cursor (7 ["lux" "type-args"])] + [dummy-cursor (9 (#Cons [dummy-cursor (5 "a")] #Nil))]] + (#Cons [[dummy-cursor (7 ["lux" "doc"])] + [dummy-cursor (5 "A potentially missing value.")]] + #Nil))))] + ["None" "Some"]) ## (type: #rec Type ## (#Primitive Text (List Type)) @@ -198,101 +194,81 @@ ## (#Apply Type Type) ## (#Named Name Type) ## ) -("lux def" Type - ("lux check type" - (10 ["lux" "Type"] - ({Type - ({Type-List - ({Type-Pair - (9 Nothing - (7 #Nil - (1 ## "lux.Primitive" - (2 Text Type-List) - (1 ## "lux.Sum" +("lux def type tagged" Type + (10 ["lux" "Type"] + ({Type + ({Type-List + ({Type-Pair + (9 Nothing + (7 #Nil + (1 ## "lux.Primitive" + (2 Text Type-List) + (1 ## "lux.Sum" + Type-Pair + (1 ## "lux.Product" Type-Pair - (1 ## "lux.Product" + (1 ## "lux.Function" Type-Pair - (1 ## "lux.Function" - Type-Pair - (1 ## "lux.Parameter" + (1 ## "lux.Parameter" + Nat + (1 ## "lux.Var" Nat - (1 ## "lux.Var" + (1 ## "lux.Ex" Nat - (1 ## "lux.Ex" - Nat - (1 ## "lux.UnivQ" + (1 ## "lux.UnivQ" + (2 Type-List Type) + (1 ## "lux.ExQ" (2 Type-List Type) - (1 ## "lux.ExQ" - (2 Type-List Type) - (1 ## "lux.Apply" - Type-Pair - ## "lux.Named" - (2 Name Type)))))))))))))} - ("lux check type" (2 Type Type)))} - ("lux check type" (9 Type List)))} - ("lux check type" (9 (4 1) (4 0)))))) + (1 ## "lux.Apply" + Type-Pair + ## "lux.Named" + (2 Name Type)))))))))))))} + ("lux check type" (2 Type Type)))} + ("lux check type" (9 Type List)))} + ("lux check type" (9 (4 1) (4 0))))) [dummy-cursor (10 (#Cons [[dummy-cursor (7 ["lux" "export?"])] [dummy-cursor (0 #1)]] - (#Cons [[dummy-cursor (7 ["lux" "tags"])] - [dummy-cursor (9 (#Cons [dummy-cursor (5 "Primitive")] - (#Cons [dummy-cursor (5 "Sum")] - (#Cons [dummy-cursor (5 "Product")] - (#Cons [dummy-cursor (5 "Function")] - (#Cons [dummy-cursor (5 "Parameter")] - (#Cons [dummy-cursor (5 "Var")] - (#Cons [dummy-cursor (5 "Ex")] - (#Cons [dummy-cursor (5 "UnivQ")] - (#Cons [dummy-cursor (5 "ExQ")] - (#Cons [dummy-cursor (5 "Apply")] - (#Cons [dummy-cursor (5 "Named")] - #Nil))))))))))))]] - (#Cons [[dummy-cursor (7 ["lux" "doc"])] - [dummy-cursor (5 "This type represents the data-structures that are used to specify types themselves.")]] - (#Cons [[dummy-cursor (7 ["lux" "type-rec?"])] - [dummy-cursor (0 #1)]] - #Nil)))))]) + (#Cons [[dummy-cursor (7 ["lux" "doc"])] + [dummy-cursor (5 "This type represents the data-structures that are used to specify types themselves.")]] + (#Cons [[dummy-cursor (7 ["lux" "type-rec?"])] + [dummy-cursor (0 #1)]] + #Nil))))] + ["Primitive" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "UnivQ" "ExQ" "Apply" "Named"]) ## (type: Cursor ## {#module Text ## #line Nat ## #column Nat}) -("lux def" Cursor +("lux def type tagged" Cursor (#Named ["lux" "Cursor"] (#Product Text (#Product Nat Nat))) [dummy-cursor - (10 (#Cons [[dummy-cursor (7 ["lux" "tags"])] - [dummy-cursor (9 (#Cons [dummy-cursor (5 "module")] - (#Cons [dummy-cursor (5 "line")] - (#Cons [dummy-cursor (5 "column")] - #Nil))))]] - (#Cons [[dummy-cursor (7 ["lux" "doc"])] - [dummy-cursor (5 "Cursors are for specifying the location of Code nodes in Lux files during compilation.")]] - (#Cons [[dummy-cursor (7 ["lux" "export?"])] - [dummy-cursor (0 #1)]] - #Nil))))]) + (10 (#Cons [[dummy-cursor (7 ["lux" "doc"])] + [dummy-cursor (5 "Cursors are for specifying the location of Code nodes in Lux files during compilation.")]] + (#Cons [[dummy-cursor (7 ["lux" "export?"])] + [dummy-cursor (0 #1)]] + #Nil)))] + ["module" "line" "column"]) ## (type: (Ann m v) ## {#meta m ## #datum v}) -("lux def" Ann +("lux def type tagged" Ann (#Named ["lux" "Ann"] (#UnivQ #Nil (#UnivQ #Nil (#Product (#Parameter 3) (#Parameter 1))))) [dummy-cursor - (10 (#Cons [[dummy-cursor (7 ["lux" "tags"])] - [dummy-cursor (9 (#Cons [dummy-cursor (5 "meta")] - (#Cons [dummy-cursor (5 "datum")] - #Nil)))]] - (#Cons [[dummy-cursor (7 ["lux" "doc"])] - [dummy-cursor (5 "The type of things that can be annotated with meta-data of arbitrary types.")]] - (#Cons [[dummy-cursor (7 ["lux" "type-args"])] - [dummy-cursor (9 (#Cons [dummy-cursor (5 "m")] (#Cons [dummy-cursor (5 "v")] #Nil)))]] - (#Cons [[dummy-cursor (7 ["lux" "export?"])] - [dummy-cursor (0 #1)]] - #Nil)))))]) + (10 (#Cons [[dummy-cursor (7 ["lux" "doc"])] + [dummy-cursor (5 "The type of things that can be annotated with meta-data of arbitrary types.")]] + (#Cons [[dummy-cursor (7 ["lux" "type-args"])] + [dummy-cursor (9 (#Cons [dummy-cursor (5 "m")] (#Cons [dummy-cursor (5 "v")] #Nil)))]] + (#Cons [[dummy-cursor (7 ["lux" "export?"])] + [dummy-cursor (0 #1)]] + #Nil))))] + ["meta" "datum"]) ## (type: (Code' w) ## (#Bit Bit) @@ -306,59 +282,46 @@ ## (#Form (List (w (Code' w)))) ## (#Tuple (List (w (Code' w)))) ## (#Record (List [(w (Code' w)) (w (Code' w))]))) -("lux def" Code' - ("lux check type" - (#Named ["lux" "Code'"] - ({Code - ({Code-List - (#UnivQ #Nil - (#Sum ## "lux.Bit" - Bit - (#Sum ## "lux.Nat" - Nat - (#Sum ## "lux.Int" - Int - (#Sum ## "lux.Rev" - Rev - (#Sum ## "lux.Frac" - Frac - (#Sum ## "lux.Text" - Text - (#Sum ## "lux.Identifier" +("lux def type tagged" Code' + (#Named ["lux" "Code'"] + ({Code + ({Code-List + (#UnivQ #Nil + (#Sum ## "lux.Bit" + Bit + (#Sum ## "lux.Nat" + Nat + (#Sum ## "lux.Int" + Int + (#Sum ## "lux.Rev" + Rev + (#Sum ## "lux.Frac" + Frac + (#Sum ## "lux.Text" + Text + (#Sum ## "lux.Identifier" + Name + (#Sum ## "lux.Tag" Name - (#Sum ## "lux.Tag" - Name - (#Sum ## "lux.Form" + (#Sum ## "lux.Form" + Code-List + (#Sum ## "lux.Tuple" Code-List - (#Sum ## "lux.Tuple" - Code-List - ## "lux.Record" - (#Apply (#Product Code Code) List) - )))))))))) - )} - ("lux check type" (#Apply Code List)))} - ("lux check type" (#Apply (#Apply (#Parameter 1) - (#Parameter 0)) - (#Parameter 1)))))) + ## "lux.Record" + (#Apply (#Product Code Code) List) + )))))))))) + )} + ("lux check type" (#Apply Code List)))} + ("lux check type" (#Apply (#Apply (#Parameter 1) + (#Parameter 0)) + (#Parameter 1))))) [dummy-cursor - (10 (#Cons [[dummy-cursor (7 ["lux" "tags"])] - [dummy-cursor (9 (#Cons [dummy-cursor (5 "Bit")] - (#Cons [dummy-cursor (5 "Nat")] - (#Cons [dummy-cursor (5 "Int")] - (#Cons [dummy-cursor (5 "Rev")] - (#Cons [dummy-cursor (5 "Frac")] - (#Cons [dummy-cursor (5 "Text")] - (#Cons [dummy-cursor (5 "Identifier")] - (#Cons [dummy-cursor (5 "Tag")] - (#Cons [dummy-cursor (5 "Form")] - (#Cons [dummy-cursor (5 "Tuple")] - (#Cons [dummy-cursor (5 "Record")] - #Nil))))))))))))]] - (#Cons [[dummy-cursor (7 ["lux" "type-args"])] - [dummy-cursor (9 (#Cons [dummy-cursor (5 "w")] #Nil))]] - (#Cons [[dummy-cursor (7 ["lux" "export?"])] - [dummy-cursor (0 #1)]] - #Nil))))]) + (10 (#Cons [[dummy-cursor (7 ["lux" "type-args"])] + [dummy-cursor (9 (#Cons [dummy-cursor (5 "w")] #Nil))]] + (#Cons [[dummy-cursor (7 ["lux" "export?"])] + [dummy-cursor (0 #1)]] + #Nil)))] + ["Bit" "Nat" "Int" "Rev" "Frac" "Text" "Identifier" "Tag" "Form" "Tuple" "Record"]) ## (type: Code ## (Ann Cursor (Code' (Ann Cursor)))) @@ -467,56 +430,50 @@ ## (type: (Bindings k v) ## {#counter Nat ## #mappings (List [k v])}) -("lux def" Bindings - ("lux check type" - (#Named ["lux" "Bindings"] - (#UnivQ #Nil - (#UnivQ #Nil - (#Product ## "lux.counter" - Nat - ## "lux.mappings" - (#Apply (#Product (#Parameter 3) - (#Parameter 1)) - List)))))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "counter") (#Cons (text$ "mappings") #Nil)))] - (#Cons [(tag$ ["lux" "type-args"]) - (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))] - default-def-meta-exported)))) +("lux def type tagged" Bindings + (#Named ["lux" "Bindings"] + (#UnivQ #Nil + (#UnivQ #Nil + (#Product ## "lux.counter" + Nat + ## "lux.mappings" + (#Apply (#Product (#Parameter 3) + (#Parameter 1)) + List))))) + (record$ (#Cons [(tag$ ["lux" "type-args"]) + (tuple$ (#Cons (text$ "k") (#Cons (text$ "v") #Nil)))] + default-def-meta-exported)) + ["counter" "mappings"]) ## (type: #export Ref ## (#Local Nat) ## (#Captured Nat)) -("lux def" Ref - ("lux check type" - (#Named ["lux" "Ref"] - (#Sum ## Local - Nat - ## Captured - Nat))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "Local") (#Cons (text$ "Captured") #Nil)))] - default-def-meta-exported))) +("lux def type tagged" Ref + (#Named ["lux" "Ref"] + (#Sum ## Local + Nat + ## Captured + Nat)) + (record$ default-def-meta-exported) + ["Local" "Captured"]) ## (type: Scope ## {#name (List Text) ## #inner Nat ## #locals (Bindings Text [Type Nat]) ## #captured (Bindings Text [Type Ref])}) -("lux def" Scope - ("lux check type" - (#Named ["lux" "Scope"] - (#Product ## name - (#Apply Text List) - (#Product ## inner - Nat - (#Product ## locals - (#Apply (#Product Type Nat) (#Apply Text Bindings)) - ## captured - (#Apply (#Product Type Ref) (#Apply Text Bindings))))))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "name") (#Cons (text$ "inner") (#Cons (text$ "locals") (#Cons (text$ "captured") #Nil)))))] - default-def-meta-exported))) +("lux def type tagged" Scope + (#Named ["lux" "Scope"] + (#Product ## name + (#Apply Text List) + (#Product ## inner + Nat + (#Product ## locals + (#Apply (#Product Type Nat) (#Apply Text Bindings)) + ## captured + (#Apply (#Product Type Ref) (#Apply Text Bindings)))))) + (record$ default-def-meta-exported) + ["name" "inner" "locals" "captured"]) ("lux def" Code-List ("lux check type" @@ -526,22 +483,20 @@ ## (type: (Either l r) ## (#Left l) ## (#Right r)) -("lux def" Either - ("lux check type" - (#Named ["lux" "Either"] - (#UnivQ #Nil - (#UnivQ #Nil - (#Sum ## "lux.Left" - (#Parameter 3) - ## "lux.Right" - (#Parameter 1)))))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "Left") (#Cons (text$ "Right") #Nil)))] - (#Cons [(tag$ ["lux" "type-args"]) - (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))] - (#Cons [(tag$ ["lux" "doc"]) - (text$ "A choice between two values of different types.")] - default-def-meta-exported))))) +("lux def type tagged" Either + (#Named ["lux" "Either"] + (#UnivQ #Nil + (#UnivQ #Nil + (#Sum ## "lux.Left" + (#Parameter 3) + ## "lux.Right" + (#Parameter 1))))) + (record$ (#Cons [(tag$ ["lux" "type-args"]) + (tuple$ (#Cons (text$ "l") (#Cons (text$ "r") #Nil)))] + (#Cons [(tag$ ["lux" "doc"]) + (text$ "A choice between two values of different types.")] + default-def-meta-exported))) + ["Left" "Right"]) ## (type: Source ## [Cursor Nat Text]) @@ -555,20 +510,18 @@ ## #Active ## #Compiled ## #Cached) -("lux def" Module-State - ("lux check type" - (#Named ["lux" "Module-State"] +("lux def type tagged" Module-State + (#Named ["lux" "Module-State"] + (#Sum + ## #Active + Any (#Sum - ## #Active + ## #Compiled Any - (#Sum - ## #Compiled - Any - ## #Cached - Any)))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "Active") (#Cons (text$ "Compiled") (#Cons (text$ "Cached") #Nil))))] - default-def-meta-exported))) + ## #Cached + Any))) + (record$ default-def-meta-exported) + ["Active" "Compiled" "Cached"]) ## (type: Module ## {#module-hash Nat @@ -579,114 +532,89 @@ ## #types (List [Text [(List Name) Bit Type]]) ## #module-annotations (Maybe Code) ## #module-state Module-State}) -("lux def" Module - ("lux check type" - (#Named ["lux" "Module"] - (#Product ## "lux.module-hash" - Nat - (#Product ## "lux.module-aliases" - (#Apply (#Product Text Text) List) - (#Product ## "lux.definitions" - (#Apply (#Product Text Definition) List) - (#Product ## "lux.imports" - (#Apply Text List) - (#Product ## "lux.tags" +("lux def type tagged" Module + (#Named ["lux" "Module"] + (#Product ## "lux.module-hash" + Nat + (#Product ## "lux.module-aliases" + (#Apply (#Product Text Text) List) + (#Product ## "lux.definitions" + (#Apply (#Product Text Definition) List) + (#Product ## "lux.imports" + (#Apply Text List) + (#Product ## "lux.tags" + (#Apply (#Product Text + (#Product Nat + (#Product (#Apply Name List) + (#Product Bit + Type)))) + List) + (#Product ## "lux.types" (#Apply (#Product Text - (#Product Nat - (#Product (#Apply Name List) - (#Product Bit - Type)))) + (#Product (#Apply Name List) + (#Product Bit + Type))) List) - (#Product ## "lux.types" - (#Apply (#Product Text - (#Product (#Apply Name List) - (#Product Bit - Type))) - List) - (#Product ## "lux.module-annotations" - (#Apply Code Maybe) - Module-State)) - ))))))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "module-hash") - (#Cons (text$ "module-aliases") - (#Cons (text$ "definitions") - (#Cons (text$ "imports") - (#Cons (text$ "tags") - (#Cons (text$ "types") - (#Cons (text$ "module-annotations") - (#Cons (text$ "module-state") - #Nil)))))))))] - (#Cons [(tag$ ["lux" "doc"]) - (text$ "All the information contained within a Lux module.")] - default-def-meta-exported)))) + (#Product ## "lux.module-annotations" + (#Apply Code Maybe) + Module-State)) + )))))) + (record$ (#Cons [(tag$ ["lux" "doc"]) + (text$ "All the information contained within a Lux module.")] + default-def-meta-exported)) + ["module-hash" "module-aliases" "definitions" "imports" "tags" "types" "module-annotations" "module-state"]) ## (type: Type-Context ## {#ex-counter Nat ## #var-counter Nat ## #var-bindings (List [Nat (Maybe Type)])}) -("lux def" Type-Context - ("lux check type" - (#Named ["lux" "Type-Context"] - (#Product ## ex-counter +("lux def type tagged" Type-Context + (#Named ["lux" "Type-Context"] + (#Product ## ex-counter + Nat + (#Product ## var-counter Nat - (#Product ## var-counter - Nat - ## var-bindings - (#Apply (#Product Nat (#Apply Type Maybe)) - List))))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "ex-counter") - (#Cons (text$ "var-counter") - (#Cons (text$ "var-bindings") - #Nil))))] - default-def-meta-exported))) + ## var-bindings + (#Apply (#Product Nat (#Apply Type Maybe)) + List)))) + (record$ default-def-meta-exported) + ["ex-counter" "var-counter" "var-bindings"]) ## (type: Mode ## #Build ## #Eval ## #Interpreter) -("lux def" Mode - ("lux check type" - (#Named ["lux" "Mode"] - (#Sum ## Build +("lux def type tagged" Mode + (#Named ["lux" "Mode"] + (#Sum ## Build + Any + (#Sum ## Eval Any - (#Sum ## Eval - Any - ## Interpreter - Any)))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "Build") - (#Cons (text$ "Eval") - (#Cons (text$ "Interpreter") - #Nil))))] - (#Cons [(tag$ ["lux" "doc"]) - (text$ "A sign that shows the conditions under which the compiler is running.")] - default-def-meta-exported)))) + ## Interpreter + Any))) + (record$ (#Cons [(tag$ ["lux" "doc"]) + (text$ "A sign that shows the conditions under which the compiler is running.")] + default-def-meta-exported)) + ["Build" "Eval" "Interpreter"]) ## (type: Info ## {#target Text ## #version Text ## #mode Mode}) -("lux def" Info - ("lux check type" - (#Named ["lux" "Info"] +("lux def type tagged" Info + (#Named ["lux" "Info"] + (#Product + ## target + Text (#Product - ## target + ## version Text - (#Product - ## version - Text - ## mode - Mode)))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "target") - (#Cons (text$ "version") - (#Cons (text$ "mode") - #Nil))))] - (#Cons [(tag$ ["lux" "doc"]) - (text$ "Information about the current version and type of compiler that is running.")] - default-def-meta-exported)))) + ## mode + Mode))) + (record$ (#Cons [(tag$ ["lux" "doc"]) + (text$ "Information about the current version and type of compiler that is running.")] + default-def-meta-exported)) + ["target" "version" "mode"]) ## (type: Lux ## {#info Info @@ -701,54 +629,40 @@ ## #scope-type-vars (List Nat) ## #extensions Any ## #host Any}) -("lux def" Lux - ("lux check type" - (#Named ["lux" "Lux"] - (#Product ## "lux.info" - Info - (#Product ## "lux.source" - Source - (#Product ## "lux.cursor" - Cursor - (#Product ## "lux.current-module" - (#Apply Text Maybe) - (#Product ## "lux.modules" - (#Apply (#Product Text Module) List) - (#Product ## "lux.scopes" - (#Apply Scope List) - (#Product ## "lux.type-context" - Type-Context - (#Product ## "lux.expected" - (#Apply Type Maybe) - (#Product ## "lux.seed" - Nat - (#Product ## scope-type-vars - (#Apply Nat List) - (#Product ## extensions - Any - ## "lux.host" - Any))))))))))))) - (record$ (#Cons [(tag$ ["lux" "tags"]) - (tuple$ (#Cons (text$ "info") - (#Cons (text$ "source") - (#Cons (text$ "cursor") - (#Cons (text$ "current-module") - (#Cons (text$ "modules") - (#Cons (text$ "scopes") - (#Cons (text$ "type-context") - (#Cons (text$ "expected") - (#Cons (text$ "seed") - (#Cons (text$ "scope-type-vars") - (#Cons (text$ "extensions") - (#Cons (text$ "host") - #Nil)))))))))))))] - (#Cons [(tag$ ["lux" "doc"]) - (text$ ("lux text concat" - ("lux text concat" "Represents the state of the Lux compiler during a run." __paragraph) - ("lux text concat" - ("lux text concat" "It is provided to macros during their invocation, so they can access compiler data." __paragraph) - "Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")))] - default-def-meta-exported)))) +("lux def type tagged" Lux + (#Named ["lux" "Lux"] + (#Product ## "lux.info" + Info + (#Product ## "lux.source" + Source + (#Product ## "lux.cursor" + Cursor + (#Product ## "lux.current-module" + (#Apply Text Maybe) + (#Product ## "lux.modules" + (#Apply (#Product Text Module) List) + (#Product ## "lux.scopes" + (#Apply Scope List) + (#Product ## "lux.type-context" + Type-Context + (#Product ## "lux.expected" + (#Apply Type Maybe) + (#Product ## "lux.seed" + Nat + (#Product ## scope-type-vars + (#Apply Nat List) + (#Product ## extensions + Any + ## "lux.host" + Any)))))))))))) + (record$ (#Cons [(tag$ ["lux" "doc"]) + (text$ ("lux text concat" + ("lux text concat" "Represents the state of the Lux compiler during a run." __paragraph) + ("lux text concat" + ("lux text concat" "It is provided to macros during their invocation, so they can access compiler data." __paragraph) + "Caveat emptor: Avoid fiddling with it, unless you know what you're doing.")))] + default-def-meta-exported)) + ["info" "source" "cursor" "current-module" "modules" "scopes" "type-context" "expected" "seed" "scope-type-vars" "extensions" "host"]) ## (type: (Meta a) ## (-> Lux (Either Text [Lux a]))) @@ -1598,16 +1512,15 @@ ## wrap) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) -(def:''' Monad - (list [(tag$ ["lux" "tags"]) - (tuple$ (list (text$ "wrap") (text$ "bind")))]) - Type - (#Named ["lux" "Monad"] - (All [m] - (& (All [a] (-> a ($' m a))) - (All [a b] (-> (-> a ($' m b)) - ($' m a) - ($' m b))))))) +("lux def type tagged" Monad + (#Named ["lux" "Monad"] + (All [m] + (& (All [a] (-> a ($' m a))) + (All [a b] (-> (-> a ($' m b)) + ($' m a) + ($' m b)))))) + (record$ (list)) + ["wrap" "bind"]) (def:''' maybe-monad #Nil @@ -3015,7 +2928,7 @@ (let' [[left right] pair] (list left right))) -(def:' (code-to-text code) +(def:' (%code code) (-> Code Text) ({[_ (#Bit value)] (bit@encode value) @@ -3047,21 +2960,21 @@ [_ (#Form xs)] ($_ text@compose "(" (|> xs - (list@map code-to-text) + (list@map %code) (interpose " ") list@reverse (list@fold text@compose "")) ")") [_ (#Tuple xs)] ($_ text@compose "[" (|> xs - (list@map code-to-text) + (list@map %code) (interpose " ") list@reverse (list@fold text@compose "")) "]") [_ (#Record kvs)] ($_ text@compose "{" (|> kvs - (list@map (function' [kv] ({[k v] ($_ text@compose (code-to-text k) " " (code-to-text v))} + (list@map (function' [kv] ({[k v] ($_ text@compose (%code k) " " (%code v))} kv))) (interpose " ") list@reverse @@ -3095,7 +3008,7 @@ _ (fail ($_ text@compose "'lux.case' expects an even number of tokens: " (|> branches - (list@map code-to-text) + (list@map %code) (interpose " ") list@reverse (list@fold text@compose ""))))} @@ -3304,13 +3217,13 @@ _ (` (#.Cons [[(~ cursor-code) (#.Tag ["lux" "func-args"])] [(~ cursor-code) (#.Tuple (.list (~+ (list@map (function (_ arg) - (` [(~ cursor-code) (#.Text (~ (text$ (code-to-text arg))))])) + (` [(~ cursor-code) (#.Text (~ (text$ (%code arg))))])) args))))]] (~ meta))))) (def:' (with-type-args args) (-> (List Code) Code) - (` {#.type-args [(~+ (list@map (function (_ arg) (text$ (code-to-text arg))) + (` {#.type-args [(~+ (list@map (function (_ arg) (text$ (%code arg))) args))]})) (def:' (export^ tokens) @@ -3387,10 +3300,10 @@ (return (list (` ("lux def" (~ name) (~ body) [(~ cursor-code) - (#Record (~ (with-func-args args - (if export? - (with-export-meta =meta) - =meta))))]))))) + (#.Record (~ (with-func-args args + (if export? + (with-export-meta =meta) + =meta))))]))))) #None (fail "Wrong syntax for def:")))) @@ -3951,25 +3864,25 @@ _ [#0 tokens']) - parts (: (Maybe [Text (List Code) Code (List Code)]) + parts (: (Maybe [Text (List Code) (List [Code Code]) (List Code)]) (case tokens' (^ (list [_ (#Identifier "" name)] [meta-cursor (#Record meta-parts)] [type-cursor (#Record type-parts)])) - (#Some [name #Nil [meta-cursor (#Record meta-parts)] (list [type-cursor (#Record type-parts)])]) + (#Some [name #Nil meta-parts (list [type-cursor (#Record type-parts)])]) (^ (list& [_ (#Identifier "" name)] [meta-cursor (#Record meta-parts)] type-code1 type-codes)) - (#Some [name #Nil [meta-cursor (#Record meta-parts)] (#Cons type-code1 type-codes)]) + (#Some [name #Nil meta-parts (#Cons type-code1 type-codes)]) (^ (list& [_ (#Identifier "" name)] type-codes)) - (#Some [name #Nil (` {}) type-codes]) + (#Some [name #Nil (list) type-codes]) (^ (list [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta-cursor (#Record meta-parts)] [type-cursor (#Record type-parts)])) - (#Some [name args [meta-cursor (#Record meta-parts)] (list [type-cursor (#Record type-parts)])]) + (#Some [name args meta-parts (list [type-cursor (#Record type-parts)])]) (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] [meta-cursor (#Record meta-parts)] type-code1 type-codes)) - (#Some [name args [meta-cursor (#Record meta-parts)] (#Cons type-code1 type-codes)]) + (#Some [name args meta-parts (#Cons type-code1 type-codes)]) (^ (list& [_ (#Form (#Cons [_ (#Identifier "" name)] args))] type-codes)) - (#Some [name args (` {}) type-codes]) + (#Some [name args (list) type-codes]) _ #None))] @@ -3980,13 +3893,6 @@ module-name current-module-name] (let [type-name (local-identifier$ name) [type tags??] type+tags?? - type-meta (: Code - (case tags?? - (#Some tags) - (` {#.tags [(~+ (list@map text$ tags))]}) - - _ - (` {}))) type' (: (Maybe Code) (if rec? (if (empty? args) @@ -4001,19 +3907,33 @@ (#Some type) _ - (#Some (` (All (~ type-name) [(~+ args)] (~ type)))))))] + (#Some (` (.All (~ type-name) [(~+ args)] (~ type))))))) + total-meta (let [meta (process-def-meta meta) + meta (if exported? + (with-export-meta meta) + meta) + meta (if rec? + (` (#.Cons (~ (flag-meta "type-rec?")) (~ meta))) + meta)] + (` [(~ cursor-code) + (#.Record (~ meta))]))] (case type' (#Some type'') - (return (list (` (..def: (~+ (export exported?)) (~ type-name) - (~ ($_ meta-code-merge (with-type-args args) - (if rec? (' {#.type-rec? #1}) (' {})) - type-meta - meta)) - Type - ("lux check type" - (#.Named [(~ (text$ module-name)) - (~ (text$ name))] - (type (~ type'')))))))) + (let [typeC (` (#.Named [(~ (text$ module-name)) + (~ (text$ name))] + (.type (~ type''))))] + (return (list (case tags?? + (#Some tags) + (` ("lux def type tagged" (~ type-name) + (~ typeC) + (~ total-meta) + [(~+ (list@map text$ tags))])) + + _ + (` ("lux def" (~ type-name) + ("lux check type" + (~ typeC)) + (~ total-meta))))))) #None (fail "Wrong syntax for type:")))) @@ -4787,7 +4707,7 @@ _ (fail ($_ text@compose "Wrong syntax for refer @ " current-module ..new-line (|> options - (list@map code-to-text) + (list@map %code) (interpose " ") (list@fold text@compose ""))))))) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 4277745f9..833af5656 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -242,7 +242,6 @@ [function-arguments #.func-args "Looks up the arguments of a function."] [type-arguments #.type-args "Looks up the arguments of a parameterized type."] - [declared-tags #.tags "Looks up the tags of a tagged (variant or record) type."] ) (def: (macro-type? type) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux index 99a8d1fe6..623019971 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux @@ -31,7 +31,7 @@ ["#/" // #_ ["#." analysis] ["#." synthesis (#+ Synthesis)] - ["#." statement (#+ Import Operation Handler Bundle)] + ["#." statement (#+ Import Requirements Phase Operation Handler Bundle)] [default ["#." evaluation]]]]]) @@ -57,16 +57,14 @@ #let [analyse (get@ [#////statement.analysis #////statement.phase] state) synthesize (get@ [#////statement.synthesis #////statement.phase] state) generate (get@ [#////statement.generation #////statement.phase] state)] - [_ code//type codeA] (////statement.lift-analysis - (////analysis.with-scope - (typeA.with-fresh-env - (typeA.with-type type - (do @ - [codeA (analyse codeC)] - (wrap [type codeA])))))) + [_ codeA] (////statement.lift-analysis + (////analysis.with-scope + (typeA.with-fresh-env + (typeA.with-type type + (analyse codeC))))) codeS (////statement.lift-synthesis (synthesize codeA))] - (evaluate!' generate code//type codeS))) + (evaluate!' generate type codeS))) ## TODO: Inline "definition'" into "definition" ASAP (def: (definition' generate name code//type codeS) @@ -83,9 +81,9 @@ _ (///generation.save! false name statement)] (wrap [code//type codeT target-name value])))) -(def: (definition name codeC) +(def: (definition name expected codeC) (All [anchor expression statement] - (-> Name Code + (-> Name (Maybe Type) Code (Operation anchor expression statement [Type expression Text Any]))) (do ///.monad [state (//.lift ///.get-state) @@ -95,31 +93,23 @@ [_ code//type codeA] (////statement.lift-analysis (////analysis.with-scope (typeA.with-fresh-env - (do @ - [[code//type codeA] (typeA.with-inference (analyse codeC)) - code//type (typeA.with-env - (check.clean code//type))] - (wrap [code//type codeA]))))) + (case expected + #.None + (do @ + [[code//type codeA] (typeA.with-inference (analyse codeC)) + code//type (typeA.with-env + (check.clean code//type))] + (wrap [code//type codeA])) + + (#.Some expected) + (do @ + [codeA (typeA.with-type expected + (analyse codeC))] + (wrap [expected codeA])))))) codeS (////statement.lift-synthesis (synthesize codeA))] (definition' generate 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 (type@= .Type type) - (case (macro.declared-tags annotations) - #.Nil - (wrap []) - - tags - (module.declare-tags tags (macro.export? annotations) (:coerce Type value))) - (wrap []))))) - (def: (refresh expander) (All [anchor expression statement] (-> Expander (Operation anchor expression statement Any))) @@ -145,10 +135,11 @@ [current-module (////statement.lift-analysis (//.lift macro.current-module-name)) #let [full-name [current-module short-name]] - [_ annotationsT annotationsV] (evaluate! Code annotationsC) - #let [annotationsV (:coerce Code annotationsV)] - [value//type valueT valueN valueV] (..definition full-name valueC) - _ (..define short-name value//type annotationsV valueV) + [_ annotationsT annotations] (evaluate! Code annotationsC) + #let [annotations (:coerce Code annotations)] + [type valueT valueN value] (..definition full-name #.None valueC) + _ (////statement.lift-analysis + (module.define short-name [type annotations value])) #let [_ (log! (format "Definition " (%name full-name)))] _ (////statement.lift-generation (///generation.learn full-name valueN)) @@ -158,6 +149,44 @@ _ (///.throw //.invalid-syntax [extension-name %code inputsC+])))) +(def: (custom [syntax handler]) + (All [anchor expression statement s] + (-> [(Parser s) + (-> Text + (Phase anchor expression statement) + s + (Operation anchor expression statement Requirements))] + (Handler anchor expression statement))) + (function (_ extension-name phase inputs) + (case (s.run syntax inputs) + (#error.Success inputs) + (handler extension-name phase inputs) + + (#error.Failure error) + (///.throw //.invalid-syntax [extension-name %code inputs])))) + +(def: (def::type-tagged expander) + (-> Expander Handler) + (..custom + [($_ p.and s.local-identifier s.any s.any (s.tuple (p.some s.text))) + (function (_ extension-name phase [short-name valueC annotationsC tags]) + (do ///.monad + [current-module (////statement.lift-analysis + (//.lift macro.current-module-name)) + #let [full-name [current-module short-name]] + [_ annotationsT annotations] (evaluate! Code annotationsC) + #let [annotations (:coerce Code annotations)] + [type valueT valueN value] (..definition full-name (#.Some .Type) valueC) + _ (////statement.lift-analysis + (do ///.monad + [_ (module.define short-name [type annotations value])] + (module.declare-tags tags (macro.export? annotations) (:coerce Type value)))) + #let [_ (log! (format "Definition " (%name full-name)))] + _ (////statement.lift-generation + (///generation.learn full-name valueN)) + _ (..refresh expander)] + (wrap ////statement.no-requirements)))])) + (def: imports (Parser (List Import)) (|> (s.tuple (p.and s.text s.text)) @@ -166,17 +195,11 @@ (def: def::module Handler - (function (_ extension-name phase inputsC+) - (case inputsC+ - (^ (list annotationsC importsC)) + (..custom + [($_ p.and s.any ..imports) + (function (_ extension-name phase [annotationsC imports]) (do ///.monad - [imports (case (s.run ..imports (list importsC)) - (#error.Success imports) - (wrap imports) - - (#error.Failure error) - (///.throw //.invalid-syntax [extension-name %code (list annotationsC importsC)])) - [_ annotationsT annotationsV] (evaluate! Code annotationsC) + [[_ annotationsT annotationsV] (evaluate! Code annotationsC) #let [annotationsV (:coerce Code annotationsV)] _ (////statement.lift-analysis (do @ @@ -189,10 +212,7 @@ imports)] (module.set-annotations annotationsV)))] (wrap {#////statement.imports imports - #////statement.referrals (list)})) - - _ - (///.throw //.invalid-syntax [extension-name %code inputsC+])))) + #////statement.referrals (list)})))])) ## TODO: Reify aliasing as a feature of the compiler, instead of ## manifesting it implicitly through definition annotations. @@ -302,18 +322,19 @@ _ (///.throw //.invalid-syntax [extension-name %code inputsC+])))) -(def: (bundle::def program) +(def: (bundle::def expander program) (All [anchor expression statement] - (-> (-> expression statement) (Bundle anchor expression statement))) + (-> Expander (-> expression statement) (Bundle anchor expression statement))) (<| (//bundle.prefix "def") (|> //bundle.empty - (dictionary.put "module" def::module) - (dictionary.put "alias" def::alias) - (dictionary.put "analysis" def::analysis) - (dictionary.put "synthesis" def::synthesis) + (dictionary.put "module" def::module) + (dictionary.put "alias" def::alias) + (dictionary.put "type tagged" (def::type-tagged expander)) + (dictionary.put "analysis" def::analysis) + (dictionary.put "synthesis" def::synthesis) (dictionary.put "generation" def::generation) - (dictionary.put "statement" def::statement) - (dictionary.put "program" (def::program program)) + (dictionary.put "statement" def::statement) + (dictionary.put "program" (def::program program)) ))) (def: #export (bundle expander program) @@ -322,4 +343,4 @@ (<| (//bundle.prefix "lux") (|> //bundle.empty (dictionary.put "def" (lux::def expander)) - (dictionary.merge (..bundle::def program))))) + (dictionary.merge (..bundle::def expander program))))) |