From c9e0b6c3a0c23b34cd6ffac1b93a266ae6243c4a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 31 Jul 2015 20:33:29 -0400 Subject: - Did some refactoring of the standard library. - Introduced 2 new modules: lux/data/tuple & lux/codata/function - Now doing safe reading of files. - Took the "let", "lambda" & "def" macros to their ultimate form. - Added some macros for doing better JVM interop. - Fixed a bug when compiling comparisons for doubles. - Changed the order in which arguments are compiled for all arithmetic operations, as the order is reversed (from the conventional order) in the JVM bytecode. --- README.md | 2 +- source/lux.lux | 1115 +++++++++++++++++++++------------------ source/lux/codata/function.lux | 26 + source/lux/codata/lazy.lux | 48 ++ source/lux/codata/reader.lux | 33 ++ source/lux/codata/state.lux | 35 ++ source/lux/codata/stream.lux | 11 +- source/lux/control/bounded.lux | 17 + source/lux/control/dict.lux | 21 + source/lux/control/eq.lux | 14 + source/lux/control/lazy.lux | 47 -- source/lux/control/number.lux | 28 + source/lux/control/ord.lux | 44 ++ source/lux/control/show.lux | 14 + source/lux/data/bool.lux | 6 +- source/lux/data/bounded.lux | 17 - source/lux/data/char.lux | 6 +- source/lux/data/cont.lux | 41 ++ source/lux/data/dict.lux | 83 --- source/lux/data/eq.lux | 14 - source/lux/data/id.lux | 12 +- source/lux/data/list.lux | 99 +++- source/lux/data/maybe.lux | 20 +- source/lux/data/number.lux | 113 ---- source/lux/data/number/int.lux | 89 ++++ source/lux/data/number/real.lux | 89 ++++ source/lux/data/ord.lux | 44 -- source/lux/data/reader.lux | 33 -- source/lux/data/show.lux | 14 - source/lux/data/state.lux | 35 -- source/lux/data/text.lux | 9 +- source/lux/data/tuple.lux | 39 ++ source/lux/host/jvm.lux | 16 +- source/lux/meta/lux.lux | 42 +- source/lux/meta/syntax.lux | 10 +- source/program.lux | 31 +- src/lux/compiler.clj | 100 ++-- src/lux/compiler/cache.clj | 126 ++--- src/lux/compiler/host.clj | 10 +- src/lux/compiler/io.clj | 18 + 40 files changed, 1481 insertions(+), 1090 deletions(-) create mode 100644 source/lux/codata/function.lux create mode 100644 source/lux/codata/lazy.lux create mode 100644 source/lux/codata/reader.lux create mode 100644 source/lux/codata/state.lux create mode 100644 source/lux/control/bounded.lux create mode 100644 source/lux/control/dict.lux create mode 100644 source/lux/control/eq.lux delete mode 100644 source/lux/control/lazy.lux create mode 100644 source/lux/control/number.lux create mode 100644 source/lux/control/ord.lux create mode 100644 source/lux/control/show.lux delete mode 100644 source/lux/data/bounded.lux create mode 100644 source/lux/data/cont.lux delete mode 100644 source/lux/data/dict.lux delete mode 100644 source/lux/data/eq.lux delete mode 100644 source/lux/data/number.lux create mode 100644 source/lux/data/number/int.lux create mode 100644 source/lux/data/number/real.lux delete mode 100644 source/lux/data/ord.lux delete mode 100644 source/lux/data/reader.lux delete mode 100644 source/lux/data/show.lux delete mode 100644 source/lux/data/state.lux create mode 100644 source/lux/data/tuple.lux create mode 100644 src/lux/compiler/io.clj diff --git a/README.md b/README.md index 094de9d8d..0c0b4e5c8 100644 --- a/README.md +++ b/README.md @@ -102,7 +102,7 @@ The mechanism hasn't been added yet to the language (mainly because there's only ### Macros Unlike in most other lisps, Lux macros are monadic. -The **(Lux a)** type is the one responsibly for the magic by treading **Compiler** instances through macros. +The **(Lux a)** type is the one responsible for the magic by treading **Compiler** instances through macros. Macros must have the **Macro** type and then be declared as macros. However, just using the **defmacro** macro will take care of it for you. diff --git a/source/lux.lux b/source/lux.lux index 8861bc241..dc186fb3d 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -373,7 +373,7 @@ (_lux_lambda _ tokens (_meta (#RecordS tokens))))) -(_lux_def let' +(_lux_def let'' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens @@ -383,10 +383,10 @@ #Nil])) _ - (fail "Wrong syntax for let'"))))) -(_lux_declare-macro let') + (fail "Wrong syntax for let''"))))) +(_lux_declare-macro let'') -(_lux_def lambda' +(_lux_def lambda'' (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens @@ -399,7 +399,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -414,7 +414,7 @@ body _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) (#Cons [(_meta (#TupleS args')) (#Cons [body #Nil])])])))) #Nil])])])]))) @@ -422,73 +422,73 @@ _ (fail "Wrong syntax for lambda"))))) -(_lux_declare-macro lambda') +(_lux_declare-macro lambda'') -(_lux_def def' +(_lux_def def'' (_lux_: Macro - (lambda' [tokens] - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) - #Nil])])) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) - (#Cons [name - (#Cons [(_meta (#TupleS args)) - (#Cons [body #Nil])])])]))) - #Nil])])]))) - #Nil])])]))) - #Nil])) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) - (#Cons [name - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) - (#Cons [type - (#Cons [body - #Nil])])]))) - #Nil])])]))) - #Nil])) + (lambda'' [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) - _ - (fail "Wrong syntax for def") - )))) -(_lux_declare-macro def') + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def'') -(def' (defmacro tokens) +(def'' (defmacro tokens) Macro (_lux_case tokens (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) (#Cons [body @@ -498,7 +498,7 @@ #Nil])])) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(tag$ ["" "export"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) @@ -587,7 +587,7 @@ _ (fail "Wrong syntax for $'"))) -(def' (foldL f init xs) +(def'' (foldL f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -600,18 +600,18 @@ (#Cons [x xs']) (foldL f (f init x) xs'))) -(def' (reverse list) +(def'' (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (lambda' [tail head] (#Cons [head tail])) + (foldL (lambda'' [tail head] (#Cons [head tail])) #Nil list)) (defmacro (list xs) - (return (#Cons [(foldL (lambda' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) + (return (#Cons [(foldL (lambda'' [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) (_meta (#TagS ["lux" "Nil"])) (reverse xs)) #Nil]))) @@ -619,45 +619,45 @@ (defmacro (list& xs) (_lux_case (reverse xs) (#Cons [last init]) - (return (list (foldL (lambda' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) + (return (list (foldL (lambda'' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) last init))) _ (fail "Wrong syntax for list&"))) -(defmacro #export (lambda tokens) - (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) - [name tokens'] - - _ - [["" ""] tokens])) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case args - #Nil - (fail "lambda requires a non-empty arguments tuple.") - - (#Cons [harg targs]) - (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ name) - harg - (foldL (lambda' [body' arg] - (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))) - - _ - (fail "Wrong syntax for lambda")))) +(defmacro (lambda' tokens) + (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + [name tokens'] -(defmacro (def'' tokens) + _ + [["" ""] tokens])) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda' requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ name) + harg + (foldL (lambda'' [body' arg] + (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda'")))) + +(defmacro (def''' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -666,7 +666,7 @@ name (form$ (list (symbol$ ["" "_lux_:"]) type - (form$ (list (symbol$ ["lux" "lambda"]) + (form$ (list (symbol$ ["lux" "lambda'"]) name (tuple$ args) body)))))) @@ -686,7 +686,7 @@ name (form$ (list (symbol$ ["" "_lux_:"]) type - (form$ (list (symbol$ ["lux" "lambda"]) + (form$ (list (symbol$ ["lux" "lambda'"]) name (tuple$ args) body)))))))) @@ -697,10 +697,10 @@ (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) _ - (fail "Wrong syntax for def") + (fail "Wrong syntax for def'") )) -(def'' (as-pairs xs) +(def''' (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (_lux_case xs @@ -710,22 +710,22 @@ _ #Nil)) -(defmacro #export (let tokens) +(defmacro (let' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) Syntax) - (lambda [body binding] - (_lux_case binding - [label value] - (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) + (lambda' [body binding] + (_lux_case binding + [label value] + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) body (reverse (as-pairs bindings))))) _ - (fail "Wrong syntax for let"))) + (fail "Wrong syntax for let'"))) -(def'' (map f xs) +(def''' (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -735,7 +735,7 @@ (#Cons [x xs']) (#Cons [(f x) (map f xs')]))) -(def'' (any? p xs) +(def''' (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs @@ -747,7 +747,7 @@ true true false (any? p xs')))) -(def'' (spliced? token) +(def''' (spliced? token) (->' Syntax Bool) (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) @@ -756,13 +756,13 @@ _ false)) -(def'' (wrap-meta content) +(def''' (wrap-meta content) (->' Syntax Syntax) (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) content))))))) -(def'' (untemplate-list tokens) +(def''' (untemplate-list tokens) (->' ($' List Syntax) Syntax) (_lux_case tokens #Nil @@ -772,7 +772,7 @@ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list token (untemplate-list tokens'))))))))) -(def'' #export (list:++ xs ys) +(def''' #export (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (_lux_case xs (#Cons [x xs']) @@ -784,41 +784,41 @@ (defmacro #export ($ tokens) (_lux_case tokens (#Cons [op (#Cons [init args])]) - (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) + (return (list (foldL (lambda' [a1 a2] (form$ (list op a1 a2))) init args))) _ (fail "Wrong syntax for $"))) -(def'' (splice replace? untemplate tag elems) +(def''' (splice replace? untemplate tag elems) (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (_lux_case replace? true (_lux_case (any? spliced? elems) true - (let [elems' (map (lambda [elem] - (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) - spliced - - _ - (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) - (tag$ ["lux" "Nil"]))))))))) - elems)] - (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "list:++"]) - elems')))))) + (let' [elems' (map (lambda' [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) + (tag$ ["lux" "Nil"]))))))))) + elems)] + (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) + elems')))))) false (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) false (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) -(def'' (untemplate replace? subst token) +(def''' (untemplate replace? subst token) (->' Bool Text Syntax Syntax) (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) [_ (#Meta [_ (#BoolS value)])] @@ -837,22 +837,22 @@ (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) [_ (#Meta [_ (#TagS [module name])])] - (let [module' (_lux_case module - "" - subst + (let' [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) [_ (#Meta [_ (#SymbolS [module name])])] - (let [module' (_lux_case module - "" - subst + (let' [module' (_lux_case module + "" + subst - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) [_ (#Meta [_ (#TupleS elems)])] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) @@ -861,15 +861,15 @@ unquoted [_ (#Meta [meta (#FormS elems)])] - (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - (#Meta [meta form'])) + (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + (#Meta [meta form'])) [_ (#Meta [_ (#RecordS fields)])] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) - (lambda [kv] - (let [[k v] kv] - (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) + (lambda' [kv] + (let' [[k v] kv] + (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) fields))))) )) @@ -881,7 +881,7 @@ _ (fail "Wrong syntax for `'"))) -(defmacro (' tokens) +(defmacro #export (' tokens) (_lux_case tokens (#Cons [template #Nil]) (return (list (untemplate false "" template))) @@ -892,16 +892,16 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (lambda [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) + (return (list (foldL (lambda' [acc app] + (_lux_case app + (#Meta [_ (#TupleS parts)]) + (tuple$ (list:++ parts (list acc))) - (#Meta [_ (#FormS parts)]) - (form$ (list:++ parts (list acc))) + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) + _ + (`' ((~ app) (~ acc))))) init apps))) @@ -920,7 +920,7 @@ ## (deftype (Lux a) ## (-> Compiler (Either Text (, Compiler a)))) -(def'' #export Lux +(def''' #export Lux Type (All' [a] (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) @@ -930,7 +930,7 @@ ## return) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) -(def'' Monad +(def''' Monad Type (All' [m] (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] @@ -938,34 +938,34 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def'' Maybe/Monad +(def''' Maybe/Monad ($' Monad Maybe) {#lux;return - (lambda return [x] - (#Some x)) + (lambda' return [x] + (#Some x)) #lux;bind - (lambda [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) + (lambda' [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) -(def'' Lux/Monad +(def''' Lux/Monad ($' Monad Lux) {#lux;return - (lambda [x] - (lambda [state] - (#Right [state x]))) + (lambda' [x] + (lambda' [state] + (#Right [state x]))) #lux;bind - (lambda [f ma] - (lambda [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) + (lambda' [f ma] + (lambda' [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right [state' a]) - (f a state'))))}) + (#Right [state' a]) + (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens @@ -978,7 +978,7 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons [output inputs]) - (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + (return (list (foldL (lambda' [o i] (`' (#;LambdaT [(~ i) (~ o)]))) output inputs))) @@ -991,28 +991,28 @@ (defmacro (do tokens) (_lux_case tokens (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) - (lambda [body' binding] - (let [[var value] binding] - (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) - (`' (;let (~ value) (~ body'))) - - _ - (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) - body - (reverse (as-pairs bindings)))] - (return (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} - (~ body')))))) + (let' [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda' [body' binding] + (let' [[var value] binding] + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let' (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (return (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) _ (fail "Wrong syntax for do"))) -(def'' (map% m f xs) +(def''' (map% m f xs) ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) (All' [m a b] @@ -1020,25 +1020,25 @@ (-> (B' a) ($' (B' m) (B' b))) ($' List (B' a)) ($' (B' m) ($' List (B' b))))) - (let [{#;return ;return #;bind _} m] - (_lux_case xs - #Nil - (;return #Nil) - - (#Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (;return (#Cons [y ys]))) - ))) + (let' [{#;return ;return #;bind _} m] + (_lux_case xs + #Nil + (;return #Nil) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (#Cons [y ys]))) + ))) -(def'' #export (. f g) +(def''' (. f g) (All' [a b c] (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) - (lambda [x] - (f (g x)))) + (lambda' [x] + (f (g x)))) -(def'' (get-ident x) +(def''' (get-ident x) (-> Syntax ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) @@ -1047,7 +1047,7 @@ _ #None)) -(def'' (tuple->list tuple) +(def''' (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (_lux_case tuple (#Meta [_ (#TupleS members)]) @@ -1056,11 +1056,11 @@ _ #None)) -(def'' RepEnv +(def''' RepEnv Type ($' List (, Text Syntax))) -(def'' (make-env xs ys) +(def''' (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) [xs ys]) @@ -1070,12 +1070,12 @@ _ #Nil)) -(def'' (text:= x y) +(def''' (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y])) -(def'' (get-rep key env) +(def''' (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) (_lux_case env #Nil @@ -1086,7 +1086,7 @@ (#Some v) (get-rep key env')))) -(def'' (apply-template env template) +(def''' (apply-template env template) (-> RepEnv Syntax Syntax) (_lux_case template (#Meta [_ (#SymbolS ["" sname])]) @@ -1105,15 +1105,15 @@ (#Meta [_ (#RecordS members)]) (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [kv] - (let [[slot value] kv] - [(apply-template env slot) (apply-template env value)]))) + (lambda' [kv] + (let' [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) members)) _ template)) -(def'' (join-map f xs) +(def''' (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -1130,11 +1130,11 @@ [(map% Maybe/Monad get-ident bindings) (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] - (let [apply (_lux_: (-> RepEnv ($' List Syntax)) - (lambda [env] (map (apply-template env) templates)))] - (|> data' - (join-map (. apply (make-env bindings'))) - return)) + (let' [apply (_lux_: (-> RepEnv ($' List Syntax)) + (lambda' [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) _ (fail "Wrong syntax for do-template")) @@ -1143,7 +1143,7 @@ (fail "Wrong syntax for do-template"))) (do-template [ ] - [(def'' #export ( x y) + [(def''' ( x y) (-> Bool) ( x y))] @@ -1156,7 +1156,7 @@ ) (do-template [ ] - [(def'' #export ( x y) + [(def''' ( x y) (-> Bool) (if ( x y) true @@ -1169,7 +1169,7 @@ ) (do-template [ ] - [(def'' #export ( x y) + [(def''' ( x y) (-> ) ( x y))] @@ -1185,29 +1185,29 @@ [r% _jvm_drem Real] ) -(def'' (multiple? div n) +(def''' (multiple? div n) (-> Int Int Bool) (i= 0 (i% n div))) -(def'' (length list) +(def''' (length list) (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + (foldL (lambda' [acc _] (_jvm_ladd 1 acc)) 0 list)) -(def'' #export (not x) +(def''' #export (not x) (-> Bool Bool) (if x false true)) -(def'' (text:++ x y) +(def''' (text:++ x y) (-> Text Text Text) (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y])) -(def'' (ident->text ident) +(def''' (ident->text ident) (-> Ident Text) - (let [[module name] ident] - ($ text:++ module ";" name))) + (let' [[module name] ident] + ($ text:++ module ";" name))) -(def'' (replace-syntax reps syntax) +(def''' (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (_lux_case syntax (#Meta [_ (#SymbolS ["" name])]) @@ -1226,9 +1226,9 @@ (#Meta [_ (#RecordS slots)]) (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) - (lambda [slot] - (let [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) + (lambda' [slot] + (let' [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) slots))]) _ @@ -1236,40 +1236,40 @@ ) (defmacro #export (All tokens) - (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-ident args) - (#Some idents) - (_lux_case idents - #Nil - (return (list body)) + (let' [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] + + _ + ["" tokens]))] + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe/Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (list body)) + + (#Cons [harg targs]) + (let' [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda' [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) + (list& self-ident idents)) + body' (foldL (lambda' [body' arg'] + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) + (replace-syntax replacements body) + (reverse targs))] + ## (#;Some #;Nil) + (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) + + #None + (fail "'All' arguments must be symbols.")) - (#Cons [harg targs]) - (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) - (list& self-ident idents)) - body' (foldL (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - ## (#;Some #;Nil) - (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) - - #None - (fail "'All' arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) - )) + _ + (fail "Wrong syntax for All")) + )) -(def'' (get k plist) +(def''' (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) (_lux_case plist @@ -1281,7 +1281,7 @@ #Nil #None)) -(def'' (put k v dict) +(def''' (put k v dict) (All [a] (-> Text a ($' List (, Text a)) ($' List (, Text a)))) (_lux_case dict @@ -1293,7 +1293,7 @@ (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')])))) -(def'' (get-module-name state) +(def''' (get-module-name state) ($' Lux Text) (_lux_case state {#source source #modules modules @@ -1306,14 +1306,14 @@ (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) (#Right [state module-name])))) -(def'' (find-macro' modules current-module module name) +(def''' (find-macro' modules current-module module name) (-> ($' List (, Text ($' Module Compiler))) Text Text Text ($' Maybe Macro)) (do Maybe/Monad [$module (get module modules) - gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] - (get name bindings))] + gdef (let' [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] (if exported? @@ -1328,24 +1328,24 @@ _ #None))) -(def'' (find-macro ident) +(def''' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) (do Lux/Monad [current-module get-module-name] - (let [[module name] ident] - (lambda [state] - (_lux_case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [state (find-macro' modules current-module module name)])))))) - -(def'' (list:join xs) + (let' [[module name] ident] + (lambda' [state] + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (#Right [state (find-macro' modules current-module module name)])))))) + +(def''' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (foldL list:++ #Nil xs)) -(def'' (normalize ident) +(def''' (normalize ident) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] @@ -1360,20 +1360,20 @@ (do Lux/Monad [pairs (map% Lux/Monad (_lux_: (-> Syntax ($' Lux Syntax)) - (lambda [token] - (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for |")))) + (lambda' [token] + (_lux_case token + (#Meta [_ (#TagS ident)]) + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for |")))) tokens)] (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) @@ -1383,23 +1383,23 @@ (do Lux/Monad [pairs (map% Lux/Monad (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) - (lambda [pair] - (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) + (lambda' [pair] + (_lux_case pair + [(#Meta [_ (#TagS ident)]) value] + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for &")))) (as-pairs tokens))] (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) -(def'' #export (->text x) +(def''' (->text x) (-> (^ java.lang.Object) Text) (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) -(def'' (interpose sep xs) +(def''' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs @@ -1412,7 +1412,7 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def'' (macro-expand syntax) +(def''' (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) @@ -1445,7 +1445,7 @@ _ (return (list syntax)))) -(def'' (walk-type type) +(def''' (walk-type type) (-> Syntax Syntax) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) @@ -1455,7 +1455,7 @@ (tuple$ (map walk-type members)) (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + (foldL (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1493,71 +1493,71 @@ _ (fail "Wrong syntax for :!"))) -(def'' (empty? xs) +(def''' (empty? xs) (All [a] (-> ($' List a) Bool)) (_lux_case xs #Nil true _ false)) (defmacro #export (deftype tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] + (let' [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + [rec? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + [true tokens'] - _ - [false tokens])) - [rec? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) - [true tokens'] - - _ - [false tokens'])) - parts (: (Maybe (, Text (List Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) - (#Some [name #Nil type]) + _ + [false tokens'])) + parts (: (Maybe (, Text (List Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) + (#Some [name #Nil type]) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) - (#Some [name args type]) + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) + (#Some [name args type]) - _ - #None))] - (_lux_case parts - (#Some [name args type]) - (let [with-export (: (List Syntax) - (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) - #Nil)) - type' (: (Maybe Syntax) - (if rec? - (if (empty? args) - (let [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] - (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) - ;Void)))) - #None) - (_lux_case args - #Nil - (#Some type) - - _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) - with-export)) + _ + #None))] + (_lux_case parts + (#Some [name args type]) + (let' [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ (symbol$ ["" name]))))) + #Nil)) + type' (: (Maybe Syntax) + (if rec? + (if (empty? args) + (let' [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] + (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) + ;Void)))) + #None) + (_lux_case args + #Nil + (#Some type) + + _ + (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + with-export)) + + #None + (fail "Wrong syntax for deftype"))) #None - (fail "Wrong syntax for deftype"))) - - #None - (fail "Wrong syntax for deftype")) - )) + (fail "Wrong syntax for deftype")) + )) ## (defmacro #export (deftype tokens) -## (let [[export? tokens'] (: (, Bool (List Syntax)) +## (let' [[export? tokens'] (: (, Bool (List Syntax)) ## (_lux_case (:! (List Syntax) tokens) ## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) ## [true (:! (List Syntax) tokens')] @@ -1576,7 +1576,7 @@ ## #None))] ## (_lux_case parts ## (#Some [name args type]) -## (let [with-export (: (List Syntax) +## (let' [with-export (: (List Syntax) ## (if export? ## (list (`' (_lux_export (~ name)))) ## #Nil)) @@ -1597,66 +1597,66 @@ (defmacro #export (exec tokens) (_lux_case (reverse tokens) (#Cons [value actions]) - (let [dummy (symbol$ ["" ""])] - (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) - value - actions)))) + (let' [dummy (symbol$ ["" ""])] + (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + value + actions)))) _ (fail "Wrong syntax for exec"))) -(defmacro #export (def tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) - (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) - [true tokens'] +(defmacro (def' tokens) + (let' [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) - _ - [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) - (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) - - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) - - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) - - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) - - _ - #None))] - (_lux_case parts - (#Some [name args ?type body]) - (let [body' (: Syntax - (_lux_case args - #Nil - body + _ + #None))] + (_lux_case parts + (#Some [name args ?type body]) + (let' [body' (: Syntax + (_lux_case args + #Nil + body - _ - (`' (;lambda (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax - (_lux_case ?type - (#Some type) - (`' (: (~ type) (~ body'))) - - #None - body'))] - (return (list& (`' (_lux_def (~ name) (~ body''))) - (if export? - (list (`' (_lux_export (~ name)))) - #Nil)))) - - #None - (fail "Wrong syntax for def")))) + _ + (`' (;lambda' (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (_lux_case ?type + (#Some type) + (`' (: (~ type) (~ body'))) + + #None + body'))] + (return (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for def'")))) -(def (rejoin-pair pair) +(def' (rejoin-pair pair) (-> (, Syntax Syntax) (List Syntax)) - (let [[left right] pair] - (list left right))) + (let' [[left right] pair] + (list left right))) (defmacro #export (case tokens) (_lux_case tokens @@ -1664,17 +1664,17 @@ (do Lux/Monad [expansions (map% Lux/Monad (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) - (lambda expander [branch] - (let [[pattern body] branch] - (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) - (do Lux/Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux/Monad expander (as-pairs expansion))] - (;return (list:join expansions))) - - _ - (;return (list branch)))))) + (lambda' expander [branch] + (let' [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (do Lux/Monad + [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux/Monad expander (as-pairs expansion))] + (;return (list:join expansions))) + + _ + (;return (list branch)))))) (as-pairs branches))] (;return (list (`' (_lux_case (~ value) (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) @@ -1707,18 +1707,12 @@ _ (do Lux/Monad [patterns' (map% Lux/Monad macro-expand patterns)] - (;return (list:join (map (lambda [pattern] (list pattern body)) + (;return (list:join (map (lambda' [pattern] (list pattern body)) (list:join patterns')))))) _ (fail "Wrong syntax for \\or"))) -(do-template [ ] - [(def #export (i+ ))] - - [inc 1] - [dec -1]) - (defmacro #export (` tokens) (do Lux/Monad [module-name get-module-name] @@ -1729,6 +1723,147 @@ _ (fail "Wrong syntax for `")))) +(def' (symbol? ast) + (-> Syntax Bool) + (case ast + (#Meta [_ (#SymbolS _)]) + true + + _ + false)) + +(defmacro #export (let tokens) + (case tokens + (\ (list (#Meta [_ (#TupleS bindings)]) body)) + (if (multiple? 2 (length bindings)) + (|> bindings as-pairs reverse + (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda' [body' lr] + (let' [[l r] lr] + (if (symbol? l) + (` (_lux_case (~ r) (~ l) (~ body'))) + (` (case (~ r) (~ l) (~ body'))))))) + body) + list + return) + (fail "let requires an even number of parts")) + + _ + (fail "Wrong syntax for let"))) + +(def' (ast:show ast) + (-> Syntax Text) + (case ast + (#Meta [_ ast]) + (case ast + (\or (#BoolS val) (#IntS val) (#RealS val)) + (->text val) + + (#CharS val) + ($ text:++ "#\"" (->text val) "\"") + + (#TextS val) + ($ text:++ "\"" (->text val) "\"") + + (#FormS parts) + ($ text:++ "(" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) ")") + + (#TupleS parts) + ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]") + + (#SymbolS [prefix name]) + ($ text:++ prefix ";" name) + + (#TagS [prefix name]) + ($ text:++ "#" prefix ";" name) + + (#RecordS kvs) + ($ text:++ "{" + (|> kvs + (map (: (-> (, Syntax Syntax) Text) + (lambda' [kv] (let [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v)))))) + (interpose " ") + (foldL text:++ "")) + "}") + ))) + +(defmacro #export (lambda tokens) + (case (: (Maybe (, Ident Syntax (List Syntax) Syntax)) + (case tokens + (\ (list (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) + (#Some [["" ""] head tail body]) + + (\ (list (#Meta [_ (#SymbolS ident)]) (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) + (#Some [ident head tail body]) + + _ + #None)) + (#Some [ident head tail body]) + (let [g!blank (symbol$ ["" ""]) + g!name (symbol$ ident) + body+ (: Syntax (foldL (: (-> Syntax Syntax Syntax) + (lambda' [body' arg] + (if (symbol? arg) + (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) + (` (_lux_lambda (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail)))] + (return (list (if (symbol? head) + (` (_lux_lambda (~ g!name) (~ head) (~ body+))) + (` (_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) + + #None + (fail "Wrong syntax for lambda"))) + +(defmacro #export (def tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + (case tokens' + (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) type body)) + (#Some [name args (#Some type) body]) + + (\ (list name type body)) + (#Some [name #Nil (#Some type) body]) + + (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) body)) + (#Some [name args #None body]) + + (\ (list name body)) + (#Some [name #Nil #None body]) + + _ + #None))] + (case parts + (#Some [name args ?type body]) + (let [body (: Syntax + (case args + #Nil + body + + _ + (` (;lambda (~ name) [(~@ args)] (~ body))))) + body (: Syntax + (case ?type + (#Some type) + (` (: (~ type) (~ body))) + + #None + body))] + (return (list& (` (_lux_def (~ name) (~ body))) + (if export? + (list (` (_lux_export (~ name)))) + (list))))) + + #None + (fail "Wrong syntax for def")))) + (def (gensym prefix state) (-> Text (Lux Syntax)) (case state @@ -1737,7 +1872,7 @@ #seed seed #eval? eval?} (#Right [{#source source #modules modules #envs envs #types types #host host - #seed (inc seed) #eval? eval?} + #seed (i+ 1 seed) #eval? eval?} (symbol$ ["__gensym__" (->text seed)])]))) (def (macro-expand-1 token) @@ -1758,7 +1893,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) (do Lux/Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1766,12 +1901,12 @@ _ (fail "Signatures require typed members!")))) (list:join tokens'))] - (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text text$)) - (~ type)])))) - members))))))))) + (;return (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) + (lambda [pair] + (let [[name type] pair] + (` [(~ (|> name ident->text text$)) + (~ type)])))) + members))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1796,13 +1931,13 @@ (let [sigs' (: Syntax (case args #Nil - (`' (;sig (~@ sigs))) + (` (;sig (~@ sigs))) _ - (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (`' (_lux_def (~ name) (~ sigs'))) + (` (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (list& (` (_lux_def (~ name) (~ sigs'))) (if export? - (list (`' (_lux_export (~ name)))) + (list (` (_lux_export (~ name)))) #Nil)))) #None @@ -1815,13 +1950,13 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) (do Lux/Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [(tag$ name') value]))) _ - (fail "Structures require defined members!")))) + (fail "Structures require defined members")))) (list:join tokens'))] (;return (list (record$ members))))) @@ -1848,13 +1983,13 @@ (let [defs' (: Syntax (case args #Nil - (`' (;struct (~@ defs))) + (` (;struct (~@ defs))) _ - (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (` (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (` (def (~ name) (~ type) (~ defs'))) (if export? - (list (`' (_lux_export (~ name)))) + (list (` (_lux_export (~ name)))) #Nil)))) #None @@ -2071,7 +2206,7 @@ (if (i< idx 0) (#Cons [module #Nil]) (#Cons [(substring2 0 idx module) - (split-module (substring1 (inc idx) module))])))) + (split-module (substring1 (i+ 1 idx) module))])))) (def (@ idx xs) (All [a] @@ -2083,7 +2218,7 @@ (#Cons [x xs']) (if (i= idx 0) (#Some x) - (@ (dec idx) xs') + (@ (i- idx 1) xs') ))) (def (split-with' p ys xs) @@ -2213,7 +2348,7 @@ (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) (map (: (-> Text Syntax) (lambda [def] - (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) defs) openings)))))) imports)] @@ -2244,7 +2379,7 @@ (-> Text (, Text Text)) (let [idx (index-of ";" slot) module (substring2 0 idx slot) - name (substring1 (inc idx) slot)] + name (substring1 (i+ 1 idx) slot)] [module name])) (def (type:show type) @@ -2363,26 +2498,13 @@ type )) -(defmacro #export (? tokens) - (case tokens - (\ (list maybe else)) - (do Lux/Monad - [g!value (gensym "")] - (return (list (` (case (~ maybe) - (#;Some (~ g!value)) - (~ g!value) - - _ - (~ else)))))) - - _ - (fail "Wrong syntax for ?"))) - (def (apply-type type-fn param) (-> Type Type (Maybe Type)) (case type-fn (#AllT [env name arg body]) - (#Some (beta-reduce (|> (? env (list)) + (#Some (beta-reduce (|> (case env + (#Some env) env + _ (list)) (put name type-fn) (put arg param)) body)) @@ -2542,27 +2664,12 @@ _ (fail "Wrong syntax for using"))) -(def #export (flip f) +(def (flip f) (All [a b c] (-> (-> a b c) (-> b a c))) (lambda [y x] (f x y))) -(def #export (curry f) - (All [a b c] - (-> (-> (, a b) c) - (-> a b c))) - (lambda [x y] - (f [x y]))) - -(def #export (uncurry f) - (All [a b c] - (-> (-> a b c) - (-> (, a b) c))) - (lambda [xy] - (let [[x y] xy] - (f x y)))) - (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux new file mode 100644 index 000000000..3c40df188 --- /dev/null +++ b/source/lux/codata/function.lux @@ -0,0 +1,26 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m))) + +## [Functions] +(def #export (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [y x] (f x y))) + +(def #export (. f g) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) + (lambda [x] (f (g x)))) + +## [Structures] +(defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) + (def m;unit id) + (def m;++ .)) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux new file mode 100644 index 000000000..94968de20 --- /dev/null +++ b/source/lux/codata/lazy.lux @@ -0,0 +1,48 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (meta macro) + (control (functor #as F #refer #all) + (monad #as M #refer #all)) + (data list)) + (.. function)) + +## Types +(deftype #export (Lazy a) + (All [b] + (-> (-> a b) b))) + +## Syntax +(defmacro #export (... tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for ..."))) + +## Functions +(def #export (! thunk) + (All [a] + (-> (Lazy a) a)) + (thunk id)) + +## Structs +(defstruct #export Lazy/Functor (Functor Lazy) + (def (F;map f ma) + (lambda [k] (ma (. k f))))) + +(defstruct #export Lazy/Monad (Monad Lazy) + (def M;_functor Lazy/Functor) + + (def (M;wrap a) + (... a)) + + (def M;join !)) diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux new file mode 100644 index 000000000..e91687c3a --- /dev/null +++ b/source/lux/codata/reader.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import (lux #refer (#exclude Reader)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Reader r a) + (-> r a)) + +## [Structures] +(defstruct #export Reader/Functor (All [r] + (Functor (Reader r))) + (def (F;map f fa) + (lambda [env] + (f (fa env))))) + +(defstruct #export Reader/Monad (All [r] + (Monad (Reader r))) + (def M;_functor Reader/Functor) + + (def (M;wrap x) + (lambda [env] x)) + + (def (M;join mma) + (lambda [env] + (mma env env)))) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux new file mode 100644 index 000000000..bc9858a29 --- /dev/null +++ b/source/lux/codata/state.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (State s a) + (-> s (, s a))) + +## [Structures] +(defstruct #export State/Functor (Functor State) + (def (F;map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(defstruct #export State/Monad (All [s] + (Monad (State s))) + (def M;_functor State/Functor) + + (def (M;wrap x) + (lambda [state] + [state x])) + + (def (M;join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 1d6dd1b50..2c854a61c 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -7,14 +7,15 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (control (lazy #as L #refer #all) - (functor #as F #refer #all) + (lux (control (functor #as F #refer #all) (monad #as M #refer #all) (comonad #as CM #refer #all)) (meta lux macro syntax) - (data (list #as l #refer (#only list list& List/Monad))))) + (data (list #as l #refer (#only list list& List/Monad)) + (number (int #open ("i" Int/Number Int/Ord)))) + (codata (lazy #as L #refer #all)))) ## [Types] (deftype #export (Stream a) @@ -59,7 +60,7 @@ (All [a] (-> Int (Stream a) a)) (let [[h t] (! s)] (if (i> idx 0) - (@ (dec idx) t) + (@ (i+ -1 idx) t) h))) (do-template [ ] @@ -89,7 +90,7 @@ [(list) xs])))] [take-while drop-while split-with (-> a Bool) (det x) det] - [take drop split Int (i> det 0) (dec det)] + [take drop split Int (i> det 0) (i+ -1 det)] ) (def #export (unfold step init) diff --git a/source/lux/control/bounded.lux b/source/lux/control/bounded.lux new file mode 100644 index 000000000..9d2dabde1 --- /dev/null +++ b/source/lux/control/bounded.lux @@ -0,0 +1,17 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Bounded a) + (: a + top) + + (: a + bottom)) diff --git a/source/lux/control/dict.lux b/source/lux/control/dict.lux new file mode 100644 index 000000000..3089ec927 --- /dev/null +++ b/source/lux/control/dict.lux @@ -0,0 +1,21 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Dict d) + (: (All [k v] + (-> k (d k v) (Maybe v))) + get) + (: (All [k v] + (-> k v (d k v) (d k v))) + put) + (: (All [k v] + (-> k (d k v) (d k v))) + remove)) diff --git a/source/lux/control/eq.lux b/source/lux/control/eq.lux new file mode 100644 index 000000000..be3400208 --- /dev/null +++ b/source/lux/control/eq.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Signatures] +(defsig #export (Eq a) + (: (-> a a Bool) + =)) diff --git a/source/lux/control/lazy.lux b/source/lux/control/lazy.lux deleted file mode 100644 index 22dac74fe..000000000 --- a/source/lux/control/lazy.lux +++ /dev/null @@ -1,47 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/meta macro) - (.. (functor #as F #refer #all) - (monad #as M #refer #all)) - (lux/data list)) - -## Types -(deftype #export (Lazy a) - (All [b] - (-> (-> a b) b))) - -## Syntax -(defmacro #export (... tokens state) - (case tokens - (\ (list value)) - (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) - - _ - (#;Left "Wrong syntax for ..."))) - -## Functions -(def #export (! thunk) - (All [a] - (-> (Lazy a) a)) - (thunk id)) - -## Structs -(defstruct #export Lazy/Functor (Functor Lazy) - (def (F;map f ma) - (lambda [k] (ma (. k f))))) - -(defstruct #export Lazy/Monad (Monad Lazy) - (def M;_functor Lazy/Functor) - - (def (M;wrap a) - (... a)) - - (def M;join !)) diff --git a/source/lux/control/number.lux b/source/lux/control/number.lux new file mode 100644 index 000000000..40906a8a8 --- /dev/null +++ b/source/lux/control/number.lux @@ -0,0 +1,28 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m) + (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## [Signatures] +(defsig #export (Number n) + (do-template [] + [(: (-> n n n) )] + [+] [-] [*] [/] [%]) + + (do-template [] + [(: (-> n n) )] + [negate] [signum] [abs]) + + (: (-> Int n) + from-int) + ) diff --git a/source/lux/control/ord.lux b/source/lux/control/ord.lux new file mode 100644 index 000000000..80f2e4fb5 --- /dev/null +++ b/source/lux/control/ord.lux @@ -0,0 +1,44 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../eq #as E)) + +## [Signatures] +(defsig #export (Ord a) + (: (E;Eq a) + _eq) + (do-template [] + [(: (-> a a Bool) )] + + [<] [<=] [>] [>=])) + +## [Constructors] +(def #export (ord$ eq < >) + (All [a] + (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) + (struct + (def _eq eq) + (def < <) + (def (<= x y) + (or (< x y) + (:: eq (E;= x y)))) + (def > >) + (def (>= x y) + (or (> x y) + (:: eq (E;= x y)))))) + +## [Functions] +(do-template [ ] + [(def #export ( ord x y) + (All [a] + (-> (Ord a) a a a)) + (if (:: ord ( x y)) x y))] + + [max ;;>] + [min ;;<]) diff --git a/source/lux/control/show.lux b/source/lux/control/show.lux new file mode 100644 index 000000000..f4e1cf762 --- /dev/null +++ b/source/lux/control/show.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Show a) + (: (-> a Text) + show)) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index d4f223612..5f4427a2c 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -7,9 +7,9 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m)) - (.. (eq #as E) - (show #as S))) + (lux/control (monoid #as m) + (eq #as E) + (show #as S))) ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) diff --git a/source/lux/data/bounded.lux b/source/lux/data/bounded.lux deleted file mode 100644 index 9d2dabde1..000000000 --- a/source/lux/data/bounded.lux +++ /dev/null @@ -1,17 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Bounded a) - (: a - top) - - (: a - bottom)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 5a811c006..b97ec644d 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -7,9 +7,9 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (.. (eq #as E) - (show #as S) - (text #as T #open ("text:" Text/Monoid)))) + (lux/control (eq #as E) + (show #as S)) + (.. (text #as T #open ("text:" Text/Monoid)))) ## [Structures] (defstruct #export Char/Eq (E;Eq Char) diff --git a/source/lux/data/cont.lux b/source/lux/data/cont.lux new file mode 100644 index 000000000..51c6ece87 --- /dev/null +++ b/source/lux/data/cont.lux @@ -0,0 +1,41 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Cont r a) + (-> (-> a r) r)) + +## [Structures] +(defstruct #export Cont/Functor (All [r] + (Functor (Cont r))) + (def (F;map f fa) + (lambda [k] + (k (fa f))))) + +(defstruct #export Cont/Monad (All [r] + (Monad (Cont r))) + (def M;_functor Cont/Functor) + + (def (M;wrap x) + (lambda [k] + (k x))) + + (def (M;join mma) + (lambda [k] + (mma (lambda [ma] (ma k)))))) + +## [Functions] +(def #export (call/cc body) + (All [r a b] + (-> (-> (-> a (Cont r b)) (Cont r a)) (Cont r a))) + (lambda [k] + (body k))) diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux deleted file mode 100644 index 63a66d49b..000000000 --- a/source/lux/data/dict.lux +++ /dev/null @@ -1,83 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/data (eq #as E))) - -## Signatures -(defsig #export (Dict d) - (: (All [k v] - (-> k (d k v) (Maybe v))) - get) - (: (All [k v] - (-> k v (d k v) (d k v))) - put) - (: (All [k v] - (-> k (d k v) (d k v))) - remove)) - -## Types -(deftype #export (PList k v) - (| (#PList (, (E;Eq k) (List (, k v)))))) - -## Constructors -(def #export (plist eq) - (All [k v] - (-> (E;Eq k) (PList k v))) - (#PList [eq #;Nil])) - -## Utils -(def (pl-get eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (Maybe v))) - (case kvs - #;Nil - #;None - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Some v') - (pl-get eq k kvs')))) - -(def (pl-put eq k v kvs) - (All [k v] - (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - (#;Cons [[k v] kvs]) - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Cons [[k v] kvs']) - (#;Cons [[k' v'] (pl-put eq k v kvs')])))) - -(def (pl-remove eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (pl-remove eq k kvs')])))) - -## Structs -(defstruct #export PList/Dict (Dict PList) - (def (get k plist) - (let [(#PList [eq kvs]) plist] - (pl-get eq k kvs))) - - (def (put k v plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-put eq k v kvs)]))) - - (def (remove k plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-remove eq k kvs)])))) diff --git a/source/lux/data/eq.lux b/source/lux/data/eq.lux deleted file mode 100644 index be3400208..000000000 --- a/source/lux/data/eq.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## [Signatures] -(defsig #export (Eq a) - (: (-> a a Bool) - =)) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 0e3bdbee6..3ad6b056b 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -8,7 +8,8 @@ (;import lux (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) + (monad #as M #refer #all) + (comonad #as CM #refer #all))) ## [Types] (deftype #export (Id a) @@ -23,6 +24,9 @@ (defstruct #export Id/Monad (Monad Id) (def M;_functor Id/Functor) (def (M;wrap a) (#Id a)) - (def (M;join mma) - (let [(#Id ma) mma] - ma))) + (def (M;join mma) (let [(#Id ma) mma] ma))) + +(defstruct #export Id/CoMonad (CoMonad Id) + (def CM;_functor Id/Functor) + (def (CM;unwrap wa) (let [(#Id a) wa] a)) + (def (CM;split wa) (#Id wa))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 8fd5c2951..8d6296b14 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -7,17 +7,66 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all)) - lux/meta/macro) + (lux (control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all) + (eq #as E) + (dict #as D #refer #all)) + (data/number (int #open ("i" Int/Number Int/Ord Int/Eq))) + meta/macro)) ## Types ## (deftype (List a) ## (| #Nil ## (#Cons (, a (List a))))) -## Functions +(deftype #export (PList k v) + (| (#PList (, (E;Eq k) (List (, k v)))))) + +## [Utils] +(def (pl-get eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (Maybe v))) + (case kvs + #;Nil + #;None + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Some v') + (pl-get eq k kvs')))) + +(def (pl-put eq k v kvs) + (All [k v] + (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + (#;Cons [[k v] kvs]) + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Cons [[k v] kvs']) + (#;Cons [[k' v'] (pl-put eq k v kvs')])))) + +(def (pl-remove eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (pl-remove eq k kvs')])))) + +## [Constructors] +(def #export (plist eq) + (All [k v] + (-> (E;Eq k) (PList k v))) + (#PList [eq #;Nil])) + +## [Functions] (def #export (foldL f init xs) (All [a b] (-> (-> a b a) a (List b) a)) @@ -38,6 +87,12 @@ (#;Cons [x xs']) (f x (foldR f init xs')))) +(def #export (fold mon xs) + (All [a] + (-> (m;Monoid a) (List a) a)) + (using mon + (foldL ++ unit xs))) + (def #export (reverse xs) (All [a] (-> (List a) (List a))) @@ -83,8 +138,8 @@ ) ))] - [take (#;Cons [x (take (dec n) xs')]) #;Nil] - [drop (drop (dec n) xs') xs] + [take (#;Cons [x (take (i+ -1 n) xs')]) #;Nil] + [drop (drop (i+ -1 n) xs') xs] ) (do-template [ ] @@ -113,7 +168,7 @@ [#;Nil #;Nil] (#;Cons [x xs']) - (let [[tail rest] (split (dec n) xs')] + (let [[tail rest] (split (i+ -1 n) xs')] [(#;Cons [x tail]) rest])) [#;Nil xs])) @@ -139,7 +194,7 @@ (All [a] (-> Int a (List a))) (if (i> n 0) - (#;Cons [x (repeat (dec n) x)]) + (#;Cons [x (repeat (i+ -1 n) x)]) #;Nil)) (def #export (iterate f x) @@ -203,7 +258,7 @@ (#;Cons [x xs']) (if (i= 0 i) (#;Some x) - (@ (dec i) xs')))) + (@ (i+ -1 i) xs')))) ## Syntax (defmacro #export (list xs state) @@ -225,6 +280,17 @@ (#;Left "Wrong syntax for list&"))) ## Structures +## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) +## (def (E;= xs ys) +## (case [xs ys] +## [#;Nil #;Nil] +## true + +## [(#;Cons [x xs']) (#;Cons [y ys'])] +## (and (:: eq (E;= x y)) +## (E;= xs' ys')) +## ))) + (defstruct #export List/Monoid (All [a] (Monoid (List a))) (def m;unit #;Nil) @@ -248,3 +314,16 @@ (def (M;join mma) (using List/Monoid (foldL ++ unit mma)))) + +(defstruct #export PList/Dict (Dict PList) + (def (D;get k plist) + (let [(#PList [eq kvs]) plist] + (pl-get eq k kvs))) + + (def (D;put k v plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-put eq k v kvs)]))) + + (def (D;remove k plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-remove eq k kvs)])))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index faec53c2e..396ec470a 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -7,9 +7,12 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m #refer #all) - (functor #as F #refer #all) - (monad #as M #refer #all))) + (.. list) + (lux (control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)) + (meta lux + syntax))) ## [Types] ## (deftype (Maybe a) @@ -40,3 +43,14 @@ (case mma #;None #;None (#;Some xs) xs))) + +## [Syntax] +(defsyntax #export (? maybe else) + (do Lux/Monad + [g!value (gensym "")] + (M;wrap (list (` (case (~ maybe) + (#;Some (~ g!value)) + (~ g!value) + + _ + (~ else))))))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux deleted file mode 100644 index 8771ef06e..000000000 --- a/source/lux/data/number.lux +++ /dev/null @@ -1,113 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (monoid #as m)) - (.. (eq #as E) - (ord #as O) - (bounded #as B) - (show #as S))) - -## Signatures -(defsig #export (Number n) - (do-template [] - [(: (-> n n n) )] - [+] [-] [*] [/] [%]) - - (: (-> Int n) - from-int) - - (do-template [] - [(: (-> n n) )] - [negate] [signum] [abs]) - ) - -## [Structures] -## Number -(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] - [(defstruct #export (Number ) - (def + <+>) - (def - <->) - (def * <*>) - (def / ) - (def % <%>) - (def (from-int x) - ( x)) - (def (negate x) - (<*> <-1> x)) - (def (abs x) - (if (<<> x <0>) - (<*> <-1> x) - x)) - (def (signum x) - (cond (<=> x <0>) <0> - (<<> x <0>) <-1> - ## else - <1>)) - )] - - [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] - [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) - -## Eq -(defstruct #export Int/Eq (E;Eq Int) - (def E;= i=)) - -(defstruct #export Real/Eq (E;Eq Real) - (def E;= r=)) - -## Ord -(do-template [ ] - [(defstruct #export (O;Ord ) - (def O;_eq ) - (def O;< ) - (def (O;<= x y) - (or ( x y) - (:: (E;= x y)))) - (def O;> ) - (def (O;>= x y) - (or ( x y) - (:: (E;= x y)))))] - - [ Int/Ord Int Int/Eq i< i>] - [Real/Ord Real Real/Eq r< r>]) - -## Bounded -(do-template [ ] - [(defstruct #export (B;Bounded ) - (def B;top ) - (def B;bottom ))] - - [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")] - [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) - -## Monoid -(do-template [ <++>] - [(defstruct #export (m;Monoid ) - (def m;unit ) - (def m;++ <++>))] - - [ IntAdd/Monoid Int 0 i+] - [ IntMul/Monoid Int 1 i*] - [RealAdd/Monoid Real 0.0 r+] - [RealMul/Monoid Real 1.0 r*] - [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] - [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] - ) - -## Show -(do-template [ ] - [(defstruct #export (S;Show ) - (def (S;show x) - ))] - - [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] - ) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux new file mode 100644 index 000000000..35c8d34bf --- /dev/null +++ b/source/lux/data/number/int.lux @@ -0,0 +1,89 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (number #as N) + (monoid #as m) + (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## [Structures] +## Number +(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] + [(defstruct #export (N;Number ) + (def (N;+ x y) (<+> x y)) + (def (N;- x y) (<-> x y)) + (def (N;* x y) (<*> x y)) + (def (N;/ x y) ( x y)) + (def (N;% x y) (<%> x y)) + (def (N;from-int x) + ( x)) + (def (N;negate x) + (<*> <-1> x)) + (def (N;abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (N;signum x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [ Int/Number Int _jvm_ladd _jvm_lsub _jvm_lmul _jvm_ldiv _jvm_lrem _jvm_leq _jvm_llt id 0 1 -1]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def (E;= x y) (_jvm_leq x y))) + +## Ord +(do-template [ <=> ] + [(defstruct #export (O;Ord ) + (def O;_eq ) + (def (O;< x y) ( x y)) + (def (O;<= x y) + (or ( x y) + (<=> x y))) + (def (O;> x y) ( x y)) + (def (O;>= x y) + (or ( x y) + (<=> x y))))] + + [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) + +## Bounded +(do-template [ ] + [(defstruct #export (B;Bounded ) + (def B;top ) + (def B;bottom ))] + + [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) + +## Monoid +(do-template [ <++>] + [(defstruct #export (m;Monoid ) + (def m;unit ) + (def (m;++ x y) (<++> x y)))] + + [ IntAdd/Monoid Int 0 _jvm_ladd] + [ IntMul/Monoid Int 1 _jvm_lmul] + [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] + ) + +## Show +(do-template [ ] + [(defstruct #export (S;Show ) + (def (S;show x) + ))] + + [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] + ) diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux new file mode 100644 index 000000000..4f9e4fa5f --- /dev/null +++ b/source/lux/data/number/real.lux @@ -0,0 +1,89 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (number #as N) + (monoid #as m) + (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## [Structures] +## Number +(do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] + [(defstruct #export (N;Number ) + (def (N;+ x y) (<+> x y)) + (def (N;- x y) (<-> x y)) + (def (N;* x y) (<*> x y)) + (def (N;/ x y) ( x y)) + (def (N;% x y) (<%> x y)) + (def (N;from-int x) + ( x)) + (def (N;negate x) + (<*> <-1> x)) + (def (N;abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (N;signum x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [Real/Number Real _jvm_dadd _jvm_dsub _jvm_dmul _jvm_ddiv _jvm_drem _jvm_deq _jvm_dlt _jvm_l2d 0.0 1.0 -1.0]) + +## Eq +(defstruct #export Real/Eq (E;Eq Real) + (def (E;= x y) (_jvm_deq x y))) + +## Ord +(do-template [ <=> ] + [(defstruct #export (O;Ord ) + (def O;_eq ) + (def (O;< x y) ( x y)) + (def (O;<= x y) + (or ( x y) + (<=> x y))) + (def (O;> x y) ( x y)) + (def (O;>= x y) + (or ( x y) + (<=> x y))))] + + [Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt]) + +## Bounded +(do-template [ ] + [(defstruct #export (B;Bounded ) + (def B;top ) + (def B;bottom ))] + + [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) + +## Monoid +(do-template [ <++>] + [(defstruct #export (m;Monoid ) + (def m;unit ) + (def (m;++ x y) (<++> x y)))] + + [RealAdd/Monoid Real 0.0 _jvm_dadd] + [RealMul/Monoid Real 1.0 _jvm_dmul] + [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] + ) + +## Show +(do-template [ ] + [(defstruct #export (S;Show ) + (def (S;show x) + ))] + + [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] + ) diff --git a/source/lux/data/ord.lux b/source/lux/data/ord.lux deleted file mode 100644 index 80f2e4fb5..000000000 --- a/source/lux/data/ord.lux +++ /dev/null @@ -1,44 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (../eq #as E)) - -## [Signatures] -(defsig #export (Ord a) - (: (E;Eq a) - _eq) - (do-template [] - [(: (-> a a Bool) )] - - [<] [<=] [>] [>=])) - -## [Constructors] -(def #export (ord$ eq < >) - (All [a] - (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) - (struct - (def _eq eq) - (def < <) - (def (<= x y) - (or (< x y) - (:: eq (E;= x y)))) - (def > >) - (def (>= x y) - (or (> x y) - (:: eq (E;= x y)))))) - -## [Functions] -(do-template [ ] - [(def #export ( ord x y) - (All [a] - (-> (Ord a) a a a)) - (if (:: ord ( x y)) x y))] - - [max ;;>] - [min ;;<]) diff --git a/source/lux/data/reader.lux b/source/lux/data/reader.lux deleted file mode 100644 index e91687c3a..000000000 --- a/source/lux/data/reader.lux +++ /dev/null @@ -1,33 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import (lux #refer (#exclude Reader)) - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Reader r a) - (-> r a)) - -## [Structures] -(defstruct #export Reader/Functor (All [r] - (Functor (Reader r))) - (def (F;map f fa) - (lambda [env] - (f (fa env))))) - -(defstruct #export Reader/Monad (All [r] - (Monad (Reader r))) - (def M;_functor Reader/Functor) - - (def (M;wrap x) - (lambda [env] x)) - - (def (M;join mma) - (lambda [env] - (mma env env)))) diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux deleted file mode 100644 index f4e1cf762..000000000 --- a/source/lux/data/show.lux +++ /dev/null @@ -1,14 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux) - -## Signatures -(defsig #export (Show a) - (: (-> a Text) - show)) diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux deleted file mode 100644 index bc9858a29..000000000 --- a/source/lux/data/state.lux +++ /dev/null @@ -1,35 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (State s a) - (-> s (, s a))) - -## [Structures] -(defstruct #export State/Functor (Functor State) - (def (F;map f ma) - (lambda [state] - (let [[state' a] (ma state)] - [state' (f a)])))) - -(defstruct #export State/Monad (All [s] - (Monad (State s))) - (def M;_functor State/Functor) - - (def (M;wrap x) - (lambda [state] - [state x])) - - (def (M;join mma) - (lambda [state] - (let [[state' ma] (mma state)] - (ma state'))))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 6ad9cfd63..c3cb1ecfb 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -7,10 +7,11 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m)) - (lux/data (eq #as E) - (ord #as O) - (show #as S))) + (lux (control (monoid #as m) + (eq #as E) + (ord #as O) + (show #as S)) + (data/number (int #open ("i" Int/Number Int/Ord Int/Eq))))) ## [Functions] (def #export (size x) diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux new file mode 100644 index 000000000..5220ad4ac --- /dev/null +++ b/source/lux/data/tuple.lux @@ -0,0 +1,39 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Functions] +(do-template [ ] + [(def #export ( xy) + (All [a b] (-> (, a b) )) + (let [[x y] xy] + ))] + + [first a x] + [second b y]) + +(def #export (curry f) + (All [a b c] + (-> (-> (, a b) c) + (-> a b c))) + (lambda [x y] + (f [x y]))) + +(def #export (uncurry f) + (All [a b c] + (-> (-> a b c) + (-> (, a b) c))) + (lambda [xy] + (let [[x y] xy] + (f x y)))) + +(def #export (swap xy) + (All [a b] (-> (, a b) (, b a))) + (let [[x y] xy] + [y x])) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 7af043969..2c90b1ba3 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -11,7 +11,8 @@ (functor #as F) (monad #as M #refer (#only do))) (data (list #as l #refer #all #open ("" List/Functor)) - (text #as text)) + (text #as text) + (number (int #open ("i" Int/Eq)))) (meta lux macro syntax))) @@ -236,3 +237,16 @@ (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ m-classes))] [(~@ m-args)])))))) + +(defsyntax #export (->maybe expr) + (do Lux/Monad + [g!val (gensym "")] + (emit (list (` (;let [(~ g!val) (~ expr)] + (;if (null? (~ g!val)) + #;None + (#;Some (~ g!val))))))))) + +(defsyntax #export (try$ expr) + (emit (list (` (try (#;Right (~ expr)) + (~ (' (catch java.lang.Exception e + (#;Left (.! (getMessage [] []) e)))))))))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 19b7dd9df..13dcae284 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -10,12 +10,11 @@ (.. macro) (lux/control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do))) + (monad #as M #refer (#only do)) + (show #as S)) (lux/data list - maybe - (show #as S) - (number #as N) - (text #as T #open ("text:" Text/Monoid Text/Eq)))) + (text #as T #open ("text:" Text/Monoid Text/Eq)) + (number/int #as I #open ("i" Int/Number)))) ## [Types] ## (deftype (Lux a) @@ -77,20 +76,27 @@ (def (find-macro' modules current-module module name) (-> (List (, Text (Module Compiler))) Text Text Text (Maybe Macro)) - (do Maybe/Monad - [$module (get module modules) - gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] - (case (: (, Bool (DefData' Macro)) gdef) - [exported? (#;MacroD macro')] - (if (or exported? (text:= module current-module)) - (#;Some macro') + (case (get module modules) + (#;Some $module) + (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name)) + (#;Some gdef) + (case (: (, Bool (DefData' Macro)) gdef) + [exported? (#;MacroD macro')] + (if (or exported? (text:= module current-module)) + (#;Some macro') + #;None) + + [_ (#;AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ #;None) - - [_ (#;AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) _ - #;None))) + #;None) + + _ + #;None)) (def #export (find-macro ident) (-> Ident (Lux (Maybe Macro))) @@ -147,8 +153,8 @@ (def #export (gensym prefix state) (-> Text (Lux Syntax)) - (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) + (#;Right [(update@ #;seed (i+ 1) state) + (symbol$ ["__gensym__" (:: I;Int/Show (S;show (get@ #;seed state)))])])) (def #export (emit datum) (All [a] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 63ab81475..972999fcb 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -10,12 +10,14 @@ (.. (macro #as m #refer #all) (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) - (monad #as M #refer (#only do))) - (data (eq #as E) - (bool #as b) + (monad #as M #refer (#only do)) + (eq #as E)) + (data (bool #as b) (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) - list))) + list + (number (int #open ("i" Int/Eq)) + (real #open ("r" Real/Eq)))))) ## [Utils] (def (first xy) diff --git a/source/program.lux b/source/program.lux index 086506725..b9f737480 100644 --- a/source/program.lux +++ b/source/program.lux @@ -7,31 +7,34 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (codata (stream #as S)) - (control monoid + (lux (control monoid functor monad - lazy - comonad) + comonad + bounded + dict + eq + ord + show + number) (data bool - bounded char - ## cont - dict (either #as e) - eq error id io list maybe - number - ord - (reader #as r) - show - state + (number int + real) (text #as t #open ("text:" Text/Monoid)) - writer) + writer + tuple) + (codata (stream #as S) + lazy + function + (reader #as r) + state) (host jvm) (meta lux macro diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 3449900e0..b88bb9c0a 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -29,7 +29,8 @@ [host :as &&host] [case :as &&case] [lambda :as &&lambda] - [package :as &&package])) + [package :as &&package] + [io :as &&io])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -372,54 +373,55 @@ (defn ^:private compile-module [name] ;; (prn 'compile-module name (&&cache/cached? name)) - (let [file-name (str &&/input-dir "/" name ".lux") - file-content (slurp file-name) - file-hash (hash file-content)] - (if (&&cache/cached? name) - (&&cache/load name file-hash compile-module) - (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] - (&/map% compile-statement analysis+))] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) - :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) - .visitEnd)) - ;; _ (prn 'compile-module name =class) - ]] - (fn [state] - (matchv ::M/objects [((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] - [["lux;Right" [?state _]]] - (&/run-state (|do [defs &a-module/defs - imports &a-module/imports - :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil - (->> defs - (&/|map (fn [_def] - (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") - (&/fold str ""))) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) - .visitEnd) - (.visitEnd)) - ;; _ (prn 'CLOSED name =class) - ]] - (&&/save-class! "_" (.toByteArray =class))) - ?state) - - [["lux;Left" ?message]] - (fail* ?message))))))) - ))) + (let [file-name (str &&/input-dir "/" name ".lux")] + (|do [file-content (&&io/read-file file-name) + :let [file-hash (hash file-content)]] + (if (&&cache/cached? name) + (&&cache/load name file-hash compile-module) + (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] + (&/map% compile-statement analysis+))] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (fail "[Compiler Error] Can't redefine a module!") + (|do [_ (&a-module/enter-module name) + :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + .visitEnd)) + ;; _ (prn 'compile-module name =class) + ]] + (fn [state] + (matchv ::M/objects [((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] + [["lux;Right" [?state _]]] + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported "1" "0") " " ?name " " ?ann)))) + (&/|interpose "\t") + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil + (->> imports (&/|interpose "\t") (&/fold str ""))) + .visitEnd) + (.visitEnd)) + ;; _ (prn 'CLOSED name =class) + ]] + (&&/save-class! "_" (.toByteArray =class))) + ?state) + + [["lux;Left" ?message]] + (fail* ?message))))))) + )) + )) (defn ^:private init! [] (.mkdirs (java.io.File. &&/output-dir))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index c0d978146..45513d0a5 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -17,7 +17,8 @@ [host :as &host]) (lux.analyser [base :as &a] [module :as &a-module]) - (lux.compiler [base :as &&])) + (lux.compiler [base :as &&] + [io :as &&io])) (:import (java.io File BufferedOutputStream FileOutputStream) @@ -74,65 +75,66 @@ (return false))]] (do ;; (prn 'load module 'sources already-loaded? ;; (&/->seq _modules)) - (if already-loaded? - (return true) - (if (cached? module) - (do ;; (prn 'load/HASH module module-hash) - (let [module* (&host/->module-class module) - module-path (str &&/output-dir "/" module*) - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= &&/version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") - ;; _ (prn 'load/IMPORTS module imports) - ] - (|do [loads (&/map% (fn [_import] - (load _import (-> (str &&/input-dir "/" _import ".lux") slurp hash) compile-module)) - (if (= [""] imports) - (&/|list) - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load module real-name) - ] - (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] - ;; (prn 'load module defs) - (|do [_ (&a-module/enter-module module) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module _name)) - "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) + (if already-loaded? + (return true) + (if (cached? module) + (do ;; (prn 'load/HASH module module-hash) + (let [module* (&host/->module-class module) + module-path (str &&/output-dir "/" module*) + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name))] + (if (and (= module-hash (get-field "_hash" module-meta)) + (= &&/version (get-field "_compiler" module-meta))) + (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + ;; _ (prn 'load/IMPORTS module imports) + ] + (|do [loads (&/map% (fn [_import] + (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux"))] + (load _import (hash content) compile-module))) + (if (= [""] imports) (&/|list) - (&/->list defs)))] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache))))) + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file) + ;; _ (prn 'load module real-name) + ] + (swap! !classes assoc (str module* "." real-name) bytecode))) + (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + ;; (prn 'load module defs) + (|do [_ (&a-module/enter-module module) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ") + ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) + ] + (|do [_ (case _ann + "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) + "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] + (&a-module/declare-macro module _name)) + "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) + def-type (get-field "_meta" def-class)] + (matchv ::M/objects [def-type] + [["lux;ValueD" _def-type]] + (&a-module/define module _name def-type _def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (do ;; (prn '__type [__module __name] (&type/show-type __type)) + (&a-module/def-alias module _name __module __name __type)))))] + (if (= "1" _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + (&/|list) + (&/->list defs)))] + (return true)))) + redo-cache))) + redo-cache) + )) + redo-cache))))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 346b66fd2..542bd9a40 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -88,11 +88,11 @@ (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) @@ -191,9 +191,9 @@ compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" - compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I" - compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I" - compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I" + compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()D" ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj new file mode 100644 index 000000000..176b4340d --- /dev/null +++ b/src/lux/compiler/io.clj @@ -0,0 +1,18 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.io + (:require (lux [base :as & :refer [|let |do return* return fail fail*]]) + )) + +;; [Resources] +(defn read-file [path] + (let [file (new java.io.File path)] + (if (.exists file) + (return (slurp file)) + (fail (str "[I/O] File doesn't exist: " path))))) -- cgit v1.2.3 From bcf0cb737e348dc9e183b1608abbebc5a40ba847 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 2 Aug 2015 22:38:43 -0400 Subject: - Added a module for hashing. - Refactored the standard library a bit. - Implemented the "loop" macro. - Added the expected type of expressions as a field in the compiler state. - Added syntactic sugar for using tuples with variants, in order to minimize the usage of brackets to delimit the contents of data-structures. - Fixed a bug wherein "macro-expand" was behaving like "macro-expand-all", and added a separate implementation for "macro-expand-all". - Fixed a few bugs. --- source/lux.lux | 561 +++++++++++++++++++++++++---------------- source/lux/codata/function.lux | 4 + source/lux/codata/stream.lux | 3 +- source/lux/control/hash.lux | 14 + source/lux/data/bool.lux | 12 +- source/lux/data/list.lux | 83 +++--- source/lux/meta/lux.lux | 34 ++- source/program.lux | 1 + src/lux/analyser.clj | 103 ++++---- src/lux/analyser/case.clj | 17 +- src/lux/analyser/lux.clj | 39 ++- src/lux/base.clj | 30 ++- src/lux/compiler/io.clj | 2 +- src/lux/type.clj | 4 +- 14 files changed, 552 insertions(+), 355 deletions(-) create mode 100644 source/lux/control/hash.lux diff --git a/source/lux.lux b/source/lux.lux index dc186fb3d..3670a9e52 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -32,29 +32,29 @@ (_lux_def Void (#VariantT #Nil)) (_lux_export Void) -(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_def Ident (#TupleT (#Cons Text (#Cons Text #Nil)))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil -## (#Cons (, a (List a))))) +## (#Cons a (List a)))) (_lux_def List - (#AllT [(#Some #Nil) "lux;List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) + (#AllT (#Some #Nil) "lux;List" "a" + (#VariantT (#Cons ["lux;Nil" (#TupleT #Nil)] + (#Cons ["lux;Cons" (#TupleT (#Cons (#BoundT "a") + (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a")) + #Nil)))] + #Nil))))) (_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT [(#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) + (#AllT (#Some #Nil) "lux;Maybe" "a" + (#VariantT (#Cons ["lux;None" (#TupleT #Nil)] + (#Cons ["lux;Some" (#BoundT "a")] + #Nil))))) (_lux_export Maybe) ## (deftype #rec Type @@ -62,29 +62,29 @@ ## (#TupleT (List Type)) ## (#VariantT (List (, Text Type))) ## (#RecordT (List (, Text Type))) -## (#LambdaT (, Type Type)) +## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) -## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) -## (#AppT (, Type Type)))) +## (#AllT (Maybe (List (, Text Type))) Text Text Type) +## (#AppT Type Type))) (_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + (_lux_case (#AppT (#BoundT "Type") (#BoundT "_")) Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil)))) TypeEnv - (#AppT [(#AllT [(#Some #Nil) "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) + (#AppT (#AllT (#Some #Nil) "Type" "_" + (#VariantT (#Cons ["lux;DataT" Text] + (#Cons ["lux;TupleT" (#AppT List Type)] + (#Cons ["lux;VariantT" TypeEnv] + (#Cons ["lux;RecordT" TypeEnv] + (#Cons ["lux;LambdaT" (#TupleT (#Cons Type (#Cons Type #Nil)))] + (#Cons ["lux;BoundT" Text] + (#Cons ["lux;VarT" Int] + (#Cons ["lux;AllT" (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil)))))] + (#Cons ["lux;AppT" (#TupleT (#Cons Type (#Cons Type #Nil)))] + (#Cons ["lux;ExT" Int] + #Nil)))))))))))) + Void)))) (_lux_export Type) ## (deftype (Bindings k v) @@ -125,7 +125,7 @@ (_lux_export Cursor) ## (deftype (Meta m v) -## (| (#Meta (, m v)))) +## (| (#Meta m v))) (_lux_def Meta (#AllT [(#Some #Nil) "lux;Meta" "m" (#AllT [#None "" "v" @@ -141,8 +141,8 @@ ## (#RealS Real) ## (#CharS Char) ## (#TextS Text) -## (#SymbolS (, Text Text)) -## (#TagS (, Text Text)) +## (#SymbolS Text Text) +## (#TagS Text Text) ## (#FormS (List (w (Syntax' w)))) ## (#TupleS (List (w (Syntax' w)))) ## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) @@ -267,7 +267,8 @@ ## #types (Bindings Int Type) ## #host HostState ## #seed Int -## #eval? Bool)) +## #eval? Bool +## #expected Type)) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] @@ -280,7 +281,8 @@ (#Cons [["lux;host" HostState] (#Cons [["lux;seed" Int] (#Cons [["lux;eval?" Bool] - #Nil])])])])])])]))]) + (#Cons [["lux;expected" Type] + #Nil])])])])])])])]))]) Void])) (_lux_export Compiler) @@ -348,6 +350,11 @@ (_lux_lambda _ text (_meta (#TextS text))))) +(_lux_def int$ + (_lux_: (#LambdaT [Int Syntax]) + (_lux_lambda _ value + (_meta (#IntS value))))) + (_lux_def symbol$ (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident @@ -1039,6 +1046,15 @@ (f (g x)))) (def''' (get-ident x) + (-> Syntax ($' Maybe Ident)) + (_lux_case x + (#Meta [_ (#SymbolS sname)]) + (#Some sname) + + _ + #None)) + +(def''' (get-name x) (-> Syntax ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) @@ -1127,7 +1143,7 @@ (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe/Monad get-ident bindings) + [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] (let' [apply (_lux_: (-> RepEnv ($' List Syntax)) @@ -1245,7 +1261,7 @@ ["" tokens]))] (_lux_case tokens' (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-ident args) + (_lux_case (map% Maybe/Monad get-name args) (#Some idents) (_lux_case idents #Nil @@ -1297,8 +1313,8 @@ ($' Lux Text) (_lux_case state {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected} (_lux_case (reverse envs) #Nil (#Left "Can't get the module name without a module!") @@ -1337,7 +1353,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (#Right [state (find-macro' modules current-module module name)])))))) (def''' (list:join xs) @@ -1367,11 +1383,16 @@ [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - + [ident (normalize ident) + #let [case-body (_lux_: Syntax + (_lux_case values + #Nil (`' Unit) + (#Cons value #Nil) value + _ (`' (, (~@ values)))))]] + (;return (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) + _ (fail "Wrong syntax for |")))) tokens)] @@ -1412,9 +1433,9 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def''' (macro-expand syntax) +(def''' (macro-expand token) (-> Syntax ($' Lux ($' List Syntax))) - (_lux_case syntax + (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad [macro-name' (normalize macro-name) @@ -1427,19 +1448,39 @@ (;return (list:join expansion'))) #None + (return (list token)))) + + _ + (return (list token)))) + +(def''' (macro-expand-all syntax) + (-> Syntax ($' Lux ($' List Syntax))) + (_lux_case syntax + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) (do Lux/Monad - [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + [expansion (macro args) + expansion' (map% Lux/Monad macro-expand-all expansion)] + (;return (list:join expansion'))) + + #None + (do Lux/Monad + [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (;return (list (form$ (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (map% Lux/Monad macro-expand targs)] + [harg+ (macro-expand-all harg) + targs+ (map% Lux/Monad macro-expand-all targs)] (;return (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) (do Lux/Monad - [members' (map% Lux/Monad macro-expand members)] + [members' (map% Lux/Monad macro-expand-all members)] (;return (list (tuple$ (list:join members'))))) _ @@ -1464,11 +1505,11 @@ (defmacro #export (type tokens) (_lux_case tokens - (#Cons [type #Nil]) + (#Cons type #Nil) (do Lux/Monad - [type+ (macro-expand type)] + [type+ (macro-expand-all type)] (_lux_case type+ - (#Cons [type' #Nil]) + (#Cons type' #Nil) (;return (list (walk-type type'))) _ @@ -1479,7 +1520,7 @@ (defmacro #export (: tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) + (#Cons type (#Cons value #Nil)) (return (list (`' (_lux_: (;type (~ type)) (~ value))))) _ @@ -1487,7 +1528,7 @@ (defmacro #export (:! tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) + (#Cons type (#Cons value #Nil)) (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) _ @@ -1502,30 +1543,30 @@ (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) [rec? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "rec")) tokens') [true tokens'] _ [false tokens'])) parts (: (Maybe (, Text (List Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) - (#Some [name #Nil type]) + (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) + (#Some name #Nil type) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) - (#Some [name args type]) + (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil)) + (#Some name args type) _ #None))] (_lux_case parts - (#Some [name args type]) + (#Some name args type) (let' [with-export (: (List Syntax) (if export? (list (`' (_lux_export (~ (symbol$ ["" name]))))) @@ -1570,12 +1611,12 @@ ## (#Some [(symbol$ name) #Nil type]) ## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) args type]) +## (#Some (symbol$ name) args type) ## _ ## #None))] ## (_lux_case parts -## (#Some [name args type]) +## (#Some name args type]) ## (let' [with-export (: (List Syntax) ## (if export? ## (list (`' (_lux_export (~ name)))) @@ -1596,7 +1637,7 @@ (defmacro #export (exec tokens) (_lux_case (reverse tokens) - (#Cons [value actions]) + (#Cons value actions) (let' [dummy (symbol$ ["" ""])] (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) value @@ -1608,29 +1649,29 @@ (defmacro (def' tokens) (let' [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) + (#Some name args (#Some type) body) - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) + (#Cons name (#Cons type (#Cons body #Nil))) + (#Some name #Nil (#Some type) body) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil)) + (#Some name args #None body) - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) + (#Cons name (#Cons body #Nil)) + (#Some name #Nil #None body) _ #None))] (_lux_case parts - (#Some [name args ?type body]) + (#Some name args ?type body) (let' [body' (: Syntax (_lux_case args #Nil @@ -1660,16 +1701,16 @@ (defmacro #export (case tokens) (_lux_case tokens - (#Cons [value branches]) + (#Cons value branches) (do Lux/Monad [expansions (map% Lux/Monad (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) (do Lux/Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + [expansion (macro-expand-all (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] (;return (list:join expansions))) @@ -1684,11 +1725,11 @@ (defmacro #export (\ tokens) (case tokens - (#Cons [body (#Cons [pattern #Nil])]) + (#Cons body (#Cons pattern #Nil)) (do Lux/Monad - [pattern+ (macro-expand pattern)] + [pattern+ (macro-expand-all pattern)] (case pattern+ - (#Cons [pattern' #Nil]) + (#Cons pattern' #Nil) (;return (list pattern' body)) _ @@ -1699,14 +1740,14 @@ (defmacro #export (\or tokens) (case tokens - (#Cons [body patterns]) + (#Cons body patterns) (case patterns #Nil (fail "\\or can't have 0 patterns") _ (do Lux/Monad - [patterns' (map% Lux/Monad macro-expand patterns)] + [patterns' (map% Lux/Monad macro-expand-all patterns)] (;return (list:join (map (lambda' [pattern] (list pattern body)) (list:join patterns')))))) @@ -1726,7 +1767,7 @@ (def' (symbol? ast) (-> Syntax Bool) (case ast - (#Meta [_ (#SymbolS _)]) + (#Meta _ (#SymbolS _)) true _ @@ -1734,7 +1775,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list (#Meta [_ (#TupleS bindings)]) body)) + (\ (list (#Meta _ (#TupleS bindings)) body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> Syntax (, Syntax Syntax) Syntax) @@ -1754,7 +1795,7 @@ (def' (ast:show ast) (-> Syntax Text) (case ast - (#Meta [_ ast]) + (#Meta _ ast) (case ast (\or (#BoolS val) (#IntS val) (#RealS val)) (->text val) @@ -1771,10 +1812,10 @@ (#TupleS parts) ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]") - (#SymbolS [prefix name]) + (#SymbolS prefix name) ($ text:++ prefix ";" name) - (#TagS [prefix name]) + (#TagS prefix name) ($ text:++ "#" prefix ";" name) (#RecordS kvs) @@ -1790,15 +1831,15 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident Syntax (List Syntax) Syntax)) (case tokens - (\ (list (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) - (#Some [["" ""] head tail body]) + (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) + (#Some ["" ""] head tail body) - (\ (list (#Meta [_ (#SymbolS ident)]) (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) - (#Some [ident head tail body]) + (\ (list (#Meta _ (#SymbolS ident)) (#Meta _ (#TupleS (#Cons head tail))) body)) + (#Some ident head tail body) _ #None)) - (#Some [ident head tail body]) + (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) body+ (: Syntax (foldL (: (-> Syntax Syntax Syntax) @@ -1819,29 +1860,29 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (case tokens' - (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) type body)) - (#Some [name args (#Some type) body]) + (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) + (#Some name args (#Some type) body) (\ (list name type body)) - (#Some [name #Nil (#Some type) body]) + (#Some name #Nil (#Some type) body) - (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) body)) - (#Some [name args #None body]) + (\ (list (#Meta _ (#FormS (#Cons name args))) body)) + (#Some name args #None body) (\ (list name body)) - (#Some [name #Nil #None body]) + (#Some name #Nil #None body) _ #None))] (case parts - (#Some [name args ?type body]) + (#Some name args ?type body) (let [body (: Syntax (case args #Nil @@ -1869,22 +1910,11 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [{#source source #modules modules - #envs envs #types types #host host - #seed (i+ 1 seed) #eval? eval?} - (symbol$ ["__gensym__" (->text seed)])]))) - -(def (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (list token')) - (;return token') - - _ - (fail "Macro expanded to more than 1 element.")))) + #seed seed #eval? eval? #expected expected} + (#Right {#source source #modules modules + #envs envs #types types #host host + #seed (i+ 1 seed) #eval? eval? #expected expected} + (symbol$ ["__gensym__" (->text seed)])))) (defmacro #export (sig tokens) (do Lux/Monad @@ -1893,7 +1923,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) (do Lux/Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1911,23 +1941,23 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) - (#Some [name args sigs]) + (\ (list& (#Meta _ (#FormS (list& name args))) sigs)) + (#Some name args sigs) (\ (list& name sigs)) - (#Some [name #Nil sigs]) + (#Some name #Nil sigs) _ #None))] (case ?parts - (#Some [name args sigs]) + (#Some name args sigs) (let [sigs' (: Syntax (case args #Nil @@ -1950,7 +1980,7 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS name)) value)))) (do Lux/Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [(tag$ name') value]))) @@ -1963,23 +1993,23 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) - (#Some [name args type defs]) + (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) + (#Some name args type defs) (\ (list& name type defs)) - (#Some [name #Nil type defs]) + (#Some name #Nil type defs) _ #None))] (case ?parts - (#Some [name args type defs]) + (#Some name args type defs) (let [defs' (: Syntax (case args #Nil @@ -2031,7 +2061,7 @@ (: (-> Syntax (Lux Text)) (lambda [def] (case def - (#Meta [_ (#SymbolS ["" name])]) + (#Meta _ (#SymbolS "" name)) (return name) _ @@ -2041,7 +2071,7 @@ (def (parse-alias tokens) (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) _ @@ -2050,17 +2080,17 @@ (def (parse-referrals tokens) (-> (List Syntax) (Lux (, Referrals (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) + (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) (case referral - (#Meta [_ (#TagS ["" "all"])]) + (#Meta _ (#TagS "" "all")) (return (: (, Referrals (List Syntax)) [#All tokens'])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) @@ -2074,7 +2104,7 @@ (def (extract-symbol syntax) (-> Syntax (Lux Ident)) (case syntax - (#Meta [_ (#SymbolS ident)]) + (#Meta _ (#SymbolS ident)) (return ident) _ @@ -2083,10 +2113,10 @@ (def (parse-openings tokens) (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) + (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] - (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) + (return (: (, (Maybe Openings) (List Syntax)) [(#Some prefix structs') tokens']))) _ (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) @@ -2097,10 +2127,10 @@ (: (-> Syntax (Lux Syntax)) (lambda [token] (case token - (#Meta [_ (#SymbolS ["" sub-name])]) + (#Meta _ (#SymbolS "" sub-name)) (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts)))) (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ @@ -2114,10 +2144,10 @@ (: (-> Syntax (Lux (List Import))) (lambda [token] (case token - (#Meta [_ (#SymbolS ["" m-name])]) + (#Meta _ (#SymbolS "" m-name)) (;return (list [m-name #None #All #None])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2141,13 +2171,13 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (case (get module modules) (#Some =module) - (#Right [state true]) + (#Right state true) #None - (#Right [state false])) + (#Right state false)) )) (def (exported-defs module state) @@ -2155,7 +2185,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (case (get module modules) (#Some =module) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) @@ -2167,7 +2197,7 @@ (list))))) (let [{#module-aliases _ #defs defs #imports _} =module] defs))] - (#Right [state (list:join to-alias)])) + (#Right state (list:join to-alias))) #None (#Left ($ text:++ "Unknown module: " module))) @@ -2195,18 +2225,18 @@ (def (split-module-contexts module) (-> Text (List Text)) - (#Cons [module (let [idx (last-index-of "/" module)] - (if (i< idx 0) - #Nil - (split-module-contexts (substring2 0 idx module))))])) + (#Cons module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module)))))) (def (split-module module) (-> Text (List Text)) (let [idx (index-of "/" module)] (if (i< idx 0) - (#Cons [module #Nil]) - (#Cons [(substring2 0 idx module) - (split-module (substring1 (i+ 1 idx) module))])))) + (#Cons module #Nil) + (#Cons (substring2 0 idx module) + (split-module (substring1 (i+ 1 idx) module)))))) (def (@ idx xs) (All [a] @@ -2215,7 +2245,7 @@ #Nil #None - (#Cons [x xs']) + (#Cons x xs') (if (i= idx 0) (#Some x) (@ (i- idx 1) xs') @@ -2228,7 +2258,7 @@ #Nil [ys xs] - (#Cons [x xs']) + (#Cons x xs') (if (p x) (split-with' p (list& x ys) xs') [ys xs]))) @@ -2267,9 +2297,9 @@ #;Nil (list) - (#;Cons [x xs']) + (#;Cons x xs') (if (p x) - (#;Cons [x (filter p xs')]) + (#;Cons x (filter p xs')) (filter p xs')))) (def (is-member? cases name) @@ -2335,7 +2365,7 @@ #None (list) - (#Some [prefix structs]) + (#Some prefix structs) (map (: (-> Ident Syntax) (lambda [struct] (let [[_ name] struct] @@ -2367,7 +2397,7 @@ #Nil #None - (#Cons [x xs']) + (#Cons x xs') (case (f x) #None (some f xs') @@ -2433,7 +2463,7 @@ (foldL text:++ "")) ")")) - (#LambdaT [input output]) + (#LambdaT input output) ($ text:++ "(-> " (type:show input) " " (type:show output) ")") (#VarT id) @@ -2445,10 +2475,10 @@ (#ExT ?id) ($ text:++ "⟨" (->text ?id) "⟩") - (#AppT [?lambda ?param]) + (#AppT ?lambda ?param) ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - (#AllT [?env ?name ?arg ?body]) + (#AllT ?env ?name ?arg ?body) ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") )) @@ -2472,19 +2502,19 @@ (#TupleT ?members) (#TupleT (map (beta-reduce env) ?members)) - (#AppT [?type-fn ?type-arg]) - (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)]) + (#AppT ?type-fn ?type-arg) + (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - (#AllT [?local-env ?local-name ?local-arg ?local-def]) + (#AllT ?local-env ?local-name ?local-arg ?local-def) (case ?local-env #None - (#AllT [(#Some env) ?local-name ?local-arg ?local-def]) + (#AllT (#Some env) ?local-name ?local-arg ?local-def) (#Some _) type) - (#LambdaT [?input ?output]) - (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)]) + (#LambdaT ?input ?output) + (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) (#BoundT ?name) (case (get ?name env) @@ -2501,7 +2531,7 @@ (def (apply-type type-fn param) (-> Type Type (Maybe Type)) (case type-fn - (#AllT [env name arg body]) + (#AllT env name arg body) (#Some (beta-reduce (|> (case env (#Some env) env _ (list)) @@ -2509,7 +2539,7 @@ (put arg param)) body)) - (#AppT [F A]) + (#AppT F A) (do Maybe/Monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -2523,10 +2553,10 @@ (#RecordT slots) (#Some type) - (#AppT [fun arg]) + (#AppT fun arg) (apply-type fun arg) - (#AllT [_ _ _ body]) + (#AllT _ _ _ body) (resolve-struct-type body) _ @@ -2545,7 +2575,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -2579,7 +2609,7 @@ (let [[v-prefix v-name] name {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} state] + #seed seed #eval? eval? #expected expected} state] (case (get v-prefix modules) #None #None @@ -2589,7 +2619,7 @@ #None #None - (#Some [_ def-data]) + (#Some _ def-data) (case def-data #TypeD (#Some Type) (#ValueD type) (#Some type) @@ -2602,7 +2632,7 @@ ## (let [[v-prefix v-name] name ## {#source source #modules modules ## #envs envs #types types #host host -## #seed seed #eval? eval?} state] +## #seed seed #eval? eval? #expected expected} state] ## (do Maybe/Monad ## [module (get v-prefix modules) ## #let [{#defs defs #module-aliases _ #imports _} module] @@ -2621,24 +2651,32 @@ (lambda [state] (case (find-in-env name state) (#Some struct-type) - (#Right [state struct-type]) + (#Right state struct-type) _ (case (find-in-defs name' state) (#Some struct-type) - (#Right [state struct-type]) + (#Right state struct-type) _ (let [{#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} state] + #seed seed #eval? eval? #expected expected} state] (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) +(def expected-type + (Lux Type) + (lambda [state] + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected} state] + (#Right state expected)))) + (defmacro #export (using tokens) (case tokens (\ (list struct body)) (case struct - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [struct-type (find-var-type name)] (case (resolve-struct-type struct-type) @@ -2687,9 +2725,9 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) record)) + (\ (list (#Meta _ (#TagS slot')) record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name) g!blank (gensym "") @@ -2724,10 +2762,10 @@ (defmacro #export (open tokens) (case tokens - (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens')) + (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) (do Lux/Monad [#let [prefix (case tokens' - (\ (list (#Meta [_ (#TextS prefix)]))) + (\ (list (#Meta _ (#TextS prefix)))) prefix _ @@ -2754,7 +2792,7 @@ (-> (Monad m) (-> a b (m a)) a (List b) (m a))) (case ys - (#Cons [y ys']) + (#Cons y ys') (do M [x' (f x y)] (foldL% M f x' ys')) @@ -2770,10 +2808,10 @@ (: (-> Syntax Syntax (Lux Syntax)) (lambda [so-far part] (case part - (#Meta [_ (#SymbolS slot)]) + (#Meta _ (#SymbolS slot)) (return (` (get@ (~ (tag$ slot)) (~ so-far)))) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args)))) (return (` ((get@ (~ (tag$ slot)) (~ so-far)) (~@ args)))) @@ -2787,9 +2825,9 @@ (defmacro #export (set@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) value record)) + (\ (list (#Meta _ (#TagS slot')) value record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) @@ -2835,9 +2873,9 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) fun record)) + (\ (list (#Meta _ (#TagS slot')) fun record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) @@ -2883,12 +2921,12 @@ (defmacro #export (\template tokens) (case tokens - (\ (list (#Meta [_ (#TupleS data)]) - (#Meta [_ (#TupleS bindings)]) - (#Meta [_ (#TupleS templates)]))) + (\ (list (#Meta _ (#TupleS data)) + (#Meta _ (#TupleS bindings)) + (#Meta _ (#TupleS templates)))) (case (: (Maybe (List Syntax)) (do Maybe/Monad - [bindings' (map% Maybe/Monad get-ident bindings) + [bindings' (map% Maybe/Monad get-name bindings) data' (map% Maybe/Monad tuple->list data)] (let [apply (: (-> RepEnv (List Syntax)) (lambda [env] (map (apply-template env) templates)))] @@ -2904,28 +2942,109 @@ _ (fail "Wrong syntax for \\template"))) -(def #export complement - (All [a] (-> (-> a Bool) (-> a Bool))) - (. not)) - -## (defmacro #export (loop tokens) -## (case tokens -## (\ (list bindings body)) -## (let [pairs (as-pairs bindings) -## vars (map first pairs) -## inits (map second pairs)] -## (if (every? symbol? inits) -## (do Lux/Monad -## [inits' (map% Maybe/Monad get-ident inits) -## init-types (map% Maybe/Monad find-var-type inits')] -## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] -## (~ body)) -## (~@ inits)))))) -## (do Lux/Monad -## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] -## (return (list (` (let [(~@ (interleave aliases inits))] -## (loop [(~@ (interleave vars aliases))] -## (~ body))))))))) - -## _ -## (fail "Wrong syntax for loop"))) +(do-template [ ] + [(def ( [x y]) + (All [a b] (-> (, a b) )) + )] + + [first a x] + [second b y]) + +(def (interleave xs ys) + (All [a] (-> (List a) (List a) (List a))) + (case xs + #Nil + #Nil + + (#Cons x xs') + (case ys + #Nil + #Nil + + (#Cons y ys') + (list& x y (interleave xs' ys'))))) + +(do-template [ ] + [(def ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] ( _1 (p _2))) xs))] + + [every? true and]) + +(def (type->syntax type) + (-> Type Syntax) + (case type + (#DataT name) + (` (#DataT (~ (text$ name)))) + + (#TupleT parts) + (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) + + (#VariantT cases) + (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + cases))))) + + (#RecordT fields) + (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + fields))))) + + (#LambdaT in out) + (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) + + (#BoundT name) + (` (#BoundT (~ (text$ name)))) + + (#VarT id) + (` (#VarT (~ (int$ id)))) + + (#ExT id) + (` (#ExT (~ (int$ id)))) + + (#AllT env name arg type) + (let [env' (: Syntax + (case env + #None (` #None) + (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + _env)))))))] + (` (#AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) + + (#AppT fun arg) + (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))))) + +(defmacro #export (loop tokens) + (case tokens + (\ (list (#Meta _ (#TupleS bindings)) body)) + (let [pairs (as-pairs bindings) + vars (map first pairs) + inits (map second pairs)] + (if (every? symbol? inits) + (do Lux/Monad + [inits' (: (Lux (List Ident)) + (case (map% Maybe/Monad get-ident inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init-types (map% Lux/Monad find-var-type inits') + expected expected-type] + (return (list (` ((: (-> (~@ (map type->syntax init-types)) + (~ (type->syntax expected))) + (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] + (~ body))) + (~@ inits)))))) + (do Lux/Monad + [aliases (map% Lux/Monad + (: (-> Syntax (Lux Syntax)) + (lambda [_] (gensym ""))) + inits)] + (return (list (` (let [(~@ (interleave aliases inits))] + (loop [(~@ (interleave vars aliases))] + (~ body))))))))) + + _ + (fail "Wrong syntax for loop"))) diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux index 3c40df188..7898e998d 100644 --- a/source/lux/codata/function.lux +++ b/source/lux/codata/function.lux @@ -10,6 +10,10 @@ (lux/control (monoid #as m))) ## [Functions] +(def #export (const x y) + (All [a b] (-> a (-> b a))) + x) + (def #export (flip f) (All [a b c] (-> (-> a b c) (-> b a c))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 2c854a61c..3bce9ee77 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -14,7 +14,8 @@ macro syntax) (data (list #as l #refer (#only list list& List/Monad)) - (number (int #open ("i" Int/Number Int/Ord)))) + (number (int #open ("i" Int/Number Int/Ord))) + bool) (codata (lazy #as L #refer #all)))) ## [Types] diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux new file mode 100644 index 000000000..bfb8e99c0 --- /dev/null +++ b/source/lux/control/hash.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Signatures] +(defsig #export (Hash a) + (: (-> a Int) + hash)) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index 5f4427a2c..92f5486ef 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -7,9 +7,10 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m) - (eq #as E) - (show #as S))) + (lux (control (monoid #as m) + (eq #as E) + (show #as S)) + (codata function))) ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) @@ -31,3 +32,8 @@ [ Or/Monoid false or] [And/Monoid true and] ) + +## [Functions] +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 8d6296b14..2bbbe66cc 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -12,7 +12,8 @@ (monad #as M #refer #all) (eq #as E) (dict #as D #refer #all)) - (data/number (int #open ("i" Int/Number Int/Ord Int/Eq))) + (data (number (int #open ("i" Int/Number Int/Ord Int/Eq))) + bool) meta/macro)) ## Types @@ -23,43 +24,6 @@ (deftype #export (PList k v) (| (#PList (, (E;Eq k) (List (, k v)))))) -## [Utils] -(def (pl-get eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (Maybe v))) - (case kvs - #;Nil - #;None - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Some v') - (pl-get eq k kvs')))) - -(def (pl-put eq k v kvs) - (All [k v] - (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - (#;Cons [[k v] kvs]) - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Cons [[k v] kvs']) - (#;Cons [[k' v'] (pl-put eq k v kvs')])))) - -(def (pl-remove eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (pl-remove eq k kvs')])))) - ## [Constructors] (def #export (plist eq) (All [k v] @@ -316,14 +280,35 @@ (foldL ++ unit mma)))) (defstruct #export PList/Dict (Dict PList) - (def (D;get k plist) - (let [(#PList [eq kvs]) plist] - (pl-get eq k kvs))) - - (def (D;put k v plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-put eq k v kvs)]))) - - (def (D;remove k plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-remove eq k kvs)])))) + (def (D;get k (#PList [eq kvs])) + (loop [kvs kvs] + (case kvs + #;Nil + #;None + + (#;Cons [k' v'] kvs') + (if (:: eq (E;= k k')) + (#;Some v') + (recur kvs'))))) + + (def (D;put k v (#PList [eq kvs])) + (#PList [eq (loop [kvs kvs] + (case kvs + #;Nil + (#;Cons [k v] kvs) + + (#;Cons [k' v'] kvs') + (if (:: eq (E;= k k')) + (#;Cons [k v] kvs') + (#;Cons [k' v'] (recur kvs')))))])) + + (def (D;remove k (#PList [eq kvs])) + (#PList [eq (loop [kvs kvs] + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (recur kvs')]))))]))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 13dcae284..66e4cc341 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -132,20 +132,40 @@ expansion' (M;map% Lux/Monad macro-expand expansion)] (M;wrap (:: List/Monad (M;join expansion')))) + #;None + (:: Lux/Monad (M;wrap (list syntax))))) + + _ + (:: Lux/Monad (M;wrap (list syntax))))) + +(def #export (macro-expand-all syntax) + (-> Syntax (Lux (List Syntax))) + (case syntax + (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (M;map% Lux/Monad macro-expand-all expansion)] + (M;wrap (:: List/Monad (M;join expansion')))) + #;None (do Lux/Monad - [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + [parts' (M;map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (M;map% Lux/Monad macro-expand targs)] + [harg+ (macro-expand-all harg) + targs+ (M;map% Lux/Monad macro-expand-all targs)] (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) (#;Meta [_ (#;TupleS members)]) (do Lux/Monad - [members' (M;map% Lux/Monad macro-expand members)] + [members' (M;map% Lux/Monad macro-expand-all members)] (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) _ @@ -234,7 +254,7 @@ (case state {#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} + #;seed seed #;eval? eval? #;expected expected} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -254,7 +274,7 @@ (let [[v-prefix v-name] name {#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] + #;seed seed #;eval? eval? #;expected expected} state] (case (get v-prefix modules) #;None #;None @@ -289,6 +309,6 @@ _ (let [{#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] + #;seed seed #;eval? eval? #;expected expected} state] (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) )) diff --git a/source/program.lux b/source/program.lux index b9f737480..ae3421078 100644 --- a/source/program.lux +++ b/source/program.lux @@ -14,6 +14,7 @@ bounded dict eq + hash ord show number) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index de7fc8497..f10f6b913 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -446,45 +446,44 @@ [_] (aba3 analyse eval! compile-module exo-type token))) -(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))] - (defn ^:private aba1 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] - ;; Standard special forms - [["lux;BoolS" ?value]] - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) +(defn ^:private aba1 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; Standard special forms + [["lux;BoolS" ?value]] + (|do [_ (&type/check exo-type &type/Bool)] + (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - [["lux;IntS" ?value]] - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) + [["lux;IntS" ?value]] + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - [["lux;RealS" ?value]] - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) + [["lux;RealS" ?value]] + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - [["lux;CharS" ?value]] - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + [["lux;CharS" ?value]] + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - [["lux;TextS" ?value]] - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + [["lux;TextS" ?value]] + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - [["lux;TupleS" ?elems]] - (&&lux/analyse-tuple analyse exo-type ?elems) + [["lux;TupleS" ?elems]] + (&&lux/analyse-tuple analyse exo-type ?elems) - [["lux;RecordS" ?elems]] - (&&lux/analyse-record analyse exo-type ?elems) + [["lux;RecordS" ?elems]] + (&&lux/analyse-record analyse exo-type ?elems) - [["lux;TagS" ?ident]] - (&&lux/analyse-variant analyse exo-type ?ident unit) - - [["lux;SymbolS" [_ "_jvm_null"]]] - (&&host/analyse-jvm-null analyse exo-type) + [["lux;TagS" ?ident]] + (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) + + [["lux;SymbolS" [_ "_jvm_null"]]] + (&&host/analyse-jvm-null analyse exo-type) - [_] - (aba2 analyse eval! compile-module exo-type token) - ))) + [_] + (aba2 analyse eval! compile-module exo-type token) + )) (defn ^:private add-loc [meta ^String msg] (if (.startsWith msg "@") @@ -512,10 +511,10 @@ ;; (assert false (aget token 0)) )) -(defn ^:private just-analyse [analyse-ast eval! compile-module syntax] +(defn ^:private just-analyse [analyser syntax] (&type/with-var (fn [?var] - (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)] + (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] (matchv ::M/objects [?var ?output-type] [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] (if (= ?e-id ?a-id) @@ -528,25 +527,25 @@ )))) (defn ^:private analyse-ast [eval! compile-module exo-type token] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.") - (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident (&/|head ?values))) - - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] - (fn [state] - (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state) - ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) - ] - [["lux;Right" [state* =fn]]] - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) - - [_] - ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) - - [_] - (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token))) + (&/with-expected-type exo-type + (matchv ::M/objects [token] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident ?values) + + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] + (fn [state] + (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module) ?fn) state) + ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) + ] + [["lux;Right" [state* =fn]]] + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) + + [_] + ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) + + [_] + (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token)))) ;; [Resources] (defn analyse [eval! compile-module] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index ebbb6911a..77f8c418c 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -16,6 +16,9 @@ [env :as &env]))) ;; [Utils] +(def ^:private unit + (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))) + (defn ^:private resolve-type [type] (matchv ::M/objects [type] [["lux;VarT" ?id]] @@ -198,19 +201,19 @@ (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) - (&/V "lux;TupleS" (&/|list)))) - kont)] + [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]] + ?values]]]] (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type ?value - kont)] + [=test =kont] (case (&/|length ?values) + 0 (analyse-pattern case-type unit kont) + 1 (analyse-pattern case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" ?values))) kont))] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) ))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 065e150d9..4fb9d1533 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -55,7 +55,25 @@ [_] (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) -(defn analyse-variant [analyse exo-type ident ?value] +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (matchv ::M/objects [?values] + [["lux;Nil" _]] + (analyse-tuple analyse exo-type (&/|list)) + + [["lux;Cons" [?value ["lux;Nil" _]]]] + (analyse exo-type ?value) + + [_] + (analyse-tuple analyse exo-type ?values) + )] + (matchv ::M/objects [output] + [["lux;Cons" [x ["lux;Nil" _]]]] + (return x) + + [_] + (fail "[Analyser Error] Can't expand to other than 1 element.")))) + +(defn analyse-variant [analyse exo-type ident ?values] (|do [exo-type* (matchv ::M/objects [exo-type] [["lux;VarT" ?id]] (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -69,7 +87,7 @@ [["lux;VariantT" ?cases]] (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] - (|do [=value (&&/analyse-1 analyse vtype ?value)] + (|do [=value (analyse-variant-body analyse vtype ?values)] (return (&/|list (&/T (&/V "variant" (&/T ?tag =value)) exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) @@ -78,7 +96,7 @@ (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** ident ?value)))) + (analyse-variant analyse exo-type** ident ?values)))) [_] (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) @@ -108,6 +126,8 @@ (fail (str "[Analyser Error] The type of a record must be a record type:\n" (&type/show-type exo-type*) "\n"))) + _ (&/assert! (= (&/|length types) (&/|length ?elems)) + (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) =slots (&/map% (fn [kv] (matchv ::M/objects [kv] [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] @@ -258,14 +278,17 @@ (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (matchv ::M/objects [$def] [["lux;MacroD" macro]] - (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) + (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] + macro-expansion #(-> macro (.apply ?args) (.apply %)) + ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) - ;; (= "case" ?name)) + ;; :let [_ (when (or (= "loop" r-name) + ;; ;; (= "struct" r-name) + ;; ) ;; (->> (&/|map &/show-ast macro-expansion*) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn ?module "case")))] + ;; (prn (str r-module ";" r-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) @@ -356,6 +379,8 @@ (defn analyse-def [analyse ?name ?value] ;; (prn 'analyse-def/BEGIN ?name) + ;; (when (= "PList/Dict" ?name) + ;; (prn 'DEF ?name (&/show-ast ?value))) (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? diff --git a/src/lux/base.clj b/src/lux/base.clj index eb94c2c90..ef3c81041 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -11,6 +11,9 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) +;; [Tags] +(def $Cons "lux;Cons") + ;; [Fields] ;; Binding (def $COUNTER 0) @@ -27,14 +30,15 @@ (def $LOADER 1) (def $WRITER 2) -;; CompilerState +;; Compiler (def $ENVS 0) (def $EVAL? 1) -(def $HOST 2) -(def $MODULES 3) -(def $SEED 4) -(def $SOURCE 5) -(def $TYPES 6) +(def $EXPECTED 2) +(def $HOST 3) +(def $MODULES 4) +(def $SEED 5) +(def $SOURCE 6) +(def $TYPES 7) ;; [Exports] (def +name-separator+ ";") @@ -487,6 +491,8 @@ (|list) ;; "lux;eval?" false + ;; "lux;expected" + (V "lux;VariantT" (|list)) ;; "lux;host" (host nil) ;; "lux;modules" @@ -610,6 +616,18 @@ [_] output)))) +(defn with-expected-type [type body] + "(All [a] (-> Type (Lux a)))" + (fn [state] + (let [output (body (set$ $EXPECTED type state))] + (matchv ::M/objects [output] + [["lux;Right" [?state ?value]]] + (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) + ?value) + + [_] + output)))) + (defn show-ast [ast] (matchv ::M/objects [ast] [["lux;Meta" [_ ["lux;BoolS" ?value]]]] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index 176b4340d..0e7982a7f 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -11,7 +11,7 @@ )) ;; [Resources] -(defn read-file [path] +(defn read-file [^String path] (let [file (new java.io.File path)] (if (.exists file) (return (slurp file)) diff --git a/src/lux/type.clj b/src/lux/type.clj index f5b8d3f25..e3255ac5c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -177,7 +177,9 @@ (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) (&/T "lux;seed" Int) - (&/T "lux;eval?" Bool)))) + (&/T "lux;eval?" Bool) + (&/T "lux;expected" Type) + ))) $Void))) (def Macro -- cgit v1.2.3 From 90399879ee7cc61e6333f7e81141441d32fcdb2e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 3 Aug 2015 01:29:48 -0400 Subject: Implemented text-interpolation through a macro ("<>") in lux/data/text --- source/lux/control/show.lux | 2 +- source/lux/control/stack.lux | 23 ++++++++++++++++++++++ source/lux/data/io.lux | 3 ++- source/lux/data/maybe.lux | 31 ++++++++++++++++------------- source/lux/data/text.lux | 47 +++++++++++++++++++++++++++++++++++++++----- source/program.lux | 7 ++++--- 6 files changed, 89 insertions(+), 24 deletions(-) create mode 100644 source/lux/control/stack.lux diff --git a/source/lux/control/show.lux b/source/lux/control/show.lux index f4e1cf762..adb5f911e 100644 --- a/source/lux/control/show.lux +++ b/source/lux/control/show.lux @@ -8,7 +8,7 @@ (;import lux) -## Signatures +## [Signatures] (defsig #export (Show a) (: (-> a Text) show)) diff --git a/source/lux/control/stack.lux b/source/lux/control/stack.lux new file mode 100644 index 000000000..1e5d086c5 --- /dev/null +++ b/source/lux/control/stack.lux @@ -0,0 +1,23 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Signatures] +(defsig #export (Stack s) + (: (All [a] (s a)) + empty) + (: (All [a] (-> (s a) Bool)) + empty?) + (: (All [a] (-> a (s a) (s a))) + push) + (: (All [a] (-> (s a) (Maybe (s a)))) + pop) + (: (All [a] (-> (s a) (Maybe a))) + top) + ) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index a194fc854..e5b265959 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -49,4 +49,5 @@ (def #export (println x) (-> Text (IO (,))) - (print (text:++ x "\n"))) + (io (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.Object"] + (_jvm_getstatic "java.lang.System" "out") [x]))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index 396ec470a..a6019e256 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -7,12 +7,11 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (.. list) - (lux (control (monoid #as m #refer #all) + (lux (meta macro) + (control (monoid #as m #refer #all) (functor #as F #refer #all) - (monad #as M #refer #all)) - (meta lux - syntax))) + (monad #as M #refer #all))) + (.. list)) ## [Types] ## (deftype (Maybe a) @@ -45,12 +44,16 @@ (#;Some xs) xs))) ## [Syntax] -(defsyntax #export (? maybe else) - (do Lux/Monad - [g!value (gensym "")] - (M;wrap (list (` (case (~ maybe) - (#;Some (~ g!value)) - (~ g!value) - - _ - (~ else))))))) +(defmacro #export (? tokens state) + (case tokens + (\ (list maybe else)) + (let [g!value (symbol$ ["" "_"])] + (#;Right state (list (` (case (~ maybe) + (#;Some (~ g!value)) + (~ g!value) + + _ + (~ else)))))) + + _ + (#;Left "Wrong syntax for ?"))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index c3cb1ecfb..ae4f9974f 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -7,11 +7,15 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (control (monoid #as m) + (lux (meta macro) + (control (monoid #as m) (eq #as E) (ord #as O) - (show #as S)) - (data/number (int #open ("i" Int/Number Int/Ord Int/Eq))))) + (show #as S) + (monad #as M #refer #all)) + (data (number (int #open ("i" Int/Number Int/Ord Int/Eq))) + maybe + (list #refer (#only foldL list list&))))) ## [Functions] (def #export (size x) @@ -132,11 +136,44 @@ [O;>= i>=])) (defstruct #export Text/Show (S;Show Text) - (def (S;show x) - x)) + (def S;show id)) (defstruct #export Text/Monoid (m;Monoid Text) (def m;unit "") (def (m;++ x y) (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y]))) + +## [Syntax] +(def (extract-var template) + (-> Text (Maybe (, Text Text Text))) + (exec (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.Object"] + (_jvm_getstatic "java.lang.System" "out") [(:: Text/Monoid (m;++ "Template: " template))]) + (do Maybe/Monad + [pre-idx (index-of "#{" template) + [pre in] (split pre-idx template) + [_ in] (split 2 in) + post-idx (index-of "}" in) + [var post] (split post-idx in) + [_ post] (split 1 post)] + (M;wrap [pre var post])))) + +(def (unravel-template template) + (-> Text (List Syntax)) + (case (extract-var template) + (#;Some [pre var post]) + (list& (text$ pre) (symbol$ ["" var]) + (unravel-template post)) + + #;None + (list (text$ template)))) + +(defmacro #export (<> tokens state) + (case tokens + (\ (list (#;Meta _ (#;TextS template)))) + (let [++ (symbol$ ["" ""])] + (#;Right state (list (` (;let [(~ ++) (;:: Text/Monoid m;++)] + (;$ (~ ++) (~@ (unravel-template template)))))))) + + _ + (#;Left "Wrong syntax for <>"))) diff --git a/source/program.lux b/source/program.lux index ae3421078..b7cce5714 100644 --- a/source/program.lux +++ b/source/program.lux @@ -17,7 +17,8 @@ hash ord show - number) + number + stack) (data bool char (either #as e) @@ -28,7 +29,7 @@ maybe (number int real) - (text #as t #open ("text:" Text/Monoid)) + (text #as t #refer (#only <>) #open ("text:" Text/Monoid)) writer tuple) (codata (stream #as S) @@ -46,7 +47,7 @@ (program args (case args (\ (list name)) - (println ($ text:++ "Hello, " name "!")) + (println (<> "Hello, #{name}!")) _ (println "Hello, world!"))) -- cgit v1.2.3 From ddc471806fba8fe179d52b4781f0a66d871b5e99 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 3 Aug 2015 19:54:53 -0400 Subject: - Type definitions inside the compiler data now hold the type itself. - Value definitions inside the compiler data now hold the value itself. - Fixed a few bugs. --- project.clj | 2 +- source/lux.lux | 24 ++++++++++---- source/lux/data/list.lux | 20 +++++++++++- source/lux/data/text.lux | 18 +++++------ source/lux/meta/lux.lux | 8 ++--- src/lux/analyser.clj | 62 +++++++++++++++++------------------ src/lux/analyser/env.clj | 1 + src/lux/analyser/host.clj | 21 ++++++------ src/lux/analyser/lux.clj | 33 ++++++++----------- src/lux/analyser/module.clj | 6 ++-- src/lux/compiler.clj | 27 +++++++++++++--- src/lux/compiler/base.clj | 2 +- src/lux/compiler/cache.clj | 22 +++++++++---- src/lux/compiler/case.clj | 4 +-- src/lux/compiler/lux.clj | 78 ++++++++++++++++++++++++++++++--------------- src/lux/compiler/type.clj | 2 +- src/lux/host.clj | 3 ++ src/lux/optimizer.clj | 4 +-- src/lux/type.clj | 4 +-- 19 files changed, 210 insertions(+), 131 deletions(-) diff --git a/project.clj b/project.clj index a0fd8d1cb..88191109a 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject lux-jvm "0.2.0" +(defproject lux-jvm "0.3.0" :description "The JVM compiler for the Lux programming language." :url "https://github.com/LuxLang/lux" :license {:name "Eclipse Public License" diff --git a/source/lux.lux b/source/lux.lux index 3670a9e52..d3dd374d5 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -220,14 +220,16 @@ #Nil])])]))) ## (deftype (DefData' m) -## (| #TypeD -## (#ValueD Type) +## (| (#TypeD Type) +## (#ValueD (, Type Unit)) ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] - (#Cons [["lux;ValueD" Type] + (#VariantT (#Cons [["lux;TypeD" Type] + (#Cons [["lux;ValueD" (#TupleT (#Cons [Type + (#Cons [Unit + #Nil])]))] (#Cons [["lux;MacroD" (#BoundT "")] (#Cons [["lux;AliasD" Ident] #Nil])])])]))])) @@ -1710,7 +1712,7 @@ (_lux_case pattern (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) (do Lux/Monad - [expansion (macro-expand-all (form$ (list& (symbol$ macro-name) body macro-args))) + [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] (;return (list:join expansions))) @@ -2621,8 +2623,8 @@ (#Some _ def-data) (case def-data - #TypeD (#Some Type) - (#ValueD type) (#Some type) + (#TypeD _) (#Some Type) + (#ValueD [type _]) (#Some type) (#MacroD m) (#Some Macro) (#AliasD name') (find-in-defs name' state)))))) ## (def (find-in-defs name state) @@ -3048,3 +3050,11 @@ _ (fail "Wrong syntax for loop"))) + +## (defmacro #export (extend tokens) +## (case tokens +## (\ (list (#Meta _ (#SymbolS name)))) + + +## _ +## (fail "Wrong syntax for extend"))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 2bbbe66cc..f840688fd 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -11,7 +11,8 @@ (functor #as F #refer #all) (monad #as M #refer #all) (eq #as E) - (dict #as D #refer #all)) + (dict #as D #refer #all) + (stack #as S)) (data (number (int #open ("i" Int/Number Int/Ord Int/Eq))) bool) meta/macro)) @@ -312,3 +313,20 @@ (if (:: eq (E;= k k')) kvs' (#;Cons [[k' v'] (recur kvs')]))))]))) + +(defstruct #export List/Stack (S;Stack List) + (def S;empty (list)) + (def (S;empty? xs) + (case xs + #;Nil true + _ false)) + (def (S;push x xs) + (#;Cons x xs)) + (def (S;pop xs) + (case xs + #;Nil #;None + (#;Cons x xs') (#;Some xs'))) + (def (S;top xs) + (case xs + #;Nil #;None + (#;Cons x xs') (#;Some x)))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index ae4f9974f..1d582c1d5 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -147,16 +147,14 @@ ## [Syntax] (def (extract-var template) (-> Text (Maybe (, Text Text Text))) - (exec (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.Object"] - (_jvm_getstatic "java.lang.System" "out") [(:: Text/Monoid (m;++ "Template: " template))]) - (do Maybe/Monad - [pre-idx (index-of "#{" template) - [pre in] (split pre-idx template) - [_ in] (split 2 in) - post-idx (index-of "}" in) - [var post] (split post-idx in) - [_ post] (split 1 post)] - (M;wrap [pre var post])))) + (do Maybe/Monad + [pre-idx (index-of "#{" template) + [pre in] (split pre-idx template) + [_ in] (split 2 in) + post-idx (index-of "}" in) + [var post] (split post-idx in) + [_ post] (split 1 post)] + (M;wrap [pre var post]))) (def (unravel-template template) (-> Text (List Syntax)) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 66e4cc341..cdbade999 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -286,10 +286,10 @@ (#;Some [_ def-data]) (case def-data - #;TypeD (#;Some Type) - (#;ValueD type) (#;Some type) - (#;MacroD m) (#;Some Macro) - (#;AliasD name') (find-in-defs name' state)))))) + (#;TypeD value) (#;Some Type) + (#;ValueD type _) (#;Some type) + (#;MacroD m) (#;Some Macro) + (#;AliasD name') (find-in-defs name' state)))))) (def #export (find-var-type name) (-> Ident (Lux Type)) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index f10f6b913..774188d82 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -34,7 +34,7 @@ ["lux;Nil" _]]]]]]]]] (&/T catch+ (&/V "lux;Some" ?finally-body)))) -(defn ^:private aba7 [analyse eval! compile-module exo-type token] +(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Arrays [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] @@ -64,25 +64,25 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) + (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] ?methods]]]]]]]] - (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) + (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-program analyse ?args ?body) + (&&host/analyse-jvm-program analyse compile-token ?args ?body) [_] (fail ""))) -(defn ^:private aba6 [analyse eval! compile-module exo-type token] +(defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Primitive conversions [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] @@ -156,9 +156,9 @@ (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) [_] - (aba7 analyse eval! compile-module exo-type token))) + (aba7 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba5 [analyse eval! compile-module exo-type token] +(defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Objects [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] @@ -265,9 +265,9 @@ (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) [_] - (aba6 analyse eval! compile-module exo-type token))) + (aba6 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba4 [analyse eval! compile-module exo-type token] +(defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Float arithmetic [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] @@ -320,9 +320,9 @@ (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) [_] - (aba5 analyse eval! compile-module exo-type token))) + (aba5 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba3 [analyse eval! compile-module exo-type token] +(defn ^:private aba3 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Host special forms ;; Characters @@ -386,9 +386,9 @@ (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) [_] - (aba4 analyse eval! compile-module exo-type token))) + (aba4 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba2 [analyse eval! compile-module exo-type token] +(defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] [["lux;SymbolS" ?ident]] (&&lux/analyse-symbol analyse exo-type ?ident) @@ -408,17 +408,17 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-def analyse ?name ?value) + (&&lux/analyse-def analyse compile-token ?name ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] ["lux;Nil" _]]]]]]] - (&&lux/analyse-declare-macro analyse ?name) + (&&lux/analyse-declare-macro analyse compile-token ?name) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] ["lux;Nil" _]]]]]]] - (&&lux/analyse-import analyse compile-module ?path) + (&&lux/analyse-import analyse compile-module compile-token ?path) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] ["lux;Cons" [?type @@ -435,18 +435,18 @@ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] ["lux;Nil" _]]]]]]] - (&&lux/analyse-export analyse ?ident) + (&&lux/analyse-export analyse compile-token ?ident) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-alias analyse ?alias ?module) + (&&lux/analyse-alias analyse compile-token ?alias ?module) [_] - (aba3 analyse eval! compile-module exo-type token))) + (aba3 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba1 [analyse eval! compile-module exo-type token] +(defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Standard special forms [["lux;BoolS" ?value]] @@ -482,7 +482,7 @@ (&&host/analyse-jvm-null analyse exo-type) [_] - (aba2 analyse eval! compile-module exo-type token) + (aba2 analyse eval! compile-module compile-token exo-type token) )) (defn ^:private add-loc [meta ^String msg] @@ -491,12 +491,12 @@ (|let [[file line col] meta] (str "@ " file "," line "," col "\n" msg)))) -(defn ^:private analyse-basic-ast [analyse eval! compile-module exo-type token] +(defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (matchv ::M/objects [token] [["lux;Meta" [meta ?token]]] (fn [state] - (matchv ::M/objects [((aba1 analyse eval! compile-module exo-type ?token) state)] + (matchv ::M/objects [((aba1 analyse eval! compile-module compile-token exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) @@ -526,28 +526,28 @@ (return (&/T ?output-term ?output-type))) )))) -(defn ^:private analyse-ast [eval! compile-module exo-type token] +(defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] (&/with-expected-type exo-type (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident ?values) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] (fn [state] - (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module) ?fn) state) + (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) ] [["lux;Right" [state* =fn]]] (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) [_] - ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) [_] - (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token)))) + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))) ;; [Resources] -(defn analyse [eval! compile-module] +(defn analyse [eval! compile-module compile-token] (|do [asts &parser/parse] - (&/flat-map% (partial analyse-ast eval! compile-module &type/$Void) asts))) + (&/flat-map% (partial analyse-ast eval! compile-module compile-token &type/$Void) asts))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index cac0f8cd4..391d78411 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -20,6 +20,7 @@ (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] + ;; (prn 'with-local name) (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) =return (body (&/update$ &/$ENVS (fn [stack] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 5033f4f2c..663c650e7 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -273,7 +273,7 @@ tname )) -(defn analyse-jvm-class [analyse ?name ?super-class ?interfaces ?fields ?methods] +(defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (matchv ::M/objects [?field] @@ -328,10 +328,11 @@ [_] (fail "[Analyser Error] Wrong syntax for method."))) - (&/enumerate ?methods))] - (return (&/|list (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))))) + (&/enumerate ?methods)) + _ (compile-token (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))] + (return (&/|list)))) -(defn analyse-jvm-interface [analyse ?name ?supers ?methods] +(defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (matchv ::M/objects [method] @@ -349,8 +350,9 @@ [_] (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - ?methods)] - (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods)))))) + ?methods) + _ (compile-token (&/V "jvm-interface" (&/T ?name =supers =methods)))] + (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] @@ -431,9 +433,10 @@ analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer" ) -(defn analyse-jvm-program [analyse ?args ?body] +(defn analyse-jvm-program [analyse compile-token ?args ?body] (|let [[_module _name] ?args] (|do [=body (&/with-scope "" (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] - (return (&/|list (&/V "jvm-program" =body)))))) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V "jvm-program" =body))] + (return (&/|list))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 4fb9d1533..c86df3027 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -163,7 +163,7 @@ ?name) ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] + [["lux;ValueD" [?type _]]] (return ?type) [["lux;MacroD" _]] @@ -188,7 +188,7 @@ ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] + [["lux;ValueD" [?type _]]] (return ?type) [["lux;MacroD" _]] @@ -282,7 +282,7 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= "loop" r-name) + ;; :let [_ (when (or (= "<>" r-name) ;; ;; (= "struct" r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion*) @@ -377,7 +377,7 @@ (|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)] (return (&/|list output)))) -(defn analyse-def [analyse ?name ?value] +(defn analyse-def [analyse compile-token ?name ?value] ;; (prn 'analyse-def/BEGIN ?name) ;; (when (= "PList/Dict" ?name) ;; (prn 'DEF ?name (&/show-ast ?value))) @@ -397,24 +397,17 @@ (return (&/|list))) [_] - (|do [=value-type (&&/expr-type =value) - :let [;; _ (prn 'analyse-def/END ?name) - _ (println 'DEF (str module-name ";" ?name)) - ;; _ (println) - def-data (cond (&type/type= &type/Type =value-type) - (&/V "lux;TypeD" nil) - - :else - (&/V "lux;ValueD" =value-type))] - _ (&&module/define module-name ?name def-data =value-type)] - (return (&/|list (&/V "def" (&/T ?name =value def-data)))))) + (do (println 'DEF (str module-name ";" ?name)) + (|do [_ (compile-token (&/V "def" (&/T ?name =value)))] + (return (&/|list))))) )))) -(defn analyse-declare-macro [analyse ?name] +(defn analyse-declare-macro [analyse compile-token ?name] (|do [module-name &/get-module-name] - (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) + (|do [_ (compile-token (&/V "declare-macro" (&/T module-name ?name)))] + (return (&/|list))))) -(defn analyse-import [analyse compile-module ?path] +(defn analyse-import [analyse compile-module compile-token ?path] (|do [module-name &/get-module-name _ (if (= module-name ?path) (fail (str "[Analyser Error] Module can't import itself: " ?path)) @@ -426,12 +419,12 @@ _ (&/when% (not already-compiled?) (compile-module ?path))] (return (&/|list)))))) -(defn analyse-export [analyse name] +(defn analyse-export [analyse compile-token name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] (return (&/|list)))) -(defn analyse-alias [analyse ex-alias ex-module] +(defn analyse-alias [analyse compile-token ex-alias ex-module] (|do [module-name &/get-module-name _ (&&module/alias module-name ex-alias ex-module)] (return (&/|list)))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 68cdc4747..327dad27f 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -72,7 +72,7 @@ [[_ ["lux;MacroD" _]]] (return* state &type/Macro) - [[_ ["lux;ValueD" _type]]] + [[_ ["lux;ValueD" [_type _]]]] (return* state _type) [[_ ["lux;AliasD" [?r-module ?r-name]]]] @@ -159,7 +159,7 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] - [[exported? ["lux;ValueD" ?type]]] + [[exported? ["lux;ValueD" [?type _]]]] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) @@ -181,7 +181,7 @@ [[_ ["lux;MacroD" _]]] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) - [[_ ["lux;TypeD" _]]] + [[_ _]] (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module does not exist: " module))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index b88bb9c0a..4c12f9519 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -326,8 +326,8 @@ (defn ^:private compile-statement [syntax] (matchv ::M/objects [syntax] - [["def" [?name ?body ?def-data]]] - (&&lux/compile-def compile-expression ?name ?body ?def-data) + [["def" [?name ?body]]] + (&&lux/compile-def compile-expression ?name ?body) [["declare-macro" [?module ?name]]] (&&lux/compile-declare-macro compile-expression ?module ?name) @@ -341,6 +341,26 @@ [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) +(defn ^:private compile-token [syntax] + (matchv ::M/objects [syntax] + [["def" [?name ?body]]] + (&&lux/compile-def compile-expression ?name ?body) + + [["declare-macro" [?module ?name]]] + (&&lux/compile-declare-macro compile-expression ?module ?name) + + [["jvm-program" ?body]] + (&&host/compile-jvm-program compile-expression ?body) + + [["jvm-interface" [?name ?supers ?methods]]] + (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) + + [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) + + [_] + (compile-expression syntax))) + (defn ^:private eval! [expr] (&/with-eval (|do [module &/get-module-name @@ -378,8 +398,7 @@ :let [file-hash (hash file-content)]] (if (&&cache/cached? name) (&&cache/load name file-hash compile-module) - (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] - (&/map% compile-statement analysis+))] + (let [compiler-step (&optimizer/optimize eval! compile-module compile-token)] (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 28339c162..74e5625b3 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -27,7 +27,7 @@ (java.lang.reflect Field))) ;; [Constants] -(def ^String version "0.2") +(def ^String version "0.3") (def ^String input-dir "source") (def ^String output-dir "target/jvm") (def ^String output-package (str output-dir "/program.jar")) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 45513d0a5..565eae898 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -26,6 +26,7 @@ ;; [Utils] (defn ^:private read-file [^File file] + "(-> File (Array Byte))" (with-open [reader (io/input-stream file)] (let [length (.length file) buffer (byte-array length)] @@ -33,6 +34,7 @@ buffer))) (defn ^:private clean-file [^File file] + "(-> File (,))" (if (.isDirectory file) (do (doseq [f (seq (.listFiles file))] (clean-file f)) @@ -40,6 +42,7 @@ (.delete file))) (defn ^:private get-field [^String field-name ^Class class] + "(-> Text Class Object)" (-> class ^Field (.getField field-name) (.get nil))) ;; [Resources] @@ -66,6 +69,7 @@ nil)) (defn load [module module-hash compile-module] + "(-> Text Int (-> Text (Lux (,))) (Lux Bool))" (|do [loader &/loader !classes &/classes already-loaded? (&a-module/exists? module) @@ -112,15 +116,19 @@ ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) ] (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module _name)) + "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field "_datum" def-class)] + (&a-module/define module _name (&/V "lux;TypeD" def-value) &type/Type)) + "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field "_datum" def-class)] + (|do [_ (&a-module/define module _name (&/V "lux;ValueD" (&/T &type/Macro def-value)) &type/Macro)] + (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) + def-meta (get-field "_meta" def-class)] + (matchv ::M/objects [def-meta] + [["lux;ValueD" [def-type _]]] + (&a-module/define module _name def-meta def-type))) ;; else (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] (|do [__type (&a-module/def-type __module __name)] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index fc0cce31f..906cc1ca8 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -47,7 +47,7 @@ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J") - (.visitLdcInsn ?value) + (.visitLdcInsn (long ?value)) (.visitInsn Opcodes/LCMP) (.visitJumpInsn Opcodes/IFNE $else) (.visitInsn Opcodes/POP) @@ -58,7 +58,7 @@ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D") - (.visitLdcInsn ?value) + (.visitLdcInsn (double ?value)) (.visitInsn Opcodes/DCMPL) (.visitJumpInsn Opcodes/IFNE $else) (.visitInsn Opcodes/POP) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index b1023689e..def5220f7 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -136,33 +136,38 @@ ?args)] (return nil))) -(defn ^:private compile-def-type [compile ?body ?def-data] +(defn ^:private compile-def-type [compile current-class ?body def-type] (|do [^MethodVisitor **writer** &/get-writer] - (matchv ::M/objects [?def-data] - [["lux;TypeD" _]] - (let [_ (doto **writer** - ;; Tail: Begin - (.visitLdcInsn (int 2)) ;; S - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;TypeD") ;; VVIT - (.visitInsn Opcodes/AASTORE) ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 1)) ;; VVI - (.visitInsn Opcodes/ACONST_NULL) ;; VVIN - (.visitInsn Opcodes/AASTORE) ;; V - )] + (matchv ::M/objects [def-type] + ["type"] + (|do [:let [;; ?type* (&&type/->analysis ?type) + _ (doto **writer** + ;; Tail: Begin + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn "lux;TypeD") ;; VVIT + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + ;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN + (.visitInsn Opcodes/AASTORE) ;; V + )] + ;; _ (compile ?type*) + ;; :let [_ (.visitInsn **writer** Opcodes/AASTORE)] + ] (return nil)) - [["lux;ValueD" _]] + ["value"] (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) - [?def-value ?def-type] (matchv ::M/objects [?body] - [[["ann" [?def-value ?type-expr]] ?def-type]] - (&/T ?def-value ?type-expr) + ?def-type (matchv ::M/objects [?body] + [[["ann" [?def-value ?type-expr]] ?def-type]] + ?type-expr - [[?def-value ?def-type]] - (&/T ?body (&&type/->analysis ?def-type)))] + [[?def-value ?def-type]] + (&&type/->analysis ?def-type))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V @@ -173,13 +178,31 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI )] + :let [_ (doto **writer** + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + )] _ (compile ?def-type) + :let [_ (.visitInsn **writer** Opcodes/AASTORE)] + :let [_ (doto **writer** + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + (.visitInsn Opcodes/AASTORE))] :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] (return nil))) ))) -(defn compile-def [compile ?name ?body ?def-data] - (|do [^ClassWriter *writer* &/get-writer +(defn compile-def [compile ?name ?body] + (|do [=value-type (&a/expr-type ?body) + :let [def-type (cond (&type/type= &type/Type =value-type) + "type" + + :else + "value")] + ^ClassWriter *writer* &/get-writer module-name &/get-module-name :let [datum-sig "Ljava/lang/Object;" def-name (&/normalize-name ?name) @@ -198,7 +221,7 @@ :let [_ (.visitCode **writer**)] _ (compile ?body) :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)] - _ (compile-def-type compile ?body ?def-data) + _ (compile-def-type compile current-class ?body def-type) :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_meta" datum-sig)] :let [_ (doto **writer** (.visitInsn Opcodes/RETURN) @@ -206,7 +229,10 @@ (.visitEnd))]] (return nil))) :let [_ (.visitEnd *writer*)] - _ (&&/save-class! def-name (.toByteArray =class))] + _ (&&/save-class! def-name (.toByteArray =class)) + class-loader &/loader + :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] + _ (&a-module/define module-name ?name (-> def-class (.getField "_meta") (.get nil)) =value-type)] (return nil))) (defn compile-ann [compile *type* ?value-ex ?type-ex] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index a92911444..01141f8e4 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -75,7 +75,7 @@ (variant$ "lux;AllT" (tuple$ (&/|list (matchv ::M/objects [?env] [["lux;None" _]] - (variant$ "lux;Some" (tuple$ (&/|list))) + (variant$ "lux;None" (tuple$ (&/|list))) [["lux;Some" ??env]] (variant$ "lux;Some" diff --git a/src/lux/host.clj b/src/lux/host.clj index 906e3c714..91582c526 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -40,6 +40,9 @@ (defn ^String ->class [class] (string/replace class #"\." "/")) +(defn ^String ->class-name [module] + (string/replace module #"/" ".")) + (defn ^String ->module-class [module-name] (string/replace module-name #"/" module-separator)) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 5056a09e0..65dc4eb0d 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -22,5 +22,5 @@ ;; Local var aliasing. ;; [Exports] -(defn optimize [eval! compile-module] - (&analyser/analyse eval! compile-module)) +(defn optimize [eval! compile-module compile-token] + (&analyser/analyse eval! compile-module compile-token)) diff --git a/src/lux/type.clj b/src/lux/type.clj index e3255ac5c..f40996d7e 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -142,8 +142,8 @@ (def DefData* (fAll "lux;DefData'" "" - (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit) - (&/T "lux;ValueD" Type) + (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Type) + (&/T "lux;ValueD" (&/V "lux;TupleT" (&/|list Type Unit))) (&/T "lux;MacroD" (&/V "lux;BoundT" "")) (&/T "lux;AliasD" Ident))))) -- cgit v1.2.3 From 8a78830404234dc6e766ed6b653905bd7c89fac2 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Aug 2015 00:22:28 -0400 Subject: - Added a macro for exporting definitions (to not depend on the #export tag on definitions). - The "open" and "using" macros now work recursively on records. --- source/lux.lux | 54 +++++++++++++++++++++++++++--------------- source/lux/control/comonad.lux | 3 +-- source/lux/control/monad.lux | 2 +- source/lux/data/list.lux | 2 +- source/lux/data/text.lux | 2 +- source/lux/meta/lux.lux | 16 ++++++------- 6 files changed, 47 insertions(+), 32 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index d3dd374d5..798742e6f 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -2674,6 +2674,20 @@ #seed seed #eval? eval? #expected expected} state] (#Right state expected)))) +(def (use-field field-name type) + (-> Text Type (, Syntax Syntax)) + (let [[module name] (split-slot field-name) + pattern (: Syntax + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [[sname stype]] (use-field sname stype))) + slots)) + + _ + (symbol$ ["" name])))] + [(tag$ [module name]) pattern])) + (defmacro #export (using tokens) (case tokens (\ (list struct body)) @@ -2684,10 +2698,7 @@ (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - [(tag$ [module name]) (symbol$ ["" name])]))) + (lambda [[sname stype]] (use-field sname stype))) slots))] (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) @@ -2762,6 +2773,19 @@ _ (fail "Wrong syntax for get@"))) +(def (open-field prefix field-name source type) + (-> Text Text Syntax Type (List Syntax)) + (let [[module name] (split-slot field-name) + source+ (: Syntax (` (get@ (~ (tag$ [module name])) (~ source))))] + (case (resolve-struct-type type) + (#Some (#RecordT slots)) + (list:join (map (: (-> (, Text Type) (List Syntax)) + (lambda [[sname stype]] (open-field prefix sname source+ stype))) + slots)) + + _ + (list (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+))))))) + (defmacro #export (open tokens) (case tokens (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) @@ -2772,16 +2796,13 @@ _ "")] - struct-type (find-var-type struct-name)] + struct-type (find-var-type struct-name) + #let [source (symbol$ struct-name)]] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) - (return (map (: (-> (, Text Type) Syntax) - (lambda [slot] - (let [[sname stype] slot - [module name] (split-slot sname)] - (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) - (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) - slots)) + (return (list:join (map (: (-> (, Text Type) (List Syntax)) + (lambda [[sname stype]] (open-field prefix sname source stype))) + slots))) _ (fail "Can only \"open\" records."))) @@ -3051,10 +3072,5 @@ _ (fail "Wrong syntax for loop"))) -## (defmacro #export (extend tokens) -## (case tokens -## (\ (list (#Meta _ (#SymbolS name)))) - - -## _ -## (fail "Wrong syntax for extend"))) +(defmacro #export (export tokens) + (return (map (lambda [token] (` (_lux_export (~ token)))) tokens))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index ce9a7e7de..a1168a3cd 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -27,8 +27,7 @@ (All [w a b] (-> (CoMonad w) (-> (w a) b) (w a) (w b))) (using w - (using _functor - (map f (split ma))))) + (map f (split ma)))) ## Syntax (defmacro #export (be tokens state) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index a03c1499a..4e4786b63 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -82,7 +82,7 @@ (All [m a b] (-> (Monad m) (-> a (m b)) (m a) (m b))) (using m - (join (:: _functor (F;map f ma))))) + (join (map f ma)))) (def #export (map% m f xs) (All [m a b] diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index f840688fd..1b1711ca7 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -13,7 +13,7 @@ (eq #as E) (dict #as D #refer #all) (stack #as S)) - (data (number (int #open ("i" Int/Number Int/Ord Int/Eq))) + (data (number (int #open ("i" Int/Number Int/Ord))) bool) meta/macro)) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 1d582c1d5..d0a6c46d1 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -13,7 +13,7 @@ (ord #as O) (show #as S) (monad #as M #refer #all)) - (data (number (int #open ("i" Int/Number Int/Ord Int/Eq))) + (data (number (int #open ("i" Int/Number Int/Ord))) maybe (list #refer (#only foldL list list&))))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index cdbade999..e1d821ff0 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -213,14 +213,14 @@ (case (get module (get@ #;modules state)) (#;Some =module) (using List/Monad - (#;Right [state (join (:: _functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (get@ #;defs =module))))])) + (#;Right [state (join (map (: (-> (, Text (, Bool (DefData' Macro))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (list name) + (list))))) + (get@ #;defs =module)))])) #;None (#;Left ($ text:++ "Unknown module: " module)))) -- cgit v1.2.3 From a8ac885a008f519816d747eca0f894ec9794e938 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Aug 2015 19:40:58 -0400 Subject: - Renamed the Syntax type to AST. - Created the lux/meta/ast module. --- source/lux.lux | 316 ++++++++++++++++++++--------------------- source/lux/codata/lazy.lux | 11 +- source/lux/codata/stream.lux | 2 +- source/lux/control/comonad.lux | 8 +- source/lux/control/monad.lux | 2 +- source/lux/data/io.lux | 15 +- source/lux/data/list.lux | 6 +- source/lux/data/maybe.lux | 3 +- source/lux/data/text.lux | 5 +- source/lux/host/jvm.lux | 20 +-- source/lux/meta/ast.lux | 46 ++++++ source/lux/meta/lux.lux | 13 +- source/lux/meta/macro.lux | 35 +---- source/lux/meta/syntax.lux | 25 ++-- source/program.lux | 5 +- src/lux/type.clj | 30 ++-- 16 files changed, 286 insertions(+), 256 deletions(-) create mode 100644 source/lux/meta/ast.lux diff --git a/source/lux.lux b/source/lux.lux index 798742e6f..deb6025ad 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -135,7 +135,7 @@ #Nil]))])])) (_lux_export Meta) -## (deftype (Syntax' w) +## (deftype (AST' w) ## (| (#BoolS Bool) ## (#IntS Int) ## (#RealS Real) @@ -143,17 +143,17 @@ ## (#TextS Text) ## (#SymbolS Text Text) ## (#TagS Text Text) -## (#FormS (List (w (Syntax' w)))) -## (#TupleS (List (w (Syntax' w)))) -## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(_lux_def Syntax' +## (#FormS (List (w (AST' w)))) +## (#TupleS (List (w (AST' w)))) +## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) +(_lux_def AST' (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "lux;Syntax'") + (#AppT [(#BoundT "lux;AST'") (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [(#Some #Nil) "lux;Syntax'" "w" + AST + (_lux_case (#AppT [List AST]) + ASTList + (#AllT [(#Some #Nil) "lux;AST'" "w" (#VariantT (#Cons [["lux;BoolS" Bool] (#Cons [["lux;IntS" Int] (#Cons [["lux;RealS" Real] @@ -161,23 +161,23 @@ (#Cons [["lux;TextS" Text] (#Cons [["lux;SymbolS" Ident] (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + (#Cons [["lux;FormS" ASTList] + (#Cons [["lux;TupleS" ASTList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))])] #Nil]) ])])])])])])])])]) )])))) -(_lux_export Syntax') +(_lux_export AST') -## (deftype Syntax -## (Meta Cursor (Syntax' (Meta Cursor)))) -(_lux_def Syntax +## (deftype AST +## (Meta Cursor (AST' (Meta Cursor)))) +(_lux_def AST (_lux_case (#AppT [Meta Cursor]) w - (#AppT [w (#AppT [Syntax' w])]))) -(_lux_export Syntax) + (#AppT [w (#AppT [AST' w])]))) +(_lux_export AST) -(_lux_def SyntaxList (#AppT [List Syntax])) +(_lux_def ASTList (#AppT [List AST])) ## (deftype (Either l r) ## (| (#Left l) @@ -246,16 +246,16 @@ ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) ## #imports (List Text) ## )) (_lux_def Module (#AllT [(#Some #Nil) "lux;Module" "Compiler" (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - SyntaxList])])]) + ASTList])])]) #Nil])])) #Nil])]))])] (#Cons [["lux;imports" (#AppT [List Text])] @@ -289,11 +289,11 @@ (_lux_export Compiler) ## (deftype Macro -## (-> (List Syntax) (StateE Compiler (List Syntax)))) +## (-> (List AST) (StateE Compiler (List AST)))) (_lux_def Macro - (#LambdaT [SyntaxList + (#LambdaT [ASTList (#AppT [(#AppT [StateE Compiler]) - SyntaxList])])) + ASTList])])) (_lux_export Macro) ## Base functions & macros @@ -304,12 +304,12 @@ (_lux_: Cursor ["" -1 -1])) ## (def (_meta data) -## (-> (Syntax' (Meta Cursor)) Syntax) +## (-> (AST' (Meta Cursor)) AST) ## (#Meta [["" -1 -1] data])) (_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' + (_lux_: (#LambdaT [(#AppT [AST' (#AppT [Meta Cursor])]) - Syntax]) + AST]) (_lux_lambda _ data (#Meta [_cursor data])))) @@ -348,37 +348,37 @@ (#Left msg))))) (_lux_def text$ - (_lux_: (#LambdaT [Text Syntax]) + (_lux_: (#LambdaT [Text AST]) (_lux_lambda _ text (_meta (#TextS text))))) (_lux_def int$ - (_lux_: (#LambdaT [Int Syntax]) + (_lux_: (#LambdaT [Int AST]) (_lux_lambda _ value (_meta (#IntS value))))) (_lux_def symbol$ - (_lux_: (#LambdaT [Ident Syntax]) + (_lux_: (#LambdaT [Ident AST]) (_lux_lambda _ ident (_meta (#SymbolS ident))))) (_lux_def tag$ - (_lux_: (#LambdaT [Ident Syntax]) + (_lux_: (#LambdaT [Ident AST]) (_lux_lambda _ ident (_meta (#TagS ident))))) (_lux_def form$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_: (#LambdaT [(#AppT [List AST]) AST]) (_lux_lambda _ tokens (_meta (#FormS tokens))))) (_lux_def tuple$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_: (#LambdaT [(#AppT [List AST]) AST]) (_lux_lambda _ tokens (_meta (#TupleS tokens))))) (_lux_def record$ - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))]) AST]) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) @@ -638,7 +638,7 @@ (fail "Wrong syntax for list&"))) (defmacro (lambda' tokens) - (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) (_lux_case tokens (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) [name tokens'] @@ -722,8 +722,8 @@ (defmacro (let' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) + (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) + AST) (lambda' [body binding] (_lux_case binding [label value] @@ -757,7 +757,7 @@ false (any? p xs')))) (def''' (spliced? token) - (->' Syntax Bool) + (->' AST Bool) (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) true @@ -766,13 +766,13 @@ false)) (def''' (wrap-meta content) - (->' Syntax Syntax) + (->' AST AST) (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) content))))))) (def''' (untemplate-list tokens) - (->' ($' List Syntax) Syntax) + (->' ($' List AST) AST) (_lux_case tokens #Nil (_meta (#TagS ["lux" "Nil"])) @@ -801,7 +801,7 @@ (fail "Wrong syntax for $"))) (def''' (splice replace? untemplate tag elems) - (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) + (->' Bool (->' AST AST) AST ($' List AST) AST) (_lux_case replace? true (_lux_case (any? spliced? elems) @@ -813,7 +813,7 @@ _ (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) (tag$ ["lux" "Nil"]))))))))) elems)] @@ -828,8 +828,8 @@ (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) (def''' (untemplate replace? subst token) - (->' Bool Text Syntax Syntax) - (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) + (->' Bool Text AST AST) + (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) [_ (#Meta [_ (#BoolS value)])] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) @@ -875,7 +875,7 @@ [_ (#Meta [_ (#RecordS fields)])] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) + (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) (lambda' [kv] (let' [[k v] kv] (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) @@ -1000,7 +1000,7 @@ (defmacro (do tokens) (_lux_case tokens (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let' [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var @@ -1048,7 +1048,7 @@ (f (g x)))) (def''' (get-ident x) - (-> Syntax ($' Maybe Ident)) + (-> AST ($' Maybe Ident)) (_lux_case x (#Meta [_ (#SymbolS sname)]) (#Some sname) @@ -1057,7 +1057,7 @@ #None)) (def''' (get-name x) - (-> Syntax ($' Maybe Text)) + (-> AST ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) (#Some sname) @@ -1066,7 +1066,7 @@ #None)) (def''' (tuple->list tuple) - (-> Syntax ($' Maybe ($' List Syntax))) + (-> AST ($' Maybe ($' List AST))) (_lux_case tuple (#Meta [_ (#TupleS members)]) (#Some members) @@ -1076,11 +1076,11 @@ (def''' RepEnv Type - ($' List (, Text Syntax))) + ($' List (, Text AST))) (def''' (make-env xs ys) - (-> ($' List Text) ($' List Syntax) RepEnv) - (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + (-> ($' List Text) ($' List AST) RepEnv) + (_lux_case (_lux_: (, ($' List Text) ($' List AST)) [xs ys]) [(#Cons [x xs']) (#Cons [y ys'])] (#Cons [[x y] (make-env xs' ys')]) @@ -1094,7 +1094,7 @@ x [y])) (def''' (get-rep key env) - (-> Text RepEnv ($' Maybe Syntax)) + (-> Text RepEnv ($' Maybe AST)) (_lux_case env #Nil #None @@ -1105,7 +1105,7 @@ (get-rep key env')))) (def''' (apply-template env template) - (-> RepEnv Syntax Syntax) + (-> RepEnv AST AST) (_lux_case template (#Meta [_ (#SymbolS ["" sname])]) (_lux_case (get-rep sname env) @@ -1122,7 +1122,7 @@ (form$ (map (apply-template env) elems)) (#Meta [_ (#RecordS members)]) - (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] [(apply-template env slot) (apply-template env value)]))) @@ -1144,11 +1144,11 @@ (defmacro #export (do-template tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] - (let' [apply (_lux_: (-> RepEnv ($' List Syntax)) + (let' [apply (_lux_: (-> RepEnv ($' List AST)) (lambda' [env] (map (apply-template env) templates)))] (|> data' (join-map (. apply (make-env bindings'))) @@ -1226,7 +1226,7 @@ ($ text:++ module ";" name))) (def''' (replace-syntax reps syntax) - (-> RepEnv Syntax Syntax) + (-> RepEnv AST AST) (_lux_case syntax (#Meta [_ (#SymbolS ["" name])]) (_lux_case (get-rep name reps) @@ -1243,7 +1243,7 @@ (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) (#Meta [_ (#RecordS slots)]) - (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (#Meta [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [slot] (let' [[k v] slot] [(replace-syntax reps k) (replace-syntax reps v)]))) @@ -1254,7 +1254,7 @@ ) (defmacro #export (All tokens) - (let' [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (let' [[self-ident tokens'] (_lux_: (, Text ASTList) (_lux_case tokens (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) [self-ident tokens'] @@ -1270,7 +1270,7 @@ (return (list body)) (#Cons [harg targs]) - (let' [replacements (map (_lux_: (-> Text (, Text Syntax)) + (let' [replacements (map (_lux_: (-> Text (, Text AST)) (lambda' [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) (list& self-ident idents)) body' (foldL (lambda' [body' arg'] @@ -1377,7 +1377,7 @@ (defmacro #export (| tokens) (do Lux/Monad [pairs (map% Lux/Monad - (_lux_: (-> Syntax ($' Lux Syntax)) + (_lux_: (-> AST ($' Lux AST)) (lambda' [token] (_lux_case token (#Meta [_ (#TagS ident)]) @@ -1388,7 +1388,7 @@ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) (do Lux/Monad [ident (normalize ident) - #let [case-body (_lux_: Syntax + #let [case-body (_lux_: AST (_lux_case values #Nil (`' Unit) (#Cons value #Nil) value @@ -1405,7 +1405,7 @@ (fail "& expects an even number of arguments.") (do Lux/Monad [pairs (map% Lux/Monad - (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) + (_lux_: (-> (, AST AST) ($' Lux AST)) (lambda' [pair] (_lux_case pair [(#Meta [_ (#TagS ident)]) value] @@ -1436,7 +1436,7 @@ (list& x sep (interpose sep xs')))) (def''' (macro-expand token) - (-> Syntax ($' Lux ($' List Syntax))) + (-> AST ($' Lux ($' List AST))) (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad @@ -1456,7 +1456,7 @@ (return (list token)))) (def''' (macro-expand-all syntax) - (-> Syntax ($' Lux ($' List Syntax))) + (-> AST ($' Lux ($' List AST))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad @@ -1489,7 +1489,7 @@ (return (list syntax)))) (def''' (walk-type type) - (-> Syntax Syntax) + (-> AST AST) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) (form$ (#Cons [(tag$ tag) (map walk-type parts)])) @@ -1543,21 +1543,21 @@ _ false)) (defmacro #export (deftype tokens) - (let' [[export? tokens'] (: (, Bool (List Syntax)) + (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) - [rec? tokens'] (: (, Bool (List Syntax)) + [rec? tokens'] (: (, Bool (List AST)) (_lux_case tokens' (#Cons (#Meta _ (#TagS "" "rec")) tokens') [true tokens'] _ [false tokens'])) - parts (: (Maybe (, Text (List Syntax) Syntax)) + parts (: (Maybe (, Text (List AST) AST)) (_lux_case tokens' (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) (#Some name #Nil type) @@ -1569,11 +1569,11 @@ #None))] (_lux_case parts (#Some name args type) - (let' [with-export (: (List Syntax) + (let' [with-export (: (List AST) (if export? (list (`' (_lux_export (~ (symbol$ ["" name]))))) #Nil)) - type' (: (Maybe Syntax) + type' (: (Maybe AST) (if rec? (if (empty? args) (let' [g!param (symbol$ ["" ""]) @@ -1600,14 +1600,14 @@ (fail "Wrong syntax for deftype")) )) ## (defmacro #export (deftype tokens) -## (let' [[export? tokens'] (: (, Bool (List Syntax)) -## (_lux_case (:! (List Syntax) tokens) +## (let' [[export? tokens'] (: (, Bool (List AST)) +## (_lux_case (:! (List AST) tokens) ## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) -## [true (:! (List Syntax) tokens')] +## [true (:! (List AST) tokens')] ## _ -## [false (:! (List Syntax) tokens)])) -## parts (: (Maybe (, Syntax (List Syntax) Syntax)) +## [false (:! (List AST) tokens)])) +## parts (: (Maybe (, AST (List AST) AST)) ## (_lux_case tokens' ## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) ## (#Some [(symbol$ name) #Nil type]) @@ -1619,11 +1619,11 @@ ## #None))] ## (_lux_case parts ## (#Some name args type]) -## (let' [with-export (: (List Syntax) +## (let' [with-export (: (List AST) ## (if export? ## (list (`' (_lux_export (~ name)))) ## #Nil)) -## type' (: Syntax +## type' (: AST ## (_lux_case args ## #Nil ## type @@ -1649,14 +1649,14 @@ (fail "Wrong syntax for exec"))) (defmacro (def' tokens) - (let' [[export? tokens'] (: (, Bool (List Syntax)) + (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (_lux_case tokens' (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) (#Some name args (#Some type) body) @@ -1674,14 +1674,14 @@ #None))] (_lux_case parts (#Some name args ?type body) - (let' [body' (: Syntax + (let' [body' (: AST (_lux_case args #Nil body _ (`' (;lambda' (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax + body'' (: AST (_lux_case ?type (#Some type) (`' (: (~ type) (~ body'))) @@ -1697,7 +1697,7 @@ (fail "Wrong syntax for def'")))) (def' (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) + (-> (, AST AST) (List AST)) (let' [[left right] pair] (list left right))) @@ -1706,7 +1706,7 @@ (#Cons value branches) (do Lux/Monad [expansions (map% Lux/Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (: (-> (, AST AST) (Lux (List (, AST AST)))) (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern @@ -1767,7 +1767,7 @@ (fail "Wrong syntax for `")))) (def' (symbol? ast) - (-> Syntax Bool) + (-> AST Bool) (case ast (#Meta _ (#SymbolS _)) true @@ -1780,7 +1780,7 @@ (\ (list (#Meta _ (#TupleS bindings)) body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse - (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (foldL (: (-> AST (, AST AST) AST) (lambda' [body' lr] (let' [[l r] lr] (if (symbol? l) @@ -1795,7 +1795,7 @@ (fail "Wrong syntax for let"))) (def' (ast:show ast) - (-> Syntax Text) + (-> AST Text) (case ast (#Meta _ ast) (case ast @@ -1823,7 +1823,7 @@ (#RecordS kvs) ($ text:++ "{" (|> kvs - (map (: (-> (, Syntax Syntax) Text) + (map (: (-> (, AST AST) Text) (lambda' [kv] (let [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v)))))) (interpose " ") (foldL text:++ "")) @@ -1831,7 +1831,7 @@ ))) (defmacro #export (lambda tokens) - (case (: (Maybe (, Ident Syntax (List Syntax) Syntax)) + (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) (#Some ["" ""] head tail body) @@ -1844,7 +1844,7 @@ (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) - body+ (: Syntax (foldL (: (-> Syntax Syntax Syntax) + body+ (: AST (foldL (: (-> AST AST AST) (lambda' [body' arg] (if (symbol? arg) (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) @@ -1860,14 +1860,14 @@ (fail "Wrong syntax for lambda"))) (defmacro #export (def tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) + (let [[export? tokens'] (: (, Bool (List AST)) (case tokens (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) (#Some name args (#Some type) body) @@ -1885,14 +1885,14 @@ #None))] (case parts (#Some name args ?type body) - (let [body (: Syntax + (let [body (: AST (case args #Nil body _ (` (;lambda (~ name) [(~@ args)] (~ body))))) - body (: Syntax + body (: AST (case ?type (#Some type) (` (: (~ type) (~ body))) @@ -1908,7 +1908,7 @@ (fail "Wrong syntax for def")))) (def (gensym prefix state) - (-> Text (Lux Syntax)) + (-> Text (Lux AST)) (case state {#source source #modules modules #envs envs #types types #host host @@ -1922,18 +1922,18 @@ (do Lux/Monad [tokens' (map% Lux/Monad macro-expand tokens) members (map% Lux/Monad - (: (-> Syntax (Lux (, Ident Syntax))) + (: (-> AST (Lux (, Ident AST))) (lambda [token] (case token (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) (do Lux/Monad [name' (normalize name)] - (;return (: (, Ident Syntax) [name' type]))) + (;return (: (, Ident AST) [name' type]))) _ (fail "Signatures require typed members!")))) (list:join tokens'))] - (;return (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) + (;return (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident AST) AST) (lambda [pair] (let [[name type] pair] (` [(~ (|> name ident->text text$)) @@ -1941,14 +1941,14 @@ members))))))))) (defmacro #export (defsig tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) + (let [[export? tokens'] (: (, Bool (List AST)) (case tokens (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) + ?parts (: (Maybe (, AST (List AST) (List AST))) (case tokens' (\ (list& (#Meta _ (#FormS (list& name args))) sigs)) (#Some name args sigs) @@ -1960,7 +1960,7 @@ #None))] (case ?parts (#Some name args sigs) - (let [sigs' (: Syntax + (let [sigs' (: AST (case args #Nil (` (;sig (~@ sigs))) @@ -1979,13 +1979,13 @@ (do Lux/Monad [tokens' (map% Lux/Monad macro-expand tokens) members (map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) + (: (-> AST (Lux (, AST AST))) (lambda [token] (case token (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS name)) value)))) (do Lux/Monad [name' (normalize name)] - (;return (: (, Syntax Syntax) [(tag$ name') value]))) + (;return (: (, AST AST) [(tag$ name') value]))) _ (fail "Structures require defined members")))) @@ -1993,14 +1993,14 @@ (;return (list (record$ members))))) (defmacro #export (defstruct tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) + (let [[export? tokens'] (: (, Bool (List AST)) (case tokens (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) + ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) (#Some name args type defs) @@ -2012,7 +2012,7 @@ #None))] (case ?parts (#Some name args type defs) - (let [defs' (: Syntax + (let [defs' (: AST (case args #Nil (` (;struct (~@ defs))) @@ -2058,9 +2058,9 @@ (, Text (Maybe Text) Referrals (Maybe Openings))) (def (extract-defs defs) - (-> (List Syntax) (Lux (List Text))) + (-> (List AST) (Lux (List Text))) (map% Lux/Monad - (: (-> Syntax (Lux Text)) + (: (-> AST (Lux Text)) (lambda [def] (case def (#Meta _ (#SymbolS "" name)) @@ -2071,40 +2071,40 @@ defs)) (def (parse-alias tokens) - (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) + (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) - (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) + (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) _ - (return (: (, (Maybe Text) (List Syntax)) [#None tokens])))) + (return (: (, (Maybe Text) (List AST)) [#None tokens])))) (def (parse-referrals tokens) - (-> (List Syntax) (Lux (, Referrals (List Syntax)))) + (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) (case referral (#Meta _ (#TagS "" "all")) - (return (: (, Referrals (List Syntax)) [#All tokens'])) + (return (: (, Referrals (List AST)) [#All tokens'])) (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) + (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) + (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) _ (fail "Incorrect syntax for referral.")) _ - (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) + (return (: (, Referrals (List AST)) [#Nothing tokens])))) (def (extract-symbol syntax) - (-> Syntax (Lux Ident)) + (-> AST (Lux Ident)) (case syntax (#Meta _ (#SymbolS ident)) (return ident) @@ -2113,20 +2113,20 @@ (fail "Not a symbol."))) (def (parse-openings tokens) - (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) + (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] - (return (: (, (Maybe Openings) (List Syntax)) [(#Some prefix structs') tokens']))) + (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) _ - (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) + (return (: (, (Maybe Openings) (List AST)) [#None tokens])))) (def (decorate-imports super-name tokens) - (-> Text (List Syntax) (Lux (List Syntax))) + (-> Text (List AST) (Lux (List AST))) (map% Lux/Monad - (: (-> Syntax (Lux Syntax)) + (: (-> AST (Lux AST)) (lambda [token] (case token (#Meta _ (#SymbolS "" sub-name)) @@ -2140,10 +2140,10 @@ tokens)) (def (parse-imports imports) - (-> (List Syntax) (Lux (List Import))) + (-> (List AST) (Lux (List Import))) (do Lux/Monad [imports' (map% Lux/Monad - (: (-> Syntax (Lux (List Import))) + (: (-> AST (Lux (List Import))) (lambda [token] (case token (#Meta _ (#SymbolS "" m-name)) @@ -2190,7 +2190,7 @@ #seed seed #eval? eval? #expected expected} (case (get module modules) (#Some =module) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) + (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST)))))) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] @@ -2341,7 +2341,7 @@ #Nil (do Lux/Monad [output' (map% Lux/Monad - (: (-> Import (Lux (List Syntax))) + (: (-> Import (Lux (List AST))) (lambda [import] (case import [m-name m-alias m-referrals m-openings] @@ -2362,13 +2362,13 @@ #Nothing (;return (list))) - #let [openings (: (List Syntax) + #let [openings (: (List AST) (case m-openings #None (list) (#Some prefix structs) - (map (: (-> Ident Syntax) + (map (: (-> Ident AST) (lambda [struct] (let [[_ name] struct] (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) @@ -2378,7 +2378,7 @@ (case m-alias #None (list) (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) - (map (: (-> Text Syntax) + (map (: (-> Text AST) (lambda [def] (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) defs) @@ -2387,7 +2387,7 @@ (;return (list:join output'))) _ - (;return (: (List Syntax) + (;return (: (List AST) (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) unknowns) (list (` (import (~@ tokens)))))))))) @@ -2675,12 +2675,12 @@ (#Right state expected)))) (def (use-field field-name type) - (-> Text Type (, Syntax Syntax)) + (-> Text Type (, AST AST)) (let [[module name] (split-slot field-name) - pattern (: Syntax + pattern (: AST (case (resolve-struct-type type) (#Some (#RecordT slots)) - (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (record$ (map (: (-> (, Text Type) (, AST AST)) (lambda [[sname stype]] (use-field sname stype))) slots)) @@ -2697,7 +2697,7 @@ [struct-type (find-var-type name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) - (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (let [pattern (record$ (map (: (-> (, Text Type) (, AST AST)) (lambda [[sname stype]] (use-field sname stype))) slots))] (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) @@ -2726,7 +2726,7 @@ (fail "cond requires an even number of arguments.") (case (reverse tokens) (\ (list& else branches')) - (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (return (list (foldL (: (-> AST (, AST AST) AST) (lambda [else branch] (let [[right left] branch] (` (if (~ left) (~ right) (~ else)))))) @@ -2750,7 +2750,7 @@ (do Lux/Monad [slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + pattern (record$ (map (: (-> (, Text Type) (, AST AST)) (lambda [slot] (let [[r-slot-name r-type] slot [r-prefix r-name] (split-slot r-slot-name)] @@ -2774,12 +2774,12 @@ (fail "Wrong syntax for get@"))) (def (open-field prefix field-name source type) - (-> Text Text Syntax Type (List Syntax)) + (-> Text Text AST Type (List AST)) (let [[module name] (split-slot field-name) - source+ (: Syntax (` (get@ (~ (tag$ [module name])) (~ source))))] + source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))] (case (resolve-struct-type type) (#Some (#RecordT slots)) - (list:join (map (: (-> (, Text Type) (List Syntax)) + (list:join (map (: (-> (, Text Type) (List AST)) (lambda [[sname stype]] (open-field prefix sname source+ stype))) slots)) @@ -2800,7 +2800,7 @@ #let [source (symbol$ struct-name)]] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) - (return (list:join (map (: (-> (, Text Type) (List Syntax)) + (return (list:join (map (: (-> (, Text Type) (List AST)) (lambda [[sname stype]] (open-field prefix sname source stype))) slots))) @@ -2828,7 +2828,7 @@ (\ (list& start parts)) (do Lux/Monad [output (foldL% Lux/Monad - (: (-> Syntax Syntax (Lux Syntax)) + (: (-> AST AST (Lux AST)) (lambda [so-far part] (case part (#Meta _ (#SymbolS slot)) @@ -2857,7 +2857,7 @@ (#Some (#RecordT slots)) (do Lux/Monad [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) + (: (-> (, Text Type) (Lux (, Text AST))) (lambda [slot] (let [[r-slot-name r-type] slot] (do Lux/Monad @@ -2866,12 +2866,12 @@ slots) slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + pattern (record$ (map (: (-> (, Text AST) (, AST AST)) (lambda [slot] (let [[r-slot-name r-var] slot] [(tag$ (split-slot r-slot-name)) r-var]))) pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + output (record$ (map (: (-> (, Text AST) (, AST AST)) (lambda [slot] (let [[r-slot-name r-var] slot [r-prefix r-name] (split-slot r-slot-name)] @@ -2905,7 +2905,7 @@ (#Some (#RecordT slots)) (do Lux/Monad [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) + (: (-> (, Text Type) (Lux (, Text AST))) (lambda [slot] (let [[r-slot-name r-type] slot] (do Lux/Monad @@ -2914,12 +2914,12 @@ slots) slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + pattern (record$ (map (: (-> (, Text AST) (, AST AST)) (lambda [slot] (let [[r-slot-name r-var] slot] [(tag$ (split-slot r-slot-name)) r-var]))) pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + output (record$ (map (: (-> (, Text AST) (, AST AST)) (lambda [slot] (let [[r-slot-name r-var] slot [r-prefix r-name] (split-slot r-slot-name)] @@ -2947,11 +2947,11 @@ (\ (list (#Meta _ (#TupleS data)) (#Meta _ (#TupleS bindings)) (#Meta _ (#TupleS templates)))) - (case (: (Maybe (List Syntax)) + (case (: (Maybe (List AST)) (do Maybe/Monad [bindings' (map% Maybe/Monad get-name bindings) data' (map% Maybe/Monad tuple->list data)] - (let [apply (: (-> RepEnv (List Syntax)) + (let [apply (: (-> RepEnv (List AST)) (lambda [env] (map (apply-template env) templates)))] (|> data' (join-map (. apply (make-env bindings'))) @@ -2996,7 +2996,7 @@ [every? true and]) (def (type->syntax type) - (-> Type Syntax) + (-> Type AST) (case type (#DataT name) (` (#DataT (~ (text$ name)))) @@ -3005,13 +3005,13 @@ (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) (#VariantT cases) - (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) AST) (lambda [[label type]] (tuple$ (list (text$ label) (type->syntax type))))) cases))))) (#RecordT fields) - (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) AST) (lambda [[label type]] (tuple$ (list (text$ label) (type->syntax type))))) fields))))) @@ -3029,10 +3029,10 @@ (` (#ExT (~ (int$ id)))) (#AllT env name arg type) - (let [env' (: Syntax + (let [env' (: AST (case env #None (` #None) - (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) AST) (lambda [[label type]] (tuple$ (list (text$ label) (type->syntax type))))) _env)))))))] @@ -3062,7 +3062,7 @@ (~@ inits)))))) (do Lux/Monad [aliases (map% Lux/Monad - (: (-> Syntax (Lux Syntax)) + (: (-> AST (Lux AST)) (lambda [_] (gensym ""))) inits)] (return (list (` (let [(~@ (interleave aliases inits))] diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index 94968de20..dbb1c13ad 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -7,18 +7,19 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (meta macro) + (lux (meta macro + ast) (control (functor #as F #refer #all) (monad #as M #refer #all)) (data list)) (.. function)) -## Types +## [Types] (deftype #export (Lazy a) (All [b] (-> (-> a b) b))) -## Syntax +## [Syntax] (defmacro #export (... tokens state) (case tokens (\ (list value)) @@ -28,13 +29,13 @@ _ (#;Left "Wrong syntax for ..."))) -## Functions +## [Functions] (def #export (! thunk) (All [a] (-> (Lazy a) a)) (thunk id)) -## Structs +## [Structs] (defstruct #export Lazy/Functor (Functor Lazy) (def (F;map f ma) (lambda [k] (ma (. k f))))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 3bce9ee77..251d77815 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -128,7 +128,7 @@ (do Lux/Monad [patterns (map% Lux/Monad macro-expand-1 patterns') g!s (gensym "s") - #let [patterns+ (: (List Syntax) + #let [patterns+ (: (List AST) (do List/Monad [pattern (l;reverse patterns)] (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index a1168a3cd..e82d079f6 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -11,7 +11,7 @@ lux/data/list lux/meta/macro) -## Signatures +## [Signatures] (defsig #export (CoMonad w) (: (F;Functor w) _functor) @@ -22,18 +22,18 @@ (-> (w a) (w (w a)))) split)) -## Functions +## [Functions] (def #export (extend w f ma) (All [w a b] (-> (CoMonad w) (-> (w a) b) (w a) (w b))) (using w (map f (split ma)))) -## Syntax +## [Syntax] (defmacro #export (be tokens state) (case tokens (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (let [body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 4e4786b63..53ab7301b 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -54,7 +54,7 @@ (case tokens ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) - (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (let [body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index e5b265959..f03dbddc6 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -7,17 +7,18 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/meta macro) - (lux/control (functor #as F) - (monad #as M)) + (lux (meta macro + ast) + (control (functor #as F) + (monad #as M))) (.. list (text #as T #open ("text:" Text/Monoid)))) -## Types +## [Types] (deftype #export (IO a) (-> (,) a)) -## Syntax +## [Syntax] (defmacro #export (io tokens state) (case tokens (\ (list value)) @@ -27,7 +28,7 @@ _ (#;Left "Wrong syntax for io"))) -## Structures +## [Structures] (defstruct #export IO/Functor (F;Functor IO) (def (F;map f ma) (io (f (ma []))))) @@ -41,7 +42,7 @@ (def (M;join mma) (mma []))) -## Functions +## [Functions] (def #export (print x) (-> Text (IO (,))) (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.Object"] diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 1b1711ca7..5b579e243 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -17,7 +17,7 @@ bool) meta/macro)) -## Types +## [Types] ## (deftype (List a) ## (| #Nil ## (#Cons (, a (List a))))) @@ -225,7 +225,7 @@ (#;Some x) (@ (i+ -1 i) xs')))) -## Syntax +## [Syntax] (defmacro #export (list xs state) (#;Right [state (#;Cons [(foldL (lambda [tail head] (` (#;Cons [(~ head) (~ tail)]))) @@ -244,7 +244,7 @@ _ (#;Left "Wrong syntax for list&"))) -## Structures +## [Structures] ## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) ## (def (E;= xs ys) ## (case [xs ys] diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index a6019e256..bba85daf7 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -7,7 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (meta macro) + (lux (meta macro + ast) (control (monoid #as m #refer #all) (functor #as F #refer #all) (monad #as M #refer #all))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index d0a6c46d1..3f6f5d085 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -7,7 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux (meta macro) + (lux (meta macro + ast) (control (monoid #as m) (eq #as E) (ord #as O) @@ -157,7 +158,7 @@ (M;wrap [pre var post]))) (def (unravel-template template) - (-> Text (List Syntax)) + (-> Text (List AST)) (case (extract-var template) (#;Some [pre var post]) (list& (text$ pre) (symbol$ ["" var]) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 2c90b1ba3..f136bd73b 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -14,20 +14,20 @@ (text #as text) (number (int #open ("i" Int/Eq)))) (meta lux - macro + ast syntax))) ## [Utils] ## Parsers (def finally^ - (Parser Syntax) + (Parser AST) (form^ (do Parser/Monad [_ (symbol?^ ["" "finally"]) expr id^] (M;wrap expr)))) (def catch^ - (Parser (, Text Ident Syntax)) + (Parser (, Text Ident AST)) (form^ (do Parser/Monad [_ (symbol?^ ["" "catch"]) ex-class local-symbol^ @@ -60,7 +60,7 @@ (M;wrap [arg-name arg-class])))) (def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (Parser (, (List Text) Text (List (, Text Text)) Text AST)) (form^ (do Parser/Monad [modifiers (*^ local-tag^) name local-symbol^ @@ -70,7 +70,7 @@ (M;wrap [modifiers name inputs output body])))) (def method-call^ - (Parser (, Text (List Text) (List Syntax))) + (Parser (, Text (List Text) (List AST))) (form^ (do Parser/Monad [method local-symbol^ arity-classes (tuple^ (*^ local-symbol^)) @@ -89,7 +89,7 @@ (defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) (emit (list (` (_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident Syntax) Syntax) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident AST) AST) (lambda [catch] (let [[class ex body] catch] (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) @@ -102,7 +102,7 @@ (list (` (_jvm_finally (~ finally))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) (lambda [member] (let [[modifiers name inputs output] member] (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) @@ -115,18 +115,18 @@ [methods (*^ method-def^)]) (do Lux/Monad [current-module get-module-name - #let [fields' (map (: (-> (, (List Text) Text Text) Syntax) + #let [fields' (map (: (-> (, (List Text) Text Text) AST) (lambda [field] (let [[modifiers name class] field] (` ((~ (text$ name)) (~ (text$ class)) [(~@ (map text$ modifiers))]))))) fields) - methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text AST) AST) (lambda [methods] (let [[modifiers name inputs output body] methods] (` ((~ (text$ name)) - [(~@ (map (: (-> (, Text Text) Syntax) + [(~@ (map (: (-> (, Text Text) AST) (lambda [in] (let [[left right] in] (form$ (list (symbol$ ["" left]) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux new file mode 100644 index 000000000..f01f08af1 --- /dev/null +++ b/source/lux/meta/ast.lux @@ -0,0 +1,46 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Types] +## (deftype (AST' w) +## (| (#;BoolS Bool) +## (#;IntS Int) +## (#;RealS Real) +## (#;CharS Char) +## (#;TextS Text) +## (#;SymbolS Text Text) +## (#;TagS Text Text) +## (#;FormS (List (w (AST' w)))) +## (#;TupleS (List (w (AST' w)))) +## (#;RecordS (List (, (w (AST' w)) (w (AST' w))))))) + +## (deftype AST +## (Meta Cursor (AST' (Meta Cursor)))) + +## [Utils] +(def _cursor Cursor ["" -1 -1]) + +## [Functions] +(do-template [ ] + [(def #export ( x) + (-> AST) + (#;Meta _cursor ( x)))] + + [bool$ Bool #;BoolS] + [int$ Int #;IntS] + [real$ Real #;RealS] + [char$ Char #;CharS] + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS] + [tag$ Ident #;TagS] + [form$ (List AST) #;FormS] + [tuple$ (List AST) #;TupleS] + [record$ (List (, AST AST)) #;RecordS] + ) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index e1d821ff0..bc859b823 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -7,7 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (.. macro) + (.. macro + ast) (lux/control (monoid #as m) (functor #as F) (monad #as M #refer (#only do)) @@ -119,7 +120,7 @@ (:: Lux/Monad (M;wrap ident)))) (def #export (macro-expand syntax) - (-> Syntax (Lux (List Syntax))) + (-> AST (Lux (List AST))) (case syntax (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) (do Lux/Monad @@ -139,7 +140,7 @@ (:: Lux/Monad (M;wrap (list syntax))))) (def #export (macro-expand-all syntax) - (-> Syntax (Lux (List Syntax))) + (-> AST (Lux (List AST))) (case syntax (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) (do Lux/Monad @@ -161,7 +162,7 @@ (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (M;map% Lux/Monad macro-expand-all targs)] - (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) + (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) (#;Meta [_ (#;TupleS members)]) (do Lux/Monad @@ -172,7 +173,7 @@ (:: Lux/Monad (M;wrap (list syntax))))) (def #export (gensym prefix state) - (-> Text (Lux Syntax)) + (-> Text (Lux AST)) (#;Right [(update@ #;seed (i+ 1) state) (symbol$ ["__gensym__" (:: I;Int/Show (S;show (get@ #;seed state)))])])) @@ -189,7 +190,7 @@ (#;Left msg))) (def #export (macro-expand-1 token) - (-> Syntax (Lux Syntax)) + (-> AST (Lux AST)) (do Lux/Monad [token+ (macro-expand token)] (case token+ diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux index 22aeaf874..15f3582fa 100644 --- a/source/lux/meta/macro.lux +++ b/source/lux/meta/macro.lux @@ -8,47 +8,24 @@ (;import lux) -## [Utils] -(def (_meta x) - (-> (Syntax' (Meta Cursor)) Syntax) - (#;Meta [["" -1 -1] x])) - ## [Syntax] (def #export (defmacro tokens state) Macro (case tokens (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) + (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) #;Nil])])]) (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) (~ (#;Meta ["" -1 -1] (#;TagS ["" "export"]))) ((~ name) (~@ args)) + (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) #;Nil])])]) _ (#;Left "Wrong syntax for defmacro"))) (_lux_declare-macro defmacro) - -## [Functions] -(do-template [ ] - [(def #export ( x) - (-> Syntax) - (#;Meta [["" -1 -1] ( x)]))] - - [bool$ Bool #;BoolS] - [int$ Int #;IntS] - [real$ Real #;RealS] - [char$ Char #;CharS] - [text$ Text #;TextS] - [symbol$ Ident #;SymbolS] - [tag$ Ident #;TagS] - [form$ (List Syntax) #;FormS] - [tuple$ (List Syntax) #;TupleS] - [record$ (List (, Syntax Syntax)) #;RecordS] - ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 972999fcb..beb2c9e7a 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -8,6 +8,7 @@ (;import lux (.. (macro #as m #refer #all) + ast (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) (monad #as M #refer (#only do)) @@ -31,11 +32,11 @@ #;Nil #;Nil (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) -## Types +## [Types] (deftype #export (Parser a) - (-> (List Syntax) (Maybe (, (List Syntax) a)))) + (-> (List AST) (Maybe (, (List AST) a)))) -## Structures +## [Structures] (defstruct #export Parser/Functor (F;Functor Parser) (def (F;map f ma) (lambda [tokens] @@ -61,9 +62,9 @@ (#;Some [tokens' ma]) (ma tokens'))))) -## Parsers +## [Parsers] (def #export (id^ tokens) - (Parser Syntax) + (Parser AST) (case tokens #;Nil #;None (#;Cons [t tokens']) (#;Some [tokens' t]))) @@ -155,7 +156,7 @@ (def (run-parser p tokens) (All [a] - (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) + (-> (Parser a) (List AST) (Maybe (, (List AST) a)))) (p tokens)) (def #export (*^ p tokens) @@ -210,9 +211,9 @@ #;Nil (#;Some [tokens []]) _ #;None)) -## Syntax +## [Syntax] (defmacro #export (defsyntax tokens) - (let [[exported? tokens] (: (, Bool (List Syntax)) + (let [[exported? tokens] (: (, Bool (List AST)) (case tokens (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) [true tokens'] @@ -224,7 +225,7 @@ body)) (do Lux/Monad [names+parsers (M;map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) + (: (-> AST (Lux (, AST AST))) (lambda [arg] (case arg (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) @@ -241,7 +242,7 @@ g!_ (gensym "_") #let [names (:: List/Functor (F;map first names+parsers)) error-msg (text$ (text:++ "Wrong syntax for " name)) - body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + body' (foldL (: (-> AST (, AST AST) AST) (lambda [body name+parser] (let [[name parser] name+parser] (` (_lux_case ((~ parser) (~ g!tokens)) @@ -251,8 +252,8 @@ (~ g!_) (l;fail (~ error-msg))))))) body - (: (List (, Syntax Syntax)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) - macro-def (: Syntax + (: (List (, AST AST)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) + macro-def (: AST (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) (~ body'))))]] (M;wrap (list& macro-def diff --git a/source/program.lux b/source/program.lux index b7cce5714..02ec633fb 100644 --- a/source/program.lux +++ b/source/program.lux @@ -29,7 +29,7 @@ maybe (number int real) - (text #as t #refer (#only <>) #open ("text:" Text/Monoid)) + (text #refer (#only <>)) writer tuple) (codata (stream #as S) @@ -38,7 +38,8 @@ (reader #as r) state) (host jvm) - (meta lux + (meta ast + lux macro syntax) (math #as m) diff --git a/src/lux/type.clj b/src/lux/type.clj index f40996d7e..18f618b43 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -91,12 +91,12 @@ (def Ident (&/V "lux;TupleT" (&/|list Text Text))) -(def Syntax* - (let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Syntax'") +(def AST* + (let [AST* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") + (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;AST'") (&/V "lux;BoundT" "w"))))) - Syntax*List (&/V "lux;AppT" (&/T List Syntax*))] - (fAll "lux;Syntax'" "w" + AST*List (&/V "lux;AppT" (&/T List AST*))] + (fAll "lux;AST'" "w" (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) (&/T "lux;IntS" Int) (&/T "lux;RealS" Real) @@ -104,16 +104,16 @@ (&/T "lux;TextS" Text) (&/T "lux;SymbolS" Ident) (&/T "lux;TagS" Ident) - (&/T "lux;FormS" Syntax*List) - (&/T "lux;TupleS" Syntax*List) - (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*)))))) + (&/T "lux;FormS" AST*List) + (&/T "lux;TupleS" AST*List) + (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) )))) -(def Syntax +(def AST (let [w (&/V "lux;AppT" (&/T Meta Cursor))] - (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T Syntax* w)))))) + (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T AST* w)))))) -(def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax))) +(def ^:private ASTList (&/V "lux;AppT" (&/T List AST))) (def Either (fAll "lux;Either" "l" @@ -159,9 +159,9 @@ (&/|list Text (&/V "lux;TupleT" (&/|list Bool (&/V "lux;AppT" (&/T DefData* - (&/V "lux;LambdaT" (&/T SyntaxList + (&/V "lux;LambdaT" (&/T ASTList (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) - SyntaxList))))))))))))) + ASTList))))))))))))) (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text))))))) (def $Compiler @@ -183,9 +183,9 @@ $Void))) (def Macro - (&/V "lux;LambdaT" (&/T SyntaxList + (&/V "lux;LambdaT" (&/T ASTList (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) - SyntaxList))))) + ASTList))))) (defn bound? [id] (fn [state] -- cgit v1.2.3 From 691b3e3174e01ed7d859f58442371328aefcfad4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Aug 2015 20:38:02 -0400 Subject: - Struct definition no longer required prefixed members (now, it actually prohibits them). --- source/lux.lux | 469 +++++++++++++++++++++------------------- source/lux/codata/function.lux | 4 +- source/lux/codata/lazy.lux | 12 +- source/lux/codata/reader.lux | 12 +- source/lux/codata/state.lux | 12 +- source/lux/codata/stream.lux | 10 +- source/lux/data/bool.lux | 8 +- source/lux/data/char.lux | 4 +- source/lux/data/error.lux | 8 +- source/lux/data/id.lux | 14 +- source/lux/data/io.lux | 8 +- source/lux/data/list.lux | 32 +-- source/lux/data/maybe.lux | 12 +- source/lux/data/number/int.lux | 40 ++-- source/lux/data/number/real.lux | 40 ++-- source/lux/data/text.lux | 18 +- source/lux/data/writer.lux | 8 +- source/lux/meta/lux.lux | 8 +- source/lux/meta/syntax.lux | 8 +- 19 files changed, 371 insertions(+), 356 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index deb6025ad..ced208d40 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1975,22 +1975,252 @@ #None (fail "Wrong syntax for defsig")))) +(def (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons x xs') + (case (f x) + #None + (some f xs') + + (#Some y) + (#Some y)))) + +(def (last-index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"] + text [part]))) + +(def (index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"] + text [part]))) + +(def (substring1 idx text) + (-> Int Text Text) + (_jvm_invokevirtual "java.lang.String" "substring" ["int"] + text [(_jvm_l2i idx)])) + +(def (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] + text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) + +(def (split-module-contexts module) + (-> Text (List Text)) + (#Cons module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module)))))) + +(def (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (i< idx 0) + (#Cons module #Nil) + (#Cons (substring2 0 idx module) + (split-module (substring1 (i+ 1 idx) module)))))) + +(def (split-slot slot) + (-> Text (, Text Text)) + (let [idx (index-of ";" slot) + module (substring2 0 idx slot) + name (substring1 (i+ 1 idx) slot)] + [module name])) + +(def (type:show type) + (-> Type Text) + (case type + (#DataT name) + ($ text:++ "(^ " name ")") + + (#TupleT elems) + (case elems + #;Nil + "(,)" + + _ + ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")")) + + (#VariantT cases) + (case cases + #;Nil + "(|)" + + _ + ($ text:++ "(| " + (|> cases + (map (: (-> (, Text Type) Text) + (lambda [kv] + (case kv + [k (#TupleT #;Nil)] + ($ text:++ "#" k) + + [k v] + ($ text:++ "(#" k " " (type:show v) ")"))))) + (interpose " ") + (foldL text:++ "")) + ")")) + + (#RecordT fields) + (case fields + #;Nil + "(&)" + + _ + ($ text:++ "(& " + (|> fields + (map (: (-> (, Text Type) Text) + (: (-> (, Text Type) Text) + (lambda [kv] + (let [[k v] kv] + ($ text:++ "(#" k " " (type:show v) ")")))))) + (interpose " ") + (foldL text:++ "")) + ")")) + + (#LambdaT input output) + ($ text:++ "(-> " (type:show input) " " (type:show output) ")") + + (#VarT id) + ($ text:++ "⌈" (->text id) "⌋") + + (#BoundT name) + name + + (#ExT ?id) + ($ text:++ "⟨" (->text ?id) "⟩") + + (#AppT ?lambda ?param) + ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") + + (#AllT ?env ?name ?arg ?body) + ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") + )) + +(def (beta-reduce env type) + (-> (List (, Text Type)) Type Type) + (case type + (#VariantT ?cases) + (#VariantT (map (: (-> (, Text Type) (, Text Type)) + (lambda [kv] + (let [[k v] kv] + [k (beta-reduce env v)]))) + ?cases)) + + (#RecordT ?fields) + (#RecordT (map (: (-> (, Text Type) (, Text Type)) + (lambda [kv] + (let [[k v] kv] + [k (beta-reduce env v)]))) + ?fields)) + + (#TupleT ?members) + (#TupleT (map (beta-reduce env) ?members)) + + (#AppT ?type-fn ?type-arg) + (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) + + (#AllT ?local-env ?local-name ?local-arg ?local-def) + (case ?local-env + #None + (#AllT (#Some env) ?local-name ?local-arg ?local-def) + + (#Some _) + type) + + (#LambdaT ?input ?output) + (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) + + (#BoundT ?name) + (case (get ?name env) + (#Some bound) + bound + + _ + type) + + _ + type + )) + +(def (apply-type type-fn param) + (-> Type Type (Maybe Type)) + (case type-fn + (#AllT env name arg body) + (#Some (beta-reduce (|> (case env + (#Some env) env + _ (list)) + (put name type-fn) + (put arg param)) + body)) + + (#AppT F A) + (do Maybe/Monad + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + _ + #None)) + +(def (resolve-struct-type type) + (-> Type (Maybe Type)) + (case type + (#RecordT slots) + (#Some type) + + (#AppT fun arg) + (apply-type fun arg) + + (#AllT _ _ _ body) + (resolve-struct-type body) + + _ + #None)) + +(def expected-type + (Lux Type) + (lambda [state] + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected} state] + (#Right state expected)))) + (defmacro #export (struct tokens) (do Lux/Monad [tokens' (map% Lux/Monad macro-expand tokens) - members (map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [token] - (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS name)) value)))) - (do Lux/Monad - [name' (normalize name)] - (;return (: (, AST AST) [(tag$ name') value]))) + struct-type expected-type] + (case (resolve-struct-type struct-type) + (#Some (#RecordT slots)) + (do Lux/Monad + [#let [translations (map (: (-> (, Text Type) (, Text Ident)) + (lambda [[sname _]] + (let [[module name] (split-slot sname)] + [name [module name]]))) + slots)] + members (map% Lux/Monad + (: (-> AST (Lux (, AST AST))) + (lambda [token] + (case token + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS ["" name])) value)))) + (case (get name translations) + (#Some tag-name) + (;return (: (, AST AST) [(tag$ tag-name) value])) + + _ + (fail "Structures require defined members")) - _ - (fail "Structures require defined members")))) - (list:join tokens'))] - (;return (list (record$ members))))) + _ + (fail "Structures members must be unqualified.")))) + (list:join tokens'))] + (;return (list (record$ members)))) + + _ + (fail "struct can only use records.")))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) @@ -2205,41 +2435,6 @@ (#Left ($ text:++ "Unknown module: " module))) )) -(def (last-index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "lastIndexOf" ["java.lang.String"] - text [part]))) - -(def (index-of part text) - (-> Text Text Int) - (_jvm_i2l (_jvm_invokevirtual "java.lang.String" "indexOf" ["java.lang.String"] - text [part]))) - -(def (substring1 idx text) - (-> Int Text Text) - (_jvm_invokevirtual "java.lang.String" "substring" ["int"] - text [(_jvm_l2i idx)])) - -(def (substring2 idx1 idx2 text) - (-> Int Int Text Text) - (_jvm_invokevirtual "java.lang.String" "substring" ["int" "int"] - text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) - -(def (split-module-contexts module) - (-> Text (List Text)) - (#Cons module (let [idx (last-index-of "/" module)] - (if (i< idx 0) - #Nil - (split-module-contexts (substring2 0 idx module)))))) - -(def (split-module module) - (-> Text (List Text)) - (let [idx (index-of "/" module)] - (if (i< idx 0) - (#Cons module #Nil) - (#Cons (substring2 0 idx module) - (split-module (substring1 (i+ 1 idx) module)))))) - (def (@ idx xs) (All [a] (-> Int (List a) (Maybe a))) @@ -2392,178 +2587,6 @@ unknowns) (list (` (import (~@ tokens)))))))))) -(def (some f xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #Nil - #None - - (#Cons x xs') - (case (f x) - #None - (some f xs') - - (#Some y) - (#Some y)))) - -(def (split-slot slot) - (-> Text (, Text Text)) - (let [idx (index-of ";" slot) - module (substring2 0 idx slot) - name (substring1 (i+ 1 idx) slot)] - [module name])) - -(def (type:show type) - (-> Type Text) - (case type - (#DataT name) - ($ text:++ "(^ " name ")") - - (#TupleT elems) - (case elems - #;Nil - "(,)" - - _ - ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")")) - - (#VariantT cases) - (case cases - #;Nil - "(|)" - - _ - ($ text:++ "(| " - (|> cases - (map (: (-> (, Text Type) Text) - (lambda [kv] - (case kv - [k (#TupleT #;Nil)] - ($ text:++ "#" k) - - [k v] - ($ text:++ "(#" k " " (type:show v) ")"))))) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#RecordT fields) - (case fields - #;Nil - "(&)" - - _ - ($ text:++ "(& " - (|> fields - (map (: (-> (, Text Type) Text) - (: (-> (, Text Type) Text) - (lambda [kv] - (let [[k v] kv] - ($ text:++ "(#" k " " (type:show v) ")")))))) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#LambdaT input output) - ($ text:++ "(-> " (type:show input) " " (type:show output) ")") - - (#VarT id) - ($ text:++ "⌈" (->text id) "⌋") - - (#BoundT name) - name - - (#ExT ?id) - ($ text:++ "⟨" (->text ?id) "⟩") - - (#AppT ?lambda ?param) - ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - - (#AllT ?env ?name ?arg ?body) - ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") - )) - -(def (beta-reduce env type) - (-> (List (, Text Type)) Type Type) - (case type - (#VariantT ?cases) - (#VariantT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?cases)) - - (#RecordT ?fields) - (#RecordT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?fields)) - - (#TupleT ?members) - (#TupleT (map (beta-reduce env) ?members)) - - (#AppT ?type-fn ?type-arg) - (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - - (#AllT ?local-env ?local-name ?local-arg ?local-def) - (case ?local-env - #None - (#AllT (#Some env) ?local-name ?local-arg ?local-def) - - (#Some _) - type) - - (#LambdaT ?input ?output) - (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) - - (#BoundT ?name) - (case (get ?name env) - (#Some bound) - bound - - _ - type) - - _ - type - )) - -(def (apply-type type-fn param) - (-> Type Type (Maybe Type)) - (case type-fn - (#AllT env name arg body) - (#Some (beta-reduce (|> (case env - (#Some env) env - _ (list)) - (put name type-fn) - (put arg param)) - body)) - - (#AppT F A) - (do Maybe/Monad - [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - _ - #None)) - -(def (resolve-struct-type type) - (-> Type (Maybe Type)) - (case type - (#RecordT slots) - (#Some type) - - (#AppT fun arg) - (apply-type fun arg) - - (#AllT _ _ _ body) - (resolve-struct-type body) - - _ - #None)) - (def (try-both f x1 x2) (All [a b] (-> (-> a (Maybe b)) a a (Maybe b))) @@ -2666,14 +2689,6 @@ #seed seed #eval? eval? #expected expected} state] (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) -(def expected-type - (Lux Type) - (lambda [state] - (let [{#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} state] - (#Right state expected)))) - (def (use-field field-name type) (-> Text Type (, AST AST)) (let [[module name] (split-slot field-name) diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux index 7898e998d..8eb87c00b 100644 --- a/source/lux/codata/function.lux +++ b/source/lux/codata/function.lux @@ -26,5 +26,5 @@ ## [Structures] (defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) - (def m;unit id) - (def m;++ .)) + (def unit id) + (def ++ .)) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index dbb1c13ad..de5c40eef 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -9,8 +9,8 @@ (;import lux (lux (meta macro ast) - (control (functor #as F #refer #all) - (monad #as M #refer #all)) + (control functor + monad) (data list)) (.. function)) @@ -37,13 +37,13 @@ ## [Structs] (defstruct #export Lazy/Functor (Functor Lazy) - (def (F;map f ma) + (def (map f ma) (lambda [k] (ma (. k f))))) (defstruct #export Lazy/Monad (Monad Lazy) - (def M;_functor Lazy/Functor) + (def _functor Lazy/Functor) - (def (M;wrap a) + (def (wrap a) (... a)) - (def M;join !)) + (def join !)) diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux index e91687c3a..ee1798793 100644 --- a/source/lux/codata/reader.lux +++ b/source/lux/codata/reader.lux @@ -7,8 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import (lux #refer (#exclude Reader)) - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) + (lux/control functor + monad)) ## [Types] (deftype #export (Reader r a) @@ -17,17 +17,17 @@ ## [Structures] (defstruct #export Reader/Functor (All [r] (Functor (Reader r))) - (def (F;map f fa) + (def (map f fa) (lambda [env] (f (fa env))))) (defstruct #export Reader/Monad (All [r] (Monad (Reader r))) - (def M;_functor Reader/Functor) + (def _functor Reader/Functor) - (def (M;wrap x) + (def (wrap x) (lambda [env] x)) - (def (M;join mma) + (def (join mma) (lambda [env] (mma env env)))) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index bc9858a29..c6fd8397d 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -7,8 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) + (lux/control functor + monad)) ## [Types] (deftype #export (State s a) @@ -16,20 +16,20 @@ ## [Structures] (defstruct #export State/Functor (Functor State) - (def (F;map f ma) + (def (map f ma) (lambda [state] (let [[state' a] (ma state)] [state' (f a)])))) (defstruct #export State/Monad (All [s] (Monad (State s))) - (def M;_functor State/Functor) + (def _functor State/Functor) - (def (M;wrap x) + (def (wrap x) (lambda [state] [state x])) - (def (M;join mma) + (def (join mma) (lambda [state] (let [[state' ma] (mma state)] (ma state'))))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 251d77815..871c50821 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -113,14 +113,14 @@ ## [Structures] (defstruct #export Stream/Functor (Functor Stream) - (def (F;map f fa) + (def (map f fa) (let [[h t] (! fa)] - (... [(f h) (F;map f t)])))) + (... [(f h) (map f t)])))) (defstruct #export Stream/CoMonad (CoMonad Stream) - (def CM;_functor Stream/Functor) - (def CM;unwrap head) - (def (CM;split wa) + (def _functor Stream/Functor) + (def unwrap head) + (def (split wa) (:: Stream/Functor (F;map repeat wa)))) ## [Pattern-matching] diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index 92f5486ef..8f7a3bd13 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -14,19 +14,19 @@ ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) - (def (E;= x y) + (def (= x y) (if x y (not y)))) (defstruct #export Bool/Show (S;Show Bool) - (def (S;show x) + (def (show x) (if x "true" "false"))) (do-template [ ] [(defstruct #export (m;Monoid Bool) - (def m;unit ) - (def (m;++ x y) + (def unit ) + (def (++ x y) ( x y)))] [ Or/Monoid false or] diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index b97ec644d..04579c3a7 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -13,9 +13,9 @@ ## [Structures] (defstruct #export Char/Eq (E;Eq Char) - (def (E;= x y) + (def (= x y) (_jvm_ceq x y))) (defstruct #export Char/Show (S;Show Char) - (def (S;show x) + (def (show x) ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux index cb5c309a6..7388dd786 100644 --- a/source/lux/data/error.lux +++ b/source/lux/data/error.lux @@ -17,18 +17,18 @@ ## [Structures] (defstruct #export Error/Functor (Functor Error) - (def (F;map f ma) + (def (map f ma) (case ma (#Fail msg) (#Fail msg) (#Ok datum) (#Ok (f datum))))) (defstruct #export Error/Monad (Monad Error) - (def M;_functor Error/Functor) + (def _functor Error/Functor) - (def (M;wrap a) + (def (wrap a) (#Ok a)) - (def (M;join mma) + (def (join mma) (case mma (#Fail msg) (#Fail msg) (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 3ad6b056b..58e7360b8 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -17,16 +17,16 @@ ## [Structures] (defstruct #export Id/Functor (Functor Id) - (def (F;map f fa) + (def (map f fa) (let [(#Id a) fa] (#Id (f a))))) (defstruct #export Id/Monad (Monad Id) - (def M;_functor Id/Functor) - (def (M;wrap a) (#Id a)) - (def (M;join mma) (let [(#Id ma) mma] ma))) + (def _functor Id/Functor) + (def (wrap a) (#Id a)) + (def (join mma) (let [(#Id ma) mma] ma))) (defstruct #export Id/CoMonad (CoMonad Id) - (def CM;_functor Id/Functor) - (def (CM;unwrap wa) (let [(#Id a) wa] a)) - (def (CM;split wa) (#Id wa))) + (def _functor Id/Functor) + (def (unwrap wa) (let [(#Id a) wa] a)) + (def (split wa) (#Id wa))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index f03dbddc6..ae71f9f34 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -30,16 +30,16 @@ ## [Structures] (defstruct #export IO/Functor (F;Functor IO) - (def (F;map f ma) + (def (map f ma) (io (f (ma []))))) (defstruct #export IO/Monad (M;Monad IO) - (def M;_functor IO/Functor) + (def _functor IO/Functor) - (def (M;wrap x) + (def (wrap x) (io x)) - (def (M;join mma) + (def (join mma) (mma []))) ## [Functions] diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 5b579e243..87afe7fe9 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -258,30 +258,30 @@ (defstruct #export List/Monoid (All [a] (Monoid (List a))) - (def m;unit #;Nil) - (def (m;++ xs ys) + (def unit #;Nil) + (def (++ xs ys) (case xs #;Nil ys - (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + (#;Cons [x xs']) (#;Cons [x (++ xs' ys)])))) (defstruct #export List/Functor (Functor List) - (def (F;map f ma) + (def (map f ma) (case ma #;Nil #;Nil - (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) (defstruct #export List/Monad (Monad List) - (def M;_functor List/Functor) + (def _functor List/Functor) - (def (M;wrap a) + (def (wrap a) (#;Cons [a #;Nil])) - (def (M;join mma) + (def (join mma) (using List/Monoid (foldL ++ unit mma)))) (defstruct #export PList/Dict (Dict PList) - (def (D;get k (#PList [eq kvs])) + (def (get k (#PList [eq kvs])) (loop [kvs kvs] (case kvs #;Nil @@ -292,7 +292,7 @@ (#;Some v') (recur kvs'))))) - (def (D;put k v (#PList [eq kvs])) + (def (put k v (#PList [eq kvs])) (#PList [eq (loop [kvs kvs] (case kvs #;Nil @@ -303,7 +303,7 @@ (#;Cons [k v] kvs') (#;Cons [k' v'] (recur kvs')))))])) - (def (D;remove k (#PList [eq kvs])) + (def (remove k (#PList [eq kvs])) (#PList [eq (loop [kvs kvs] (case kvs #;Nil @@ -315,18 +315,18 @@ (#;Cons [[k' v'] (recur kvs')]))))]))) (defstruct #export List/Stack (S;Stack List) - (def S;empty (list)) - (def (S;empty? xs) + (def empty (list)) + (def (empty? xs) (case xs #;Nil true _ false)) - (def (S;push x xs) + (def (push x xs) (#;Cons x xs)) - (def (S;pop xs) + (def (pop xs) (case xs #;Nil #;None (#;Cons x xs') (#;Some xs'))) - (def (S;top xs) + (def (top xs) (case xs #;Nil #;None (#;Cons x xs') (#;Some x)))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index bba85daf7..e23dbe291 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -21,25 +21,25 @@ ## [Structures] (defstruct #export Maybe/Monoid (Monoid Maybe) - (def m;unit #;None) - (def (m;++ xs ys) + (def unit #;None) + (def (++ xs ys) (case xs #;None ys (#;Some x) (#;Some x)))) (defstruct #export Maybe/Functor (Functor Maybe) - (def (F;map f ma) + (def (map f ma) (case ma #;None #;None (#;Some a) (#;Some (f a))))) (defstruct #export Maybe/Monad (Monad Maybe) - (def M;_functor Maybe/Functor) + (def _functor Maybe/Functor) - (def (M;wrap x) + (def (wrap x) (#;Some x)) - (def (M;join mma) + (def (join mma) (case mma #;None #;None (#;Some xs) xs))) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index 35c8d34bf..f3c81ef4e 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -18,20 +18,20 @@ ## Number (do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] [(defstruct #export (N;Number ) - (def (N;+ x y) (<+> x y)) - (def (N;- x y) (<-> x y)) - (def (N;* x y) (<*> x y)) - (def (N;/ x y) ( x y)) - (def (N;% x y) (<%> x y)) - (def (N;from-int x) + (def (+ x y) (<+> x y)) + (def (- x y) (<-> x y)) + (def (* x y) (<*> x y)) + (def (/ x y) ( x y)) + (def (% x y) (<%> x y)) + (def (from-int x) ( x)) - (def (N;negate x) + (def (negate x) (<*> <-1> x)) - (def (N;abs x) + (def (abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (N;signum x) + (def (signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else @@ -42,18 +42,18 @@ ## Eq (defstruct #export Int/Eq (E;Eq Int) - (def (E;= x y) (_jvm_leq x y))) + (def (= x y) (_jvm_leq x y))) ## Ord (do-template [ <=> ] [(defstruct #export (O;Ord ) - (def O;_eq ) - (def (O;< x y) ( x y)) - (def (O;<= x y) + (def _eq ) + (def (< x y) ( x y)) + (def (<= x y) (or ( x y) (<=> x y))) - (def (O;> x y) ( x y)) - (def (O;>= x y) + (def (> x y) ( x y)) + (def (>= x y) (or ( x y) (<=> x y))))] @@ -62,16 +62,16 @@ ## Bounded (do-template [ ] [(defstruct #export (B;Bounded ) - (def B;top ) - (def B;bottom ))] + (def top ) + (def bottom ))] [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) ## Monoid (do-template [ <++>] [(defstruct #export (m;Monoid ) - (def m;unit ) - (def (m;++ x y) (<++> x y)))] + (def unit ) + (def (++ x y) (<++> x y)))] [ IntAdd/Monoid Int 0 _jvm_ladd] [ IntMul/Monoid Int 1 _jvm_lmul] @@ -82,7 +82,7 @@ ## Show (do-template [ ] [(defstruct #export (S;Show ) - (def (S;show x) + (def (show x) ))] [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux index 4f9e4fa5f..9ba05df62 100644 --- a/source/lux/data/number/real.lux +++ b/source/lux/data/number/real.lux @@ -18,20 +18,20 @@ ## Number (do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] [(defstruct #export (N;Number ) - (def (N;+ x y) (<+> x y)) - (def (N;- x y) (<-> x y)) - (def (N;* x y) (<*> x y)) - (def (N;/ x y) ( x y)) - (def (N;% x y) (<%> x y)) - (def (N;from-int x) + (def (+ x y) (<+> x y)) + (def (- x y) (<-> x y)) + (def (* x y) (<*> x y)) + (def (/ x y) ( x y)) + (def (% x y) (<%> x y)) + (def (from-int x) ( x)) - (def (N;negate x) + (def (negate x) (<*> <-1> x)) - (def (N;abs x) + (def (abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (N;signum x) + (def (signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else @@ -42,18 +42,18 @@ ## Eq (defstruct #export Real/Eq (E;Eq Real) - (def (E;= x y) (_jvm_deq x y))) + (def (= x y) (_jvm_deq x y))) ## Ord (do-template [ <=> ] [(defstruct #export (O;Ord ) - (def O;_eq ) - (def (O;< x y) ( x y)) - (def (O;<= x y) + (def _eq ) + (def (< x y) ( x y)) + (def (<= x y) (or ( x y) (<=> x y))) - (def (O;> x y) ( x y)) - (def (O;>= x y) + (def (> x y) ( x y)) + (def (>= x y) (or ( x y) (<=> x y))))] @@ -62,16 +62,16 @@ ## Bounded (do-template [ ] [(defstruct #export (B;Bounded ) - (def B;top ) - (def B;bottom ))] + (def top ) + (def bottom ))] [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) ## Monoid (do-template [ <++>] [(defstruct #export (m;Monoid ) - (def m;unit ) - (def (m;++ x y) (<++> x y)))] + (def unit ) + (def (++ x y) (<++> x y)))] [RealAdd/Monoid Real 0.0 _jvm_dadd] [RealMul/Monoid Real 1.0 _jvm_dmul] @@ -82,7 +82,7 @@ ## Show (do-template [ ] [(defstruct #export (S;Show ) - (def (S;show x) + (def (show x) ))] [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 3f6f5d085..f691be397 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -118,12 +118,12 @@ ## [Structures] (defstruct #export Text/Eq (E;Eq Text) - (def (E;= x y) + (def (= x y) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y]))) (defstruct #export Text/Ord (O;Ord Text) - (def O;_eq Text/Eq) + (def _eq Text/Eq) (do-template [ ] [(def ( x y) @@ -131,17 +131,17 @@ x [y])) 0))] - [O;< i<] - [O;<= i<=] - [O;> i>] - [O;>= i>=])) + [< i<] + [<= i<=] + [> i>] + [>= i>=])) (defstruct #export Text/Show (S;Show Text) - (def S;show id)) + (def show id)) (defstruct #export Text/Monoid (m;Monoid Text) - (def m;unit "") - (def (m;++ x y) + (def unit "") + (def (++ x y) (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y]))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux index f71492e35..7c6831e85 100644 --- a/source/lux/data/writer.lux +++ b/source/lux/data/writer.lux @@ -18,17 +18,17 @@ ## [Structures] (defstruct #export Writer/Functor (All [l] (Functor (Writer l))) - (def (F;map f fa) + (def (map f fa) (let [[log datum] fa] [log (f datum)]))) (defstruct #export (Writer/Monad mon) (All [l] (-> (Monoid l) (Monad (Writer l)))) - (def M;_functor Writer/Functor) + (def _functor Writer/Functor) - (def (M;wrap x) + (def (wrap x) [(:: mon m;unit) x]) - (def (M;join mma) + (def (join mma) (let [[log1 [log2 a]] mma] [(:: mon (m;++ log1 log2)) a]))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index bc859b823..26513ed81 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -29,7 +29,7 @@ ## [Structures] (defstruct #export Lux/Functor (F;Functor Lux) - (def (F;map f fa) + (def (map f fa) (lambda [state] (case (fa state) (#;Left msg) @@ -39,11 +39,11 @@ (#;Right [state' (f a)]))))) (defstruct #export Lux/Monad (M;Monad Lux) - (def M;_functor Lux/Functor) - (def (M;wrap x) + (def _functor Lux/Functor) + (def (wrap x) (lambda [state] (#;Right [state x]))) - (def (M;join mma) + (def (join mma) (lambda [state] (case (mma state) (#;Left msg) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index beb2c9e7a..a69a89cb3 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -38,7 +38,7 @@ ## [Structures] (defstruct #export Parser/Functor (F;Functor Parser) - (def (F;map f ma) + (def (map f ma) (lambda [tokens] (case (ma tokens) #;None @@ -48,12 +48,12 @@ (#;Some [tokens' (f a)]))))) (defstruct #export Parser/Monad (M;Monad Parser) - (def M;_functor Parser/Functor) + (def _functor Parser/Functor) - (def (M;wrap x tokens) + (def (wrap x tokens) (#;Some [tokens x])) - (def (M;join mma) + (def (join mma) (lambda [tokens] (case (mma tokens) #;None -- cgit v1.2.3 From f855c20a7af7428b638e4c2a3c4c654bd01576dc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Aug 2015 00:05:04 -0400 Subject: - The compiler now stores the cursor of the last analysed AST in order to avoid the problem of error ocurring "nowhere" (at ["" -1 -1]). --- source/lux.lux | 36 ++++++++++++++++++++++++------------ source/lux/meta/lux.lux | 9 ++++++--- src/lux/analyser.clj | 43 ++++++++++++++++++++++--------------------- src/lux/base.clj | 35 ++++++++++++++++++++++++++--------- src/lux/type.clj | 1 + 5 files changed, 79 insertions(+), 45 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index ced208d40..36a0997f4 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -270,7 +270,8 @@ ## #host HostState ## #seed Int ## #eval? Bool -## #expected Type)) +## #expected Type +## #cursor Cursor)) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] @@ -284,7 +285,8 @@ (#Cons [["lux;seed" Int] (#Cons [["lux;eval?" Bool] (#Cons [["lux;expected" Type] - #Nil])])])])])])])]))]) + (#Cons [["lux;cursor" Cursor] + #Nil])])])])])])])])]))]) Void])) (_lux_export Compiler) @@ -1316,7 +1318,8 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} + #seed seed #eval? eval? #expected expected + #cursor cursor} (_lux_case (reverse envs) #Nil (#Left "Can't get the module name without a module!") @@ -1355,7 +1358,8 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} + #seed seed #eval? eval? #expected expected + #cursor cursor} (#Right [state (find-macro' modules current-module module name)])))))) (def''' (list:join xs) @@ -1912,10 +1916,12 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} + #seed seed #eval? eval? #expected expected + #cursor cursor} (#Right {#source source #modules modules #envs envs #types types #host host - #seed (i+ 1 seed) #eval? eval? #expected expected} + #seed (i+ 1 seed) #eval? eval? #expected expected + #cursor cursor} (symbol$ ["__gensym__" (->text seed)])))) (defmacro #export (sig tokens) @@ -2187,7 +2193,8 @@ (lambda [state] (let [{#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} state] + #seed seed #eval? eval? #expected expected + #cursor cursor} state] (#Right state expected)))) (defmacro #export (struct tokens) @@ -2403,7 +2410,8 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} + #seed seed #eval? eval? #expected expected + #cursor cursor} (case (get module modules) (#Some =module) (#Right state true) @@ -2417,7 +2425,8 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} + #seed seed #eval? eval? #expected expected + #cursor cursor} (case (get module modules) (#Some =module) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST)))))) @@ -2600,7 +2609,8 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} + #seed seed #eval? eval? #expected expected + #cursor cursor} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -2634,7 +2644,8 @@ (let [[v-prefix v-name] name {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} state] + #seed seed #eval? eval? #expected expected + #cursor cursor} state] (case (get v-prefix modules) #None #None @@ -2686,7 +2697,8 @@ _ (let [{#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval? #expected expected} state] + #seed seed #eval? eval? #expected expected + #cursor cursor} state] (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) (def (use-field field-name type) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 26513ed81..4d6c15bde 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -255,7 +255,8 @@ (case state {#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval? #;expected expected} + #;seed seed #;eval? eval? #;expected expected + #;cursor cursor} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -275,7 +276,8 @@ (let [[v-prefix v-name] name {#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval? #;expected expected} state] + #;seed seed #;eval? eval? #;expected expected + #;cursor cursor} state] (case (get v-prefix modules) #;None #;None @@ -310,6 +312,7 @@ _ (let [{#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval? #;expected expected} state] + #;seed seed #;eval? eval? #;expected expected + #;cursor cursor} state] (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) )) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 774188d82..d18c2cfcf 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -501,10 +501,10 @@ (return* state* output) [["lux;Left" ""]] - (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) [["lux;Left" msg]] - (fail* (add-loc meta msg)) + (fail* (add-loc (&/get$ &/$cursor state) msg)) )) ;; [_] @@ -527,25 +527,26 @@ )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] - (&/with-expected-type exo-type - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) - - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] - (fn [state] - (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) - ] - [["lux;Right" [state* =fn]]] - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - [_] - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - [_] - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))) + (&/with-cursor (aget token 1 0) + (&/with-expected-type exo-type + (matchv ::M/objects [token] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) + + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] + (fn [state] + (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) + ] + [["lux;Right" [state* =fn]]] + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + [_] + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + [_] + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/base.clj b/src/lux/base.clj index ef3c81041..85e8df4d1 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -31,14 +31,15 @@ (def $WRITER 2) ;; Compiler -(def $ENVS 0) -(def $EVAL? 1) -(def $EXPECTED 2) -(def $HOST 3) -(def $MODULES 4) -(def $SEED 5) -(def $SOURCE 6) -(def $TYPES 7) +(def $cursor 0) +(def $ENVS 1) +(def $EVAL? 2) +(def $EXPECTED 3) +(def $HOST 4) +(def $MODULES 5) +(def $SEED 6) +(def $SOURCE 7) +(def $TYPES 8) ;; [Exports] (def +name-separator+ ";") @@ -487,7 +488,9 @@ (V "lux;None" nil)))) (defn init-state [_] - (R ;; "lux;envs" + (R ;; "lux;cursor" + (T "" -1 -1) + ;; "lux;envs" (|list) ;; "lux;eval?" false @@ -628,6 +631,20 @@ [_] output)))) +(defn with-cursor [cursor body] + "(All [a] (-> Cursor (Lux a)))" + (if (= "" (aget cursor 0)) + body + (fn [state] + (let [output (body (set$ $cursor cursor state))] + (matchv ::M/objects [output] + [["lux;Right" [?state ?value]]] + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) + + [_] + output))))) + (defn show-ast [ast] (matchv ::M/objects [ast] [["lux;Meta" [_ ["lux;BoolS" ?value]]]] diff --git a/src/lux/type.clj b/src/lux/type.clj index 18f618b43..e4117492c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -179,6 +179,7 @@ (&/T "lux;seed" Int) (&/T "lux;eval?" Bool) (&/T "lux;expected" Type) + (&/T "lux;cursor" Cursor) ))) $Void))) -- cgit v1.2.3 From 24cc40e76f83188688ad43c499a44508e1aa5d60 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Aug 2015 20:21:04 -0400 Subject: - Local vars can now longer have prefixed symbols. --- source/lux.lux | 220 +++++++++++++++++++++++-------------------- source/lux/codata/stream.lux | 2 +- source/lux/control/monad.lux | 15 +-- source/lux/data/text.lux | 2 +- source/lux/host/jvm.lux | 16 ++-- source/lux/meta/lux.lux | 16 ++-- source/lux/meta/syntax.lux | 20 ++-- src/lux/analyser.clj | 18 ++-- src/lux/analyser/case.clj | 7 +- src/lux/analyser/host.clj | 17 ++-- src/lux/analyser/lambda.clj | 24 ++--- src/lux/analyser/lux.clj | 167 ++++++++++++++++---------------- 12 files changed, 270 insertions(+), 254 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 36a0997f4..7110cc709 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1010,14 +1010,14 @@ (`' (;let' (~ value) (~ body'))) _ - (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] (return (list (`' (_lux_case (~ monad) - {#;return ;return #;bind ;bind} + {#;return wrap #;bind bind} (~ body')))))) _ @@ -1031,16 +1031,16 @@ (-> (B' a) ($' (B' m) (B' b))) ($' List (B' a)) ($' (B' m) ($' List (B' b))))) - (let' [{#;return ;return #;bind _} m] + (let' [{#;return wrap #;bind _} m] (_lux_case xs #Nil - (;return #Nil) + (wrap #Nil) (#Cons [x xs']) (do m [y (f x) ys (map% m f xs')] - (;return (#Cons [y ys]))) + (wrap (#Cons [y ys]))) ))) (def''' (. f g) @@ -1373,7 +1373,7 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (;return (_lux_: Ident [module-name name]))) + (wrap (_lux_: Ident [module-name name]))) _ (return ident))) @@ -1387,7 +1387,7 @@ (#Meta [_ (#TagS ident)]) (do Lux/Monad [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) + (wrap (`' [(~ (text$ (ident->text ident))) (;,)]))) (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) (do Lux/Monad @@ -1397,12 +1397,12 @@ #Nil (`' Unit) (#Cons value #Nil) value _ (`' (, (~@ values)))))]] - (;return (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) + (wrap (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) _ (fail "Wrong syntax for |")))) tokens)] - (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) + (wrap (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1415,12 +1415,12 @@ [(#Meta [_ (#TagS ident)]) value] (do Lux/Monad [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + (wrap (`' [(~ (text$ (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) + (wrap (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) (def''' (->text x) (-> (^ java.lang.Object) Text) @@ -1451,7 +1451,7 @@ (do Lux/Monad [expansion (macro args) expansion' (map% Lux/Monad macro-expand expansion)] - (;return (list:join expansion'))) + (wrap (list:join expansion'))) #None (return (list token)))) @@ -1471,23 +1471,23 @@ (do Lux/Monad [expansion (macro args) expansion' (map% Lux/Monad macro-expand-all expansion)] - (;return (list:join expansion'))) + (wrap (list:join expansion'))) #None (do Lux/Monad [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] - (;return (list (form$ (list:join parts'))))))) + (wrap (list (form$ (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (map% Lux/Monad macro-expand-all targs)] - (;return (list (form$ (list:++ harg+ (list:join targs+)))))) + (wrap (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) (do Lux/Monad [members' (map% Lux/Monad macro-expand-all members)] - (;return (list (tuple$ (list:join members'))))) + (wrap (list (tuple$ (list:join members'))))) _ (return (list syntax)))) @@ -1516,7 +1516,7 @@ [type+ (macro-expand-all type)] (_lux_case type+ (#Cons type' #Nil) - (;return (list (walk-type type'))) + (wrap (list (walk-type type'))) _ (fail "The expansion of the type-syntax had to yield a single element."))) @@ -1718,13 +1718,13 @@ (do Lux/Monad [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] - (;return (list:join expansions))) + (wrap (list:join expansions))) _ - (;return (list branch)))))) + (wrap (list branch)))))) (as-pairs branches))] - (;return (list (`' (_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + (wrap (list (`' (_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) _ (fail "Wrong syntax for case"))) @@ -1736,7 +1736,7 @@ [pattern+ (macro-expand-all pattern)] (case pattern+ (#Cons pattern' #Nil) - (;return (list pattern' body)) + (wrap (list pattern' body)) _ (fail "\\ can only expand to 1 pattern."))) @@ -1754,8 +1754,8 @@ _ (do Lux/Monad [patterns' (map% Lux/Monad macro-expand-all patterns)] - (;return (list:join (map (lambda' [pattern] (list pattern body)) - (list:join patterns')))))) + (wrap (list:join (map (lambda' [pattern] (list pattern body)) + (list:join patterns')))))) _ (fail "Wrong syntax for \\or"))) @@ -1765,7 +1765,7 @@ [module-name get-module-name] (case tokens (\ (list template)) - (;return (list (untemplate true module-name template))) + (wrap (list (untemplate true module-name template))) _ (fail "Wrong syntax for `")))) @@ -1849,13 +1849,13 @@ (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) body+ (: AST (foldL (: (-> AST AST AST) - (lambda' [body' arg] - (if (symbol? arg) - (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) - (` (_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) - body - (reverse tail)))] + (lambda' [body' arg] + (if (symbol? arg) + (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) + (` (_lux_lambda (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail)))] (return (list (if (symbol? head) (` (_lux_lambda (~ g!name) (~ head) (~ body+))) (` (_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) @@ -1922,7 +1922,7 @@ #envs envs #types types #host host #seed (i+ 1 seed) #eval? eval? #expected expected #cursor cursor} - (symbol$ ["__gensym__" (->text seed)])))) + (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) (defmacro #export (sig tokens) (do Lux/Monad @@ -1934,17 +1934,17 @@ (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) (do Lux/Monad [name' (normalize name)] - (;return (: (, Ident AST) [name' type]))) + (wrap (: (, Ident AST) [name' type]))) _ (fail "Signatures require typed members!")))) (list:join tokens'))] - (;return (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident AST) AST) - (lambda [pair] - (let [[name type] pair] - (` [(~ (|> name ident->text text$)) - (~ type)])))) - members))))))))) + (wrap (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident AST) AST) + (lambda [pair] + (let [[name type] pair] + (` [(~ (|> name ident->text text$)) + (~ type)])))) + members))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) @@ -2216,7 +2216,7 @@ (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS ["" name])) value)))) (case (get name translations) (#Some tag-name) - (;return (: (, AST AST) [(tag$ tag-name) value])) + (wrap (: (, AST AST) [(tag$ tag-name) value])) _ (fail "Structures require defined members")) @@ -2224,7 +2224,7 @@ _ (fail "Structures members must be unqualified.")))) (list:join tokens'))] - (;return (list (record$ members)))) + (wrap (list (record$ members)))) _ (fail "struct can only use records.")))) @@ -2384,7 +2384,7 @@ (lambda [token] (case token (#Meta _ (#SymbolS "" m-name)) - (;return (list [m-name #None #All #None])) + (wrap (list [m-name #None #All #None])) (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) (do Lux/Monad @@ -2396,14 +2396,14 @@ #let [[openings extra] openings+extra] extra (decorate-imports m-name extra) sub-imports (parse-imports extra)] - (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) - [#Nothing #None #None] sub-imports - _ (list& [m-name alias referral openings] sub-imports)))) + (wrap (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) + [#Nothing #None #None] sub-imports + _ (list& [m-name alias referral openings] sub-imports)))) _ (fail "Wrong syntax for import")))) imports)] - (;return (list:join imports')))) + (wrap (list:join imports')))) (def (module-exists? module state) (-> Text (Lux Bool)) @@ -2527,7 +2527,7 @@ [m-name m-alias m-referrals m-openings] (do Lux/Monad [m-name (clean-module m-name)] - (;return (: Import [m-name m-alias m-referrals m-openings])))))) + (wrap (: Import [m-name m-alias m-referrals m-openings])))))) imports) unknowns' (map% Lux/Monad (: (-> Import (Lux (List Text))) @@ -2536,9 +2536,9 @@ [m-name _ _ _] (do Lux/Monad [? (module-exists? m-name)] - (;return (if ? - (list) - (list m-name))))))) + (wrap (if ? + (list) + (list m-name))))))) imports) #let [unknowns (list:join unknowns')]] (case unknowns @@ -2557,15 +2557,15 @@ (#Only +defs) (do Lux/Monad [*defs (exported-defs m-name)] - (;return (filter (is-member? +defs) *defs))) + (wrap (filter (is-member? +defs) *defs))) (#Exclude -defs) (do Lux/Monad [*defs (exported-defs m-name)] - (;return (filter (. not (is-member? -defs)) *defs))) + (wrap (filter (. not (is-member? -defs)) *defs))) #Nothing - (;return (list))) + (wrap (list))) #let [openings (: (List AST) (case m-openings #None @@ -2577,24 +2577,24 @@ (let [[_ name] struct] (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] - (;return ($ list:++ - (list (` (_lux_import (~ (text$ m-name))))) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) - (map (: (-> Text AST) - (lambda [def] - (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs) - openings)))))) + (wrap ($ list:++ + (list (` (_lux_import (~ (text$ m-name))))) + (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) + (map (: (-> Text AST) + (lambda [def] + (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + defs) + openings)))))) imports)] - (;return (list:join output'))) + (wrap (list:join output'))) _ - (;return (: (List AST) - (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) - unknowns) - (list (` (import (~@ tokens)))))))))) + (wrap (: (List AST) + (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) + unknowns) + (list (` (import (~@ tokens)))))))))) (def (try-both f x1 x2) (All [a b] @@ -2604,26 +2604,25 @@ (#;Some y) (#;Some y))) (def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None))))) - locals - closure)))) - envs)))) + (-> Text Compiler (Maybe Type)) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= name bname) + (#Some type) + #None))))) + locals + closure)))) + envs))) (def (show-envs envs) (-> (List (Env Text (, LuxVar Type))) Text) @@ -2675,22 +2674,34 @@ ## def (get v-name defs) ## #let [[_ def-data] def]] ## (case def-data -## #TypeD (;return Type) -## (#ValueD type) (;return type) -## (#MacroD m) (;return Macro) +## #TypeD (wrap Type) +## (#ValueD type) (wrap type) +## (#MacroD m) (wrap Macro) ## (#AliasD name') (find-in-defs name' state)))))) -(def (find-var-type name) +(def (find-var-type ident) (-> Ident (Lux Type)) (do Lux/Monad - [name' (normalize name)] + [#let [[module name] ident] + current-module get-module-name] (lambda [state] - (case (find-in-env name state) - (#Some struct-type) - (#Right state struct-type) + (if (text:= "" module) + (case (find-in-env name state) + (#Some struct-type) + (#Right state struct-type) - _ - (case (find-in-defs name' state) + _ + (case (find-in-defs [current-module name] state) + (#Some struct-type) + (#Right state struct-type) + + _ + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) + (case (find-in-defs ident state) (#Some struct-type) (#Right state struct-type) @@ -2699,7 +2710,8 @@ #envs envs #types types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] - (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) + (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) + ))) (def (use-field field-name type) (-> Text Type (, AST AST)) @@ -2982,7 +2994,7 @@ (lambda [env] (map (apply-template env) templates)))] (|> data' (join-map (. apply (make-env bindings'))) - ;return)))) + wrap)))) (#Some output) (return output) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 871c50821..728adc174 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -132,4 +132,4 @@ (do List/Monad [pattern (l;reverse patterns)] (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] - (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) + (wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 53ab7301b..c87c4fdc3 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -9,7 +9,8 @@ (;import lux (.. (functor #as F) (monoid #as M)) - lux/meta/macro) + (lux/meta macro + ast)) ## [Utils] (def (foldL f init xs) @@ -54,7 +55,9 @@ (case tokens ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) - (let [body' (foldL (: (-> AST (, AST AST) AST) + (let [g!map (symbol$ ["" " map "]) + g!join (symbol$ ["" " join "]) + body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var @@ -62,15 +65,13 @@ (` (;let (~ value) (~ body'))) _ - (` (;case ;;_functor - {#F;map F;map} - (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) + (` (;|> (~ value) ((~ g!map) (;lambda [(~ var)] (~ body'))) (~ g!join))) ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) )))) body (reverse (as-pairs bindings)))] (#;Right [state (#;Cons [(` (;case (~ monad) - {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + {#;;_functor {#F;map (~ g!map)} #;;wrap (~ (' wrap)) #;;join (~ g!join)} (~ body'))) #;Nil])])) @@ -95,5 +96,5 @@ (do m [y (f x) ys (map% m f xs')] - (;;wrap (#;Cons [y ys]))) + (wrap (#;Cons [y ys]))) )) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index f691be397..81a642698 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -155,7 +155,7 @@ post-idx (index-of "}" in) [var post] (split post-idx in) [_ post] (split 1 post)] - (M;wrap [pre var post]))) + (wrap [pre var post]))) (def (unravel-template template) (-> Text (List AST)) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index f136bd73b..4f3d6df8a 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -24,7 +24,7 @@ (form^ (do Parser/Monad [_ (symbol?^ ["" "finally"]) expr id^] - (M;wrap expr)))) + (wrap expr)))) (def catch^ (Parser (, Text Ident AST)) @@ -33,7 +33,7 @@ ex-class local-symbol^ ex symbol^ expr id^] - (M;wrap [ex-class ex expr])))) + (wrap [ex-class ex expr])))) (def method-decl^ (Parser (, (List Text) Text (List Text) Text)) @@ -42,7 +42,7 @@ name local-symbol^ inputs (tuple^ (*^ local-symbol^)) output local-symbol^] - (M;wrap [modifiers name inputs output])))) + (wrap [modifiers name inputs output])))) (def field-decl^ (Parser (, (List Text) Text Text)) @@ -50,14 +50,14 @@ [modifiers (*^ local-tag^) name local-symbol^ class local-symbol^] - (M;wrap [modifiers name class])))) + (wrap [modifiers name class])))) (def arg-decl^ (Parser (, Text Text)) (form^ (do Parser/Monad [arg-name local-symbol^ arg-class local-symbol^] - (M;wrap [arg-name arg-class])))) + (wrap [arg-name arg-class])))) (def method-def^ (Parser (, (List Text) Text (List (, Text Text)) Text AST)) @@ -67,7 +67,7 @@ inputs (tuple^ (*^ arg-decl^)) output local-symbol^ body id^] - (M;wrap [modifiers name inputs output body])))) + (wrap [modifiers name inputs output body])))) (def method-call^ (Parser (, Text (List Text) (List AST))) @@ -78,9 +78,9 @@ _ (: (Parser (,)) (if (i= (size arity-classes) (size arity-args)) - (M;wrap []) + (wrap []) (lambda [_] #;None)))] - (M;wrap [method arity-classes arity-args]) + (wrap [method arity-classes arity-args]) ))) ## [Syntax] diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 4d6c15bde..d1bc4e219 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -114,7 +114,7 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (M;wrap (: Ident [module-name name]))) + (wrap (: Ident [module-name name]))) _ (:: Lux/Monad (M;wrap ident)))) @@ -131,7 +131,7 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand expansion)] - (M;wrap (:: List/Monad (M;join expansion')))) + (wrap (:: List/Monad (M;join expansion')))) #;None (:: Lux/Monad (M;wrap (list syntax))))) @@ -151,23 +151,23 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand-all expansion)] - (M;wrap (:: List/Monad (M;join expansion')))) + (wrap (:: List/Monad (M;join expansion')))) #;None (do Lux/Monad [parts' (M;map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] - (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) + (wrap (list (form$ (:: List/Monad (M;join parts')))))))) (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (M;map% Lux/Monad macro-expand-all targs)] - (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) + (wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) (#;Meta [_ (#;TupleS members)]) (do Lux/Monad [members' (M;map% Lux/Monad macro-expand-all members)] - (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) + (wrap (list (tuple$ (:: List/Monad (M;join members')))))) _ (:: Lux/Monad (M;wrap (list syntax))))) @@ -175,7 +175,7 @@ (def #export (gensym prefix state) (-> Text (Lux AST)) (#;Right [(update@ #;seed (i+ 1) state) - (symbol$ ["__gensym__" (:: I;Int/Show (S;show (get@ #;seed state)))])])) + (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (S;show (get@ #;seed state))))])])) (def #export (emit datum) (All [a] @@ -195,7 +195,7 @@ [token+ (macro-expand token)] (case token+ (\ (list token')) - (M;wrap token') + (wrap token') _ (fail "Macro expanded to more than 1 element.")))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index a69a89cb3..f1644cdb5 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -166,7 +166,7 @@ #;None (#;Some [tokens (list)]) (#;Some [tokens' x]) (run-parser (do Parser/Monad [xs (*^ p)] - (M;wrap (list& x xs))) + (wrap (list& x xs))) tokens'))) (def #export (+^ p) @@ -175,7 +175,7 @@ (do Parser/Monad [x p xs (*^ p)] - (M;wrap (list& x xs)))) + (wrap (list& x xs)))) (def #export (&^ p1 p2) (All [a b] @@ -183,7 +183,7 @@ (do Parser/Monad [x1 p1 x2 p2] - (M;wrap [x1 x2]))) + (wrap [x1 x2]))) (def #export (|^ p1 p2 tokens) (All [a b] @@ -192,7 +192,7 @@ (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) #;None (run-parser (do Parser/Monad [x2 p2] - (M;wrap (#;Right x2))) + (wrap (#;Right x2))) tokens))) (def #export (||^ ps tokens) @@ -230,10 +230,10 @@ (case arg (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) parser))])) - (M;wrap [(symbol$ var-name) parser]) + (wrap [(symbol$ var-name) parser]) (\ (#;Meta [_ (#;SymbolS var-name)])) - (M;wrap [(symbol$ var-name) (` id^)]) + (wrap [(symbol$ var-name) (` id^)]) _ (l;fail "Syntax pattern expects 2-tuples or symbols.")))) @@ -256,10 +256,10 @@ macro-def (: AST (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) (~ body'))))]] - (M;wrap (list& macro-def - (if exported? - (list (` (_lux_export (~ (symbol$ ["" name]))))) - (list))))) + (wrap (list& macro-def + (if exported? + (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list))))) _ (l;fail "Wrong syntax for defsyntax")))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index d18c2cfcf..7dc4c7607 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -24,15 +24,18 @@ (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ex-arg]]]] ["lux;Cons" [?catch-body ["lux;Nil" _]]]]]]]]]]]]] - (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] ["lux;Cons" [?finally-body ["lux;Nil" _]]]]]]]]] - (&/T catch+ (&/V "lux;Some" ?finally-body)))) + (return (&/T catch+ (&/V "lux;Some" ?finally-body))) + + [_] + (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] @@ -74,7 +77,7 @@ ;; Programs [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?args]]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -246,7 +249,8 @@ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] ["lux;Cons" [?body ?handlers]]]]]] - (&&host/analyse-jvm-try analyse exo-type ?body (&/fold parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)) + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)] + (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] ["lux;Cons" [?ex @@ -398,8 +402,8 @@ (&&lux/analyse-case analyse exo-type ?value ?branches) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?self]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?arg]]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 77f8c418c..7f2c34924 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -116,12 +116,15 @@ (matchv ::M/objects [pattern] [["lux;Meta" [_ pattern*]]] (matchv ::M/objects [pattern*] - [["lux;SymbolS" ?ident]] - (|do [=kont (&env/with-local (&/ident->text ?ident) value-type + [["lux;SymbolS" ["" name]]] + (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) + [["lux;SymbolS" ident]] + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) + [["lux;BoolS" ?value]] (|do [_ (&type/check value-type &type/Bool) =kont kont] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 663c650e7..d03d0e65c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -299,10 +299,10 @@ ["lux;Nil" _]]]]]]]]]]]]]]]] (|do [=method-inputs (&/map% (fn [minput] (matchv ::M/objects [minput] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?input-name]]] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?input-name]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] ["lux;Nil" _]]]]]]]]] - (return (&/T (&/ident->text ?input-name) ?input-type)) + (return (&/T ?input-name ?input-type)) [_] (fail "[Analyser Error] Wrong syntax for method input."))) @@ -358,7 +358,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) @@ -434,9 +434,8 @@ ) (defn analyse-jvm-program [analyse compile-token ?args ?body] - (|let [[_module _name] ?args] - (|do [=body (&/with-scope "" - (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V "jvm-program" =body))] - (return (&/|list))))) + (|do [=body (&/with-scope "" + (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V "jvm-program" =body))] + (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index b1b9e2c22..7c7b80577 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -16,26 +16,22 @@ ;; [Resource] (defn with-lambda [self self-type arg arg-type body] - (|let [[?module1 ?name1] self - [?module2 ?name2] arg] - (&/with-closure - (|do [scope-name &/get-scope-name] - (&env/with-local (str ?module1 ";" ?name1) self-type - (&env/with-local (str ?module2 ";" ?name2) arg-type - (|do [=return body - =captured &env/captured-vars] - (return (&/T scope-name =captured =return))))))))) + (&/with-closure + (|do [scope-name &/get-scope-name] + (&env/with-local self self-type + (&env/with-local arg arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T scope-name =captured =return)))))))) -(defn close-over [scope ident register frame] +(defn close-over [scope name register frame] (matchv ::M/objects [register] [[_ register-type]] (|let [register* (&/T (&/V "captured" (&/T scope (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) register)) - register-type) - [?module ?name] ident - full-name (str ?module ";" ?name)] + register-type)] (&/T register* (&/update$ &/$CLOSURE #(->> % (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put full-name register* mps)))) + (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) frame))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index c86df3027..7aba5dd39 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -143,90 +143,91 @@ ?elems)] (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) +(defn ^:private analyse-global [analyse exo-type module name] + (|do [[[r-module r-name] $def] (&&module/find-def module name) + ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" [?type _]]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type))))) + +(defn ^:private analyse-local [analyse exo-type name] + (fn [state] + (|let [stack (&/get$ &/$ENVS state) + no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) + (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) + [inner outer] (&/|split-with no-binding? stack)] + (matchv ::M/objects [outer] + [["lux;Nil" _]] + (&/run-state (|do [module-name &/get-module-name] + (analyse-global analyse exo-type module-name name)) + state) + + [["lux;Cons" [?genv ["lux;Nil" _]]]] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) + (matchv ::M/objects [global] + [[["lux;Global" [?module* name*]] _]] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) + ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" [?type _]]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) + + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) + (fail* "_{_ analyse-symbol _}_"))) + + [["lux;Cons" [top-outer _]]] + (do ;; (prn 'analyse-symbol/_3 ?module name) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) + (&/|map #(&/get$ &/$NAME %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name)) + (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get name))) + (&/|list)) + (&/|reverse inner) scopes)] + ((|do [btype (&&/expr-type =local) + _ (&type/check exo-type btype)] + (return (&/|list =local))) + (&/set$ &/$ENVS (&/|++ inner* outer) state)))) + )))) + (defn analyse-symbol [analyse exo-type ident] - (|do [module-name &/get-module-name] - (fn [state] - (|let [[?module ?name] ident - ;; _ (prn 'analyse-symbol/_0 ?module ?name) - local-ident (str ?module ";" ?name) - stack (&/get$ &/$ENVS state) - no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not) - (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not)) - [inner outer] (&/|split-with no-binding? stack)] - (matchv ::M/objects [outer] - [["lux;Nil" _]] - (do ;; (prn 'analyse-symbol/_1 - ;; [?module ?name] - ;; [(if (.equals "" ?module) module-name ?module) - ;; ?name]) - ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) - ?name) - ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state)) - - [["lux;Cons" [?genv ["lux;Nil" _]]]] - (do ;; (prn 'analyse-symbol/_2 ?module ?name local-ident (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] - (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* ?name*]] _]] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) - ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) - - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) - (fail* "_{_ analyse-symbol _}_"))) - - [["lux;Cons" [top-outer _]]] - (do ;; (prn 'analyse-symbol/_3 ?module ?name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) - (&/|reverse inner))) - [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] - (|let [[register new-inner] register+new-inner - [register* frame*] (&&lambda/close-over (&/|reverse in-scope) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/|reverse inner) scopes)] - ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state)))) - ))) + (|do [:let [[?module ?name] ident]] + (if (= "" ?module) + (analyse-local analyse exo-type ?name) + (analyse-global analyse exo-type ?module ?name)) )) (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] -- cgit v1.2.3 From 218af254c30f35d290ab944aef1cf2b33e179224 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 18:33:25 -0400 Subject: - Refacted the compiler by shifting to a pattern-matching syntax more akin to Lux's, while also allowing non-literal tags that can be defined as constants elsewhere. - Added some extra JVM ops for bit-fiddling that were missing. --- src/lux/analyser.clj | 499 ++++++++++++++++++++++---------------------- src/lux/analyser/base.clj | 13 +- src/lux/analyser/case.clj | 157 +++++++------- src/lux/analyser/env.clj | 10 +- src/lux/analyser/host.clj | 117 ++++++----- src/lux/analyser/lambda.clj | 23 +- src/lux/analyser/lux.clj | 169 ++++++++------- src/lux/analyser/module.clj | 85 ++++---- src/lux/base.clj | 297 ++++++++++++++------------ src/lux/compiler.clj | 247 +++++++++++----------- src/lux/compiler/cache.clj | 8 +- src/lux/compiler/case.clj | 24 +-- src/lux/compiler/host.clj | 67 +++--- src/lux/compiler/lambda.clj | 16 +- src/lux/compiler/lux.clj | 16 +- src/lux/compiler/type.clj | 28 +-- src/lux/host.clj | 12 +- src/lux/parser.clj | 87 ++++---- src/lux/reader.clj | 34 +-- src/lux/type.clj | 343 +++++++++++++++--------------- 20 files changed, 1141 insertions(+), 1111 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 7dc4c7607..e49797fa5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -8,9 +8,9 @@ (ns lux.analyser (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail*]] + (lux [base :as & :refer [|let |do return fail return* fail* |case]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -21,471 +21,483 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ex-arg]]]] - ["lux;Cons" [?catch-body - ["lux;Nil" _]]]]]]]]]]]]] + (|case token + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_catch")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?ex-class)) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ex-arg)) + ("lux;Cons" ?catch-body + ("lux;Nil"))))))) (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] - ["lux;Cons" [?finally-body - ["lux;Nil" _]]]]]]]]] + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_finally")) + ("lux;Cons" ?finally-body + ("lux;Nil"))))) (return (&/T catch+ (&/V "lux;Some" ?finally-body))) - [_] + _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Arrays - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new-array")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?length)) + ("lux;Nil"))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Cons" [?elem - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aastore")) + ("lux;Cons" ?array + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) + ("lux;Cons" ?elem + ("lux;Nil")))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aaload")) + ("lux;Cons" ?array + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) + ("lux;Nil"))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_class")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?super-class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?interfaces)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?fields)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?methods)) + ("lux;Nil")))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] - ?methods]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_interface")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?supers)) + ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?args]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_program")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?args)) + ("lux;Cons" ?body + ("lux;Nil"))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) - [_] + _ (fail ""))) (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Primitive conversions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2b")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2c")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2s")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iand")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ior")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ixor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_land")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lxor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) - [_] + _ (aba7 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Objects - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_null?")) + ("lux;Cons" ?object + ("lux;Nil")))) (&&host/analyse-jvm-null? analyse exo-type ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_instanceof")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ?object + ("lux;Nil"))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getstatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Nil"))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getfield")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?object + ("lux;Nil")))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putstatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?value + ("lux;Nil")))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?object - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putfield")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?object + ("lux;Cons" ?value + ("lux;Nil"))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokestatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil"))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokevirtual")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokeinterface")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokespecial")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] - ["lux;Cons" [?body - ?handlers]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_try")) + ("lux;Cons" ?body + ?handlers))) (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] - ["lux;Cons" [?ex - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_throw")) + ("lux;Cons" ?ex + ("lux;Nil")))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorenter")) + ("lux;Cons" ?monitor + ("lux;Nil")))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorexit")) + ("lux;Cons" ?monitor + ("lux;Nil")))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) - [_] + _ (aba6 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Float arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) - - [_] + + _ (aba5 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba3 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Host special forms ;; Characters - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) - [_] + _ (aba4 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] - [["lux;SymbolS" ?ident]] + (|case token + ("lux;SymbolS" ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] - ["lux;Cons" [?value ?branches]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_case")) + ("lux;Cons" ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?self]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?arg]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_lambda")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?self)) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?arg)) + ("lux;Cons" ?body + ("lux;Nil")))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_def")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-def analyse compile-token ?name ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_declare-macro")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) + ("lux;Nil")))) (&&lux/analyse-declare-macro analyse compile-token ?name) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_import")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?path)) + ("lux;Nil")))) (&&lux/analyse-import analyse compile-module compile-token ?path) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:")) + ("lux;Cons" ?type + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:!")) + ("lux;Cons" ?type + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_export")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ident)) + ("lux;Nil")))) (&&lux/analyse-export analyse compile-token ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_alias")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?alias)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?module)) + ("lux;Nil"))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) - [_] + _ (aba3 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Standard special forms - [["lux;BoolS" ?value]] + ("lux;BoolS" ?value) (|do [_ (&type/check exo-type &type/Bool)] (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - [["lux;IntS" ?value]] + ("lux;IntS" ?value) (|do [_ (&type/check exo-type &type/Int)] (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - [["lux;RealS" ?value]] + ("lux;RealS" ?value) (|do [_ (&type/check exo-type &type/Real)] (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - [["lux;CharS" ?value]] + ("lux;CharS" ?value) (|do [_ (&type/check exo-type &type/Char)] (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - [["lux;TextS" ?value]] + ("lux;TextS" ?value) (|do [_ (&type/check exo-type &type/Text)] (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - [["lux;TupleS" ?elems]] + ("lux;TupleS" ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) - [["lux;RecordS" ?elems]] + ("lux;RecordS" ?elems) (&&lux/analyse-record analyse exo-type ?elems) - [["lux;TagS" ?ident]] + ("lux;TagS" ?ident) (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) - [["lux;SymbolS" [_ "_jvm_null"]]] + ("lux;SymbolS" _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) - [_] + _ (aba2 analyse eval! compile-module compile-token exo-type token) )) @@ -497,30 +509,27 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) - (matchv ::M/objects [token] - [["lux;Meta" [meta ?token]]] + (|case token + ("lux;Meta" meta ?token) (fn [state] - (matchv ::M/objects [((aba1 analyse eval! compile-module compile-token exo-type ?token) state)] - [["lux;Right" [state* output]]] + (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" ""]] + ("lux;Left" "") (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* (add-loc (&/get$ &/$cursor state) msg)) )) - - ;; [_] - ;; (assert false (aget token 0)) )) (defn ^:private just-analyse [analyser syntax] (&type/with-var (fn [?var] (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] - (matchv ::M/objects [?var ?output-type] - [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] + (|case [?var ?output-type] + [("lux;VarT" ?e-id) ("lux;VarT" ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] (return (&/T ?output-term ?output-type*))) @@ -533,23 +542,21 @@ (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] (&/with-cursor (aget token 1 0) (&/with-expected-type exo-type - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] + (|case token + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) ?values))) (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ?fn ?args))) (fn [state] - (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) - ] - [["lux;Right" [state* =fn]]] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + ("lux;Right" state* =fn) (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - [_] + _ ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - [_] + _ (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 9fc3f1030..beeb57b08 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -7,24 +7,23 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.base - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [type :as &type]))) ;; [Exports] (defn expr-type [syntax+] - (matchv ::M/objects [syntax+] - [[_ type]] + (|let [[_ type] syntax+] (return type))) (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] + (|case output + ("lux;Cons" x ("lux;Nil")) (return x) - [_] + _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn resolved-ident [ident] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 7f2c34924..2cdf233cc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.case - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail |let]] + (lux [base :as & :refer [|do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -20,13 +20,13 @@ (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))) (defn ^:private resolve-type [type] - (matchv ::M/objects [type] - [["lux;VarT" ?id]] + (|case type + ("lux;VarT" ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (resolve-type type*)) - [["lux;AllT" [_aenv _aname _aarg _abody]]] + ("lux;AllT" _aenv _aname _aarg _abody) ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] @@ -36,20 +36,20 @@ ;; (|do [=type (&type/apply-type type $var)] ;; (&type/actual-type =type)))) - [_] + _ (&type/actual-type type))) (defn adjust-type* [up type] "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - (matchv ::M/objects [type] - [["lux;AllT" [_aenv _aname _aarg _abody]]] + (|case type + ("lux;AllT" _aenv _aname _aarg _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - [["lux;TupleT" ?members]] - (|do [["lux;TupleT" ?members*] (&/fold% (fn [_abody ena] + ("lux;TupleT" ?members) + (|do [("lux;TupleT" ?members*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -63,8 +63,8 @@ up)) ?members*)))) - [["lux;RecordT" ?fields]] - (|do [["lux;RecordT" ?fields*] (&/fold% (fn [_abody ena] + ("lux;RecordT" ?fields) + (|do [("lux;RecordT" ?fields*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -79,8 +79,8 @@ up)))) ?fields*)))) - [["lux;VariantT" ?cases]] - (|do [["lux;VariantT" ?cases*] (&/fold% (fn [_abody ena] + ("lux;VariantT" ?cases) + (|do [("lux;VariantT" ?cases*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -95,11 +95,11 @@ up)))) ?cases*)))) - [["lux;AppT" [?tfun ?targ]]] + ("lux;AppT" ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] (adjust-type* up =type)) - [["lux;VarT" ?id]] + ("lux;VarT" ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (adjust-type* up type*)) @@ -113,48 +113,47 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (matchv ::M/objects [pattern] - [["lux;Meta" [_ pattern*]]] - (matchv ::M/objects [pattern*] - [["lux;SymbolS" ["" name]]] + (|let [("lux;Meta" _ pattern*) pattern] + (|case pattern* + ("lux;SymbolS" "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) - [["lux;SymbolS" ident]] + ("lux;SymbolS" ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - [["lux;BoolS" ?value]] + ("lux;BoolS" ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] (return (&/T (&/V "BoolTestAC" ?value) =kont))) - [["lux;IntS" ?value]] + ("lux;IntS" ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] (return (&/T (&/V "IntTestAC" ?value) =kont))) - [["lux;RealS" ?value]] + ("lux;RealS" ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] (return (&/T (&/V "RealTestAC" ?value) =kont))) - [["lux;CharS" ?value]] + ("lux;CharS" ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] (return (&/T (&/V "CharTestAC" ?value) =kont))) - [["lux;TextS" ?value]] + ("lux;TextS" ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] (return (&/T (&/V "TextTestAC" ?value) =kont))) - [["lux;TupleS" ?members]] + ("lux;TupleS" ?members) (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (matchv ::M/objects [value-type*] - [["lux;TupleT" ?member-types]] + (|case value-type* + ("lux;TupleT" ?member-types) (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) @@ -167,48 +166,48 @@ (&/|reverse (&/zip2 ?member-types ?members)))] (return (&/T (&/V "TupleTestAC" =tests) =kont))))) - [_] + _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - - [["lux;RecordS" ?slots]] + + ("lux;RecordS" ?slots) (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] value-type* (adjust-type value-type) ;; :let [_ (prn 'POST (&type/show-type value-type*))] ;; value-type* (resolve-type value-type) ] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?slot-types]] + (|case value-type* + ("lux;RecordT" ?slot-types) (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] - (matchv ::M/objects [sn] - [["lux;Meta" [_ ["lux;TagS" ?ident]]]] + (|case sn + ("lux;Meta" _ ("lux;TagS" ?ident)) (|do [=tag (&&/resolved-ident ?ident)] (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] (return (&/T (&/|put =tag =test =tests) =kont))) (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) - [_] + _ (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) (|do [=kont kont] (return (&/T (&/|table) =kont))) (&/|reverse ?slots))] (return (&/T (&/V "RecordTestAC" =tests) =kont)))) - [_] + _ (fail "[Pattern-matching Error] Record requires record-type."))) - [["lux;TagS" ?ident]] + ("lux;TagS" ?ident) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] - ?values]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) + ?values)) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) @@ -228,50 +227,50 @@ (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] - (matchv ::M/objects [struct test] - [["DefaultTotal" total?] ["StoreTestAC" ?idx]] + (|case [struct test] + [("DefaultTotal" total?) ("StoreTestAC" ?idx)] (return (&/V "DefaultTotal" true)) - [[?tag [total? ?values]] ["StoreTestAC" ?idx]] + [[?tag [total? ?values]] ("StoreTestAC" ?idx)] (return (&/V ?tag (&/T true ?values))) - [["DefaultTotal" total?] ["BoolTestAC" ?value]] + [("DefaultTotal" total?) ("BoolTestAC" ?value)] (return (&/V "BoolTotal" (&/T total? (&/|list ?value)))) - [["BoolTotal" [total? ?values]] ["BoolTestAC" ?value]] + [("BoolTotal" total? ?values) ("BoolTestAC" ?value)] (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["IntTestAC" ?value]] + [("DefaultTotal" total?) ("IntTestAC" ?value)] (return (&/V "IntTotal" (&/T total? (&/|list ?value)))) - [["IntTotal" [total? ?values]] ["IntTestAC" ?value]] + [("IntTotal" total? ?values) ("IntTestAC" ?value)] (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["RealTestAC" ?value]] + [("DefaultTotal" total?) ("RealTestAC" ?value)] (return (&/V "RealTotal" (&/T total? (&/|list ?value)))) - [["RealTotal" [total? ?values]] ["RealTestAC" ?value]] + [("RealTotal" total? ?values) ("RealTestAC" ?value)] (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["CharTestAC" ?value]] + [("DefaultTotal" total?) ("CharTestAC" ?value)] (return (&/V "CharTotal" (&/T total? (&/|list ?value)))) - [["CharTotal" [total? ?values]] ["CharTestAC" ?value]] + [("CharTotal" total? ?values) ("CharTestAC" ?value)] (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["TextTestAC" ?value]] + [("DefaultTotal" total?) ("TextTestAC" ?value)] (return (&/V "TextTotal" (&/T total? (&/|list ?value)))) - [["TextTotal" [total? ?values]] ["TextTestAC" ?value]] + [("TextTotal" total? ?values) ("TextTestAC" ?value)] (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["TupleTestAC" ?tests]] + [("DefaultTotal" total?) ("TupleTestAC" ?tests)] (|do [structs (&/map% (fn [t] (merge-total (&/V "DefaultTotal" total?) (&/T t ?body))) ?tests)] (return (&/V "TupleTotal" (&/T total? structs)))) - [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] + [("TupleTotal" total? ?values) ("TupleTestAC" ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T t ?body))) @@ -279,7 +278,7 @@ (return (&/V "TupleTotal" (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [["DefaultTotal" total?] ["RecordTestAC" ?tests]] + [("DefaultTotal" total?) ("RecordTestAC" ?tests)] (|do [structs (&/map% (fn [t] (|let [[slot value] t] (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] @@ -290,7 +289,7 @@ &/->list))] (return (&/V "RecordTotal" (&/T total? structs)))) - [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] + [("RecordTotal" total? ?values) ("RecordTestAC" ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [left right] (|let [[lslot sub-struct] left @@ -307,12 +306,12 @@ (return (&/V "RecordTotal" (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent record-size.")) - [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] + [("DefaultTotal" total?) ("VariantTestAC" ?tag ?test)] (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) (&/T ?test ?body))] (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct (&/|table)))))) - [["VariantTotal" [total? ?branches]] ["VariantTestAC" [?tag ?test]]] + [("VariantTotal" total? ?branches) ("VariantTestAC" ?tag ?test)] (|do [sub-struct (merge-total (or (&/|get ?tag ?branches) (&/V "DefaultTotal" total?)) (&/T ?test ?body))] @@ -320,43 +319,43 @@ )))) (defn ^:private check-totality [value-type struct] - (matchv ::M/objects [struct] - [["BoolTotal" [?total ?values]]] + (|case struct + ("BoolTotal" ?total ?values) (return (or ?total (= #{true false} (set (&/->seq ?values))))) - [["IntTotal" [?total _]]] + ("IntTotal" ?total _) (return ?total) - [["RealTotal" [?total _]]] + ("RealTotal" ?total _) (return ?total) - [["CharTotal" [?total _]]] + ("CharTotal" ?total _) (return ?total) - [["TextTotal" [?total _]]] + ("TextTotal" ?total _) (return ?total) - [["TupleTotal" [?total ?structs]]] + ("TupleTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;TupleT" ?members]] + (|case value-type* + ("lux;TupleT" ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Tuple is not total.")))) - [["RecordTotal" [?total ?structs]]] + ("RecordTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?fields]] + (|case value-type* + ("lux;RecordT" ?fields) (|do [totals (&/map% (fn [field] (|let [[?tk ?tv] field] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -365,15 +364,15 @@ ?fields)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Record is not total.")))) - [["VariantTotal" [?total ?structs]]] + ("VariantTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;VariantT" ?cases]] + (|case value-type* + ("lux;VariantT" ?cases) (|do [totals (&/map% (fn [case] (|let [[?tk ?tv] case] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -382,10 +381,10 @@ ?cases)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Variant is not total.")))) - [["DefaultTotal" ?total]] + ("DefaultTotal" ?total) (return ?total) )) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 391d78411..a39ec490a 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.env - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail]]) + (lux [base :as & :refer [|do return return* fail |case]]) [lux.analyser.base :as &&])) ;; [Exports] @@ -31,8 +31,8 @@ (&/|head stack)) (&/|tail stack)))) state))] - (matchv ::M/objects [=return] - [["lux;Right" [?state ?value]]] + (|case =return + ("lux;Right" ?state ?value) (return* (&/update$ &/$ENVS (fn [stack*] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER dec) @@ -42,7 +42,7 @@ ?state) ?value) - [_] + _ =return)))) (def captured-vars diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index d03d0e65c..707060323 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -8,9 +8,9 @@ (ns lux.analyser.host (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -19,39 +19,37 @@ ;; [Utils] (defn ^:private extract-text [text] - (matchv ::M/objects [text] - [["lux;Meta" [_ ["lux;TextS" ?text]]]] + (|case text + ("lux;Meta" _ ("lux;TextS" ?text)) (return ?text) - [_] + _ (fail "[Analyser Error] Can't extract Text."))) (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token)] - (matchv ::M/objects [=expr] - [[?item ?type]] - (|do [=type (&type/clean $var ?type)] - (return (&/T ?item =type))) - ))))) + (|do [=expr (&&/analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" - (matchv ::M/objects [token] - [[_ ["lux;DataT" _]]] + (|case token + [_ ("lux;DataT" _)] (return nil) - [_] + _ (fail "[Analyser Error] Expecting object"))) (defn ^:private as-object [type] "(-> Type Type)" - (matchv ::M/objects [type] - [["lux;DataT" class]] + (|case type + ("lux;DataT" class) (&/V "lux;DataT" (&type/as-obj class)) - [_] + _ type)) ;; [Resources] @@ -225,32 +223,32 @@ (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] - (matchv ::M/objects [modif] - [["lux;Meta" [_ ["lux;TextS" "public"]]]] + (|case modif + ("lux;Meta" _ ("lux;TextS" "public")) (return (assoc so-far :visibility "public")) - [["lux;Meta" [_ ["lux;TextS" "private"]]]] + ("lux;Meta" _ ("lux;TextS" "private")) (return (assoc so-far :visibility "private")) - [["lux;Meta" [_ ["lux;TextS" "protected"]]]] + ("lux;Meta" _ ("lux;TextS" "protected")) (return (assoc so-far :visibility "protected")) - [["lux;Meta" [_ ["lux;TextS" "static"]]]] + ("lux;Meta" _ ("lux;TextS" "static")) (return (assoc so-far :static? true)) - [["lux;Meta" [_ ["lux;TextS" "final"]]]] + ("lux;Meta" _ ("lux;TextS" "final")) (return (assoc so-far :final? true)) - [["lux;Meta" [_ ["lux;TextS" "abstract"]]]] + ("lux;Meta" _ ("lux;TextS" "abstract")) (return (assoc so-far :abstract? true)) - [["lux;Meta" [_ ["lux;TextS" "synchronized"]]]] + ("lux;Meta" _ ("lux;TextS" "synchronized")) (return (assoc so-far :concurrency "synchronized")) - [["lux;Meta" [_ ["lux;TextS" "volatile"]]]] + ("lux;Meta" _ ("lux;TextS" "volatile")) (return (assoc so-far :concurrency "volatile")) - [_] + _ (fail (str "[Analyser Error] Unknown modifier: " (&/show-ast modif))))) {:visibility "default" :static? false @@ -276,35 +274,35 @@ (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] - (matchv ::M/objects [?field] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-type]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?field-modifiers]]] - ["lux;Nil" _]]]]]]]]]]] + (|case ?field + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-type)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?field-modifiers)) + ("lux;Nil")))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers :type ?field-type})) - [_] + _ (fail "[Analyser Error] Wrong syntax for field."))) ?fields) =methods (&/map% (fn [?method] - (matchv ::M/objects [?method] - [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-output]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-modifiers]]] - ["lux;Cons" [?method-body - ["lux;Nil" _]]]]]]]]]]]]]]]] + (|case ?method + [?idx ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-inputs)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-output)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-modifiers)) + ("lux;Cons" ?method-body + ("lux;Nil"))))))))] (|do [=method-inputs (&/map% (fn [minput] - (matchv ::M/objects [minput] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?input-name]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] - ["lux;Nil" _]]]]]]]]] + (|case minput + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?input-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?input-type)) + ("lux;Nil"))))) (return (&/T ?input-name ?input-type)) - [_] + _ (fail "[Analyser Error] Wrong syntax for method input."))) ?method-inputs) =method-modifiers (analyse-modifiers ?method-modifiers) @@ -326,7 +324,7 @@ :output ?method-output :body =method-body})) - [_] + _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) _ (compile-token (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))] @@ -335,12 +333,12 @@ (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] - (matchv ::M/objects [method] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?output]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?modifiers]]] - ["lux;Nil" _]]]]]]]]]]]]] + (|case method + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?inputs)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?output)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?modifiers)) + ("lux;Nil"))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -348,7 +346,7 @@ :inputs =inputs :output ?output})) - [_] + _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) _ (compile-token (&/V "jvm-interface" (&/T ?name =supers =methods)))] @@ -363,10 +361,10 @@ idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (matchv ::M/objects [?finally] - [["lux;None" _]] (return (&/V "lux;None" nil)) - [["lux;Some" ?finally*]] (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V "lux;Some" =finally))))] + =finally (|case [?finally] + ("lux;None") (return (&/V "lux;None" nil)) + ("lux;Some" ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (return (&/V "lux;Some" =finally))))] (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] @@ -423,11 +421,14 @@ analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ixor "jvm-ixor" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishl "jvm-ishl" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishr "jvm-ishr" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-iushr "jvm-iushr" "java.lang.Integer" "java.lang.Integer" analyse-jvm-land "jvm-land" "java.lang.Long" "java.lang.Long" analyse-jvm-lor "jvm-lor" "java.lang.Long" "java.lang.Long" analyse-jvm-lxor "jvm-lxor" "java.lang.Long" "java.lang.Long" - analyse-jvm-lshl "jvm-lshl" "java.lang.Long" "java.lang.Integer" analyse-jvm-lshr "jvm-lshr" "java.lang.Long" "java.lang.Integer" analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer" diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 7c7b80577..a230c8642 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.lambda - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -25,13 +25,12 @@ (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] - (matchv ::M/objects [register] - [[_ register-type]] - (|let [register* (&/T (&/V "captured" (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) - register)) - register-type)] - (&/T register* (&/update$ &/$CLOSURE #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) - frame))))) + (|let [[_ register-type] register + register* (&/T (&/V "captured" (&/T scope + (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) + register)) + register-type)] + (&/T register* (&/update$ &/$CLOSURE #(->> % + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) + frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 7aba5dd39..cd89764c3 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -8,9 +8,9 @@ (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -23,68 +23,66 @@ (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token)] - (matchv ::M/objects [=expr] - [[?item ?type]] - (|do [=type (&type/clean $var ?type)] - (return (&/T ?item =type))) - ))))) + (|do [=expr (&&/analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) (defn ^:private with-cursor [cursor form] - (matchv ::M/objects [form] - [["lux;Meta" [_ syntax]]] + (|case form + ("lux;Meta" _ syntax) (&/V "lux;Meta" (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] - (matchv ::M/objects [exo-type*] - [["lux;TupleT" ?members]] + (|case exo-type* + ("lux;TupleT" ?members) (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) ?members ?elems)] (return (&/|list (&/T (&/V "tuple" =elems) exo-type)))) - [["lux;AllT" _]] + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-tuple analyse exo-type** ?elems)))) - [_] + _ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) (defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [output (matchv ::M/objects [?values] - [["lux;Nil" _]] + (|do [output (|case ?values + ("lux;Nil") (analyse-tuple analyse exo-type (&/|list)) - [["lux;Cons" [?value ["lux;Nil" _]]]] + ("lux;Cons" ?value ("lux;Nil")) (analyse exo-type ?value) - [_] + _ (analyse-tuple analyse exo-type ?values) )] - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] + (|case output + ("lux;Cons" x ("lux;Nil")) (return x) - [_] + _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn analyse-variant [analyse exo-type ident ?values] - (|do [exo-type* (matchv ::M/objects [exo-type] - [["lux;VarT" ?id]] + (|do [exo-type* (|case exo-type + ("lux;VarT" ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) (|do [_ (&type/set-var ?id &type/Type)] (&type/actual-type &type/Type)))) - [_] + _ (&type/actual-type exo-type))] - (matchv ::M/objects [exo-type*] - [["lux;VariantT" ?cases]] + (|case exo-type* + ("lux;VariantT" ?cases) (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] (|do [=value (analyse-variant-body analyse vtype ?values)] @@ -92,22 +90,22 @@ exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - [["lux;AllT" _]] + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** ident ?values)))) - [_] + _ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - (|do [exo-type* (matchv ::M/objects [exo-type] - [["lux;VarT" ?id]] + (|do [exo-type* (|case exo-type + ("lux;VarT" ?id) (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) - [["lux;AllT" _]] + ("lux;AllT" _) (|do [$var &type/existential =type (&type/apply-type exo-type $var)] (&type/actual-type =type)) @@ -116,21 +114,21 @@ ;; (|do [=type (&type/apply-type exo-type $var)] ;; (&type/actual-type =type)))) - [_] + _ (&type/actual-type exo-type)) - types (matchv ::M/objects [exo-type*] - [["lux;RecordT" ?table]] + types (|case exo-type* + ("lux;RecordT" ?table) (return ?table) - [_] + _ (fail (str "[Analyser Error] The type of a record must be a record type:\n" (&type/show-type exo-type*) "\n"))) _ (&/assert! (= (&/|length types) (&/|length ?elems)) (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) =slots (&/map% (fn [kv] - (matchv ::M/objects [kv] - [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] + (|case kv + [("lux;Meta" _ ["lux;TagS" ?ident]) ?value] (|do [?tag (&&/resolved-ident ?ident) slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) @@ -138,7 +136,7 @@ =value (&&/analyse-1 analyse slot-type ?value)] (return (&/T ?tag =value))) - [_] + _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) ?elems)] (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) @@ -146,14 +144,14 @@ (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] + endo-type (|case $def + ("lux;ValueD" ?type _) (return ?type) - [["lux;MacroD" _]] + ("lux;MacroD" _) (return &type/Macro) - [["lux;TypeD" _]] + ("lux;TypeD" _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -168,28 +166,28 @@ no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] - (matchv ::M/objects [outer] - [["lux;Nil" _]] + (|case outer + ("lux;Nil") (&/run-state (|do [module-name &/get-module-name] (analyse-global analyse exo-type module-name name)) state) - [["lux;Cons" [?genv ["lux;Nil" _]]]] + ("lux;Cons" ?genv ("lux;Nil")) (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* name*]] _]] + (|case global + [("lux;Global" ?module* name*) _] ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] + endo-type (|case $def + ("lux;ValueD" ?type _) (return ?type) - [["lux;MacroD" _]] + ("lux;MacroD" _) (return &type/Macro) - [["lux;TypeD" _]] + ("lux;TypeD" _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -204,7 +202,7 @@ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) - [["lux;Cons" [top-outer _]]] + ("lux;Cons" top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) (&/|map #(&/get$ &/$NAME %) outer) @@ -232,15 +230,15 @@ (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] ;; (prn 'analyse-apply* (aget fun-type 0)) - (matchv ::M/objects [?args] - [["lux;Nil" _]] + (|case ?args + ("lux;Nil") (|do [_ (&type/check exo-type fun-type)] (return (&/T fun-type (&/|list)))) - [["lux;Cons" [?arg ?args*]]] + ("lux;Cons" ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" [_aenv _aname _aarg _abody]]] + (|case ?fun-type* + ("lux;AllT" _aenv _aname _aarg _abody) ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -248,8 +246,8 @@ (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] + (|case $var + ("lux;VarT" ?id) (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) @@ -258,7 +256,7 @@ (return (&/T type** =args))) )))) - [["lux;LambdaT" [?input-t ?output-t]]] + ("lux;LambdaT" ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) @@ -266,19 +264,18 @@ ;; [["lux;VarT" ?id-t]] ;; (|do [ (&type/deref ?id-t)]) - [_] + _ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) (defn analyse-apply [analyse exo-type form-cursor =fn ?args] (|do [loader &/loader] - (matchv ::M/objects [=fn] - [[=fn-form =fn-type]] - (matchv ::M/objects [=fn-form] - [["lux;Global" [?module ?name]]] + (|let [[=fn-form =fn-type] =fn] + (|case =fn-form + ("lux;Global" ?module ?name) (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] - (matchv ::M/objects [$def] - [["lux;MacroD" macro]] + (|case $def + ("lux;MacroD" macro) (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] @@ -293,12 +290,12 @@ ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) - [_] + _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) =output-t)))))) - [_] + _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) =output-t))))) @@ -316,8 +313,8 @@ (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|do [exo-type* (&type/actual-type exo-type)] - (matchv ::M/objects [exo-type] - [["lux;AllT" _]] + (|case exo-type + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -326,38 +323,38 @@ ;; exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - [["lux;LambdaT" [?arg-t ?return-t]]] + ("lux;LambdaT" ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) - [_] + _ (fail (str "[Analyser Error] Functions require function types: " (&type/show-type exo-type*)))))) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] - (matchv ::M/objects [exo-type] - [["lux;AllT" [_env _self _arg _body]]] + (|case exo-type + ("lux;AllT" _env _self _arg _body) (&type/with-var (fn [$var] (|do [exo-type* (&type/apply-type exo-type $var) [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] + (|case $var + ("lux;VarT" ?id) (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id) ;; dtype* (&type/actual-type dtype) ] - (matchv ::M/objects [dtype] - [["lux;BoundT" ?vname]] + (|case dtype + ("lux;BoundT" ?vname) (return (&/T _expr exo-type)) - [["lux;ExT" _]] + ("lux;ExT" _) (return (&/T _expr exo-type)) - [["lux;VarT" ?_id]] + ("lux;VarT" ?_id) (|do [?? (&type/bound? ?_id)] ;; (return (&/T _expr exo-type)) (if ?? @@ -365,11 +362,11 @@ (return (&/T _expr exo-type))) ) - [_] + _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) - [_] + _ (|do [exo-type* (&type/actual-type exo-type)] (analyse-lambda* analyse exo-type* ?self ?arg ?body)) )) @@ -389,15 +386,15 @@ (|do [=value (&/with-scope ?name (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] - (matchv ::M/objects [=value] - [[["lux;Global" [?r-module ?r-name]] _]] + (|case =value + [("lux;Global" ?r-module ?r-name) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] ] (return (&/|list))) - [_] + _ (do (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V "def" (&/T ?name =value)))] (return (&/|list))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 327dad27f..c92b7b976 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -9,9 +9,9 @@ (ns lux.analyser.module (:refer-clojure :exclude [alias]) (:require [clojure.string :as string] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return return* fail fail*]] + (lux [base :as & :refer [|let |do return return* fail fail* |case]] [type :as &type] [host :as &host]) [lux.analyser.base :as &&])) @@ -44,8 +44,8 @@ (defn define [module name def-data type] (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -57,7 +57,7 @@ ms)))) nil) - [_] + _ (fail* (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))))) (defn def-type [module name] @@ -65,17 +65,17 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[_ ["lux;TypeD" _]]] + (|case $def + [_ ("lux;TypeD" _)] (return* state &type/Type) - [[_ ["lux;MacroD" _]]] + [_ ("lux;MacroD" _)] (return* state &type/Macro) - [[_ ["lux;ValueD" [_type _]]]] + [_ ("lux;ValueD" _type _)] (return* state _type) - [[_ ["lux;AliasD" [?r-module ?r-name]]]] + [_ ("lux;AliasD" ?r-module ?r-name)] (&/run-state (def-type ?r-module ?r-name) state)) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) @@ -84,8 +84,8 @@ (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -97,7 +97,7 @@ ms)))) nil) - [_] + _ (fail* "[Analyser Error] Can't alias a global definition outside of a global environment.")))) (defn exists? [name] @@ -133,17 +133,16 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[exported? $$def]] + (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] + (|case $$def + ("lux;AliasD" ?r-module ?r-name) (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) ((find-def ?r-module ?r-name) state)) - [_] + _ (return* state (&/T (&/T module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) @@ -158,8 +157,8 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? ["lux;ValueD" [?type _]]]] + (|case $def + [exported? ("lux;ValueD" ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) @@ -178,24 +177,24 @@ nil))) state) - [[_ ["lux;MacroD" _]]] + [_ ("lux;MacroD" _)] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) - [[_ _]] + [_ _] (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module does not exist: " module))))) (defn export [module name] (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[true _]] + (|case $def + [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) - [[false ?data]] + [false ?data] (return* (->> state (&/update$ &/$MODULES (fn [ms] (&/|update module (fn [m] @@ -206,7 +205,7 @@ nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) - [_] + _ (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) (def defs @@ -214,22 +213,20 @@ (fn [state] (return* state (&/|map (fn [kv] - (|let [[k v] kv] - (matchv ::M/objects [v] - [[?exported? ?def]] - (do ;; (prn 'defs k ?exported?) - (matchv ::M/objects [?def] - [["lux;AliasD" [?r-module ?r-name]]] - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - - [["lux;MacroD" _]] - (&/T ?exported? k "M") - - [["lux;TypeD" _]] - (&/T ?exported? k "T") - - [_] - (&/T ?exported? k "V")))))) + (|let [[k [?exported? ?def]] kv] + (do ;; (prn 'defs k ?exported?) + (|case ?def + ("lux;AliasD" ?r-module ?r-name) + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + + ("lux;MacroD" _) + (&/T ?exported? k "M") + + ("lux;TypeD" _) + (&/T ?exported? k "T") + + _ + (&/T ?exported? k "V"))))) (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) (def imports diff --git a/src/lux/base.clj b/src/lux/base.clj index 85e8df4d1..bcd113daa 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -12,6 +12,7 @@ clojure.core.match.array)) ;; [Tags] +(def $Nil "lux;Nil") (def $Cons "lux;Cons") ;; [Fields] @@ -73,10 +74,33 @@ (defn return* [state value] (V "lux;Right" (T state value))) +(defn transform-pattern [pattern] + (cond (vector? pattern) (mapv transform-pattern pattern) + (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] + (vec (cons (eval (first pattern)) + (list (case (count parts) + 0 '_ + 1 (first parts) + ;; else + `[~@parts]))))) + :else pattern + )) + +(defmacro |case [value & branches] + (assert (= 0 (mod (count branches) 2))) + (let [value* (if (vector? value) + [`(T ~@value)] + [value])] + `(matchv ::M/objects ~value* + ~@(mapcat (fn [[pattern body]] + (list [(transform-pattern pattern)] + body)) + (partition 2 branches))))) + (defmacro |let [bindings body] (reduce (fn [inner [left right]] - `(matchv ::M/objects [~right] - [~left] + `(|case ~right + ~left ~inner)) body (reverse (partition 2 bindings)))) @@ -94,59 +118,62 @@ (reverse (partition 2 elems)))) (defn |get [slot table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) nil - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) v (|get slot table*)))) (defn |put [slot value table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) (V "lux;Cons" (T (T slot value) table*)) - (V "lux;Cons" (T (T k v) (|put slot value table*)))))) + (V "lux;Cons" (T (T k v) (|put slot value table*)))) + + _ + (assert false (prn-str '|put (aget table 0))))) (defn |remove [slot table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) table - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) table* (V "lux;Cons" (T (T k v) (|remove slot table*)))))) (defn |update [k f table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) table - [["lux;Cons" [[k* v] table*]]] + ($Cons [k* v] table*) (if (.equals ^Object k k*) (V "lux;Cons" (T (T k* (f v)) table*)) (V "lux;Cons" (T (T k* v) (|update k f table*)))))) (defn |head [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (assert false) - [["lux;Cons" [x _]]] + ($Cons x _) x)) (defn |tail [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (assert false) - [["lux;Cons" [_ xs*]]] + ($Cons _ xs*) xs*)) ;; [Resources/Monads] @@ -161,11 +188,11 @@ (defn bind [m-value step] (fn [state] (let [inputs (m-value state)] - (matchv ::M/objects [inputs] - [["lux;Right" [?state ?datum]]] + (|case inputs + ("lux;Right" ?state ?datum) ((step ?datum) ?state) - [["lux;Left" _]] + ("lux;Left" _) inputs )))) @@ -177,8 +204,8 @@ ;; else `(bind ~computation (fn [val#] - (matchv ::M/objects [val#] - [~label] + (|case val# + ~label ~inner))))) return (reverse (partition 2 steps)))) @@ -188,90 +215,90 @@ (V "lux;Cons" (T head tail))) (defn |++ [xs ys] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) ys - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T x (|++ xs* ys))))) (defn |map [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T (f x) (|map f xs*))))) (defn |empty? [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) true - [["lux;Cons" [_ _]]] + ($Cons _ _) false)) (defn |filter [p xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (if (p x) (V "lux;Cons" (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|++ (f x) (flat-map f xs*)))) (defn |split-with [p xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (T xs xs) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] (T (|cons x pre) post)) (T (V "lux;Nil" nil) xs)))) (defn |contains? [k table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) false - [["lux;Cons" [[k* _] table*]]] + ($Cons [k* _] table*) (or (.equals ^Object k k*) (|contains? k table*)))) (defn fold [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) init - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (fold f (f init x) xs*))) (defn fold% [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (return init) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|do [init* (f init x)] (fold% f init* xs*)))) (defn folds [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (|list init) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|cons init (folds f (f init x) xs*)))) (defn |length [xs] @@ -293,47 +320,47 @@ _2)) (defn zip2 [xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (V "lux;Cons" (T (T x y) (zip2 xs* ys*))) [_ _] (V "lux;Nil" nil))) (defn |keys [plist] - (matchv ::M/objects [plist] - [["lux;Nil" _]] + (|case plist + ($Nil) (|list) - [["lux;Cons" [[k v] plist*]]] + ($Cons [k v] plist*) (|cons k (|keys plist*)))) (defn |vals [plist] - (matchv ::M/objects [plist] - [["lux;Nil" _]] + (|case plist + ($Nil) (|list) - [["lux;Cons" [[k v] plist*]]] + ($Cons [k v] plist*) (|cons v (|vals plist*)))) (defn |interpose [sep xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [_ ["lux;Nil" _]]]] + ($Cons _ ($Nil)) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T x (V "lux;Cons" (T sep (|interpose sep xs*))))))) (do-template [ ] (defn [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (return xs) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|do [y (f x) ys ( f xs*)] (return ( y ys))))) @@ -345,11 +372,11 @@ (fold |++ (V "lux;Nil" nil) xss)) (defn |as-pairs [xs] - (matchv ::M/objects [xs] - [["lux;Cons" [x ["lux;Cons" [y xs*]]]]] + (|case xs + ($Cons x ($Cons y xs*)) (V "lux;Cons" (T (T x y) (|as-pairs xs*))) - [_] + _ (V "lux;Nil" nil))) (defn |reverse [xs] @@ -368,18 +395,18 @@ (return* state state))) (defn try-all% [monads] - (matchv ::M/objects [monads] - [["lux;Nil" _]] + (|case monads + ($Nil) (fail "There are no alternatives to try!") - [["lux;Cons" [m monads*]]] + ($Cons m monads*) (fn [state] (let [output (m state)] - (matchv ::M/objects [output monads*] - [["lux;Right" _] _] + (|case [output monads*] + [("lux;Right" _) _] output - [_ ["lux;Nil" _]] + [_ ($Nil)] output [_ _] @@ -395,11 +422,11 @@ (defn exhaust% [step] (fn [state] - (matchv ::M/objects [(step state)] - [["lux;Right" [state* _]]] + (|case (step state) + ("lux;Right" state* _) ((exhaust% step) state*) - [["lux;Left" msg]] + ("lux;Left" msg) (if (.equals "[Reader Error] EOF" msg) (return* state nil) (fail* msg))))) @@ -510,23 +537,23 @@ (defn save-module [body] (fn [state] - (matchv ::M/objects [(body state)] - [["lux;Right" [state* output]]] + (|case (body state) + ("lux;Right" state* output) (return* (->> state* (set$ $ENVS (get$ $ENVS state)) (set$ $SOURCE (get$ $SOURCE state))) output) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg)))) (defn with-eval [body] (fn [state] - (matchv ::M/objects [(body (set$ $EVAL? true state))] - [["lux;Right" [state* output]]] + (|case (body (set$ $EVAL? true state)) + ("lux;Right" state* output) (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg)))) (def get-eval @@ -536,11 +563,11 @@ (def get-writer (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] - (matchv ::M/objects [writer*] - [["lux;Some" datum]] + (|case writer* + ("lux;Some" datum) (return* state datum) - [_] + _ (fail* "Writer hasn't been set."))))) (def get-top-local-env @@ -556,11 +583,11 @@ (return* (set$ $SEED (inc seed) state) seed)))) (defn ->seq [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (list) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (cons x (->seq xs*)))) (defn ->list [seq] @@ -575,21 +602,21 @@ (def get-module-name (fn [state] - (matchv ::M/objects [(|reverse (get$ $ENVS state))] - [["lux;Nil"]] + (|case (|reverse (get$ $ENVS state)) + ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") - [["lux;Cons" [?global _]]] + ($Cons ?global _) (return* state (get$ $NAME ?global))))) (defn with-scope [name body] (fn [state] (let [output (body (update$ $ENVS #(|cons (env name) %) state))] - (matchv ::M/objects [output] - [["lux;Right" [state* datum]]] + (|case output + ("lux;Right" state* datum) (return* (update$ $ENVS |tail state*) datum) - [_] + _ output)))) (defn run-state [monad state] @@ -611,24 +638,24 @@ (defn with-writer [writer body] (fn [state] (let [output (body (update$ $HOST #(set$ $WRITER (V "lux;Some" writer) %) state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) ?value) - [_] + _ output)))) (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] (let [output (body (set$ $EXPECTED type state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) ?value) - [_] + _ output)))) (defn with-cursor [cursor body] @@ -637,50 +664,50 @@ body (fn [state] (let [output (body (set$ $cursor cursor state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (set$ $cursor (get$ $cursor state) ?state) ?value) - [_] + _ output))))) (defn show-ast [ast] - (matchv ::M/objects [ast] - [["lux;Meta" [_ ["lux;BoolS" ?value]]]] + (|case ast + ("lux;Meta" _ ["lux;BoolS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;IntS" ?value]]]] + ("lux;Meta" _ ["lux;IntS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;RealS" ?value]]]] + ("lux;Meta" _ ["lux;RealS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;CharS" ?value]]]] + ("lux;Meta" _ ["lux;CharS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;TextS" ?value]]]] + ("lux;Meta" _ ["lux;TextS" ?value]) (str "\"" ?value "\"") - [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]] + ("lux;Meta" _ ["lux;TagS" ?module ?tag]) (str "#" ?module ";" ?tag) - [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] + ("lux;Meta" _ ["lux;SymbolS" ?module ?ident]) (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - [["lux;Meta" [_ ["lux;TupleS" ?elems]]]] + ("lux;Meta" _ ["lux;TupleS" ?elems]) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [["lux;Meta" [_ ["lux;RecordS" ?elems]]]] + ("lux;Meta" _ ["lux;RecordS" ?elems]) (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [["lux;Meta" [_ ["lux;FormS" ?elems]]]] + ("lux;Meta" _ ["lux;FormS" ?elems]) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) @@ -689,57 +716,57 @@ (str ?module ";" ?name))) (defn fold2% [f init xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|do [init* (f init x y)] (fold2% f init* xs* ys*)) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] (return init) [_ _] (fail "Lists don't match in size."))) (defn map2% [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] (return (|cons z zs))) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] (return (V "lux;Nil" nil)) [_ _] (fail "Lists don't match in size."))) (defn map2 [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|cons (f x y) (map2 f xs* ys*)) [_ _] (V "lux;Nil" nil))) (defn fold2 [f init xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (and init (fold2 f (f init x y) xs* ys*)) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] init [_ _] false)) (defn ^:private enumerate* [idx xs] - (matchv ::M/objects [xs] - [["lux;Cons" [x xs*]]] + (|case xs + ($Cons x xs*) (V "lux;Cons" (T (T idx x) (enumerate* (inc idx) xs*))) - [["lux;Nil" _]] + ($Nil) xs )) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 4c12f9519..7463bdce7 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -11,9 +11,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail*]] + (lux [base :as & :refer [|let |do return* return fail fail* |case]] [type :as &type] [reader :as &reader] [lexer :as &lexer] @@ -38,327 +38,338 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - (matchv ::M/objects [syntax] - [[?form ?type]] - (matchv ::M/objects [?form] - [["bool" ?value]] + (|let [[?form ?type] syntax] + (|case ?form + ("bool" ?value) (&&lux/compile-bool compile-expression ?type ?value) - [["int" ?value]] + ("int" ?value) (&&lux/compile-int compile-expression ?type ?value) - [["real" ?value]] + ("real" ?value) (&&lux/compile-real compile-expression ?type ?value) - [["char" ?value]] + ("char" ?value) (&&lux/compile-char compile-expression ?type ?value) - [["text" ?value]] + ("text" ?value) (&&lux/compile-text compile-expression ?type ?value) - [["tuple" ?elems]] + ("tuple" ?elems) (&&lux/compile-tuple compile-expression ?type ?elems) - [["record" ?elems]] + ("record" ?elems) (&&lux/compile-record compile-expression ?type ?elems) - [["lux;Local" ?idx]] + ("lux;Local" ?idx) (&&lux/compile-local compile-expression ?type ?idx) - [["captured" [?scope ?captured-id ?source]]] + ("captured" ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - [["lux;Global" [?owner-class ?name]]] + ("lux;Global" ?owner-class ?name) (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["apply" [?fn ?args]]] + ("apply" ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) - [["variant" [?tag ?members]]] + ("variant" ?tag ?members) (&&lux/compile-variant compile-expression ?type ?tag ?members) - [["case" [?value ?match]]] + ("case" ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) - [["lambda" [?scope ?env ?body]]] + ("lambda" ?scope ?env ?body) (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - [["ann" [?value-ex ?type-ex]]] + ("ann" ?value-ex ?type-ex) (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) ;; Characters - [["jvm-ceq" [?x ?y]]] + ("jvm-ceq" ?x ?y) (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - [["jvm-clt" [?x ?y]]] + ("jvm-clt" ?x ?y) (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - [["jvm-cgt" [?x ?y]]] + ("jvm-cgt" ?x ?y) (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) ;; Integer arithmetic - [["jvm-iadd" [?x ?y]]] + ("jvm-iadd" ?x ?y) (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - [["jvm-isub" [?x ?y]]] + ("jvm-isub" ?x ?y) (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - [["jvm-imul" [?x ?y]]] + ("jvm-imul" ?x ?y) (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - [["jvm-idiv" [?x ?y]]] + ("jvm-idiv" ?x ?y) (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - [["jvm-irem" [?x ?y]]] + ("jvm-irem" ?x ?y) (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - [["jvm-ieq" [?x ?y]]] + ("jvm-ieq" ?x ?y) (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - [["jvm-ilt" [?x ?y]]] + ("jvm-ilt" ?x ?y) (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - [["jvm-igt" [?x ?y]]] + ("jvm-igt" ?x ?y) (&&host/compile-jvm-igt compile-expression ?type ?x ?y) ;; Long arithmetic - [["jvm-ladd" [?x ?y]]] + ("jvm-ladd" ?x ?y) (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - [["jvm-lsub" [?x ?y]]] + ("jvm-lsub" ?x ?y) (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - [["jvm-lmul" [?x ?y]]] + ("jvm-lmul" ?x ?y) (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - [["jvm-ldiv" [?x ?y]]] + ("jvm-ldiv" ?x ?y) (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - [["jvm-lrem" [?x ?y]]] + ("jvm-lrem" ?x ?y) (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - [["jvm-leq" [?x ?y]]] + ("jvm-leq" ?x ?y) (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - [["jvm-llt" [?x ?y]]] + ("jvm-llt" ?x ?y) (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - [["jvm-lgt" [?x ?y]]] + ("jvm-lgt" ?x ?y) (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) ;; Float arithmetic - [["jvm-fadd" [?x ?y]]] + ("jvm-fadd" ?x ?y) (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - [["jvm-fsub" [?x ?y]]] + ("jvm-fsub" ?x ?y) (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - [["jvm-fmul" [?x ?y]]] + ("jvm-fmul" ?x ?y) (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - [["jvm-fdiv" [?x ?y]]] + ("jvm-fdiv" ?x ?y) (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - [["jvm-frem" [?x ?y]]] + ("jvm-frem" ?x ?y) (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - [["jvm-feq" [?x ?y]]] + ("jvm-feq" ?x ?y) (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - [["jvm-flt" [?x ?y]]] + ("jvm-flt" ?x ?y) (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - [["jvm-fgt" [?x ?y]]] + ("jvm-fgt" ?x ?y) (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) ;; Double arithmetic - [["jvm-dadd" [?x ?y]]] + ("jvm-dadd" ?x ?y) (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - [["jvm-dsub" [?x ?y]]] + ("jvm-dsub" ?x ?y) (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - [["jvm-dmul" [?x ?y]]] + ("jvm-dmul" ?x ?y) (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - [["jvm-ddiv" [?x ?y]]] + ("jvm-ddiv" ?x ?y) (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - [["jvm-drem" [?x ?y]]] + ("jvm-drem" ?x ?y) (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - [["jvm-deq" [?x ?y]]] + ("jvm-deq" ?x ?y) (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - [["jvm-dlt" [?x ?y]]] + ("jvm-dlt" ?x ?y) (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - [["jvm-dgt" [?x ?y]]] + ("jvm-dgt" ?x ?y) (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - [["jvm-null" _]] + ("jvm-null" _) (&&host/compile-jvm-null compile-expression ?type) - [["jvm-null?" ?object]] + ("jvm-null?" ?object) (&&host/compile-jvm-null? compile-expression ?type ?object) - [["jvm-new" [?class ?classes ?args]]] + ("jvm-new" ?class ?classes ?args) (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - [["jvm-getstatic" [?class ?field]]] + ("jvm-getstatic" ?class ?field) (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - [["jvm-getfield" [?class ?field ?object]]] + ("jvm-getfield" ?class ?field ?object) (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - [["jvm-putstatic" [?class ?field ?value]]] + ("jvm-putstatic" ?class ?field ?value) (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - [["jvm-putfield" [?class ?field ?object ?value]]] + ("jvm-putfield" ?class ?field ?object ?value) (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - [["jvm-invokestatic" [?class ?method ?classes ?args]]] + ("jvm-invokestatic" ?class ?method ?classes ?args) (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] + ("jvm-invokevirtual" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] + ("jvm-invokeinterface" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] + ("jvm-invokespecial" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-new-array" [?class ?length]]] + ("jvm-new-array" ?class ?length) (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) - [["jvm-aastore" [?array ?idx ?elem]]] + ("jvm-aastore" ?array ?idx ?elem) (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) - [["jvm-aaload" [?array ?idx]]] + ("jvm-aaload" ?array ?idx) (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) - [["jvm-try" [?body ?catches ?finally]]] + ("jvm-try" ?body ?catches ?finally) (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) - [["jvm-throw" ?ex]] + ("jvm-throw" ?ex) (&&host/compile-jvm-throw compile-expression ?type ?ex) - [["jvm-monitorenter" ?monitor]] + ("jvm-monitorenter" ?monitor) (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) - [["jvm-monitorexit" ?monitor]] + ("jvm-monitorexit" ?monitor) (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) - [["jvm-d2f" ?value]] + ("jvm-d2f" ?value) (&&host/compile-jvm-d2f compile-expression ?type ?value) - [["jvm-d2i" ?value]] + ("jvm-d2i" ?value) (&&host/compile-jvm-d2i compile-expression ?type ?value) - [["jvm-d2l" ?value]] + ("jvm-d2l" ?value) (&&host/compile-jvm-d2l compile-expression ?type ?value) - [["jvm-f2d" ?value]] + ("jvm-f2d" ?value) (&&host/compile-jvm-f2d compile-expression ?type ?value) - [["jvm-f2i" ?value]] + ("jvm-f2i" ?value) (&&host/compile-jvm-f2i compile-expression ?type ?value) - [["jvm-f2l" ?value]] + ("jvm-f2l" ?value) (&&host/compile-jvm-f2l compile-expression ?type ?value) - [["jvm-i2b" ?value]] + ("jvm-i2b" ?value) (&&host/compile-jvm-i2b compile-expression ?type ?value) - [["jvm-i2c" ?value]] + ("jvm-i2c" ?value) (&&host/compile-jvm-i2c compile-expression ?type ?value) - [["jvm-i2d" ?value]] + ("jvm-i2d" ?value) (&&host/compile-jvm-i2d compile-expression ?type ?value) - [["jvm-i2f" ?value]] + ("jvm-i2f" ?value) (&&host/compile-jvm-i2f compile-expression ?type ?value) - [["jvm-i2l" ?value]] + ("jvm-i2l" ?value) (&&host/compile-jvm-i2l compile-expression ?type ?value) - [["jvm-i2s" ?value]] + ("jvm-i2s" ?value) (&&host/compile-jvm-i2s compile-expression ?type ?value) - [["jvm-l2d" ?value]] + ("jvm-l2d" ?value) (&&host/compile-jvm-l2d compile-expression ?type ?value) - [["jvm-l2f" ?value]] + ("jvm-l2f" ?value) (&&host/compile-jvm-l2f compile-expression ?type ?value) - [["jvm-l2i" ?value]] + ("jvm-l2i" ?value) (&&host/compile-jvm-l2i compile-expression ?type ?value) - [["jvm-iand" [?x ?y]]] + ("jvm-iand" ?x ?y) (&&host/compile-jvm-iand compile-expression ?type ?x ?y) - [["jvm-ior" [?x ?y]]] + ("jvm-ior" ?x ?y) (&&host/compile-jvm-ior compile-expression ?type ?x ?y) - [["jvm-land" [?x ?y]]] + ("jvm-ixor" ?x ?y) + (&&host/compile-jvm-ixor compile-expression ?type ?x ?y) + + ("jvm-ishl" ?x ?y) + (&&host/compile-jvm-ishl compile-expression ?type ?x ?y) + + ("jvm-ishr" ?x ?y) + (&&host/compile-jvm-ishr compile-expression ?type ?x ?y) + + ("jvm-iushr" ?x ?y) + (&&host/compile-jvm-iushr compile-expression ?type ?x ?y) + + ("jvm-land" ?x ?y) (&&host/compile-jvm-land compile-expression ?type ?x ?y) - [["jvm-lor" [?x ?y]]] + ("jvm-lor" ?x ?y) (&&host/compile-jvm-lor compile-expression ?type ?x ?y) - [["jvm-lxor" [?x ?y]]] + ("jvm-lxor" ?x ?y) (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) - [["jvm-lshl" [?x ?y]]] + ("jvm-lshl" ?x ?y) (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) - [["jvm-lshr" [?x ?y]]] + ("jvm-lshr" ?x ?y) (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) - [["jvm-lushr" [?x ?y]]] + ("jvm-lushr" ?x ?y) (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) - [["jvm-instanceof" [?class ?object]]] + ("jvm-instanceof" ?class ?object) (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) ) )) (defn ^:private compile-statement [syntax] - (matchv ::M/objects [syntax] - [["def" [?name ?body]]] + (|case syntax + ("def" ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - [["declare-macro" [?module ?name]]] + ("declare-macro" ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - [["jvm-program" ?body]] + ("jvm-program" ?body) (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?name ?supers ?methods]]] + ("jvm-interface" ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) (defn ^:private compile-token [syntax] - (matchv ::M/objects [syntax] - [["def" [?name ?body]]] + (|case syntax + ("def" ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - [["declare-macro" [?module ?name]]] + ("declare-macro" ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - [["jvm-program" ?body]] + ("jvm-program" ?body) (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?name ?supers ?methods]]] + ("jvm-interface" ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) - [_] + _ (compile-expression syntax))) (defn ^:private eval! [expr] @@ -413,10 +424,10 @@ ;; _ (prn 'compile-module name =class) ]] (fn [state] - (matchv ::M/objects [((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] - [["lux;Right" [?state _]]] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$SOURCE (&reader/from file-name file-content) state)) + ("lux;Right" ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports :let [_ (doto =class @@ -437,7 +448,7 @@ (&&/save-class! "_" (.toByteArray =class))) ?state) - [["lux;Left" ?message]] + ("lux;Left" ?message) (fail* ?message))))))) )) )) @@ -448,11 +459,11 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))] - [["lux;Right" [?state _]]] + (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) + ("lux;Right" ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) (&&package/package program-module)) - [["lux;Left" ?message]] + ("lux;Left" ?message) (assert false ?message))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 565eae898..2b6f2e919 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -10,9 +10,9 @@ (:refer-clojure :exclude [load]) (:require [clojure.string :as string] [clojure.java.io :as io] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail* |case]] [type :as &type] [host :as &host]) (lux.analyser [base :as &a] @@ -126,8 +126,8 @@ "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) def-meta (get-field "_meta" def-class)] - (matchv ::M/objects [def-meta] - [["lux;ValueD" [def-type _]]] + (|case def-meta + ("lux;ValueD" def-type _) (&a-module/define module _name def-meta def-type))) ;; else (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 906cc1ca8..d27577be1 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -9,9 +9,9 @@ (ns lux.compiler.case (:require (clojure [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -26,13 +26,13 @@ ;; [Utils] (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] - (matchv ::M/objects [?match] - [["StoreTestAC" ?idx]] + (|case ?match + ("StoreTestAC" ?idx) (doto writer (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO $target)) - [["BoolTestAC" ?value]] + ("BoolTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) @@ -42,7 +42,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["IntTestAC" ?value]] + ("IntTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) @@ -53,7 +53,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RealTestAC" ?value]] + ("RealTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) @@ -64,7 +64,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["CharTestAC" ?value]] + ("CharTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) @@ -74,7 +74,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TextTestAC" ?value]] + ("TextTestAC" ?value) (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) @@ -83,7 +83,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TupleTestAC" ?members]] + ("TupleTestAC" ?members) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -101,7 +101,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RecordTestAC" ?slots]] + ("RecordTestAC" ?slots) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -124,7 +124,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["VariantTestAC" [?tag ?test]]] + ("VariantTestAC" ?tag ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 542bd9a40..bde19d8fb 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -51,35 +51,35 @@ double-class "java.lang.Double" char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] - (matchv ::M/objects [*type*] - [["lux;TupleT" ["lux;Nil" _]]] + (|case *type* + ("lux;TupleT" ("lux;Nil")) (.visitInsn *writer* Opcodes/ACONST_NULL) - [["lux;DataT" "boolean"]] + ("lux;DataT" "boolean") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - [["lux;DataT" "byte"]] + ("lux;DataT" "byte") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - [["lux;DataT" "short"]] + ("lux;DataT" "short") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - [["lux;DataT" "int"]] + ("lux;DataT" "int") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - [["lux;DataT" "long"]] + ("lux;DataT" "long") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - [["lux;DataT" "float"]] + ("lux;DataT" "float") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - [["lux;DataT" "double"]] + ("lux;DataT" "double") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - [["lux;DataT" "char"]] + ("lux;DataT" "char") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - [["lux;DataT" _]] + ("lux;DataT" _) nil) *writer*)) @@ -413,16 +413,16 @@ $to (new Label) $end (new Label) $catch-finally (new Label) - compile-finally (matchv ::M/objects [?finally] - [["lux;Some" ?finally*]] (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) - [["lux;None" _]] (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + compile-finally (|case ?finally + ("lux;Some" ?finally*) (|do [_ (return nil) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) + ("lux;None") (|do [_ (return nil) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -447,14 +447,14 @@ catch-boundaries) ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] - _ (matchv ::M/objects [?finally] - [["lux;Some" ?finally*]] (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) - [["lux;None" _]] (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + _ (|case ?finally + ("lux;Some" ?finally*) (|do [_ (compile ?finally*) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) + ("lux;None") (|do [_ (return nil) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) @@ -533,11 +533,14 @@ compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" - compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index ccd12e68a..0d1ea4844 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail* |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -46,8 +46,8 @@ (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) + (|case ?name+?captured + [?name [("captured" _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -83,8 +83,8 @@ (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] _ (&/map% (fn [?name+?captured] - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ _ ?source]] _]]] + (|case ?name+?captured + [?name [("captured" _ _ ?source) _]] (compile ?source))) closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] @@ -101,8 +101,8 @@ (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) + (|case ?name+?captured + [?name [("captured" _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq ?env)]))) (add-lambda-apply class-name ?env) (add-lambda- class-name ?env) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index def5220f7..9a3a7a6f2 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -138,8 +138,8 @@ (defn ^:private compile-def-type [compile current-class ?body def-type] (|do [^MethodVisitor **writer** &/get-writer] - (matchv ::M/objects [def-type] - ["type"] + (|case def-type + "type" (|do [:let [;; ?type* (&&type/->analysis ?type) _ (doto **writer** ;; Tail: Begin @@ -160,13 +160,13 @@ ] (return nil)) - ["value"] + "value" (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) - ?def-type (matchv ::M/objects [?body] - [[["ann" [?def-value ?type-expr]] ?def-type]] + ?def-type (|case ?body + [("ann" ?def-value ?type-expr) ?def-type] ?type-expr - [[?def-value ?def-type]] + [?def-value ?def-type] (&&type/->analysis ?def-type))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 01141f8e4..bfa322206 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.compiler.type - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]))) ;; [Utils] @@ -39,18 +39,18 @@ ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" - (matchv ::M/objects [type] - [["lux;DataT" ?class]] + (|case type + ("lux;DataT" ?class) (variant$ "lux;DataT" (text$ ?class)) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (variant$ "lux;TupleT" (&/fold (fn [tail head] (Cons$ (->analysis head) tail)) $Nil (&/|reverse ?members))) - [["lux;VariantT" ?cases]] + ("lux;VariantT" ?cases) (variant$ "lux;VariantT" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -59,7 +59,7 @@ $Nil (&/|reverse ?cases))) - [["lux;RecordT" ?slots]] + ("lux;RecordT" ?slots) (variant$ "lux;RecordT" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -68,16 +68,16 @@ $Nil (&/|reverse ?slots))) - [["lux;LambdaT" [?input ?output]]] + ("lux;LambdaT" ?input ?output) (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - [["lux;AllT" [?env ?name ?arg ?body]]] + ("lux;AllT" ?env ?name ?arg ?body) (variant$ "lux;AllT" - (tuple$ (&/|list (matchv ::M/objects [?env] - [["lux;None" _]] + (tuple$ (&/|list (|case ?env + ("lux;None") (variant$ "lux;None" (tuple$ (&/|list))) - [["lux;Some" ??env]] + ("lux;Some" ??env) (variant$ "lux;Some" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -89,9 +89,9 @@ (text$ ?arg) (->analysis ?body)))) - [["lux;BoundT" ?name]] + ("lux;BoundT" ?name) (variant$ "lux;BoundT" (text$ ?name)) - [["lux;AppT" [?fun ?arg]]] + ("lux;AppT" ?fun ?arg) (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 91582c526..2414d97b6 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -9,9 +9,9 @@ (ns lux.host (:require (clojure [string :as string] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) (:import (java.lang.reflect Field Method Modifier))) @@ -68,14 +68,14 @@ )) (defn ->java-sig [^objects type] - (matchv ::M/objects [type] - [["lux;DataT" ?name]] + (|case type + ("lux;DataT" ?name) (->type-signature ?name) - [["lux;LambdaT" [_ _]]] + ("lux;LambdaT" _ _) (->type-signature function-class) - [["lux;TupleT" ["lux;Nil" _]]] + ("lux;TupleT" ("lux;Nil")) "V" )) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 966c322bf..aa05b48af 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -8,9 +8,9 @@ (ns lux.parser (:require [clojure.template :refer [do-template]] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail]] + (lux [base :as & :refer [|do return fail |case]] [lexer :as &lexer]))) ;; [Utils] @@ -18,11 +18,11 @@ (defn [parse] (|do [elems (&/repeat% parse) token &lexer/lex] - (matchv ::M/objects [token] - [["lux;Meta" [meta [ _]]]] + (|case token + ("lux;Meta" meta [ _]) (return (&/V (&/fold &/|++ (&/|list) elems))) - [_] + _ (fail (str "[Parser Error] Unbalanced " "."))))) ^:private parse-form "Close_Paren" "parantheses" "lux;FormS" @@ -33,60 +33,59 @@ (|do [elems* (&/repeat% parse) token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["Close_Brace" _]]]] + (|case token + ("lux;Meta" meta ("Close_Brace" _)) (if (even? (&/|length elems)) (return (&/V "lux;RecordS" (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) - [_] + _ (fail (str "[Parser Error] Unbalanced braces."))))) ;; [Interface] (def parse - (|do [token &lexer/lex] - (matchv ::M/objects [token] - [["lux;Meta" [meta token*]]] - (matchv ::M/objects [token*] - [["White_Space" _]] - (return (&/|list)) + (|do [token &lexer/lex + :let [("lux;Meta" meta token*) token]] + (|case token* + ("White_Space" _) + (return (&/|list)) - [["Comment" _]] - (return (&/|list)) - - [["Bool" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) + ("Comment" _) + (return (&/|list)) + + ("Bool" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) - [["Int" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) + ("Int" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) - [["Real" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) + ("Real" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) - [["Char" ^String ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) + ("Char" ^String ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) - [["Text" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) + ("Text" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) - [["Symbol" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) + ("Symbol" ?ident) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) - [["Tag" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) + ("Tag" ?ident) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) - [["Open_Paren" _]] - (|do [syntax (parse-form parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - - [["Open_Bracket" _]] - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + ("Open_Paren" _) + (|do [syntax (parse-form parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + + ("Open_Bracket" _) + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [["Open_Brace" _]] - (|do [syntax (parse-record parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + ("Open_Brace" _) + (|do [syntax (parse-record parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [_] - (fail "[Parser Error] Unknown lexer token.") - )))) + _ + (fail "[Parser Error] Unknown lexer token.") + ))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 9fd9b14ea..6bda8f166 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -8,40 +8,40 @@ (ns lux.reader (:require [clojure.string :as string] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* |let]])) + [lux.base :as & :refer [|do return* return fail fail* |let |case]])) ;; [Utils] (defn ^:private with-line [body] (fn [state] - (matchv ::M/objects [(&/get$ &/$SOURCE state)] - [["lux;Nil" _]] + (|case (&/get$ &/$SOURCE state) + ("lux;Nil") (fail* "[Reader Error] EOF") - [["lux;Cons" [[[file-name line-num column-num] line] - more]]] - (matchv ::M/objects [(body file-name line-num column-num line)] - [["No" msg]] + ("lux;Cons" [[file-name line-num column-num] line] + more) + (|case (body file-name line-num column-num line) + ("No" msg) (fail* msg) - [["Done" output]] + ("Done" output) (return* (&/set$ &/$SOURCE more state) output) - [["Yes" [output line*]]] + ("Yes" output line*) (return* (&/set$ &/$SOURCE (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (matchv ::M/objects [(body (&/get$ &/$SOURCE state))] - [["lux;Right" [reader* match]]] + (|case (body (&/get$ &/$SOURCE state)) + ("lux;Right" reader* match) (return* (&/set$ &/$SOURCE reader* state) match) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg) ))) @@ -102,12 +102,12 @@ (fn [reader] (loop [prefix "" reader* reader] - (matchv ::M/objects [reader*] - [["lux;Nil" _]] + (|case reader* + ("lux;Nil") (&/V "lux;Left" "[Reader Error] EOF") - [["lux;Cons" [[[file-name line-num column-num] ^String line] - reader**]]] + ("lux;Cons" [[file-name line-num column-num] ^String line] + reader**) (if-let [^String match (do ;; (prn 'read-regex+ regex line) (re-find1! regex column-num line))] (let [match-length (.length match) diff --git a/src/lux/type.clj b/src/lux/type.clj index e4117492c..ab8ea4e61 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -8,9 +8,9 @@ (ns lux.type (:refer-clojure :exclude [deref apply merge bound?]) - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) (declare show-type) @@ -191,33 +191,33 @@ (defn bound? [id] (fn [state] (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [type] - [["lux;Some" type*]] + (|case type + ("lux;Some" type*) (return* state true) - [["lux;None" _]] + ("lux;None") (return* state false)) (fail* (str "[Type Error] Unknown type-var: " id))))) (defn deref [id] (fn [state] (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [type*] - [["lux;Some" type]] + (|case type* + ("lux;Some" type) (return* state type) - [["lux;None" _]] + ("lux;None") (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id))))) (defn set-var [id type] (fn [state] (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [tvar] - [["lux;Some" bound]] + (|case tvar + ("lux;Some" bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) - [["lux;None" _]] + ("lux;None") (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) ts)) state) @@ -251,18 +251,18 @@ (|let [[?id ?type] binding] (if (.equals ^Object id ?id) (return binding) - (matchv ::M/objects [?type] - [["lux;None" _]] + (|case ?type + ("lux;None") (return binding) - [["lux;Some" ?type*]] - (matchv ::M/objects [?type*] - [["lux;VarT" ?id*]] + ("lux;Some" ?type*) + (|case ?type* + ("lux;VarT" ?id*) (if (.equals ^Object id ?id*) (return (&/T ?id (&/V "lux;None" nil))) (return binding)) - [_] + _ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V "lux;Some" ?type**))))) )))) @@ -288,46 +288,46 @@ (return output))) (defn clean* [?tid type] - (matchv ::M/objects [type] - [["lux;VarT" ?id]] + (|case type + ("lux;VarT" ?id) (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) - [["lux;LambdaT" [?arg ?return]]] + ("lux;LambdaT" ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] (return (&/V "lux;LambdaT" (&/T =arg =return)))) - [["lux;AppT" [?lambda ?param]]] + ("lux;AppT" ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] (return (&/V "lux;AppT" (&/T =lambda =param)))) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] (return (&/V "lux;TupleT" =members))) - [["lux;VariantT" ?members]] + ("lux;VariantT" ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] (return (&/V "lux;VariantT" =members))) - [["lux;RecordT" ?members]] + ("lux;RecordT" ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] (return (&/V "lux;RecordT" =members))) - [["lux;AllT" [?env ?name ?arg ?body]]] - (|do [=env (matchv ::M/objects [?env] - [["lux;None" _]] + ("lux;AllT" ?env ?name ?arg ?body) + (|do [=env (|case ?env + ("lux;None") (return ?env) - [["lux;Some" ?env*]] + ("lux;Some" ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) @@ -336,96 +336,96 @@ body* (clean* ?tid ?body)] (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) - [_] + _ (return type) )) (defn clean [tvar type] - (matchv ::M/objects [tvar] - [["lux;VarT" ?id]] + (|case tvar + ("lux;VarT" ?id) (clean* ?id type) - [_] + _ (fail (str "[Type Error] Not type-var: " (show-type tvar))))) (defn ^:private unravel-fun [type] - (matchv ::M/objects [type] - [["lux;LambdaT" [?in ?out]]] + (|case type + ("lux;LambdaT" ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] (&/T ??out (&/|cons ?in ?args))) - [_] + _ (&/T type (&/|list)))) (defn ^:private unravel-app [fun-type] - (matchv ::M/objects [fun-type] - [["lux;AppT" [?left ?right]]] + (|case fun-type + ("lux;AppT" ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) - [_] + _ (&/T fun-type (&/|list)))) (defn show-type [^objects type] - (matchv ::M/objects [type] - [["lux;DataT" name]] + (|case type + ("lux;DataT" name) (str "(^ " name ")") - [["lux;TupleT" elems]] + ("lux;TupleT" elems) (if (&/|empty? elems) "(,)" (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;VariantT" cases]] + ("lux;VariantT" cases) (if (&/|empty? cases) "(|)" (str "(| " (->> cases (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k ["lux;TupleT" ["lux;Nil" _]]]] + (|case kv + [k ("lux;TupleT" ("lux;Nil"))] (str "#" k) - [[k v]] + [k v] (str "(#" k " " (show-type v) ")")))) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;RecordT" fields]] + ("lux;RecordT" fields) (str "(& " (->> fields (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k v]] + (|case kv + [k v] (str "#" k " " (show-type v))))) (&/|interpose " ") (&/fold str "")) ")") - [["lux;LambdaT" [input output]]] + ("lux;LambdaT" input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - [["lux;VarT" id]] + ("lux;VarT" id) (str "⌈" id "⌋") - [["lux;ExT" ?id]] + ("lux;ExT" ?id) (str "⟨" ?id "⟩") - [["lux;BoundT" name]] + ("lux;BoundT" name) name - [["lux;AppT" [_ _]]] + ("lux;AppT" _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;AllT" [?env ?name ?arg ?body]]] + ("lux;AllT" ?env ?name ?arg ?body) (if (= "" ?name) (let [[args body] (loop [args (list ?arg) body* ?body] - (matchv ::M/objects [body*] - [["lux;AllT" [?env* ?name* ?arg* ?body*]]] + (|case body* + ("lux;AllT" ?env* ?name* ?arg* ?body*) (recur (cons ?arg* args) ?body*) - [_] + _ [args body*]))] (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) @@ -433,17 +433,17 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) - (let [output (matchv ::M/objects [x y] - [["lux;DataT" xname] ["lux;DataT" yname]] + (let [output (|case [x y] + [("lux;DataT" xname) ("lux;DataT" yname)] (.equals ^Object xname yname) - [["lux;TupleT" xelems] ["lux;TupleT" yelems]] + [("lux;TupleT" xelems) ("lux;TupleT" yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) - [["lux;VariantT" xcases] ["lux;VariantT" ycases]] + [("lux;VariantT" xcases) ("lux;VariantT" ycases)] (&/fold2 (fn [old xcase ycase] (|let [[xname xtype] xcase [yname ytype] ycase] @@ -451,7 +451,7 @@ true xcases ycases) - [["lux;RecordT" xslots] ["lux;RecordT" yslots]] + [("lux;RecordT" xslots) ("lux;RecordT" yslots)] (&/fold2 (fn [old xslot yslot] (|let [[xname xtype] xslot [yname ytype] yslot] @@ -459,23 +459,23 @@ true xslots yslots) - [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + [("lux;LambdaT" xinput xoutput) ("lux;LambdaT" yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) - [["lux;VarT" xid] ["lux;VarT" yid]] + [("lux;VarT" xid) ("lux;VarT" yid)] (.equals ^Object xid yid) - [["lux;BoundT" xname] ["lux;BoundT" yname]] + [("lux;BoundT" xname) ("lux;BoundT" yname)] (.equals ^Object xname yname) - [["lux;ExT" xid] ["lux;ExT" yid]] + [("lux;ExT" xid) ("lux;ExT" yid)] (.equals ^Object xid yid) - [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] + [("lux;AppT" xlambda xparam) ("lux;AppT" ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] + [("lux;AllT" xenv xname xarg xbody) ("lux;AllT" yenv yname yarg ybody)] (and (.equals ^Object xname yname) (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] @@ -501,11 +501,11 @@ (defn ^:private fp-get [k fixpoints] (|let [[e a] k] - (matchv ::M/objects [fixpoints] - [["lux;Nil" _]] + (|case fixpoints + ("lux;Nil") (&/V "lux;None" nil) - [["lux;Cons" [[[e* a*] v*] fixpoints*]]] + ("lux;Cons" [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) (&/V "lux;Some" v*) @@ -521,73 +521,64 @@ "\n")) (defn beta-reduce [env type] - (matchv ::M/objects [type] - [["lux;VariantT" ?cases]] + (|case type + ("lux;VariantT" ?cases) (&/V "lux;VariantT" (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?cases)) - [["lux;RecordT" ?fields]] + ("lux;RecordT" ?fields) (&/V "lux;RecordT" (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?fields)) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members)) - [["lux;AppT" [?type-fn ?type-arg]]] + ("lux;AppT" ?type-fn ?type-arg) (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) - [["lux;AllT" [?local-env ?local-name ?local-arg ?local-def]]] - (matchv ::M/objects [?local-env] - [["lux;None" _]] + ("lux;AllT" ?local-env ?local-name ?local-arg ?local-def) + (|case ?local-env + ("lux;None") (&/V "lux;AllT" (&/T (&/V "lux;Some" env) ?local-name ?local-arg ?local-def)) - [["lux;Some" _]] + ("lux;Some" _) type) - [["lux;LambdaT" [?input ?output]]] + ("lux;LambdaT" ?input ?output) (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output))) - [["lux;BoundT" ?name]] + ("lux;BoundT" ?name) (if-let [bound (&/|get ?name env)] (beta-reduce env bound) type) - [_] + _ type )) -(defn slot-type [record slot] - (fn [state] - (matchv ::M/objects [(&/|get slot record)] - [["lux;Left" msg]] - (fail* msg) - - [["lux;Right" type]] - (return* state type)))) - (defn apply-type [type-fn param] - (matchv ::M/objects [type-fn] - [["lux;AllT" [local-env local-name local-arg local-def]]] - (let [local-env* (matchv ::M/objects [local-env] - [["lux;None" _]] + (|case type-fn + ("lux;AllT" local-env local-name local-arg local-def) + (let [local-env* (|case local-env + ("lux;None") (&/|table) - [["lux;Some" local-env*]] + ("lux;Some" local-env*) local-env*)] (return (beta-reduce (->> local-env* (&/|put local-name type-fn) (&/|put local-arg param)) local-def))) - [["lux;AppT" [F A]]] + ("lux;AppT" F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) - [_] + _ (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] @@ -610,85 +601,85 @@ (defn ^:private check* [class-loader fixpoints expected actual] (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) - (matchv ::M/objects [expected actual] - [["lux;VarT" ?eid] ["lux;VarT" ?aid]] + (|case [expected actual] + [("lux;VarT" ?eid) ("lux;VarT" ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/T fixpoints nil)) (|do [ebound (fn [state] - (matchv ::M/objects [((deref ?eid) state)] - [["lux;Right" [state* ebound]]] + (|case ((deref ?eid) state) + ("lux;Right" state* ebound) (return* state* (&/V "lux;Some" ebound)) - [["lux;Left" _]] + ("lux;Left" _) (return* state (&/V "lux;None" nil)))) abound (fn [state] - (matchv ::M/objects [((deref ?aid) state)] - [["lux;Right" [state* abound]]] + (|case ((deref ?aid) state) + ("lux;Right" state* abound) (return* state* (&/V "lux;Some" abound)) - [["lux;Left" _]] + ("lux;Left" _) (return* state (&/V "lux;None" nil))))] - (matchv ::M/objects [ebound abound] - [["lux;None" _] ["lux;None" _]] + (|case [ebound abound] + [("lux;None" _) ("lux;None" _)] (|do [_ (set-var ?eid actual)] (return (&/T fixpoints nil))) - [["lux;Some" etype] ["lux;None" _]] + [("lux;Some" etype) ("lux;None" _)] (check* class-loader fixpoints etype actual) - [["lux;None" _] ["lux;Some" atype]] + [("lux;None" _) ("lux;Some" atype)] (check* class-loader fixpoints expected atype) - [["lux;Some" etype] ["lux;Some" atype]] + [("lux;Some" etype) ("lux;Some" atype)] (check* class-loader fixpoints etype atype)))) - [["lux;VarT" ?id] _] + [("lux;VarT" ?id) _] (fn [state] - (matchv ::M/objects [((set-var ?id actual) state)] - [["lux;Right" [state* _]]] + (|case ((set-var ?id actual) state) + ("lux;Right" state* _) (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] + ("lux;Left" _) ((|do [bound (deref ?id)] (check* class-loader fixpoints bound actual)) state))) - [_ ["lux;VarT" ?id]] + [_ ("lux;VarT" ?id)] (fn [state] - (matchv ::M/objects [((set-var ?id expected) state)] - [["lux;Right" [state* _]]] + (|case ((set-var ?id expected) state) + ("lux;Right" state* _) (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] + ("lux;Left" _) ((|do [bound (deref ?id)] (check* class-loader fixpoints expected bound)) state))) - [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] + [("lux;AppT" ("lux;VarT" ?eid) A1) ("lux;AppT" ("lux;VarT" ?aid) A2)] (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?eid)] - (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) - state)))) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F1 (deref ?eid)] + (fn [state] + (|case [((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + state)] + ("lux;Right" state* output) + (return* state* output) + + ("lux;Left" _) + ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] + ("lux;Left" _) + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) @@ -697,15 +688,15 @@ ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) - [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + [("lux;AppT" ("lux;VarT" ?id) A1) ("lux;AppT" F2 A2)] (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F1 (deref ?id)] + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) @@ -719,15 +710,15 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + [("lux;AppT" F1 A1) ("lux;AppT" ("lux;VarT" ?id) A2)] (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F2 (deref ?id)] + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) @@ -741,7 +732,7 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [F A]] _] + [("lux;AppT" F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) @@ -752,33 +743,33 @@ (&/|interpose "\n\n") (&/fold str ""))) (assert false))] - (matchv ::M/objects [(fp-get fp-pair fixpoints)] - [["lux;Some" ?]] + (|case (fp-get fp-pair fixpoints) + ("lux;Some" ?) (if ? (return (&/T fixpoints nil)) (fail (check-error expected actual))) - [["lux;None" _]] + ("lux;None") (|do [expected* (apply-type F A)] (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) - [_ ["lux;AppT" [F A]]] + [_ ("lux;AppT" F A)] (|do [actual* (apply-type F A)] (check* class-loader fixpoints expected actual*)) - [["lux;AllT" _] _] + [("lux;AllT" _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] (check* class-loader fixpoints expected* actual)))) - [_ ["lux;AllT" _]] + [_ ("lux;AllT" _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints expected actual*)))) - [["lux;DataT" e!name] ["lux;DataT" "null"]] + [("lux;DataT" e!name) ("lux;DataT" "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) @@ -791,11 +782,11 @@ (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) - [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] + [("lux;LambdaT" eI eO) ("lux;LambdaT" aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [["lux;TupleT" e!members] ["lux;TupleT" a!members]] + [("lux;TupleT" e!members) ("lux;TupleT" a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp e a)] (return fp*))) @@ -803,7 +794,7 @@ e!members a!members)] (return (&/T fixpoints* nil))) - [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] + [("lux;VariantT" e!cases) ("lux;VariantT" a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] (|let [[e!name e!type] e!case [a!name a!type] a!case] @@ -815,7 +806,7 @@ e!cases a!cases)] (return (&/T fixpoints* nil))) - [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]] + [("lux;RecordT" e!slots) ("lux;RecordT" a!slots)] (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] (|let [[e!name e!type] e!slot [a!name a!type] a!slot] @@ -827,7 +818,7 @@ e!slots a!slots)] (return (&/T fixpoints* nil))) - [["lux;ExT" e!id] ["lux;ExT" a!id]] + [("lux;ExT" e!id) ("lux;ExT" a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -842,41 +833,41 @@ (return nil))) (defn apply-lambda [func param] - (matchv ::M/objects [func] - [["lux;LambdaT" [input output]]] + (|case func + ("lux;LambdaT" input output) (|do [_ (check* init-fixpoints input param)] (return output)) - [["lux;AllT" _]] + ("lux;AllT" _) (with-var (fn [$var] (|do [func* (apply-type func $var) =return (apply-lambda func* param)] (clean $var =return)))) - [_] + _ (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] - (matchv ::M/objects [type] - [["lux;AppT" [?all ?param]]] + (|case type + ("lux;AppT" ?all ?param) (|do [type* (apply-type ?all ?param)] (actual-type type*)) - [["lux;VarT" ?id]] + ("lux;VarT" ?id) (deref ?id) - [_] + _ (return type) )) (defn variant-case [case type] - (matchv ::M/objects [type] - [["lux;VariantT" ?cases]] + (|case type + ("lux;VariantT" ?cases) (if-let [case-type (&/|get case ?cases)] (return case-type) (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) - [_] + _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) -- cgit v1.2.3 From 39b1f7161c4fd5c9c5a90d2f85758ed9febfd4ef Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 19:06:00 -0400 Subject: - Fixed some errors with argument ordering with JVM arithmetic ops. --- src/lux/analyser.clj | 70 +++++++++++++++++++++++------------------------ src/lux/compiler/host.clj | 12 ++++---- 2 files changed, 41 insertions(+), 41 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index e49797fa5..95e8f5f43 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -286,53 +286,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -342,63 +342,63 @@ (|case token ;; Host special forms ;; Characters - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index bde19d8fb..8a9c8dfcc 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -88,11 +88,11 @@ (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) @@ -130,11 +130,11 @@ (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) @@ -162,11 +162,11 @@ (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) -- cgit v1.2.3 From 8c448ad5500a732b2fd560f26d5e75fcaac80917 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 20:03:04 -0400 Subject: Started factoring out the tags used in variants within the compiler. --- src/lux/analyser.clj | 440 ++++++++++++++++++++++---------------------- src/lux/analyser/base.clj | 2 +- src/lux/analyser/case.clj | 30 +-- src/lux/analyser/env.clj | 2 +- src/lux/analyser/host.clj | 62 +++---- src/lux/analyser/lux.clj | 22 +-- src/lux/analyser/module.clj | 6 +- src/lux/base.clj | 131 +++++++------ src/lux/compiler.clj | 8 +- src/lux/compiler/host.clj | 14 +- src/lux/compiler/type.clj | 12 +- src/lux/host.clj | 2 +- src/lux/lexer.clj | 18 +- src/lux/parser.clj | 32 ++-- src/lux/reader.clj | 18 +- src/lux/type.clj | 156 ++++++++-------- 16 files changed, 487 insertions(+), 468 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 95e8f5f43..0ad6553bf 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -22,17 +22,17 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_catch")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?ex-class)) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ex-arg)) - ("lux;Cons" ?catch-body - ("lux;Nil"))))))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) + (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) + (&/$Cons ?catch-body + (&/$Nil))))))) (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_finally")) - ("lux;Cons" ?finally-body - ("lux;Nil"))))) - (return (&/T catch+ (&/V "lux;Some" ?finally-body))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) + (&/$Cons ?finally-body + (&/$Nil))))) + (return (&/T catch+ (&/V &/$Some ?finally-body))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) @@ -40,46 +40,46 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new-array")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?length)) - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) + (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) + (&/$Cons (&/$Meta _ (&/$IntS ?length)) + (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aastore")) - ("lux;Cons" ?array - ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) - ("lux;Cons" ?elem - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) + (&/$Cons ?array + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons ?elem + (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aaload")) - ("lux;Cons" ?array - ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) + (&/$Cons ?array + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_class")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?super-class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?interfaces)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?fields)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?methods)) - ("lux;Nil")))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) + (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) + (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) + (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_interface")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?supers)) - ?methods)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) + ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_program")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?args)) - ("lux;Cons" ?body - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) + (&/$Cons ?body + (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) _ @@ -88,86 +88,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2f")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2i")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2l")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2d")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2i")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2l")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2b")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2c")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2d")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2f")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2l")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2s")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2d")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2f")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2i")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iand")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ior")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ixor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_land")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lxor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -176,108 +176,108 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_null?")) - ("lux;Cons" ?object - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) + (&/$Cons ?object + (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_instanceof")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ?object - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons ?object + (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getstatic")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getfield")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) - ("lux;Cons" ?object - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$Cons ?object + (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putstatic")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) - ("lux;Cons" ?value - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$Cons ?value + (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putfield")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) - ("lux;Cons" ?object - ("lux;Cons" ?value - ("lux;Nil"))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$Cons ?object + (&/$Cons ?value + (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokestatic")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil"))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokevirtual")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ?object - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil")))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons ?object + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokeinterface")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ?object - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil")))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons ?object + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokespecial")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ?object - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil")))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons ?object + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_try")) - ("lux;Cons" ?body - ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) + (&/$Cons ?body + ?handlers))) + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_throw")) - ("lux;Cons" ?ex - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) + (&/$Cons ?ex + (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorenter")) - ("lux;Cons" ?monitor - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) + (&/$Cons ?monitor + (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorexit")) - ("lux;Cons" ?monitor - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) + (&/$Cons ?monitor + (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) _ @@ -286,53 +286,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -342,63 +342,63 @@ (|case token ;; Host special forms ;; Characters - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -406,57 +406,57 @@ (defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token] (|case token - ("lux;SymbolS" ?ident) + (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_case")) - ("lux;Cons" ?value ?branches))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) + (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_lambda")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?self)) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?arg)) - ("lux;Cons" ?body - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) + (&/$Cons ?body + (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_def")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) - ("lux;Cons" ?value - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$Cons ?value + (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_declare-macro")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_import")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?path)) - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) + (&/$Cons (&/$Meta _ (&/$TextS ?path)) + (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:")) - ("lux;Cons" ?type - ("lux;Cons" ?value - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) + (&/$Cons ?type + (&/$Cons ?value + (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:!")) - ("lux;Cons" ?type - ("lux;Cons" ?value - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) + (&/$Cons ?type + (&/$Cons ?value + (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_export")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ident)) - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) + (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_alias")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?alias)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?module)) - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) + (&/$Cons (&/$Meta _ (&/$TextS ?alias)) + (&/$Cons (&/$Meta _ (&/$TextS ?module)) + (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) _ @@ -465,36 +465,36 @@ (defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Standard special forms - ("lux;BoolS" ?value) + (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - ("lux;IntS" ?value) + (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - ("lux;RealS" ?value) + (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - ("lux;CharS" ?value) + (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - ("lux;TextS" ?value) + (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - ("lux;TupleS" ?elems) + (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) - ("lux;RecordS" ?elems) + (&/$RecordS ?elems) (&&lux/analyse-record analyse exo-type ?elems) - ("lux;TagS" ?ident) + (&/$TagS ?ident) (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) - ("lux;SymbolS" _ "_jvm_null") + (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) _ @@ -510,16 +510,16 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - ("lux;Meta" meta ?token) + (&/$Meta meta ?token) (fn [state] (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" "") + (&/$Left "") (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - ("lux;Left" msg) + (&/$Left msg) (fail* (add-loc (&/get$ &/$cursor state) msg)) )) )) @@ -543,13 +543,13 @@ (&/with-cursor (aget token 1 0) (&/with-expected-type exo-type (|case token - ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) ?values))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) - ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ?fn ?args))) + (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) (fn [state] (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - ("lux;Right" state* =fn) + (&/$Right state* =fn) (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index beeb57b08..ed81aa9bc 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -20,7 +20,7 @@ (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] (|case output - ("lux;Cons" x ("lux;Nil")) + (&/$Cons x (&/$Nil)) (return x) _ diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 2cdf233cc..0bbbde2d7 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -17,7 +17,7 @@ ;; [Utils] (def ^:private unit - (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))) + (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) (defn ^:private resolve-type [type] (|case type @@ -113,43 +113,43 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [("lux;Meta" _ pattern*) pattern] + (|let [(&/$Meta _ pattern*) pattern] (|case pattern* - ("lux;SymbolS" "" name) + (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) - ("lux;SymbolS" ident) + (&/$SymbolS ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - ("lux;BoolS" ?value) + (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] (return (&/T (&/V "BoolTestAC" ?value) =kont))) - ("lux;IntS" ?value) + (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] (return (&/T (&/V "IntTestAC" ?value) =kont))) - ("lux;RealS" ?value) + (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] (return (&/T (&/V "RealTestAC" ?value) =kont))) - ("lux;CharS" ?value) + (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] (return (&/T (&/V "CharTestAC" ?value) =kont))) - ("lux;TextS" ?value) + (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] (return (&/T (&/V "TextTestAC" ?value) =kont))) - ("lux;TupleS" ?members) + (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) (|case value-type* @@ -169,7 +169,7 @@ _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - ("lux;RecordS" ?slots) + (&/$RecordS ?slots) (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] value-type* (adjust-type value-type) ;; :let [_ (prn 'POST (&type/show-type value-type*))] @@ -182,7 +182,7 @@ (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] (|case sn - ("lux;Meta" _ ("lux;TagS" ?ident)) + (&/$Meta _ (&/$TagS ?ident)) (|do [=tag (&&/resolved-ident ?ident)] (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] @@ -199,14 +199,14 @@ _ (fail "[Pattern-matching Error] Record requires record-type."))) - ("lux;TagS" ?ident) + (&/$TagS ?ident) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) + (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) @@ -215,7 +215,7 @@ 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" ?values))) kont))] + (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) ))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index a39ec490a..9a8a6a3d7 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -32,7 +32,7 @@ (&/|tail stack)))) state))] (|case =return - ("lux;Right" ?state ?value) + (&/$Right ?state ?value) (return* (&/update$ &/$ENVS (fn [stack*] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER dec) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 707060323..06cb5ebfc 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -20,7 +20,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - ("lux;Meta" _ ("lux;TextS" ?text)) + (&/$Meta _ (&/$TextS ?text)) (return ?text) _ @@ -208,7 +208,7 @@ (defn analyse-jvm-new-array [analyse ?class ?length] (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) - (&/V "lux;Nil" nil))))))) + (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) @@ -224,28 +224,28 @@ (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - ("lux;Meta" _ ("lux;TextS" "public")) + (&/$Meta _ (&/$TextS "public")) (return (assoc so-far :visibility "public")) - ("lux;Meta" _ ("lux;TextS" "private")) + (&/$Meta _ (&/$TextS "private")) (return (assoc so-far :visibility "private")) - ("lux;Meta" _ ("lux;TextS" "protected")) + (&/$Meta _ (&/$TextS "protected")) (return (assoc so-far :visibility "protected")) - ("lux;Meta" _ ("lux;TextS" "static")) + (&/$Meta _ (&/$TextS "static")) (return (assoc so-far :static? true)) - ("lux;Meta" _ ("lux;TextS" "final")) + (&/$Meta _ (&/$TextS "final")) (return (assoc so-far :final? true)) - ("lux;Meta" _ ("lux;TextS" "abstract")) + (&/$Meta _ (&/$TextS "abstract")) (return (assoc so-far :abstract? true)) - ("lux;Meta" _ ("lux;TextS" "synchronized")) + (&/$Meta _ (&/$TextS "synchronized")) (return (assoc so-far :concurrency "synchronized")) - ("lux;Meta" _ ("lux;TextS" "volatile")) + (&/$Meta _ (&/$TextS "volatile")) (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-type)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?field-modifiers)) - ("lux;Nil")))))) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) + (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) + (&/$Nil)))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -289,17 +289,17 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-inputs)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-output)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-modifiers)) - ("lux;Cons" ?method-body - ("lux;Nil"))))))))] + [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) + (&/$Cons ?method-body + (&/$Nil))))))))] (|do [=method-inputs (&/map% (fn [minput] (|case minput - ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?input-name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?input-type)) - ("lux;Nil"))))) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) + (&/$Nil))))) (return (&/T ?input-name ?input-type)) _ @@ -334,11 +334,11 @@ (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?inputs)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?output)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?modifiers)) - ("lux;Nil"))))))) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) + (&/$Nil))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -362,9 +362,9 @@ (return (&/T ?ex-class idx =catch-body)))) ?catches) =finally (|case [?finally] - ("lux;None") (return (&/V "lux;None" nil)) - ("lux;Some" ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V "lux;Some" =finally))))] + (&/$None) (return (&/V &/$None nil)) + (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index cd89764c3..ac7e56ef4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -30,8 +30,8 @@ (defn ^:private with-cursor [cursor form] (|case form - ("lux;Meta" _ syntax) - (&/V "lux;Meta" (&/T cursor syntax)))) + (&/$Meta _ syntax) + (&/V &/$Meta (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] @@ -55,17 +55,17 @@ (defn ^:private analyse-variant-body [analyse exo-type ?values] (|do [output (|case ?values - ("lux;Nil") + (&/$Nil) (analyse-tuple analyse exo-type (&/|list)) - ("lux;Cons" ?value ("lux;Nil")) + (&/$Cons ?value (&/$Nil)) (analyse exo-type ?value) _ (analyse-tuple analyse exo-type ?values) )] (|case output - ("lux;Cons" x ("lux;Nil")) + (&/$Cons x (&/$Nil)) (return x) _ @@ -128,7 +128,7 @@ (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) =slots (&/map% (fn [kv] (|case kv - [("lux;Meta" _ ["lux;TagS" ?ident]) ?value] + [(&/$Meta _ (&/$TagS ?ident)) ?value] (|do [?tag (&&/resolved-ident ?ident) slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) @@ -167,12 +167,12 @@ (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer - ("lux;Nil") + (&/$Nil) (&/run-state (|do [module-name &/get-module-name] (analyse-global analyse exo-type module-name name)) state) - ("lux;Cons" ?genv ("lux;Nil")) + (&/$Cons ?genv (&/$Nil)) (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) @@ -202,7 +202,7 @@ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) - ("lux;Cons" top-outer _) + (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) (&/|map #(&/get$ &/$NAME %) outer) @@ -231,11 +231,11 @@ (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] ;; (prn 'analyse-apply* (aget fun-type 0)) (|case ?args - ("lux;Nil") + (&/$Nil) (|do [_ (&type/check exo-type fun-type)] (return (&/T fun-type (&/|list)))) - ("lux;Cons" ?arg ?args*) + (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* ("lux;AllT" _aenv _aname _aarg _abody) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index c92b7b976..78f5c675d 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -45,7 +45,7 @@ (defn define [module name def-data type] (fn [state] (|case (&/get$ &/$ENVS state) - ("lux;Cons" ?env ("lux;Nil")) + (&/$Cons ?env (&/$Nil)) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -85,7 +85,7 @@ ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] (|case (&/get$ &/$ENVS state) - ("lux;Cons" ?env ("lux;Nil")) + (&/$Cons ?env (&/$Nil)) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -188,7 +188,7 @@ (defn export [module name] (fn [state] (|case (&/get$ &/$ENVS state) - ("lux;Cons" ?env ("lux;Nil")) + (&/$Cons ?env (&/$Nil)) (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] (|case $def [true _] diff --git a/src/lux/base.clj b/src/lux/base.clj index bcd113daa..7ec9e3029 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -15,6 +15,25 @@ (def $Nil "lux;Nil") (def $Cons "lux;Cons") +(def $None "lux;None") +(def $Some "lux;Some") + +(def $Meta "lux;Meta") + +(def $Left "lux;Left") +(def $Right "lux;Right") + +(def $BoolS "lux;BoolS") +(def $IntS "lux;IntS") +(def $RealS "lux;RealS") +(def $CharS "lux;CharS") +(def $TextS "lux;TextS") +(def $SymbolS "lux;SymbolS") +(def $TagS "lux;TagS") +(def $FormS "lux;FormS") +(def $TupleS "lux;TupleS") +(def $RecordS "lux;RecordS") + ;; [Fields] ;; Binding (def $COUNTER 0) @@ -69,10 +88,10 @@ record#))) (defn fail* [message] - (V "lux;Left" message)) + (V $Left message)) (defn return* [state value] - (V "lux;Right" (T state value))) + (V $Right (T state value))) (defn transform-pattern [pattern] (cond (vector? pattern) (mapv transform-pattern pattern) @@ -107,8 +126,8 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(V "lux;Cons" (T ~head ~tail))) - `(V "lux;Nil" nil) + `(V $Cons (T ~head ~tail))) + `(V $Nil nil) (reverse elems))) (defmacro |table [& elems] @@ -130,12 +149,12 @@ (defn |put [slot value table] (|case table ($Nil) - (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) + (V $Cons (T (T slot value) (V $Nil nil))) ($Cons [k v] table*) (if (.equals ^Object k slot) - (V "lux;Cons" (T (T slot value) table*)) - (V "lux;Cons" (T (T k v) (|put slot value table*)))) + (V $Cons (T (T slot value) table*)) + (V $Cons (T (T k v) (|put slot value table*)))) _ (assert false (prn-str '|put (aget table 0))))) @@ -148,7 +167,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (V "lux;Cons" (T (T k v) (|remove slot table*)))))) + (V $Cons (T (T k v) (|remove slot table*)))))) (defn |update [k f table] (|case table @@ -157,8 +176,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (V "lux;Cons" (T (T k* (f v)) table*)) - (V "lux;Cons" (T (T k* v) (|update k f table*)))))) + (V $Cons (T (T k* (f v)) table*)) + (V $Cons (T (T k* v) (|update k f table*)))))) (defn |head [xs] (|case xs @@ -179,20 +198,20 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (V "lux;Left" message))) + (V $Left message))) (defn return [value] (fn [state] - (V "lux;Right" (T state value)))) + (V $Right (T state value)))) (defn bind [m-value step] (fn [state] (let [inputs (m-value state)] (|case inputs - ("lux;Right" ?state ?datum) + ($Right ?state ?datum) ((step ?datum) ?state) - ("lux;Left" _) + ($Left _) inputs )))) @@ -212,7 +231,7 @@ ;; [Resources/Combinators] (defn |cons [head tail] - (V "lux;Cons" (T head tail))) + (V $Cons (T head tail))) (defn |++ [xs ys] (|case xs @@ -220,7 +239,7 @@ ys ($Cons x xs*) - (V "lux;Cons" (T x (|++ xs* ys))))) + (V $Cons (T x (|++ xs* ys))))) (defn |map [f xs] (|case xs @@ -228,7 +247,7 @@ xs ($Cons x xs*) - (V "lux;Cons" (T (f x) (|map f xs*))))) + (V $Cons (T (f x) (|map f xs*))))) (defn |empty? [xs] (|case xs @@ -245,7 +264,7 @@ ($Cons x xs*) (if (p x) - (V "lux;Cons" (T x (|filter p xs*))) + (V $Cons (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] @@ -265,7 +284,7 @@ (if (p x) (|let [[pre post] (|split-with p xs*)] (T (|cons x pre) post)) - (T (V "lux;Nil" nil) xs)))) + (T (V $Nil nil) xs)))) (defn |contains? [k table] (|case table @@ -306,8 +325,8 @@ (let [|range* (fn |range* [from to] (if (< from to) - (V "lux;Cons" (T from (|range* (inc from) to))) - (V "lux;Nil" nil)))] + (V $Cons (T from (|range* (inc from) to))) + (V $Nil nil)))] (defn |range [n] (|range* 0 n))) @@ -322,10 +341,10 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (V "lux;Cons" (T (T x y) (zip2 xs* ys*))) + (V $Cons (T (T x y) (zip2 xs* ys*))) [_ _] - (V "lux;Nil" nil))) + (V $Nil nil))) (defn |keys [plist] (|case plist @@ -352,7 +371,7 @@ xs ($Cons x xs*) - (V "lux;Cons" (T x (V "lux;Cons" (T sep (|interpose sep xs*))))))) + (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) (do-template [ ] (defn [f xs] @@ -369,15 +388,15 @@ flat-map% |++) (defn list-join [xss] - (fold |++ (V "lux;Nil" nil) xss)) + (fold |++ (V $Nil nil) xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (V "lux;Cons" (T (T x y) (|as-pairs xs*))) + (V $Cons (T (T x y) (|as-pairs xs*))) _ - (V "lux;Nil" nil))) + (V $Nil nil))) (defn |reverse [xs] (fold (fn [tail head] @@ -403,7 +422,7 @@ (fn [state] (let [output (m state)] (|case [output monads*] - [("lux;Right" _) _] + [($Right _) _] output [_ ($Nil)] @@ -423,10 +442,10 @@ (defn exhaust% [step] (fn [state] (|case (step state) - ("lux;Right" state* _) + ($Right state* _) ((exhaust% step) state*) - ("lux;Left" msg) + ($Left msg) (if (.equals "[Reader Error] EOF" msg) (return* state nil) (fail* msg))))) @@ -512,7 +531,7 @@ ;; "lux;loader" (memory-class-loader store) ;; "lux;writer" - (V "lux;None" nil)))) + (V $None nil)))) (defn init-state [_] (R ;; "lux;cursor" @@ -530,7 +549,7 @@ ;; "lux;seed" 0 ;; "lux;source" - (V "lux;None" nil) + (V $None nil) ;; "lux;types" +init-bindings+ )) @@ -538,22 +557,22 @@ (defn save-module [body] (fn [state] (|case (body state) - ("lux;Right" state* output) + ($Right state* output) (return* (->> state* (set$ $ENVS (get$ $ENVS state)) (set$ $SOURCE (get$ $SOURCE state))) output) - ("lux;Left" msg) + ($Left msg) (fail* msg)))) (defn with-eval [body] (fn [state] (|case (body (set$ $EVAL? true state)) - ("lux;Right" state* output) + ($Right state* output) (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) - ("lux;Left" msg) + ($Left msg) (fail* msg)))) (def get-eval @@ -564,7 +583,7 @@ (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] (|case writer* - ("lux;Some" datum) + ($Some datum) (return* state datum) _ @@ -613,7 +632,7 @@ (fn [state] (let [output (body (update$ $ENVS #(|cons (env name) %) state))] (|case output - ("lux;Right" state* datum) + ($Right state* datum) (return* (update$ $ENVS |tail state*) datum) _ @@ -637,9 +656,9 @@ (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $HOST #(set$ $WRITER (V "lux;Some" writer) %) state))] + (let [output (body (update$ $HOST #(set$ $WRITER (V $Some writer) %) state))] (|case output - ("lux;Right" ?state ?value) + ($Right ?state ?value) (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) ?value) @@ -651,7 +670,7 @@ (fn [state] (let [output (body (set$ $EXPECTED type state))] (|case output - ("lux;Right" ?state ?value) + ($Right ?state ?value) (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) ?value) @@ -665,7 +684,7 @@ (fn [state] (let [output (body (set$ $cursor cursor state))] (|case output - ("lux;Right" ?state ?value) + ($Right ?state ?value) (return* (set$ $cursor (get$ $cursor state) ?state) ?value) @@ -674,40 +693,40 @@ (defn show-ast [ast] (|case ast - ("lux;Meta" _ ["lux;BoolS" ?value]) + ($Meta _ ($BoolS ?value)) (pr-str ?value) - ("lux;Meta" _ ["lux;IntS" ?value]) + ($Meta _ ($IntS ?value)) (pr-str ?value) - ("lux;Meta" _ ["lux;RealS" ?value]) + ($Meta _ ($RealS ?value)) (pr-str ?value) - ("lux;Meta" _ ["lux;CharS" ?value]) + ($Meta _ ($CharS ?value)) (pr-str ?value) - ("lux;Meta" _ ["lux;TextS" ?value]) + ($Meta _ ($TextS ?value)) (str "\"" ?value "\"") - ("lux;Meta" _ ["lux;TagS" ?module ?tag]) + ($Meta _ ($TagS ?module ?tag)) (str "#" ?module ";" ?tag) - ("lux;Meta" _ ["lux;SymbolS" ?module ?ident]) + ($Meta _ ($SymbolS ?module ?ident)) (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - ("lux;Meta" _ ["lux;TupleS" ?elems]) + ($Meta _ ($TupleS ?elems)) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - ("lux;Meta" _ ["lux;RecordS" ?elems]) + ($Meta _ ($RecordS ?elems)) (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - ("lux;Meta" _ ["lux;FormS" ?elems]) + ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) @@ -735,7 +754,7 @@ (return (|cons z zs))) [($Nil) ($Nil)] - (return (V "lux;Nil" nil)) + (return (V $Nil nil)) [_ _] (fail "Lists don't match in size."))) @@ -746,7 +765,7 @@ (|cons (f x y) (map2 f xs* ys*)) [_ _] - (V "lux;Nil" nil))) + (V $Nil nil))) (defn fold2 [f init xs ys] (|case [xs ys] @@ -763,8 +782,8 @@ (defn ^:private enumerate* [idx xs] (|case xs ($Cons x xs*) - (V "lux;Cons" (T (T idx x) - (enumerate* (inc idx) xs*))) + (V $Cons (T (T idx x) + (enumerate* (inc idx) xs*))) ($Nil) xs diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 7463bdce7..86359d26e 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -427,7 +427,7 @@ (|case ((&/with-writer =class (&/exhaust% compiler-step)) (&/set$ &/$SOURCE (&reader/from file-name file-content) state)) - ("lux;Right" ?state _) + (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports :let [_ (doto =class @@ -448,7 +448,7 @@ (&&/save-class! "_" (.toByteArray =class))) ?state) - ("lux;Left" ?message) + (&/$Left ?message) (fail* ?message))))))) )) )) @@ -460,10 +460,10 @@ (defn compile-program [program-module] (init!) (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) - ("lux;Right" ?state _) + (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) (&&package/package program-module)) - ("lux;Left" ?message) + (&/$Left ?message) (assert false ?message))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 8a9c8dfcc..02e9e1430 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - ("lux;TupleT" ("lux;Nil")) + ("lux;TupleT" (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) ("lux;DataT" "boolean") @@ -414,13 +414,13 @@ $end (new Label) $catch-finally (new Label) compile-finally (|case ?finally - ("lux;Some" ?finally*) (|do [_ (return nil) + (&/$Some ?finally*) (|do [_ (return nil) _ (compile ?finally*) :let [_ (doto *writer* (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $end))]] (return nil)) - ("lux;None") (|do [_ (return nil) + (&/$None) (|do [_ (return nil) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) @@ -448,11 +448,11 @@ ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally - ("lux;Some" ?finally*) (|do [_ (compile ?finally*) + (&/$Some ?finally*) (|do [_ (compile ?finally*) :let [_ (.visitInsn *writer* Opcodes/POP)] :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil)) - ("lux;None") (|do [_ (return nil) + (&/$None) (|do [_ (return nil) :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] @@ -564,7 +564,7 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;Nil") ;; VVIT + (.visitLdcInsn &/$Nil) ;; VVIT (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -609,7 +609,7 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; I2V (.visitInsn Opcodes/DUP) ;; I2VV (.visitLdcInsn (int 0)) ;; I2VVI - (.visitLdcInsn "lux;Cons") ;; I2VVIT + (.visitLdcInsn &/$Cons) ;; I2VVIT (.visitInsn Opcodes/AASTORE) ;; I2V (.visitInsn Opcodes/DUP_X1) ;; IV2V (.visitInsn Opcodes/SWAP) ;; IVV2 diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index bfa322206..6f785905a 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -30,11 +30,11 @@ (def ^:private $Nil "Analysis" - (variant$ "lux;Nil" (tuple$ (&/|list)))) + (variant$ &/$Nil (tuple$ (&/|list)))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (variant$ "lux;Cons" (tuple$ (&/|list head tail)))) + (variant$ &/$Cons (tuple$ (&/|list head tail)))) ;; [Exports] (defn ->analysis [type] @@ -74,11 +74,11 @@ ("lux;AllT" ?env ?name ?arg ?body) (variant$ "lux;AllT" (tuple$ (&/|list (|case ?env - ("lux;None") - (variant$ "lux;None" (tuple$ (&/|list))) + (&/$None) + (variant$ &/$None (tuple$ (&/|list))) - ("lux;Some" ??env) - (variant$ "lux;Some" + (&/$Some ??env) + (variant$ &/$Some (&/fold (fn [tail head] (|let [[hlabel htype] head] (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 2414d97b6..3f1ffb25a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -75,7 +75,7 @@ ("lux;LambdaT" _ _) (->type-signature function-class) - ("lux;TupleT" ("lux;Nil")) + ("lux;TupleT" (&/$Nil)) "V" )) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index bb6e54cb4..22e1b3de1 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -39,12 +39,12 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space)))))) + (return (&/V &/$Meta (&/T meta (&/V "White_Space" white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) + (return (&/V &/$Meta (&/T meta (&/V "Comment" comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") @@ -63,7 +63,7 @@ (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) + (return (&/V &/$Meta (&/T meta (&/V "Comment" comment)))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -72,7 +72,7 @@ (do-template [ ] (def (|do [[meta token] (&reader/read-regex )] - (return (&/V "lux;Meta" (&/T meta (&/V token)))))) + (return (&/V &/$Meta (&/T meta (&/V token)))))) ^:private lex-bool "Bool" #"^(true|false)" ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" @@ -86,13 +86,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V "lux;Meta" (&/T meta (&/V "Char" token)))))) + (return (&/V &/$Meta (&/T meta (&/V "Char" token)))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V "lux;Meta" (&/T meta (&/V "Text" token)))))) + (return (&/V &/$Meta (&/T meta (&/V "Text" token)))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -118,17 +118,17 @@ (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident)))))) + (return (&/V &/$Meta (&/T meta (&/V "Symbol" ident)))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident)))))) + (return (&/V &/$Meta (&/T meta (&/V "Tag" ident)))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/V "lux;Meta" (&/T meta (&/V nil)))))) + (return (&/V &/$Meta (&/T meta (&/V nil)))))) ^:private lex-open-paren "(" "Open_Paren" ^:private lex-close-paren ")" "Close_Paren" diff --git a/src/lux/parser.clj b/src/lux/parser.clj index aa05b48af..762e2582f 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -19,14 +19,14 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - ("lux;Meta" meta [ _]) + (&/$Meta meta [ _]) (return (&/V (&/fold &/|++ (&/|list) elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) - ^:private parse-form "Close_Paren" "parantheses" "lux;FormS" - ^:private parse-tuple "Close_Bracket" "brackets" "lux;TupleS" + ^:private parse-form "Close_Paren" "parantheses" &/$FormS + ^:private parse-tuple "Close_Bracket" "brackets" &/$TupleS ) (defn ^:private parse-record [parse] @@ -34,9 +34,9 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - ("lux;Meta" meta ("Close_Brace" _)) + (&/$Meta meta ("Close_Brace" _)) (if (even? (&/|length elems)) - (return (&/V "lux;RecordS" (&/|as-pairs elems))) + (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -45,7 +45,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [("lux;Meta" meta token*) token]] + :let [(&/$Meta meta token*) token]] (|case token* ("White_Space" _) (return (&/|list)) @@ -54,37 +54,37 @@ (return (&/|list)) ("Bool" ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) ("Int" ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Integer/parseInt ?value)))))) ("Real" ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Float/parseFloat ?value)))))) ("Char" ^String ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) ("Text" ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) ("Symbol" ?ident) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) ("Tag" ?ident) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) ("Open_Paren" _) (|do [syntax (parse-form parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ("Open_Bracket" _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ("Open_Brace" _) (|do [syntax (parse-record parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 6bda8f166..7cdf9efdf 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -16,10 +16,10 @@ (defn ^:private with-line [body] (fn [state] (|case (&/get$ &/$SOURCE state) - ("lux;Nil") + (&/$Nil) (fail* "[Reader Error] EOF") - ("lux;Cons" [[file-name line-num column-num] line] + (&/$Cons [[file-name line-num column-num] line] more) (|case (body file-name line-num column-num line) ("No" msg) @@ -37,11 +37,11 @@ (defn ^:private with-lines [body] (fn [state] (|case (body (&/get$ &/$SOURCE state)) - ("lux;Right" reader* match) + (&/$Right reader* match) (return* (&/set$ &/$SOURCE reader* state) match) - ("lux;Left" msg) + (&/$Left msg) (fail* msg) ))) @@ -103,10 +103,10 @@ (loop [prefix "" reader* reader] (|case reader* - ("lux;Nil") - (&/V "lux;Left" "[Reader Error] EOF") + (&/$Nil) + (&/V &/$Left "[Reader Error] EOF") - ("lux;Cons" [[file-name line-num column-num] ^String line] + (&/$Cons [[file-name line-num column-num] ^String line] reader**) (if-let [^String match (do ;; (prn 'read-regex+ regex line) (re-find1! regex column-num line))] @@ -114,10 +114,10 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V "lux;Right" (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) + (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) reader**) (&/T (&/T file-name line-num column-num) (str prefix match)))))) - (&/V "lux;Left" (str "[Reader Error] Pattern failed: " regex)))))))) + (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line diff --git a/src/lux/type.clj b/src/lux/type.clj index ab8ea4e61..45c1f2247 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -24,26 +24,26 @@ (def $Void (&/V "lux;VariantT" (&/|list))) (def IO - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "IO" "a" + (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a")))))) (def List - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;List" "a" - (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" Unit) - (&/T "lux;Cons" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") + (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" + (&/V "lux;VariantT" (&/|list (&/T &/$Nil Unit) + (&/T &/$Cons (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") (&/V "lux;BoundT" "a"))))))))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;Maybe" "a" - (&/V "lux;VariantT" (&/|list (&/T "lux;None" Unit) - (&/T "lux;Some" (&/V "lux;BoundT" "a"))))))) + (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" + (&/V "lux;VariantT" (&/|list (&/T &/$None Unit) + (&/T &/$Some (&/V "lux;BoundT" "a"))))))) (def Type (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "Type" "_" + (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) (&/T "lux;VariantT" TypeEnv) @@ -58,7 +58,7 @@ $Void)))) (defn fAll [name arg body] - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) name arg body))) + (&/V "lux;AllT" (&/T (&/V &/$None nil) name arg body))) (def Bindings (fAll "lux;Bindings" "k" @@ -84,9 +84,9 @@ (&/V "lux;TupleT" (&/|list Text Int Int))) (def Meta - (fAll "lux;Meta" "m" + (fAll &/$Meta "m" (fAll "" "v" - (&/V "lux;VariantT" (&/|list (&/T "lux;Meta" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") + (&/V "lux;VariantT" (&/|list (&/T &/$Meta (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") (&/V "lux;BoundT" "v"))))))))) (def Ident (&/V "lux;TupleT" (&/|list Text Text))) @@ -97,16 +97,16 @@ (&/V "lux;BoundT" "w"))))) AST*List (&/V "lux;AppT" (&/T List AST*))] (fAll "lux;AST'" "w" - (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) - (&/T "lux;IntS" Int) - (&/T "lux;RealS" Real) - (&/T "lux;CharS" Char) - (&/T "lux;TextS" Text) - (&/T "lux;SymbolS" Ident) - (&/T "lux;TagS" Ident) - (&/T "lux;FormS" AST*List) - (&/T "lux;TupleS" AST*List) - (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) + (&/V "lux;VariantT" (&/|list (&/T &/$BoolS Bool) + (&/T &/$IntS Int) + (&/T &/$RealS Real) + (&/T &/$CharS Char) + (&/T &/$TextS Text) + (&/T &/$SymbolS Ident) + (&/T &/$TagS Ident) + (&/T &/$FormS AST*List) + (&/T &/$TupleS AST*List) + (&/T &/$RecordS (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) )))) (def AST @@ -118,8 +118,8 @@ (def Either (fAll "lux;Either" "l" (fAll "" "r" - (&/V "lux;VariantT" (&/|list (&/T "lux;Left" (&/V "lux;BoundT" "l")) - (&/T "lux;Right" (&/V "lux;BoundT" "r"))))))) + (&/V "lux;VariantT" (&/|list (&/T &/$Left (&/V "lux;BoundT" "l")) + (&/T &/$Right (&/V "lux;BoundT" "r"))))))) (def StateE (fAll "lux;StateE" "s" @@ -192,10 +192,10 @@ (fn [state] (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] (|case type - ("lux;Some" type*) + (&/$Some type*) (return* state true) - ("lux;None") + (&/$None) (return* state false)) (fail* (str "[Type Error] Unknown type-var: " id))))) @@ -203,10 +203,10 @@ (fn [state] (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] (|case type* - ("lux;Some" type) + (&/$Some type) (return* state type) - ("lux;None") + (&/$None) (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id))))) @@ -214,11 +214,11 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] (|case tvar - ("lux;Some" bound) + (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) - ("lux;None") - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) + (&/$None) + (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V &/$Some type) %) ts)) state) nil)) @@ -231,7 +231,7 @@ (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))] (return* (&/update$ &/$TYPES #(->> % (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms)))) + (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V &/$None nil) ms)))) state) id)))) @@ -252,19 +252,19 @@ (if (.equals ^Object id ?id) (return binding) (|case ?type - ("lux;None") + (&/$None) (return binding) - ("lux;Some" ?type*) + (&/$Some ?type*) (|case ?type* ("lux;VarT" ?id*) (if (.equals ^Object id ?id*) - (return (&/T ?id (&/V "lux;None" nil))) + (return (&/T ?id (&/V &/$None nil))) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/T ?id (&/V "lux;Some" ?type**))))) + (return (&/T ?id (&/V &/$Some ?type**))))) )))) (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] (fn [state] @@ -324,15 +324,15 @@ ("lux;AllT" ?env ?name ?arg ?body) (|do [=env (|case ?env - ("lux;None") + (&/$None) (return ?env) - ("lux;Some" ?env*) + (&/$Some ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?env*)] - (return (&/V "lux;Some" clean-env)))) + (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) @@ -382,7 +382,7 @@ (str "(| " (->> cases (&/|map (fn [kv] (|case kv - [k ("lux;TupleT" ("lux;Nil"))] + [k ("lux;TupleT" (&/$Nil))] (str "#" k) [k v] @@ -479,10 +479,10 @@ (and (.equals ^Object xname yname) (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] - ;; [["lux;None" _] ["lux;None" _]] + ;; [[&/$None _] [&/$None _]] ;; true - ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] + ;; [[&/$Some xenv*] [&/$Some yenv*]] ;; (&/fold (fn [old bname] ;; (and old ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) @@ -502,13 +502,13 @@ (defn ^:private fp-get [k fixpoints] (|let [[e a] k] (|case fixpoints - ("lux;Nil") - (&/V "lux;None" nil) + (&/$Nil) + (&/V &/$None nil) - ("lux;Cons" [[e* a*] v*] fixpoints*) + (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/V "lux;Some" v*) + (&/V &/$Some v*) (fp-get k fixpoints*)) ))) @@ -542,10 +542,10 @@ ("lux;AllT" ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env - ("lux;None") - (&/V "lux;AllT" (&/T (&/V "lux;Some" env) ?local-name ?local-arg ?local-def)) + (&/$None) + (&/V "lux;AllT" (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) - ("lux;Some" _) + (&/$Some _) type) ("lux;LambdaT" ?input ?output) @@ -564,10 +564,10 @@ (|case type-fn ("lux;AllT" local-env local-name local-arg local-def) (let [local-env* (|case local-env - ("lux;None") + (&/$None) (&/|table) - ("lux;Some" local-env*) + (&/$Some local-env*) local-env*)] (return (beta-reduce (->> local-env* (&/|put local-name type-fn) @@ -607,39 +607,39 @@ (return (&/T fixpoints nil)) (|do [ebound (fn [state] (|case ((deref ?eid) state) - ("lux;Right" state* ebound) - (return* state* (&/V "lux;Some" ebound)) + (&/$Right state* ebound) + (return* state* (&/V &/$Some ebound)) - ("lux;Left" _) - (return* state (&/V "lux;None" nil)))) + (&/$Left _) + (return* state (&/V &/$None nil)))) abound (fn [state] (|case ((deref ?aid) state) - ("lux;Right" state* abound) - (return* state* (&/V "lux;Some" abound)) + (&/$Right state* abound) + (return* state* (&/V &/$Some abound)) - ("lux;Left" _) - (return* state (&/V "lux;None" nil))))] + (&/$Left _) + (return* state (&/V &/$None nil))))] (|case [ebound abound] - [("lux;None" _) ("lux;None" _)] + [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] (return (&/T fixpoints nil))) - [("lux;Some" etype) ("lux;None" _)] + [(&/$Some etype) (&/$None _)] (check* class-loader fixpoints etype actual) - [("lux;None" _) ("lux;Some" atype)] + [(&/$None _) (&/$Some atype)] (check* class-loader fixpoints expected atype) - [("lux;Some" etype) ("lux;Some" atype)] + [(&/$Some etype) (&/$Some atype)] (check* class-loader fixpoints etype atype)))) [("lux;VarT" ?id) _] (fn [state] (|case ((set-var ?id actual) state) - ("lux;Right" state* _) + (&/$Right state* _) (return* state* (&/T fixpoints nil)) - ("lux;Left" _) + (&/$Left _) ((|do [bound (deref ?id)] (check* class-loader fixpoints bound actual)) state))) @@ -647,10 +647,10 @@ [_ ("lux;VarT" ?id)] (fn [state] (|case ((set-var ?id expected) state) - ("lux;Right" state* _) + (&/$Right state* _) (return* state* (&/T fixpoints nil)) - ("lux;Left" _) + (&/$Left _) ((|do [bound (deref ?id)] (check* class-loader fixpoints expected bound)) state))) @@ -662,24 +662,24 @@ (|case [((|do [F2 (deref ?aid)] (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) state)] - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) state)))) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) (|case ((|do [F2 (deref ?aid)] (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) @@ -693,10 +693,10 @@ (|case ((|do [F1 (deref ?id)] (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) @@ -715,10 +715,10 @@ (|case ((|do [F2 (deref ?id)] (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) @@ -744,12 +744,12 @@ (&/fold str ""))) (assert false))] (|case (fp-get fp-pair fixpoints) - ("lux;Some" ?) + (&/$Some ?) (if ? (return (&/T fixpoints nil)) (fail (check-error expected actual))) - ("lux;None") + (&/$None) (|do [expected* (apply-type F A)] (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) -- cgit v1.2.3 From e6237709ed8954228e639a098d81fac2bcd81cab Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 20:29:17 -0400 Subject: More factoring of tags. --- src/lux/analyser.clj | 2 +- src/lux/analyser/case.clj | 116 +++++++-------- src/lux/analyser/host.clj | 48 +++---- src/lux/analyser/lux.clj | 42 +++--- src/lux/base.clj | 26 +++- src/lux/compiler/base.clj | 2 +- src/lux/compiler/host.clj | 20 +-- src/lux/compiler/type.clj | 32 ++--- src/lux/host.clj | 8 +- src/lux/type.clj | 356 +++++++++++++++++++++++----------------------- 10 files changed, 335 insertions(+), 317 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0ad6553bf..f8dd13bd6 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -529,7 +529,7 @@ (fn [?var] (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] (|case [?var ?output-type] - [("lux;VarT" ?e-id) ("lux;VarT" ?a-id)] + [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] (return (&/T ?output-term ?output-type*))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 0bbbde2d7..aaf11ff15 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -21,12 +21,12 @@ (defn ^:private resolve-type [type] (|case type - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (resolve-type type*)) - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] @@ -42,64 +42,64 @@ (defn adjust-type* [up type] "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" (|case type - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - ("lux;TupleT" ?members) - (|do [("lux;TupleT" ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;TupleT" (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - ("lux;RecordT" ?fields) - (|do [("lux;RecordT" ?fields*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;RecordT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?fields*)))) - - ("lux;VariantT" ?cases) - (|do [("lux;VariantT" ?cases*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;VariantT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?cases*)))) - - ("lux;AppT" ?tfun ?targ) + (&/$TupleT ?members) + (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$TupleT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$RecordT ?fields) + (|do [(&/$RecordT ?fields*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$RecordT (&/|map (fn [kv] + (|let [[k v] kv] + (&/T k (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)))) + ?fields*)))) + + (&/$VariantT ?cases) + (|do [(&/$VariantT ?cases*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [kv] + (|let [[k v] kv] + (&/T k (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)))) + ?cases*)))) + + (&/$AppT ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] (adjust-type* up =type)) - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (adjust-type* up type*)) @@ -153,7 +153,7 @@ (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) (|case value-type* - ("lux;TupleT" ?member-types) + (&/$TupleT ?member-types) (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) @@ -176,7 +176,7 @@ ;; value-type* (resolve-type value-type) ] (|case value-type* - ("lux;RecordT" ?slot-types) + (&/$RecordT ?slot-types) (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] @@ -207,7 +207,7 @@ (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) - ?values)) + ?values)) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) @@ -341,7 +341,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) ?structs ?members)] @@ -355,7 +355,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;RecordT" ?fields) + (&/$RecordT ?fields) (|do [totals (&/map% (fn [field] (|let [[?tk ?tv] field] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -372,7 +372,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (|do [totals (&/map% (fn [case] (|let [[?tk ?tv] case] (if-let [sub-struct (&/|get ?tk ?structs)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 06cb5ebfc..ec8b8b5db 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -37,7 +37,7 @@ (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" (|case token - [_ ("lux;DataT" _)] + [_ (&/$DataT _)] (return nil) _ @@ -46,16 +46,16 @@ (defn ^:private as-object [type] "(-> Type Type)" (|case type - ("lux;DataT" class) - (&/V "lux;DataT" (&type/as-obj class)) + (&/$DataT class) + (&/V &/$DataT (&type/as-obj class)) _ type)) ;; [Resources] (do-template [ ] - (let [input-type (&/V "lux;DataT" ) - output-type (&/V "lux;DataT" )] + (let [input-type (&/V &/$DataT ) + output-type (&/V &/$DataT )] (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) @@ -140,10 +140,10 @@ =classes (&/map% extract-text ?classes) =return (&host/lookup-static-method class-loader ?class ?method =classes) ;; :let [_ (matchv ::M/objects [=return] - ;; [["lux;DataT" _return-class]] + ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) + (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) =classes ?args) :let [output-type =return] @@ -162,8 +162,8 @@ (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] @@ -179,9 +179,9 @@ =return (if (= "" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] @@ -195,19 +195,19 @@ (return (&/|list (&/T (&/V "jvm-null?" =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V "lux;DataT" "null")] + (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&/V "lux;DataT" ?class)] + :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) + (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] @@ -309,11 +309,11 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&/V "lux;DataT" (as-otype itype)) + (&&env/with-local iname (&/V &/$DataT (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V "lux;DataT" (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs (&/|cons (&/T ";this" ?super-class) @@ -356,7 +356,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) @@ -370,7 +370,7 @@ (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&/V "lux;DataT" "java.lang.Throwable") _type)] + _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) (do-template [ ] @@ -386,9 +386,9 @@ ) (do-template [ ] - (let [output-type (&/V "lux;DataT" )] + (let [output-type (&/V &/$DataT )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" ) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -413,9 +413,9 @@ ) (do-template [ ] - (let [output-type (&/V "lux;DataT" )] + (let [output-type (&/V &/$DataT )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" ) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) + (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) _ (compile-token (&/V "jvm-program" =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index ac7e56ef4..6503fe2ea 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -37,14 +37,14 @@ (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) ?members ?elems)] (return (&/|list (&/T (&/V "tuple" =elems) exo-type)))) - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -73,7 +73,7 @@ (defn analyse-variant [analyse exo-type ident ?values] (|do [exo-type* (|case exo-type - ("lux;VarT" ?id) + (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) (|do [_ (&type/set-var ?id &type/Type)] @@ -82,7 +82,7 @@ _ (&type/actual-type exo-type))] (|case exo-type* - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] (|do [=value (analyse-variant-body analyse vtype ?values)] @@ -90,7 +90,7 @@ exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -101,11 +101,11 @@ (defn analyse-record [analyse exo-type ?elems] (|do [exo-type* (|case exo-type - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) - ("lux;AllT" _) + (&/$AllT _) (|do [$var &type/existential =type (&type/apply-type exo-type $var)] (&type/actual-type =type)) @@ -117,7 +117,7 @@ _ (&type/actual-type exo-type)) types (|case exo-type* - ("lux;RecordT" ?table) + (&/$RecordT ?table) (return ?table) _ @@ -139,7 +139,7 @@ _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) ?elems)] - (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) + (return (&/|list (&/T (&/V "record" =slots) (&/V &/$RecordT exo-type)))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -238,7 +238,7 @@ (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -247,21 +247,21 @@ (|do [type* (&type/apply-type ?fun-type* $var) [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] (|case $var - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] (&type/clean $var =output-t)))] (return (&/T type** =args))) )))) - ("lux;LambdaT" ?input-t ?output-t) + (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) - ;; [["lux;VarT" ?id-t]] + ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) _ @@ -314,7 +314,7 @@ (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -323,7 +323,7 @@ ;; exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - ("lux;LambdaT" ?arg-t ?return-t) + (&/$LambdaT ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] @@ -335,26 +335,26 @@ (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type - ("lux;AllT" _env _self _arg _body) + (&/$AllT _env _self _arg _body) (&type/with-var (fn [$var] (|do [exo-type* (&type/apply-type exo-type $var) [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] (|case $var - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id) ;; dtype* (&type/actual-type dtype) ] (|case dtype - ("lux;BoundT" ?vname) + (&/$BoundT ?vname) (return (&/T _expr exo-type)) - ("lux;ExT" _) + (&/$ExT _) (return (&/T _expr exo-type)) - ("lux;VarT" ?_id) + (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] ;; (return (&/T _expr exo-type)) (if ?? diff --git a/src/lux/base.clj b/src/lux/base.clj index 7ec9e3029..532f56695 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -12,17 +12,22 @@ clojure.core.match.array)) ;; [Tags] +;; List (def $Nil "lux;Nil") (def $Cons "lux;Cons") +;; Maybe (def $None "lux;None") (def $Some "lux;Some") +;; Meta (def $Meta "lux;Meta") +;; Either (def $Left "lux;Left") (def $Right "lux;Right") +;; AST (def $BoolS "lux;BoolS") (def $IntS "lux;IntS") (def $RealS "lux;RealS") @@ -34,6 +39,18 @@ (def $TupleS "lux;TupleS") (def $RecordS "lux;RecordS") +;; Type +(def $DataT "lux;DataT") +(def $TupleT "lux;TupleT") +(def $VariantT "lux;VariantT") +(def $RecordT "lux;RecordT") +(def $LambdaT "lux;LambdaT") +(def $VarT "lux;VarT") +(def $ExT "lux;ExT") +(def $BoundT "lux;BoundT") +(def $AppT "lux;AppT") +(def $AllT "lux;AllT") + ;; [Fields] ;; Binding (def $COUNTER 0) @@ -156,8 +173,9 @@ (V $Cons (T (T slot value) table*)) (V $Cons (T (T k v) (|put slot value table*)))) - _ - (assert false (prn-str '|put (aget table 0))))) + ;; _ + ;; (assert false (prn-str '|put (aget table 0))) + )) (defn |remove [slot table] (|case table @@ -541,7 +559,7 @@ ;; "lux;eval?" false ;; "lux;expected" - (V "lux;VariantT" (|list)) + (V $VariantT (|list)) ;; "lux;host" (host nil) ;; "lux;modules" @@ -677,7 +695,7 @@ _ output)))) -(defn with-cursor [cursor body] +(defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" (if (= "" (aget cursor 0)) body diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 74e5625b3..03fae9fec 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -50,7 +50,7 @@ (write-file (str module-dir "/" name ".class") data))) ;; [Exports] -(defn load-class! [^ClassLoader loader name] +(defn ^Class load-class! [^ClassLoader loader name] ;; (prn 'load-class! name) (.loadClass loader name)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 02e9e1430..78b9e72f6 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,34 +52,34 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - ("lux;TupleT" (&/$Nil)) + (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) - ("lux;DataT" "boolean") + (&/$DataT "boolean") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - ("lux;DataT" "byte") + (&/$DataT "byte") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - ("lux;DataT" "short") + (&/$DataT "short") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - ("lux;DataT" "int") + (&/$DataT "int") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - ("lux;DataT" "long") + (&/$DataT "long") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - ("lux;DataT" "float") + (&/$DataT "float") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - ("lux;DataT" "double") + (&/$DataT "double") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - ("lux;DataT" "char") + (&/$DataT "char") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - ("lux;DataT" _) + (&/$DataT _) nil) *writer*)) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 6f785905a..46e6ec2d9 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -40,18 +40,18 @@ (defn ->analysis [type] "(-> Type Analysis)" (|case type - ("lux;DataT" ?class) - (variant$ "lux;DataT" (text$ ?class)) + (&/$DataT ?class) + (variant$ &/$DataT (text$ ?class)) - ("lux;TupleT" ?members) - (variant$ "lux;TupleT" + (&/$TupleT ?members) + (variant$ &/$TupleT (&/fold (fn [tail head] (Cons$ (->analysis head) tail)) $Nil (&/|reverse ?members))) - ("lux;VariantT" ?cases) - (variant$ "lux;VariantT" + (&/$VariantT ?cases) + (variant$ &/$VariantT (&/fold (fn [tail head] (|let [[hlabel htype] head] (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) @@ -59,8 +59,8 @@ $Nil (&/|reverse ?cases))) - ("lux;RecordT" ?slots) - (variant$ "lux;RecordT" + (&/$RecordT ?slots) + (variant$ &/$RecordT (&/fold (fn [tail head] (|let [[hlabel htype] head] (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) @@ -68,11 +68,11 @@ $Nil (&/|reverse ?slots))) - ("lux;LambdaT" ?input ?output) - (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + (&/$LambdaT ?input ?output) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - ("lux;AllT" ?env ?name ?arg ?body) - (variant$ "lux;AllT" + (&/$AllT ?env ?name ?arg ?body) + (variant$ &/$AllT (tuple$ (&/|list (|case ?env (&/$None) (variant$ &/$None (tuple$ (&/|list))) @@ -89,9 +89,9 @@ (text$ ?arg) (->analysis ?body)))) - ("lux;BoundT" ?name) - (variant$ "lux;BoundT" (text$ ?name)) + (&/$BoundT ?name) + (variant$ &/$BoundT (text$ ?name)) - ("lux;AppT" ?fun ?arg) - (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (&/$AppT ?fun ?arg) + (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 3f1ffb25a..8ffe77b96 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,7 +29,7 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base))) ))) @@ -69,13 +69,13 @@ (defn ->java-sig [^objects type] (|case type - ("lux;DataT" ?name) + (&/$DataT ?name) (->type-signature ?name) - ("lux;LambdaT" _ _) + (&/$LambdaT _ _) (->type-signature function-class) - ("lux;TupleT" (&/$Nil)) + (&/$TupleT (&/$Nil)) "V" )) diff --git a/src/lux/type.clj b/src/lux/type.clj index 45c1f2247..0a80d4fbc 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -15,65 +15,65 @@ (declare show-type) ;; [Util] -(def Bool (&/V "lux;DataT" "java.lang.Boolean")) -(def Int (&/V "lux;DataT" "java.lang.Long")) -(def Real (&/V "lux;DataT" "java.lang.Double")) -(def Char (&/V "lux;DataT" "java.lang.Character")) -(def Text (&/V "lux;DataT" "java.lang.String")) -(def Unit (&/V "lux;TupleT" (&/|list))) -(def $Void (&/V "lux;VariantT" (&/|list))) +(def Bool (&/V &/$DataT "java.lang.Boolean")) +(def Int (&/V &/$DataT "java.lang.Long")) +(def Real (&/V &/$DataT "java.lang.Double")) +(def Char (&/V &/$DataT "java.lang.Character")) +(def Text (&/V &/$DataT "java.lang.String")) +(def Unit (&/V &/$TupleT (&/|list))) +(def $Void (&/V &/$VariantT (&/|list))) (def IO - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" - (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a")))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" + (&/V &/$LambdaT (&/T Unit (&/V &/$BoundT "a")))))) (def List - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" - (&/V "lux;VariantT" (&/|list (&/T &/$Nil Unit) - (&/T &/$Cons (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") - (&/V "lux;BoundT" "a"))))))))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" + (&/V &/$VariantT (&/|list (&/T &/$Nil Unit) + (&/T &/$Cons (&/V &/$TupleT (&/|list (&/V &/$BoundT "a") + (&/V &/$AppT (&/T (&/V &/$BoundT "lux;List") + (&/V &/$BoundT "a"))))))))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" - (&/V "lux;VariantT" (&/|list (&/T &/$None Unit) - (&/T &/$Some (&/V "lux;BoundT" "a"))))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" + (&/V &/$VariantT (&/|list (&/T &/$None Unit) + (&/T &/$Some (&/V &/$BoundT "a"))))))) (def Type - (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) - TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) - TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" - (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) - (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) - (&/T "lux;VariantT" TypeEnv) - (&/T "lux;RecordT" TypeEnv) - (&/T "lux;LambdaT" TypePair) - (&/T "lux;BoundT" Text) - (&/T "lux;VarT" Int) - (&/T "lux;AllT" (&/V "lux;TupleT" (&/|list (&/V "lux;AppT" (&/T Maybe TypeEnv)) Text Text Type))) - (&/T "lux;AppT" TypePair) - (&/T "lux;ExT" Int) + (let [Type (&/V &/$AppT (&/T (&/V &/$BoundT "Type") (&/V &/$BoundT "_"))) + TypeEnv (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Type)))) + TypePair (&/V &/$TupleT (&/|list Type Type))] + (&/V &/$AppT (&/T (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" + (&/V &/$VariantT (&/|list (&/T &/$DataT Text) + (&/T &/$TupleT (&/V &/$AppT (&/T List Type))) + (&/T &/$VariantT TypeEnv) + (&/T &/$RecordT TypeEnv) + (&/T &/$LambdaT TypePair) + (&/T &/$BoundT Text) + (&/T &/$VarT Int) + (&/T &/$AllT (&/V &/$TupleT (&/|list (&/V &/$AppT (&/T Maybe TypeEnv)) Text Text Type))) + (&/T &/$AppT TypePair) + (&/T &/$ExT Int) )))) $Void)))) (defn fAll [name arg body] - (&/V "lux;AllT" (&/T (&/V &/$None nil) name arg body))) + (&/V &/$AllT (&/T (&/V &/$None nil) name arg body))) (def Bindings (fAll "lux;Bindings" "k" (fAll "" "v" - (&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int) - (&/T "lux;mappings" (&/V "lux;AppT" (&/T List - (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "k") - (&/V "lux;BoundT" "v"))))))))))) + (&/V &/$RecordT (&/|list (&/T "lux;counter" Int) + (&/T "lux;mappings" (&/V &/$AppT (&/T List + (&/V &/$TupleT (&/|list (&/V &/$BoundT "k") + (&/V &/$BoundT "v"))))))))))) (def Env - (let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k"))) - (&/V "lux;BoundT" "v")))] + (let [bindings (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings (&/V &/$BoundT "k"))) + (&/V &/$BoundT "v")))] (fAll "lux;Env" "k" (fAll "" "v" - (&/V "lux;RecordT" + (&/V &/$RecordT (&/|list (&/T "lux;name" Text) (&/T "lux;inner-closures" Int) (&/T "lux;locals" bindings) @@ -81,23 +81,23 @@ )))))) (def Cursor - (&/V "lux;TupleT" (&/|list Text Int Int))) + (&/V &/$TupleT (&/|list Text Int Int))) (def Meta (fAll &/$Meta "m" (fAll "" "v" - (&/V "lux;VariantT" (&/|list (&/T &/$Meta (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") - (&/V "lux;BoundT" "v"))))))))) + (&/V &/$VariantT (&/|list (&/T &/$Meta (&/V &/$TupleT (&/|list (&/V &/$BoundT "m") + (&/V &/$BoundT "v"))))))))) -(def Ident (&/V "lux;TupleT" (&/|list Text Text))) +(def Ident (&/V &/$TupleT (&/|list Text Text))) (def AST* - (let [AST* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;AST'") - (&/V "lux;BoundT" "w"))))) - AST*List (&/V "lux;AppT" (&/T List AST*))] + (let [AST* (&/V &/$AppT (&/T (&/V &/$BoundT "w") + (&/V &/$AppT (&/T (&/V &/$BoundT "lux;AST'") + (&/V &/$BoundT "w"))))) + AST*List (&/V &/$AppT (&/T List AST*))] (fAll "lux;AST'" "w" - (&/V "lux;VariantT" (&/|list (&/T &/$BoolS Bool) + (&/V &/$VariantT (&/|list (&/T &/$BoolS Bool) (&/T &/$IntS Int) (&/T &/$RealS Real) (&/T &/$CharS Char) @@ -106,75 +106,75 @@ (&/T &/$TagS Ident) (&/T &/$FormS AST*List) (&/T &/$TupleS AST*List) - (&/T &/$RecordS (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) + (&/T &/$RecordS (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list AST* AST*)))))) )))) (def AST - (let [w (&/V "lux;AppT" (&/T Meta Cursor))] - (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T AST* w)))))) + (let [w (&/V &/$AppT (&/T Meta Cursor))] + (&/V &/$AppT (&/T w (&/V &/$AppT (&/T AST* w)))))) -(def ^:private ASTList (&/V "lux;AppT" (&/T List AST))) +(def ^:private ASTList (&/V &/$AppT (&/T List AST))) (def Either (fAll "lux;Either" "l" (fAll "" "r" - (&/V "lux;VariantT" (&/|list (&/T &/$Left (&/V "lux;BoundT" "l")) - (&/T &/$Right (&/V "lux;BoundT" "r"))))))) + (&/V &/$VariantT (&/|list (&/T &/$Left (&/V &/$BoundT "l")) + (&/T &/$Right (&/V &/$BoundT "r"))))))) (def StateE (fAll "lux;StateE" "s" (fAll "" "a" - (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s") - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text)) - (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "s") - (&/V "lux;BoundT" "a")))))))))) + (&/V &/$LambdaT (&/T (&/V &/$BoundT "s") + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Either Text)) + (&/V &/$TupleT (&/|list (&/V &/$BoundT "s") + (&/V &/$BoundT "a")))))))))) (def Reader - (&/V "lux;AppT" (&/T List - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Meta Cursor)) + (&/V &/$AppT (&/T List + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Meta Cursor)) Text))))) (def HostState - (&/V "lux;RecordT" - (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter")) - (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader")) - (&/T "lux;classes" (&/V "lux;DataT" "clojure.lang.Atom"))))) + (&/V &/$RecordT + (&/|list (&/T "lux;writer" (&/V &/$DataT "org.objectweb.asm.ClassWriter")) + (&/T "lux;loader" (&/V &/$DataT "java.lang.ClassLoader")) + (&/T "lux;classes" (&/V &/$DataT "clojure.lang.Atom"))))) (def DefData* (fAll "lux;DefData'" "" - (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Type) - (&/T "lux;ValueD" (&/V "lux;TupleT" (&/|list Type Unit))) - (&/T "lux;MacroD" (&/V "lux;BoundT" "")) + (&/V &/$VariantT (&/|list (&/T "lux;TypeD" Type) + (&/T "lux;ValueD" (&/V &/$TupleT (&/|list Type Unit))) + (&/T "lux;MacroD" (&/V &/$BoundT "")) (&/T "lux;AliasD" Ident))))) (def LuxVar - (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int) + (&/V &/$VariantT (&/|list (&/T "lux;Local" Int) (&/T "lux;Global" Ident)))) (def $Module (fAll "lux;$Module" "Compiler" - (&/V "lux;RecordT" - (&/|list (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text))))) - (&/T "lux;defs" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" + (&/V &/$RecordT + (&/|list (&/T "lux;module-aliases" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Text))))) + (&/T "lux;defs" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text - (&/V "lux;TupleT" (&/|list Bool - (&/V "lux;AppT" (&/T DefData* - (&/V "lux;LambdaT" (&/T ASTList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) + (&/V &/$TupleT (&/|list Bool + (&/V &/$AppT (&/T DefData* + (&/V &/$LambdaT (&/T ASTList + (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE (&/V &/$BoundT "Compiler"))) ASTList))))))))))))) - (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text))))))) + (&/T "lux;imports" (&/V &/$AppT (&/T List Text))))))) (def $Compiler - (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" - (&/V "lux;RecordT" + (&/V &/$AppT (&/T (fAll "lux;Compiler" "" + (&/V &/$RecordT (&/|list (&/T "lux;source" Reader) - (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" + (&/T "lux;modules" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text - (&/V "lux;AppT" (&/T $Module (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" "")))))))))) - (&/T "lux;envs" (&/V "lux;AppT" (&/T List - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text)) - (&/V "lux;TupleT" (&/|list LuxVar Type))))))) - (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) + (&/V &/$AppT (&/T $Module (&/V &/$AppT (&/T (&/V &/$BoundT "lux;Compiler") (&/V &/$BoundT "")))))))))) + (&/T "lux;envs" (&/V &/$AppT (&/T List + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Env Text)) + (&/V &/$TupleT (&/|list LuxVar Type))))))) + (&/T "lux;types" (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) (&/T "lux;seed" Int) (&/T "lux;eval?" Bool) @@ -184,8 +184,8 @@ $Void))) (def Macro - (&/V "lux;LambdaT" (&/T ASTList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) + (&/V &/$LambdaT (&/T ASTList + (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE $Compiler)) ASTList))))) (defn bound? [id] @@ -237,7 +237,7 @@ (def existential (|do [seed &/gen-id] - (return (&/V "lux;ExT" seed)))) + (return (&/V &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -257,7 +257,7 @@ (&/$Some ?type*) (|case ?type* - ("lux;VarT" ?id*) + (&/$VarT ?id*) (if (.equals ^Object id ?id*) (return (&/T ?id (&/V &/$None nil))) (return binding)) @@ -277,52 +277,52 @@ (defn with-var [k] (|do [id create-var - output (k (&/V "lux;VarT" id)) + output (k (&/V &/$VarT id)) _ (delete-var id)] (return output))) (defn with-vars [amount k] (|do [=vars (&/map% (constantly create-var) (&/|range amount)) - output (k (&/|map #(&/V "lux;VarT" %) =vars)) + output (k (&/|map #(&/V &/$VarT %) =vars)) _ (&/map% delete-var (&/|reverse =vars))] (return output))) (defn clean* [?tid type] (|case type - ("lux;VarT" ?id) + (&/$VarT ?id) (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) - ("lux;LambdaT" ?arg ?return) + (&/$LambdaT ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] - (return (&/V "lux;LambdaT" (&/T =arg =return)))) + (return (&/V &/$LambdaT (&/T =arg =return)))) - ("lux;AppT" ?lambda ?param) + (&/$AppT ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] - (return (&/V "lux;AppT" (&/T =lambda =param)))) + (return (&/V &/$AppT (&/T =lambda =param)))) - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (&/V "lux;TupleT" =members))) + (return (&/V &/$TupleT =members))) - ("lux;VariantT" ?members) + (&/$VariantT ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] - (return (&/V "lux;VariantT" =members))) + (return (&/V &/$VariantT =members))) - ("lux;RecordT" ?members) + (&/$RecordT ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] - (return (&/V "lux;RecordT" =members))) + (return (&/V &/$RecordT =members))) - ("lux;AllT" ?env ?name ?arg ?body) + (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env (&/$None) (return ?env) @@ -334,7 +334,7 @@ ?env*)] (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] - (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) + (return (&/V &/$AllT (&/T =env ?name ?arg body*)))) _ (return type) @@ -342,7 +342,7 @@ (defn clean [tvar type] (|case tvar - ("lux;VarT" ?id) + (&/$VarT ?id) (clean* ?id type) _ @@ -350,7 +350,7 @@ (defn ^:private unravel-fun [type] (|case type - ("lux;LambdaT" ?in ?out) + (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] (&/T ??out (&/|cons ?in ?args))) @@ -359,7 +359,7 @@ (defn ^:private unravel-app [fun-type] (|case fun-type - ("lux;AppT" ?left ?right) + (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) @@ -368,21 +368,21 @@ (defn show-type [^objects type] (|case type - ("lux;DataT" name) + (&/$DataT name) (str "(^ " name ")") - ("lux;TupleT" elems) + (&/$TupleT elems) (if (&/|empty? elems) "(,)" (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - ("lux;VariantT" cases) + (&/$VariantT cases) (if (&/|empty? cases) "(|)" (str "(| " (->> cases (&/|map (fn [kv] (|case kv - [k ("lux;TupleT" (&/$Nil))] + [k (&/$TupleT (&/$Nil))] (str "#" k) [k v] @@ -391,7 +391,7 @@ (&/fold str "")) ")")) - ("lux;RecordT" fields) + (&/$RecordT fields) (str "(& " (->> fields (&/|map (fn [kv] (|case kv @@ -400,29 +400,29 @@ (&/|interpose " ") (&/fold str "")) ")") - ("lux;LambdaT" input output) + (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - ("lux;VarT" id) + (&/$VarT id) (str "⌈" id "⌋") - ("lux;ExT" ?id) + (&/$ExT ?id) (str "⟨" ?id "⟩") - ("lux;BoundT" name) + (&/$BoundT name) name - ("lux;AppT" _ _) + (&/$AppT _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - ("lux;AllT" ?env ?name ?arg ?body) + (&/$AllT ?env ?name ?arg ?body) (if (= "" ?name) (let [[args body] (loop [args (list ?arg) body* ?body] (|case body* - ("lux;AllT" ?env* ?name* ?arg* ?body*) + (&/$AllT ?env* ?name* ?arg* ?body*) (recur (cons ?arg* args) ?body*) _ @@ -434,16 +434,16 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] - [("lux;DataT" xname) ("lux;DataT" yname)] + [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [("lux;TupleT" xelems) ("lux;TupleT" yelems)] + [(&/$TupleT xelems) (&/$TupleT yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) - [("lux;VariantT" xcases) ("lux;VariantT" ycases)] + [(&/$VariantT xcases) (&/$VariantT ycases)] (&/fold2 (fn [old xcase ycase] (|let [[xname xtype] xcase [yname ytype] ycase] @@ -451,7 +451,7 @@ true xcases ycases) - [("lux;RecordT" xslots) ("lux;RecordT" yslots)] + [(&/$RecordT xslots) (&/$RecordT yslots)] (&/fold2 (fn [old xslot yslot] (|let [[xname xtype] xslot [yname ytype] yslot] @@ -459,23 +459,23 @@ true xslots yslots) - [("lux;LambdaT" xinput xoutput) ("lux;LambdaT" yinput youtput)] + [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) - [("lux;VarT" xid) ("lux;VarT" yid)] + [(&/$VarT xid) (&/$VarT yid)] (.equals ^Object xid yid) - [("lux;BoundT" xname) ("lux;BoundT" yname)] + [(&/$BoundT xname) (&/$BoundT yname)] (.equals ^Object xname yname) - [("lux;ExT" xid) ("lux;ExT" yid)] + [(&/$ExT xid) (&/$ExT yid)] (.equals ^Object xid yid) - [("lux;AppT" xlambda xparam) ("lux;AppT" ylambda yparam)] + [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [("lux;AllT" xenv xname xarg xbody) ("lux;AllT" yenv yname yarg ybody)] + [(&/$AllT xenv xname xarg xbody) (&/$AllT yenv yname yarg ybody)] (and (.equals ^Object xname yname) (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] @@ -522,36 +522,36 @@ (defn beta-reduce [env type] (|case type - ("lux;VariantT" ?cases) - (&/V "lux;VariantT" (&/|map (fn [kv] + (&/$VariantT ?cases) + (&/V &/$VariantT (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?cases)) - ("lux;RecordT" ?fields) - (&/V "lux;RecordT" (&/|map (fn [kv] + (&/$RecordT ?fields) + (&/V &/$RecordT (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?fields)) - ("lux;TupleT" ?members) - (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members)) + (&/$TupleT ?members) + (&/V &/$TupleT (&/|map (partial beta-reduce env) ?members)) - ("lux;AppT" ?type-fn ?type-arg) - (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) + (&/$AppT ?type-fn ?type-arg) + (&/V &/$AppT (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) - ("lux;AllT" ?local-env ?local-name ?local-arg ?local-def) + (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (&/V "lux;AllT" (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) + (&/V &/$AllT (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) (&/$Some _) type) - ("lux;LambdaT" ?input ?output) - (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output))) + (&/$LambdaT ?input ?output) + (&/V &/$LambdaT (&/T (beta-reduce env ?input) (beta-reduce env ?output))) - ("lux;BoundT" ?name) + (&/$BoundT ?name) (if-let [bound (&/|get ?name env)] (beta-reduce env bound) type) @@ -562,7 +562,7 @@ (defn apply-type [type-fn param] (|case type-fn - ("lux;AllT" local-env local-name local-arg local-def) + (&/$AllT local-env local-name local-arg local-def) (let [local-env* (|case local-env (&/$None) (&/|table) @@ -574,7 +574,7 @@ (&/|put local-arg param)) local-def))) - ("lux;AppT" F A) + (&/$AppT F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -602,7 +602,7 @@ (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) (|case [expected actual] - [("lux;VarT" ?eid) ("lux;VarT" ?aid)] + [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/T fixpoints nil)) (|do [ebound (fn [state] @@ -633,7 +633,7 @@ [(&/$Some etype) (&/$Some atype)] (check* class-loader fixpoints etype atype)))) - [("lux;VarT" ?id) _] + [(&/$VarT ?id) _] (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) @@ -644,7 +644,7 @@ (check* class-loader fixpoints bound actual)) state))) - [_ ("lux;VarT" ?id)] + [_ (&/$VarT ?id)] (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) @@ -655,18 +655,18 @@ (check* class-loader fixpoints expected bound)) state))) - [("lux;AppT" ("lux;VarT" ?eid) A1) ("lux;AppT" ("lux;VarT" ?aid) A2)] + [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] (fn [state] (|case ((|do [F1 (deref ?eid)] (fn [state] (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) (&/V &/$AppT (&/T F2 A2)))) state)] (&/$Right state* output) (return* state* output) (&/$Left _) - ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + ((check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual) state)))) state) (&/$Right state* output) @@ -674,65 +674,65 @@ (&/$Left _) (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) state)))) - ;; (|do [_ (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; (|do [_ (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) - [("lux;AppT" ("lux;VarT" ?id) A1) ("lux;AppT" F2 A2)] + [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual)) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) - ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] + ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [("lux;AppT" F1 A1) ("lux;AppT" ("lux;VarT" ?id) A2)] + [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] + ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [("lux;AppT" F A) _] + [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) @@ -753,28 +753,28 @@ (|do [expected* (apply-type F A)] (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) - [_ ("lux;AppT" F A)] + [_ (&/$AppT F A)] (|do [actual* (apply-type F A)] (check* class-loader fixpoints expected actual*)) - [("lux;AllT" _) _] + [(&/$AllT _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] (check* class-loader fixpoints expected* actual)))) - [_ ("lux;AllT" _)] + [_ (&/$AllT _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints expected actual*)))) - [("lux;DataT" e!name) ("lux;DataT" "null")] + [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) - [["lux;DataT" e!name] ["lux;DataT" a!name]] + [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) @@ -782,11 +782,11 @@ (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) - [("lux;LambdaT" eI eO) ("lux;LambdaT" aI aO)] + [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [("lux;TupleT" e!members) ("lux;TupleT" a!members)] + [(&/$TupleT e!members) (&/$TupleT a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp e a)] (return fp*))) @@ -794,7 +794,7 @@ e!members a!members)] (return (&/T fixpoints* nil))) - [("lux;VariantT" e!cases) ("lux;VariantT" a!cases)] + [(&/$VariantT e!cases) (&/$VariantT a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] (|let [[e!name e!type] e!case [a!name a!type] a!case] @@ -806,7 +806,7 @@ e!cases a!cases)] (return (&/T fixpoints* nil))) - [("lux;RecordT" e!slots) ("lux;RecordT" a!slots)] + [(&/$RecordT e!slots) (&/$RecordT a!slots)] (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] (|let [[e!name e!type] e!slot [a!name a!type] a!slot] @@ -818,7 +818,7 @@ e!slots a!slots)] (return (&/T fixpoints* nil))) - [("lux;ExT" e!id) ("lux;ExT" a!id)] + [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -834,11 +834,11 @@ (defn apply-lambda [func param] (|case func - ("lux;LambdaT" input output) + (&/$LambdaT input output) (|do [_ (check* init-fixpoints input param)] (return output)) - ("lux;AllT" _) + (&/$AllT _) (with-var (fn [$var] (|do [func* (apply-type func $var) @@ -851,11 +851,11 @@ (defn actual-type [type] (|case type - ("lux;AppT" ?all ?param) + (&/$AppT ?all ?param) (|do [type* (apply-type ?all ?param)] (actual-type type*)) - ("lux;VarT" ?id) + (&/$VarT ?id) (deref ?id) _ @@ -864,7 +864,7 @@ (defn variant-case [case type] (|case type - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (if-let [case-type (&/|get case ?cases)] (return case-type) (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) -- cgit v1.2.3 From ede9a0500ed00b5636d5eaf9a5b470f159c97edb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 8 Aug 2015 17:57:07 -0400 Subject: More refactoring of tags, this time for reader, lexer & parser. --- src/lux/base.clj | 4 ++++ src/lux/lexer.clj | 53 ++++++++++++++++++++++++++++++++++++----------------- src/lux/parser.clj | 51 +++++++++++++++++++++++++++++++++++---------------- src/lux/reader.clj | 32 +++++++++++++++++++------------- 4 files changed, 94 insertions(+), 46 deletions(-) diff --git a/src/lux/base.clj b/src/lux/base.clj index 532f56695..66b972f94 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -12,6 +12,10 @@ clojure.core.match.array)) ;; [Tags] +(defmacro deftags [prefix & names] + `(do ~@(for [name names] + `(def ~(symbol (str "$" name)) ~name)))) + ;; List (def $Nil "lux;Nil") (def $Cons "lux;Cons") diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 22e1b3de1..e848cc3fd 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -8,10 +8,29 @@ (ns lux.lexer (:require [clojure.template :refer [do-template]] - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [deftags |do return* return fail fail*]] [reader :as &reader]) [lux.analyser.module :as &module])) +;; [Tags] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" + ) + ;; [Utils] (defn ^:private escape-char [escaped] (cond (.equals ^Object escaped "\\t") (return "\t") @@ -39,12 +58,12 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V &/$Meta (&/T meta (&/V "White_Space" white-space)))))) + (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V &/$Meta (&/T meta (&/V "Comment" comment)))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") @@ -63,7 +82,7 @@ (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V &/$Meta (&/T meta (&/V "Comment" comment)))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -74,9 +93,9 @@ (|do [[meta token] (&reader/read-regex )] (return (&/V &/$Meta (&/T meta (&/V token)))))) - ^:private lex-bool "Bool" #"^(true|false)" - ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" - ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" + ^:private lex-bool $Bool #"^(true|false)" + ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" + ^:private lex-real $Real #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char @@ -86,13 +105,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V "Char" token)))))) + (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V "Text" token)))))) + (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -118,24 +137,24 @@ (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V "Symbol" ident)))))) + (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V "Tag" ident)))))) + (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] (return (&/V &/$Meta (&/T meta (&/V nil)))))) - ^:private lex-open-paren "(" "Open_Paren" - ^:private lex-close-paren ")" "Close_Paren" - ^:private lex-open-bracket "[" "Open_Bracket" - ^:private lex-close-bracket "]" "Close_Bracket" - ^:private lex-open-brace "{" "Open_Brace" - ^:private lex-close-brace "}" "Close_Brace" + ^:private lex-open-paren "(" $Open_Paren + ^:private lex-close-paren ")" $Close_Paren + ^:private lex-open-bracket "[" $Open_Bracket + ^:private lex-close-bracket "]" $Close_Bracket + ^:private lex-open-brace "{" $Open_Brace + ^:private lex-close-brace "}" $Close_Brace ) (def ^:private lex-delimiter diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 762e2582f..a8b2cfc16 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -10,9 +10,28 @@ (:require [clojure.template :refer [do-template]] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail |case]] + (lux [base :as & :refer [deftags |do return fail |case]] [lexer :as &lexer]))) +;; [Tags] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" + ) + ;; [Utils] (do-template [ ] (defn [parse] @@ -25,8 +44,8 @@ _ (fail (str "[Parser Error] Unbalanced " "."))))) - ^:private parse-form "Close_Paren" "parantheses" &/$FormS - ^:private parse-tuple "Close_Bracket" "brackets" &/$TupleS + ^:private parse-form $Close_Paren "parantheses" &/$FormS + ^:private parse-tuple $Close_Bracket "brackets" &/$TupleS ) (defn ^:private parse-record [parse] @@ -34,7 +53,7 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - (&/$Meta meta ("Close_Brace" _)) + (&/$Meta meta ($Close_Brace _)) (if (even? (&/|length elems)) (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) @@ -47,42 +66,42 @@ (|do [token &lexer/lex :let [(&/$Meta meta token*) token]] (|case token* - ("White_Space" _) + ($White_Space _) (return (&/|list)) - ("Comment" _) + ($Comment _) (return (&/|list)) - ("Bool" ?value) + ($Bool ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) - ("Int" ?value) + ($Int ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Integer/parseInt ?value)))))) - ("Real" ?value) + ($Real ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Float/parseFloat ?value)))))) - ("Char" ^String ?value) + ($Char ^String ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) - ("Text" ?value) + ($Text ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) - ("Symbol" ?ident) + ($Symbol ?ident) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) - ("Tag" ?ident) + ($Tag ?ident) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) - ("Open_Paren" _) + ($Open_Paren _) (|do [syntax (parse-form parse)] (return (&/|list (&/V &/$Meta (&/T meta syntax))))) - ("Open_Bracket" _) + ($Open_Bracket _) (|do [syntax (parse-tuple parse)] (return (&/|list (&/V &/$Meta (&/T meta syntax))))) - ("Open_Brace" _) + ($Open_Brace _) (|do [syntax (parse-record parse)] (return (&/|list (&/V &/$Meta (&/T meta syntax))))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 7cdf9efdf..6aa8cca6d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,7 +10,13 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* |let |case]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) + +;; [Tags] +(deftags "" + "No" + "Done" + "Yes") ;; [Utils] (defn ^:private with-line [body] @@ -22,14 +28,14 @@ (&/$Cons [[file-name line-num column-num] line] more) (|case (body file-name line-num column-num line) - ("No" msg) + ($No msg) (fail* msg) - ("Done" output) + ($Done output) (return* (&/set$ &/$SOURCE more state) output) - ("Yes" output line*) + ($Yes output line*) (return* (&/set$ &/$SOURCE (&/|cons line* more) state) output)) ))) @@ -79,10 +85,10 @@ match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) match)) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) match) + (&/V $Done (&/T (&/T file-name line-num column-num) match)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -92,10 +98,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) + (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -127,10 +133,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) text)) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) text) + (&/V $Done (&/T (&/T file-name line-num column-num) text)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Text failed: " text)))))) + (&/V $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] -- cgit v1.2.3 From eb1290b70e26e7cf176e12873aca1593a70f2276 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 8 Aug 2015 18:40:29 -0400 Subject: Refactored tags for pattern-matching and vars. --- src/lux/analyser/case.clj | 145 +++++++++++++++++++++++++++------------------- src/lux/analyser/env.clj | 2 +- src/lux/analyser/lux.clj | 10 ++-- src/lux/base.clj | 5 ++ src/lux/compiler.clj | 4 +- src/lux/compiler/case.clj | 19 +++--- 6 files changed, 108 insertions(+), 77 deletions(-) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index aaf11ff15..6cf070a52 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -9,12 +9,37 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail |let |case]] + (lux [base :as & :refer [deftags |do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] [env :as &env]))) +;; [Tags] +(deftags "" + "DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "RecordTotal" + "VariantTotal" + ) + +(deftags "" + "StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "RecordTestAC" + "VariantTestAC" + ) + ;; [Utils] (def ^:private unit (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) @@ -119,7 +144,7 @@ (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/T (&/V "StoreTestAC" idx) =kont))) + (return (&/T (&/V $StoreTestAC idx) =kont))) (&/$SymbolS ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) @@ -127,27 +152,27 @@ (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/T (&/V "BoolTestAC" ?value) =kont))) + (return (&/T (&/V $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/T (&/V "IntTestAC" ?value) =kont))) + (return (&/T (&/V $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/T (&/V "RealTestAC" ?value) =kont))) + (return (&/T (&/V $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/T (&/V "CharTestAC" ?value) =kont))) + (return (&/T (&/V $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/T (&/V "TextTestAC" ?value) =kont))) + (return (&/T (&/V $TextTestAC ?value) =kont))) (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] @@ -164,7 +189,7 @@ (|do [=kont kont] (return (&/T (&/|list) =kont))) (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V "TupleTestAC" =tests) =kont))))) + (return (&/T (&/V $TupleTestAC =tests) =kont))))) _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) @@ -194,7 +219,7 @@ (|do [=kont kont] (return (&/T (&/|table) =kont))) (&/|reverse ?slots))] - (return (&/T (&/V "RecordTestAC" =tests) =kont)))) + (return (&/T (&/V $RecordTestAC =tests) =kont)))) _ (fail "[Pattern-matching Error] Record requires record-type."))) @@ -204,7 +229,7 @@ value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type unit kont)] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) @@ -216,7 +241,7 @@ 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] @@ -228,68 +253,68 @@ (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] - [("DefaultTotal" total?) ("StoreTestAC" ?idx)] - (return (&/V "DefaultTotal" true)) + [($DefaultTotal total?) ($StoreTestAC ?idx)] + (return (&/V $DefaultTotal true)) - [[?tag [total? ?values]] ("StoreTestAC" ?idx)] + [[?tag [total? ?values]] ($StoreTestAC ?idx)] (return (&/V ?tag (&/T true ?values))) - [("DefaultTotal" total?) ("BoolTestAC" ?value)] - (return (&/V "BoolTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($BoolTestAC ?value)] + (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) - [("BoolTotal" total? ?values) ("BoolTestAC" ?value)] - (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values)))) + [($BoolTotal total? ?values) ($BoolTestAC ?value)] + (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("IntTestAC" ?value)] - (return (&/V "IntTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($IntTestAC ?value)] + (return (&/V $IntTotal (&/T total? (&/|list ?value)))) - [("IntTotal" total? ?values) ("IntTestAC" ?value)] - (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values)))) + [($IntTotal total? ?values) ($IntTestAC ?value)] + (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("RealTestAC" ?value)] - (return (&/V "RealTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($RealTestAC ?value)] + (return (&/V $RealTotal (&/T total? (&/|list ?value)))) - [("RealTotal" total? ?values) ("RealTestAC" ?value)] - (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values)))) + [($RealTotal total? ?values) ($RealTestAC ?value)] + (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("CharTestAC" ?value)] - (return (&/V "CharTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($CharTestAC ?value)] + (return (&/V $CharTotal (&/T total? (&/|list ?value)))) - [("CharTotal" total? ?values) ("CharTestAC" ?value)] - (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values)))) + [($CharTotal total? ?values) ($CharTestAC ?value)] + (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("TextTestAC" ?value)] - (return (&/V "TextTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($TextTestAC ?value)] + (return (&/V $TextTotal (&/T total? (&/|list ?value)))) - [("TextTotal" total? ?values) ("TextTestAC" ?value)] - (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values)))) + [($TextTotal total? ?values) ($TextTestAC ?value)] + (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("TupleTestAC" ?tests)] + [($DefaultTotal total?) ($TupleTestAC ?tests)] (|do [structs (&/map% (fn [t] - (merge-total (&/V "DefaultTotal" total?) (&/T t ?body))) + (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) ?tests)] - (return (&/V "TupleTotal" (&/T total? structs)))) + (return (&/V $TupleTotal (&/T total? structs)))) - [("TupleTotal" total? ?values) ("TupleTestAC" ?tests)] + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T t ?body))) ?values ?tests)] - (return (&/V "TupleTotal" (&/T total? structs)))) + (return (&/V $TupleTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [("DefaultTotal" total?) ("RecordTestAC" ?tests)] + [($DefaultTotal total?) ($RecordTestAC ?tests)] (|do [structs (&/map% (fn [t] (|let [[slot value] t] - (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] + (|do [struct* (merge-total (&/V $DefaultTotal total?) (&/T value ?body))] (return (&/T slot struct*))))) (->> ?tests &/->seq (sort compare-kv) &/->list))] - (return (&/V "RecordTotal" (&/T total? structs)))) + (return (&/V $RecordTotal (&/T total? structs)))) - [("RecordTotal" total? ?values) ("RecordTestAC" ?tests)] + [($RecordTotal total? ?values) ($RecordTestAC ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [left right] (|let [[lslot sub-struct] left @@ -303,40 +328,40 @@ &/->seq (sort compare-kv) &/->list))] - (return (&/V "RecordTotal" (&/T total? structs)))) + (return (&/V $RecordTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent record-size.")) - [("DefaultTotal" total?) ("VariantTestAC" ?tag ?test)] - (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) + [($DefaultTotal total?) ($VariantTestAC ?tag ?test)] + (|do [sub-struct (merge-total (&/V $DefaultTotal total?) (&/T ?test ?body))] - (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct (&/|table)))))) + (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct (&/|table)))))) - [("VariantTotal" total? ?branches) ("VariantTestAC" ?tag ?test)] + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?test)] (|do [sub-struct (merge-total (or (&/|get ?tag ?branches) - (&/V "DefaultTotal" total?)) + (&/V $DefaultTotal total?)) (&/T ?test ?body))] - (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct ?branches))))) + (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct ?branches))))) )))) (defn ^:private check-totality [value-type struct] (|case struct - ("BoolTotal" ?total ?values) + ($BoolTotal ?total ?values) (return (or ?total (= #{true false} (set (&/->seq ?values))))) - ("IntTotal" ?total _) + ($IntTotal ?total _) (return ?total) - ("RealTotal" ?total _) + ($RealTotal ?total _) (return ?total) - ("CharTotal" ?total _) + ($CharTotal ?total _) (return ?total) - ("TextTotal" ?total _) + ($TextTotal ?total _) (return ?total) - ("TupleTotal" ?total ?structs) + ($TupleTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] @@ -350,7 +375,7 @@ _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ("RecordTotal" ?total ?structs) + ($RecordTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] @@ -367,7 +392,7 @@ _ (fail "[Pattern-maching Error] Record is not total.")))) - ("VariantTotal" ?total ?structs) + ($VariantTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] @@ -384,7 +409,7 @@ _ (fail "[Pattern-maching Error] Variant is not total.")))) - ("DefaultTotal" ?total) + ($DefaultTotal ?total) (return ?total) )) @@ -395,7 +420,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/V "DefaultTotal" false) patterns) + struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 9a8a6a3d7..2f35218d8 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -24,7 +24,7 @@ (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) =return (body (&/update$ &/$ENVS (fn [stack] - (let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] + (let [bound-unit (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER inc) (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6503fe2ea..843cfef96 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -157,7 +157,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] @@ -177,7 +177,7 @@ (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global - [("lux;Global" ?module* name*) _] + [(&/$Global ?module* name*) _] ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] endo-type (|case $def @@ -193,7 +193,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) endo-type)))) state) @@ -272,7 +272,7 @@ (|do [loader &/loader] (|let [[=fn-form =fn-type] =fn] (|case =fn-form - ("lux;Global" ?module ?name) + (&/$Global ?module ?name) (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (|case $def ("lux;MacroD" macro) @@ -387,7 +387,7 @@ (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] (|case =value - [("lux;Global" ?r-module ?r-name) _] + [(&/$Global ?r-module ?r-name) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 66b972f94..b496be449 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -82,6 +82,11 @@ (def $SOURCE 7) (def $TYPES 8) +;; Vars +(deftags "lux;" + "Local" + "Global") + ;; [Exports] (def +name-separator+ ";") diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 86359d26e..2565c3b20 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -61,13 +61,13 @@ ("record" ?elems) (&&lux/compile-record compile-expression ?type ?elems) - ("lux;Local" ?idx) + (&/$Local ?idx) (&&lux/compile-local compile-expression ?type ?idx) ("captured" ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - ("lux;Global" ?owner-class ?name) + (&/$Global ?owner-class ?name) (&&lux/compile-global compile-expression ?type ?owner-class ?name) ("apply" ?fn ?args) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index d27577be1..e2cbe77a2 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -17,6 +17,7 @@ [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.analyser.case :as &a-case] [lux.compiler.base :as &&]) (:import (org.objectweb.asm Opcodes Label @@ -27,12 +28,12 @@ (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] (|case ?match - ("StoreTestAC" ?idx) + (&a-case/$StoreTestAC ?idx) (doto writer (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO $target)) - ("BoolTestAC" ?value) + (&a-case/$BoolTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) @@ -42,7 +43,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("IntTestAC" ?value) + (&a-case/$IntTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) @@ -53,7 +54,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("RealTestAC" ?value) + (&a-case/$RealTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) @@ -64,7 +65,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("CharTestAC" ?value) + (&a-case/$CharTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) @@ -74,7 +75,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("TextTestAC" ?value) + (&a-case/$TextTestAC ?value) (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) @@ -83,7 +84,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("TupleTestAC" ?members) + (&a-case/$TupleTestAC ?members) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -101,7 +102,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("RecordTestAC" ?slots) + (&a-case/$RecordTestAC ?slots) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -124,7 +125,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("VariantTestAC" ?tag ?test) + (&a-case/$VariantTestAC ?tag ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) -- cgit v1.2.3 From 4b96f550165bcea089a78a6901d40850d06a4b05 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 8 Aug 2015 18:54:09 -0400 Subject: Refactored the tags of definitions. --- src/lux/analyser/lux.clj | 15 ++++++++------- src/lux/analyser/module.clj | 24 ++++++++++++------------ src/lux/base.clj | 9 ++++++++- src/lux/compiler/cache.clj | 6 +++--- src/lux/compiler/lux.clj | 4 ++-- 5 files changed, 33 insertions(+), 25 deletions(-) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 843cfef96..e0f00a0a2 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -144,14 +144,15 @@ (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] + ;; :let [_ (prn 'analyse-global/$def (aget $def 0))] endo-type (|case $def - ("lux;ValueD" ?type _) + (&/$ValueD ?type _) (return ?type) - ("lux;MacroD" _) + (&/$MacroD _) (return &type/Macro) - ("lux;TypeD" _) + (&/$TypeD _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -181,13 +182,13 @@ ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] endo-type (|case $def - ("lux;ValueD" ?type _) + (&/$ValueD ?type _) (return ?type) - ("lux;MacroD" _) + (&/$MacroD _) (return &type/Macro) - ("lux;TypeD" _) + (&/$TypeD _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -275,7 +276,7 @@ (&/$Global ?module ?name) (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (|case $def - ("lux;MacroD" macro) + (&/$MacroD macro) (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 78f5c675d..35ae7e5b7 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -66,16 +66,16 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] (|case $def - [_ ("lux;TypeD" _)] + [_ (&/$TypeD _)] (return* state &type/Type) - [_ ("lux;MacroD" _)] + [_ (&/$MacroD _)] (return* state &type/Macro) - [_ ("lux;ValueD" _type _)] + [_ (&/$ValueD _type _)] (return* state _type) - [_ ("lux;AliasD" ?r-module ?r-name)] + [_ (&/$AliasD ?r-module ?r-name)] (&/run-state (def-type ?r-module ?r-name) state)) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) @@ -92,7 +92,7 @@ (&/|update a-module (fn [m] (&/update$ $DEFS - #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) + #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) m)) ms)))) nil) @@ -137,7 +137,7 @@ (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) (|case $$def - ("lux;AliasD" ?r-module ?r-name) + (&/$AliasD ?r-module ?r-name) (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) ((find-def ?r-module ?r-name) state)) @@ -158,7 +158,7 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] (|case $def - [exported? ("lux;ValueD" ?type _)] + [exported? (&/$ValueD ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) @@ -170,14 +170,14 @@ (&/|update module (fn [m] (&/update$ $DEFS - #(&/|put name (&/T exported? (&/V "lux;MacroD" macro)) %) + #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) m)) $modules)) state*) nil))) state) - [_ ("lux;MacroD" _)] + [_ (&/$MacroD _)] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) [_ _] @@ -216,13 +216,13 @@ (|let [[k [?exported? ?def]] kv] (do ;; (prn 'defs k ?exported?) (|case ?def - ("lux;AliasD" ?r-module ?r-name) + (&/$AliasD ?r-module ?r-name) (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - ("lux;MacroD" _) + (&/$MacroD _) (&/T ?exported? k "M") - ("lux;TypeD" _) + (&/$TypeD _) (&/T ?exported? k "T") _ diff --git a/src/lux/base.clj b/src/lux/base.clj index b496be449..f690ef65f 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -14,7 +14,7 @@ ;; [Tags] (defmacro deftags [prefix & names] `(do ~@(for [name names] - `(def ~(symbol (str "$" name)) ~name)))) + `(def ~(symbol (str "$" name)) ~(str prefix name))))) ;; List (def $Nil "lux;Nil") @@ -87,6 +87,13 @@ "Local" "Global") +;; Definitions +(deftags "lux;" + "ValueD" + "TypeD" + "MacroD" + "AliasD") + ;; [Exports] (def +name-separator+ ";") diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 2b6f2e919..742ac69d8 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -118,16 +118,16 @@ (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field "_datum" def-class)] - (&a-module/define module _name (&/V "lux;TypeD" def-value) &type/Type)) + (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field "_datum" def-class)] - (|do [_ (&a-module/define module _name (&/V "lux;ValueD" (&/T &type/Macro def-value)) &type/Macro)] + (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) def-meta (get-field "_meta" def-class)] (|case def-meta - ("lux;ValueD" def-type _) + (&/$ValueD def-type _) (&a-module/define module _name def-meta def-type))) ;; else (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 9a3a7a6f2..2d28f8b3f 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -147,7 +147,7 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;TypeD") ;; VVIT + (.visitLdcInsn &/$TypeD) ;; VVIT (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -173,7 +173,7 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;ValueD") ;; VVIT + (.visitLdcInsn &/$ValueD) ;; VVIT (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI -- cgit v1.2.3 From 4fabf7e4f01d1e617620e9bc361ed27ba3b8b5e0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 8 Aug 2015 19:34:10 -0400 Subject: Refactored the tags for the analyser. --- src/lux/analyser.clj | 10 +-- src/lux/analyser/base.clj | 118 ++++++++++++++++++++++++- src/lux/analyser/host.clj | 180 +++++++++++++++++++------------------- src/lux/analyser/lambda.clj | 6 +- src/lux/analyser/lux.clj | 24 ++--- src/lux/compiler.clj | 208 ++++++++++++++++++++++---------------------- src/lux/compiler/lambda.clj | 6 +- src/lux/compiler/lux.clj | 2 +- src/lux/compiler/type.clj | 9 +- 9 files changed, 340 insertions(+), 223 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index f8dd13bd6..0e58f530b 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -467,23 +467,23 @@ ;; Standard special forms (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index ed81aa9bc..3484e869d 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -9,9 +9,125 @@ (ns lux.analyser.base (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case]] + (lux [base :as & :refer [deftags |let |do return fail |case]] [type :as &type]))) +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "record" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + ;; [Exports] (defn expr-type [syntax+] (|let [[_ type] syntax+] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index ec8b8b5db..64f297994 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -62,45 +62,45 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) - analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-isub "jvm-isub" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-imul "jvm-imul" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-idiv "jvm-idiv" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-irem "jvm-irem" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ieq "jvm-ieq" "java.lang.Integer" "java.lang.Boolean" - analyse-jvm-ilt "jvm-ilt" "java.lang.Integer" "java.lang.Boolean" - analyse-jvm-igt "jvm-igt" "java.lang.Integer" "java.lang.Boolean" - - analyse-jvm-ceq "jvm-ceq" "java.lang.Character" "java.lang.Boolean" - analyse-jvm-clt "jvm-clt" "java.lang.Character" "java.lang.Boolean" - analyse-jvm-cgt "jvm-cgt" "java.lang.Character" "java.lang.Boolean" - - analyse-jvm-ladd "jvm-ladd" "java.lang.Long" "java.lang.Long" - analyse-jvm-lsub "jvm-lsub" "java.lang.Long" "java.lang.Long" - analyse-jvm-lmul "jvm-lmul" "java.lang.Long" "java.lang.Long" - analyse-jvm-ldiv "jvm-ldiv" "java.lang.Long" "java.lang.Long" - analyse-jvm-lrem "jvm-lrem" "java.lang.Long" "java.lang.Long" - analyse-jvm-leq "jvm-leq" "java.lang.Long" "java.lang.Boolean" - analyse-jvm-llt "jvm-llt" "java.lang.Long" "java.lang.Boolean" - analyse-jvm-lgt "jvm-lgt" "java.lang.Long" "java.lang.Boolean" - - analyse-jvm-fadd "jvm-fadd" "java.lang.Float" "java.lang.Float" - analyse-jvm-fsub "jvm-fsub" "java.lang.Float" "java.lang.Float" - analyse-jvm-fmul "jvm-fmul" "java.lang.Float" "java.lang.Float" - analyse-jvm-fdiv "jvm-fdiv" "java.lang.Float" "java.lang.Float" - analyse-jvm-frem "jvm-frem" "java.lang.Float" "java.lang.Float" - analyse-jvm-feq "jvm-feq" "java.lang.Float" "java.lang.Boolean" - analyse-jvm-flt "jvm-flt" "java.lang.Float" "java.lang.Boolean" - analyse-jvm-fgt "jvm-fgt" "java.lang.Float" "java.lang.Boolean" - - analyse-jvm-dadd "jvm-dadd" "java.lang.Double" "java.lang.Double" - analyse-jvm-dsub "jvm-dsub" "java.lang.Double" "java.lang.Double" - analyse-jvm-dmul "jvm-dmul" "java.lang.Double" "java.lang.Double" - analyse-jvm-ddiv "jvm-ddiv" "java.lang.Double" "java.lang.Double" - analyse-jvm-drem "jvm-drem" "java.lang.Double" "java.lang.Double" - analyse-jvm-deq "jvm-deq" "java.lang.Double" "java.lang.Boolean" - analyse-jvm-dlt "jvm-dlt" "java.lang.Double" "java.lang.Boolean" - analyse-jvm-dgt "jvm-dgt" "java.lang.Double" "java.lang.Boolean" + analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" + analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" + analyse-jvm-imul &&/$jvm-imul "java.lang.Integer" "java.lang.Integer" + analyse-jvm-idiv &&/$jvm-idiv "java.lang.Integer" "java.lang.Integer" + analyse-jvm-irem &&/$jvm-irem "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ieq &&/$jvm-ieq "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-ilt &&/$jvm-ilt "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-igt &&/$jvm-igt "java.lang.Integer" "java.lang.Boolean" + + analyse-jvm-ceq &&/$jvm-ceq "java.lang.Character" "java.lang.Boolean" + analyse-jvm-clt &&/$jvm-clt "java.lang.Character" "java.lang.Boolean" + analyse-jvm-cgt &&/$jvm-cgt "java.lang.Character" "java.lang.Boolean" + + analyse-jvm-ladd &&/$jvm-ladd "java.lang.Long" "java.lang.Long" + analyse-jvm-lsub &&/$jvm-lsub "java.lang.Long" "java.lang.Long" + analyse-jvm-lmul &&/$jvm-lmul "java.lang.Long" "java.lang.Long" + analyse-jvm-ldiv &&/$jvm-ldiv "java.lang.Long" "java.lang.Long" + analyse-jvm-lrem &&/$jvm-lrem "java.lang.Long" "java.lang.Long" + analyse-jvm-leq &&/$jvm-leq "java.lang.Long" "java.lang.Boolean" + analyse-jvm-llt &&/$jvm-llt "java.lang.Long" "java.lang.Boolean" + analyse-jvm-lgt &&/$jvm-lgt "java.lang.Long" "java.lang.Boolean" + + analyse-jvm-fadd &&/$jvm-fadd "java.lang.Float" "java.lang.Float" + analyse-jvm-fsub &&/$jvm-fsub "java.lang.Float" "java.lang.Float" + analyse-jvm-fmul &&/$jvm-fmul "java.lang.Float" "java.lang.Float" + analyse-jvm-fdiv &&/$jvm-fdiv "java.lang.Float" "java.lang.Float" + analyse-jvm-frem &&/$jvm-frem "java.lang.Float" "java.lang.Float" + analyse-jvm-feq &&/$jvm-feq "java.lang.Float" "java.lang.Boolean" + analyse-jvm-flt &&/$jvm-flt "java.lang.Float" "java.lang.Boolean" + analyse-jvm-fgt &&/$jvm-fgt "java.lang.Float" "java.lang.Boolean" + + analyse-jvm-dadd &&/$jvm-dadd "java.lang.Double" "java.lang.Double" + analyse-jvm-dsub &&/$jvm-dsub "java.lang.Double" "java.lang.Double" + analyse-jvm-dmul &&/$jvm-dmul "java.lang.Double" "java.lang.Double" + analyse-jvm-ddiv &&/$jvm-ddiv "java.lang.Double" "java.lang.Double" + analyse-jvm-drem &&/$jvm-drem "java.lang.Double" "java.lang.Double" + analyse-jvm-deq &&/$jvm-deq "java.lang.Double" "java.lang.Boolean" + analyse-jvm-dlt &&/$jvm-dlt "java.lang.Double" "java.lang.Boolean" + analyse-jvm-dgt &&/$jvm-dgt "java.lang.Double" "java.lang.Boolean" ) (defn analyse-jvm-getstatic [analyse exo-type ?class ?field] @@ -108,7 +108,7 @@ =type (&host/lookup-static-field class-loader ?class ?field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) (defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] (|do [class-loader &/loader @@ -116,7 +116,7 @@ =object (&&/analyse-1 analyse ?object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) (defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] (|do [class-loader &/loader @@ -124,7 +124,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) (defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] (|do [class-loader &/loader @@ -133,7 +133,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) (defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] (|do [class-loader &/loader @@ -148,14 +148,14 @@ ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) (do-template [ ] (defn [analyse exo-type ?class ?method ?classes ?object ?args] @@ -169,8 +169,8 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) - analyse-jvm-invokevirtual "jvm-invokevirtual" - analyse-jvm-invokeinterface "jvm-invokeinterface" + analyse-jvm-invokevirtual &&/$jvm-invokevirtual + analyse-jvm-invokeinterface &&/$jvm-invokeinterface ) (defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args] @@ -185,41 +185,41 @@ =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-null?" =object) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) - (&/V &/$Nil nil))))))) + (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) + (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V "jvm-aastore" (&/T =array ?idx =elem)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] @@ -327,7 +327,7 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] @@ -349,7 +349,7 @@ _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) - _ (compile-token (&/V "jvm-interface" (&/T ?name =supers =methods)))] + _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] @@ -365,13 +365,13 @@ (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] - (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) + (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] - (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] (defn [analyse exo-type ?monitor] @@ -381,8 +381,8 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =monitor) output-type))))) - analyse-jvm-monitorenter "jvm-monitorenter" - analyse-jvm-monitorexit "jvm-monitorexit" + analyse-jvm-monitorenter &&/$jvm-monitorenter + analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [ ] @@ -392,24 +392,24 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) - analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float" - analyse-jvm-d2i "jvm-d2i" "java.lang.Double" "java.lang.Integer" - analyse-jvm-d2l "jvm-d2l" "java.lang.Double" "java.lang.Long" + analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" + analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" + analyse-jvm-d2l &&/$jvm-d2l "java.lang.Double" "java.lang.Long" - analyse-jvm-f2d "jvm-f2d" "java.lang.Float" "java.lang.Double" - analyse-jvm-f2i "jvm-f2i" "java.lang.Float" "java.lang.Integer" - analyse-jvm-f2l "jvm-f2l" "java.lang.Float" "java.lang.Long" + analyse-jvm-f2d &&/$jvm-f2d "java.lang.Float" "java.lang.Double" + analyse-jvm-f2i &&/$jvm-f2i "java.lang.Float" "java.lang.Integer" + analyse-jvm-f2l &&/$jvm-f2l "java.lang.Float" "java.lang.Long" - analyse-jvm-i2b "jvm-i2b" "java.lang.Integer" "java.lang.Byte" - analyse-jvm-i2c "jvm-i2c" "java.lang.Integer" "java.lang.Character" - analyse-jvm-i2d "jvm-i2d" "java.lang.Integer" "java.lang.Double" - analyse-jvm-i2f "jvm-i2f" "java.lang.Integer" "java.lang.Float" - analyse-jvm-i2l "jvm-i2l" "java.lang.Integer" "java.lang.Long" - analyse-jvm-i2s "jvm-i2s" "java.lang.Integer" "java.lang.Short" + analyse-jvm-i2b &&/$jvm-i2b "java.lang.Integer" "java.lang.Byte" + analyse-jvm-i2c &&/$jvm-i2c "java.lang.Integer" "java.lang.Character" + analyse-jvm-i2d &&/$jvm-i2d "java.lang.Integer" "java.lang.Double" + analyse-jvm-i2f &&/$jvm-i2f "java.lang.Integer" "java.lang.Float" + analyse-jvm-i2l &&/$jvm-i2l "java.lang.Integer" "java.lang.Long" + analyse-jvm-i2s &&/$jvm-i2s "java.lang.Integer" "java.lang.Short" - analyse-jvm-l2d "jvm-l2d" "java.lang.Long" "java.lang.Double" - analyse-jvm-l2f "jvm-l2f" "java.lang.Long" "java.lang.Float" - analyse-jvm-l2i "jvm-l2i" "java.lang.Long" "java.lang.Integer" + analyse-jvm-l2d &&/$jvm-l2d "java.lang.Long" "java.lang.Double" + analyse-jvm-l2f &&/$jvm-l2f "java.lang.Long" "java.lang.Float" + analyse-jvm-l2i &&/$jvm-l2i "java.lang.Long" "java.lang.Integer" ) (do-template [ ] @@ -419,24 +419,24 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) - analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ixor "jvm-ixor" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ishl "jvm-ishl" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ishr "jvm-ishr" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-iushr "jvm-iushr" "java.lang.Integer" "java.lang.Integer" - - analyse-jvm-land "jvm-land" "java.lang.Long" "java.lang.Long" - analyse-jvm-lor "jvm-lor" "java.lang.Long" "java.lang.Long" - analyse-jvm-lxor "jvm-lxor" "java.lang.Long" "java.lang.Long" - analyse-jvm-lshl "jvm-lshl" "java.lang.Long" "java.lang.Integer" - analyse-jvm-lshr "jvm-lshr" "java.lang.Long" "java.lang.Integer" - analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer" + analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ixor &&/$jvm-ixor "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishl &&/$jvm-ishl "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishr &&/$jvm-ishr "java.lang.Integer" "java.lang.Integer" + analyse-jvm-iushr &&/$jvm-iushr "java.lang.Integer" "java.lang.Integer" + + analyse-jvm-land &&/$jvm-land "java.lang.Long" "java.lang.Long" + analyse-jvm-lor &&/$jvm-lor "java.lang.Long" "java.lang.Long" + analyse-jvm-lxor &&/$jvm-lxor "java.lang.Long" "java.lang.Long" + analyse-jvm-lshl &&/$jvm-lshl "java.lang.Long" "java.lang.Integer" + analyse-jvm-lshr &&/$jvm-lshr "java.lang.Long" "java.lang.Integer" + analyse-jvm-lushr &&/$jvm-lushr "java.lang.Long" "java.lang.Integer" ) (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V "jvm-program" =body))] + _ (compile-token (&/V &&/$jvm-program =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index a230c8642..91cf3443b 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -26,9 +26,9 @@ (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/T (&/V "captured" (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) - register)) + register* (&/T (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) + register)) register-type)] (&/T register* (&/update$ &/$CLOSURE #(->> % (&/update$ &/$COUNTER inc) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index e0f00a0a2..45177ce46 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -41,7 +41,7 @@ (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) ?members ?elems)] - (return (&/|list (&/T (&/V "tuple" =elems) + (return (&/|list (&/T (&/V &&/$tuple =elems) exo-type)))) (&/$AllT _) @@ -86,7 +86,7 @@ (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] (|do [=value (analyse-variant-body analyse vtype ?values)] - (return (&/|list (&/T (&/V "variant" (&/T ?tag =value)) + (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) @@ -139,7 +139,7 @@ _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) ?elems)] - (return (&/|list (&/T (&/V "record" =slots) (&/V &/$RecordT exo-type)))))) + (return (&/|list (&/T (&/V &&/$record =slots) (&/V &/$RecordT exo-type)))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -282,7 +282,7 @@ ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (or (= "<>" r-name) - ;; ;; (= "struct" r-name) + ;; ;; (= &&/$struct r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion*) ;; (&/|interpose "\n") @@ -293,12 +293,12 @@ _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t))))) ))) @@ -309,7 +309,7 @@ =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/T (&/V "case" (&/T =value =match)) + (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -328,7 +328,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) + (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -397,13 +397,13 @@ _ (do (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V "def" (&/T ?name =value)))] + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))] (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] (|do [module-name &/get-module-name] - (|do [_ (compile-token (&/V "declare-macro" (&/T module-name ?name)))] + (|do [_ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] (return (&/|list))))) (defn analyse-import [analyse compile-module compile-token ?path] @@ -433,7 +433,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V "ann" (&/T =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -441,5 +441,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V "ann" (&/T =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 2565c3b20..490491bd0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -40,333 +40,333 @@ (defn ^:private compile-expression [syntax] (|let [[?form ?type] syntax] (|case ?form - ("bool" ?value) + (&a/$bool ?value) (&&lux/compile-bool compile-expression ?type ?value) - ("int" ?value) + (&a/$int ?value) (&&lux/compile-int compile-expression ?type ?value) - ("real" ?value) + (&a/$real ?value) (&&lux/compile-real compile-expression ?type ?value) - ("char" ?value) + (&a/$char ?value) (&&lux/compile-char compile-expression ?type ?value) - ("text" ?value) + (&a/$text ?value) (&&lux/compile-text compile-expression ?type ?value) - ("tuple" ?elems) + (&a/$tuple ?elems) (&&lux/compile-tuple compile-expression ?type ?elems) - ("record" ?elems) + (&a/$record ?elems) (&&lux/compile-record compile-expression ?type ?elems) (&/$Local ?idx) (&&lux/compile-local compile-expression ?type ?idx) - ("captured" ?scope ?captured-id ?source) + (&a/$captured ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) (&/$Global ?owner-class ?name) (&&lux/compile-global compile-expression ?type ?owner-class ?name) - ("apply" ?fn ?args) + (&a/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) - ("variant" ?tag ?members) + (&a/$variant ?tag ?members) (&&lux/compile-variant compile-expression ?type ?tag ?members) - ("case" ?value ?match) + (&a/$case ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) - ("lambda" ?scope ?env ?body) + (&a/$lambda ?scope ?env ?body) (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - ("ann" ?value-ex ?type-ex) + (&a/$ann ?value-ex ?type-ex) (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) ;; Characters - ("jvm-ceq" ?x ?y) + (&a/$jvm-ceq ?x ?y) (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - ("jvm-clt" ?x ?y) + (&a/$jvm-clt ?x ?y) (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - ("jvm-cgt" ?x ?y) + (&a/$jvm-cgt ?x ?y) (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) ;; Integer arithmetic - ("jvm-iadd" ?x ?y) + (&a/$jvm-iadd ?x ?y) (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - ("jvm-isub" ?x ?y) + (&a/$jvm-isub ?x ?y) (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - ("jvm-imul" ?x ?y) + (&a/$jvm-imul ?x ?y) (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - ("jvm-idiv" ?x ?y) + (&a/$jvm-idiv ?x ?y) (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - ("jvm-irem" ?x ?y) + (&a/$jvm-irem ?x ?y) (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - ("jvm-ieq" ?x ?y) + (&a/$jvm-ieq ?x ?y) (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - ("jvm-ilt" ?x ?y) + (&a/$jvm-ilt ?x ?y) (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - ("jvm-igt" ?x ?y) + (&a/$jvm-igt ?x ?y) (&&host/compile-jvm-igt compile-expression ?type ?x ?y) ;; Long arithmetic - ("jvm-ladd" ?x ?y) + (&a/$jvm-ladd ?x ?y) (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - ("jvm-lsub" ?x ?y) + (&a/$jvm-lsub ?x ?y) (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - ("jvm-lmul" ?x ?y) + (&a/$jvm-lmul ?x ?y) (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - ("jvm-ldiv" ?x ?y) + (&a/$jvm-ldiv ?x ?y) (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - ("jvm-lrem" ?x ?y) + (&a/$jvm-lrem ?x ?y) (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - ("jvm-leq" ?x ?y) + (&a/$jvm-leq ?x ?y) (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - ("jvm-llt" ?x ?y) + (&a/$jvm-llt ?x ?y) (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - ("jvm-lgt" ?x ?y) + (&a/$jvm-lgt ?x ?y) (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) ;; Float arithmetic - ("jvm-fadd" ?x ?y) + (&a/$jvm-fadd ?x ?y) (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - ("jvm-fsub" ?x ?y) + (&a/$jvm-fsub ?x ?y) (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - ("jvm-fmul" ?x ?y) + (&a/$jvm-fmul ?x ?y) (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - ("jvm-fdiv" ?x ?y) + (&a/$jvm-fdiv ?x ?y) (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - ("jvm-frem" ?x ?y) + (&a/$jvm-frem ?x ?y) (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - ("jvm-feq" ?x ?y) + (&a/$jvm-feq ?x ?y) (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - ("jvm-flt" ?x ?y) + (&a/$jvm-flt ?x ?y) (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - ("jvm-fgt" ?x ?y) + (&a/$jvm-fgt ?x ?y) (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) ;; Double arithmetic - ("jvm-dadd" ?x ?y) + (&a/$jvm-dadd ?x ?y) (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - ("jvm-dsub" ?x ?y) + (&a/$jvm-dsub ?x ?y) (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - ("jvm-dmul" ?x ?y) + (&a/$jvm-dmul ?x ?y) (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - ("jvm-ddiv" ?x ?y) + (&a/$jvm-ddiv ?x ?y) (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - ("jvm-drem" ?x ?y) + (&a/$jvm-drem ?x ?y) (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - ("jvm-deq" ?x ?y) + (&a/$jvm-deq ?x ?y) (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - ("jvm-dlt" ?x ?y) + (&a/$jvm-dlt ?x ?y) (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - ("jvm-dgt" ?x ?y) + (&a/$jvm-dgt ?x ?y) (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - ("jvm-null" _) + (&a/$jvm-null _) (&&host/compile-jvm-null compile-expression ?type) - ("jvm-null?" ?object) + (&a/$jvm-null? ?object) (&&host/compile-jvm-null? compile-expression ?type ?object) - ("jvm-new" ?class ?classes ?args) + (&a/$jvm-new ?class ?classes ?args) (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - ("jvm-getstatic" ?class ?field) + (&a/$jvm-getstatic ?class ?field) (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - ("jvm-getfield" ?class ?field ?object) + (&a/$jvm-getfield ?class ?field ?object) (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - ("jvm-putstatic" ?class ?field ?value) + (&a/$jvm-putstatic ?class ?field ?value) (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - ("jvm-putfield" ?class ?field ?object ?value) + (&a/$jvm-putfield ?class ?field ?object ?value) (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - ("jvm-invokestatic" ?class ?method ?classes ?args) + (&a/$jvm-invokestatic ?class ?method ?classes ?args) (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - ("jvm-invokevirtual" ?class ?method ?classes ?object ?args) + (&a/$jvm-invokevirtual ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - ("jvm-invokeinterface" ?class ?method ?classes ?object ?args) + (&a/$jvm-invokeinterface ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - ("jvm-invokespecial" ?class ?method ?classes ?object ?args) + (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - ("jvm-new-array" ?class ?length) + (&a/$jvm-new-array ?class ?length) (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) - ("jvm-aastore" ?array ?idx ?elem) + (&a/$jvm-aastore ?array ?idx ?elem) (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) - ("jvm-aaload" ?array ?idx) + (&a/$jvm-aaload ?array ?idx) (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) - ("jvm-try" ?body ?catches ?finally) + (&a/$jvm-try ?body ?catches ?finally) (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) - ("jvm-throw" ?ex) + (&a/$jvm-throw ?ex) (&&host/compile-jvm-throw compile-expression ?type ?ex) - ("jvm-monitorenter" ?monitor) + (&a/$jvm-monitorenter ?monitor) (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) - ("jvm-monitorexit" ?monitor) + (&a/$jvm-monitorexit ?monitor) (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) - ("jvm-d2f" ?value) + (&a/$jvm-d2f ?value) (&&host/compile-jvm-d2f compile-expression ?type ?value) - ("jvm-d2i" ?value) + (&a/$jvm-d2i ?value) (&&host/compile-jvm-d2i compile-expression ?type ?value) - ("jvm-d2l" ?value) + (&a/$jvm-d2l ?value) (&&host/compile-jvm-d2l compile-expression ?type ?value) - ("jvm-f2d" ?value) + (&a/$jvm-f2d ?value) (&&host/compile-jvm-f2d compile-expression ?type ?value) - ("jvm-f2i" ?value) + (&a/$jvm-f2i ?value) (&&host/compile-jvm-f2i compile-expression ?type ?value) - ("jvm-f2l" ?value) + (&a/$jvm-f2l ?value) (&&host/compile-jvm-f2l compile-expression ?type ?value) - ("jvm-i2b" ?value) + (&a/$jvm-i2b ?value) (&&host/compile-jvm-i2b compile-expression ?type ?value) - ("jvm-i2c" ?value) + (&a/$jvm-i2c ?value) (&&host/compile-jvm-i2c compile-expression ?type ?value) - ("jvm-i2d" ?value) + (&a/$jvm-i2d ?value) (&&host/compile-jvm-i2d compile-expression ?type ?value) - ("jvm-i2f" ?value) + (&a/$jvm-i2f ?value) (&&host/compile-jvm-i2f compile-expression ?type ?value) - ("jvm-i2l" ?value) + (&a/$jvm-i2l ?value) (&&host/compile-jvm-i2l compile-expression ?type ?value) - ("jvm-i2s" ?value) + (&a/$jvm-i2s ?value) (&&host/compile-jvm-i2s compile-expression ?type ?value) - ("jvm-l2d" ?value) + (&a/$jvm-l2d ?value) (&&host/compile-jvm-l2d compile-expression ?type ?value) - ("jvm-l2f" ?value) + (&a/$jvm-l2f ?value) (&&host/compile-jvm-l2f compile-expression ?type ?value) - ("jvm-l2i" ?value) + (&a/$jvm-l2i ?value) (&&host/compile-jvm-l2i compile-expression ?type ?value) - ("jvm-iand" ?x ?y) + (&a/$jvm-iand ?x ?y) (&&host/compile-jvm-iand compile-expression ?type ?x ?y) - ("jvm-ior" ?x ?y) + (&a/$jvm-ior ?x ?y) (&&host/compile-jvm-ior compile-expression ?type ?x ?y) - ("jvm-ixor" ?x ?y) + (&a/$jvm-ixor ?x ?y) (&&host/compile-jvm-ixor compile-expression ?type ?x ?y) - ("jvm-ishl" ?x ?y) + (&a/$jvm-ishl ?x ?y) (&&host/compile-jvm-ishl compile-expression ?type ?x ?y) - ("jvm-ishr" ?x ?y) + (&a/$jvm-ishr ?x ?y) (&&host/compile-jvm-ishr compile-expression ?type ?x ?y) - ("jvm-iushr" ?x ?y) + (&a/$jvm-iushr ?x ?y) (&&host/compile-jvm-iushr compile-expression ?type ?x ?y) - ("jvm-land" ?x ?y) + (&a/$jvm-land ?x ?y) (&&host/compile-jvm-land compile-expression ?type ?x ?y) - ("jvm-lor" ?x ?y) + (&a/$jvm-lor ?x ?y) (&&host/compile-jvm-lor compile-expression ?type ?x ?y) - ("jvm-lxor" ?x ?y) + (&a/$jvm-lxor ?x ?y) (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) - ("jvm-lshl" ?x ?y) + (&a/$jvm-lshl ?x ?y) (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) - ("jvm-lshr" ?x ?y) + (&a/$jvm-lshr ?x ?y) (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) - ("jvm-lushr" ?x ?y) + (&a/$jvm-lushr ?x ?y) (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) - ("jvm-instanceof" ?class ?object) + (&a/$jvm-instanceof ?class ?object) (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) ) )) (defn ^:private compile-statement [syntax] (|case syntax - ("def" ?name ?body) + (&a/$def ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - ("declare-macro" ?module ?name) + (&a/$declare-macro ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - ("jvm-program" ?body) + (&a/$jvm-program ?body) (&&host/compile-jvm-program compile-expression ?body) - ("jvm-interface" ?name ?supers ?methods) + (&a/$jvm-interface ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) + (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) (defn ^:private compile-token [syntax] (|case syntax - ("def" ?name ?body) + (&a/$def ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - ("declare-macro" ?module ?name) + (&a/$declare-macro ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - ("jvm-program" ?body) + (&a/$jvm-program ?body) (&&host/compile-jvm-program compile-expression ?body) - ("jvm-interface" ?name ?supers ?methods) + (&a/$jvm-interface ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) + (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) _ diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 0d1ea4844..136ec0cfc 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -47,7 +47,7 @@ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [("captured" _ ?captured-id ?source) _]]) + [?name [(&a/$captured _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -84,7 +84,7 @@ (.visitInsn Opcodes/DUP))] _ (&/map% (fn [?name+?captured] (|case ?name+?captured - [?name [("captured" _ _ ?source) _]] + [?name [(&a/$captured _ _ ?source) _]] (compile ?source))) closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] @@ -102,7 +102,7 @@ (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [("captured" _ ?captured-id ?source) _]]) + [?name [(&a/$captured _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq ?env)]))) (add-lambda-apply class-name ?env) (add-lambda- class-name ?env) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 2d28f8b3f..87327311c 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -163,7 +163,7 @@ "value" (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) ?def-type (|case ?body - [("ann" ?def-value ?type-expr) ?def-type] + [(&a/$ann ?def-value ?type-expr) ?def-type] ?type-expr [?def-value ?def-type] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 46e6ec2d9..e9d3014db 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -10,22 +10,23 @@ (:require clojure.core.match clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type]))) + [type :as &type]) + [lux.analyser.base :as &a])) ;; [Utils] (defn ^:private variant$ [tag body] "(-> Text Analysis Analysis)" - (&/T (&/V "variant" (&/T tag body)) + (&/T (&/V &a/$variant (&/T tag body)) &type/$Void)) (defn ^:private tuple$ [members] "(-> (List Analysis) Analysis)" - (&/T (&/V "tuple" members) + (&/T (&/V &a/$tuple members) &type/$Void)) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/T (&/V "text" text) + (&/T (&/V &a/$text text) &type/$Void)) (def ^:private $Nil -- cgit v1.2.3 From 4134c811399abfce64b54a821e427d2b153f3e57 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Aug 2015 18:25:39 -0400 Subject: - Changing tags so they're actually indices (part 1). - Fixed a bug regarding type coercion (type-checking was ocurring unnecessarily). - Fixed another bug regarding Local/Global variables. --- source/lux.lux | 308 ++++++++++++++++++++------------- src/lux/analyser.clj | 38 +++- src/lux/analyser/base.clj | 1 + src/lux/analyser/env.clj | 2 +- src/lux/analyser/lux.clj | 84 +++++++-- src/lux/analyser/module.clj | 47 ++++- src/lux/base.clj | 98 +++++++---- src/lux/compiler.clj | 4 +- src/lux/compiler/lux.clj | 15 +- src/lux/type.clj | 409 +++++++++++++++++++++++++------------------- 10 files changed, 652 insertions(+), 354 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 7110cc709..d023406f8 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -10,6 +10,10 @@ (_jvm_interface "Function" [] ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) +(_lux_declare-tags [#DataT #TupleT #VariantT #RecordT #LambdaT #BoundT #VarT #ExT #AllT #AppT]) +(_lux_declare-tags [#None #Some]) +(_lux_declare-tags [#Nil #Cons]) + ## Basic types (_lux_def Bool (#DataT "java.lang.Boolean")) (_lux_export Bool) @@ -40,11 +44,13 @@ ## (#Cons a (List a)))) (_lux_def List (#AllT (#Some #Nil) "lux;List" "a" - (#VariantT (#Cons ["lux;Nil" (#TupleT #Nil)] - (#Cons ["lux;Cons" (#TupleT (#Cons (#BoundT "a") - (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a")) - #Nil)))] - #Nil))))) + (#VariantT (#Cons ## "lux;Nil" + (#TupleT #Nil) + (#Cons ## "lux;Cons" + (#TupleT (#Cons (#BoundT "a") + (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a")) + #Nil))) + #Nil))))) (_lux_export List) ## (deftype (Maybe a) @@ -52,16 +58,18 @@ ## (#Some a))) (_lux_def Maybe (#AllT (#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons ["lux;None" (#TupleT #Nil)] - (#Cons ["lux;Some" (#BoundT "a")] - #Nil))))) + (#VariantT (#Cons ## "lux;None" + (#TupleT #Nil) + (#Cons ## "lux;Some" + (#BoundT "a") + #Nil))))) (_lux_export Maybe) ## (deftype #rec Type ## (| (#DataT Text) ## (#TupleT (List Type)) -## (#VariantT (List (, Text Type))) -## (#RecordT (List (, Text Type))) +## (#VariantT (List Type)) +## (#RecordT (List Type)) ## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) @@ -72,19 +80,31 @@ Type (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil)))) TypeEnv - (#AppT (#AllT (#Some #Nil) "Type" "_" - (#VariantT (#Cons ["lux;DataT" Text] - (#Cons ["lux;TupleT" (#AppT List Type)] - (#Cons ["lux;VariantT" TypeEnv] - (#Cons ["lux;RecordT" TypeEnv] - (#Cons ["lux;LambdaT" (#TupleT (#Cons Type (#Cons Type #Nil)))] - (#Cons ["lux;BoundT" Text] - (#Cons ["lux;VarT" Int] - (#Cons ["lux;AllT" (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil)))))] - (#Cons ["lux;AppT" (#TupleT (#Cons Type (#Cons Type #Nil)))] - (#Cons ["lux;ExT" Int] - #Nil)))))))))))) - Void)))) + (_lux_case (#AppT List Type) + TypeList + (#AppT (#AllT (#Some #Nil) "Type" "_" + (#VariantT (#Cons ## "lux;DataT" + Text + (#Cons ## "lux;TupleT" + TypeList + (#Cons ## "lux;VariantT" + TypeList + (#Cons ## "lux;RecordT" + TypeList + (#Cons ## "lux;LambdaT" + (#TupleT (#Cons Type (#Cons Type #Nil))) + (#Cons ## "lux;BoundT" + Text + (#Cons ## "lux;VarT" + Int + (#Cons ## "lux;ExT" + Int + (#Cons ## "lux;AllT" + (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil))))) + (#Cons ## "lux;AppT" + (#TupleT (#Cons Type (#Cons Type #Nil))) + #Nil)))))))))))) + Void))))) (_lux_export Type) ## (deftype (Bindings k v) @@ -93,12 +113,14 @@ (_lux_def Bindings (#AllT [(#Some #Nil) "lux;Bindings" "k" (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;counter" Int] - (#Cons [["lux;mappings" (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))])] - #Nil])]))])])) + (#RecordT (#Cons ## "lux;counter" + Int + (#Cons ## "lux;mappings" + (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))]) + #Nil)))])])) (_lux_export Bindings) ## (deftype (Env k v) @@ -109,12 +131,16 @@ (_lux_def Env (#AllT [(#Some #Nil) "lux;Env" "k" (#AllT [#None "" "v" - (#RecordT (#Cons [["lux;name" Text] - (#Cons [["lux;inner-closures" Int] - (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] - (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")])] + (#RecordT (#Cons [## "lux;name" + Text + (#Cons [## "lux;inner-closures" + Int + (#Cons [## "lux;locals" + (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")]) + (#Cons [## "lux;closure" + (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")]) #Nil])])])]))])])) (_lux_export Env) @@ -129,11 +155,13 @@ (_lux_def Meta (#AllT [(#Some #Nil) "lux;Meta" "m" (#AllT [#None "" "v" - (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])]))] + (#VariantT (#Cons [## "lux;Meta" + (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])])) #Nil]))])])) (_lux_export Meta) +(_lux_declare-tags [#Meta]) ## (deftype (AST' w) ## (| (#BoolS Bool) @@ -154,20 +182,31 @@ (_lux_case (#AppT [List AST]) ASTList (#AllT [(#Some #Nil) "lux;AST'" "w" - (#VariantT (#Cons [["lux;BoolS" Bool] - (#Cons [["lux;IntS" Int] - (#Cons [["lux;RealS" Real] - (#Cons [["lux;CharS" Char] - (#Cons [["lux;TextS" Text] - (#Cons [["lux;SymbolS" Ident] - (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" ASTList] - (#Cons [["lux;TupleS" ASTList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))])] + (#VariantT (#Cons [## "lux;BoolS" + Bool + (#Cons [## "lux;IntS" + Int + (#Cons [## "lux;RealS" + Real + (#Cons [## "lux;CharS" + Char + (#Cons [## "lux;TextS" + Text + (#Cons [## "lux;SymbolS" + Ident + (#Cons [## "lux;TagS" + Ident + (#Cons [## "lux;FormS" + ASTList + (#Cons [## "lux;TupleS" + ASTList + (#Cons [## "lux;RecordS" + (#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))]) #Nil]) ])])])])])])])])]) )])))) (_lux_export AST') +(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS]) ## (deftype AST ## (Meta Cursor (AST' (Meta Cursor)))) @@ -185,10 +224,13 @@ (_lux_def Either (#AllT [(#Some #Nil) "lux;Either" "l" (#AllT [#None "" "r" - (#VariantT (#Cons [["lux;Left" (#BoundT "l")] - (#Cons [["lux;Right" (#BoundT "r")] + (#VariantT (#Cons [## "lux;Left" + (#BoundT "l") + (#Cons [## "lux;Right" + (#BoundT "r") #Nil])]))])])) (_lux_export Either) +(_lux_declare-tags [#Left #Right]) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) @@ -214,9 +256,12 @@ ## #loader (^ java.net.URLClassLoader) ## #classes (^ clojure.lang.Atom))) (_lux_def HostState - (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] - (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] - (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] + (#RecordT (#Cons [## "lux;writer" + (#DataT "org.objectweb.asm.ClassWriter") + (#Cons [## "lux;loader" + (#DataT "java.lang.ClassLoader") + (#Cons [## "lux;classes" + (#DataT "clojure.lang.Atom") #Nil])])]))) ## (deftype (DefData' m) @@ -226,12 +271,16 @@ ## (#AliasD Ident))) (_lux_def DefData' (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [["lux;TypeD" Type] - (#Cons [["lux;ValueD" (#TupleT (#Cons [Type - (#Cons [Unit - #Nil])]))] - (#Cons [["lux;MacroD" (#BoundT "")] - (#Cons [["lux;AliasD" Ident] + (#VariantT (#Cons [## "lux;TypeD" + Type + (#Cons [## "lux;ValueD" + (#TupleT (#Cons [Type + (#Cons [Unit + #Nil])])) + (#Cons [## "lux;MacroD" + (#BoundT "") + (#Cons [## "lux;AliasD" + Ident #Nil])])])]))])) (_lux_export DefData') @@ -239,27 +288,40 @@ ## (| (#Local Int) ## (#Global Ident))) (_lux_def LuxVar - (#VariantT (#Cons [["lux;Local" Int] - (#Cons [["lux;Global" Ident] + (#VariantT (#Cons [## "lux;Local" + Int + (#Cons [## "lux;Global" + Ident #Nil])]))) (_lux_export LuxVar) ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) -## #imports (List Text) +## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) +## #imports (List Text) +## #tags (List (, Text (, Int (List Ident)))) ## )) (_lux_def Module (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] - (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - ASTList])])]) - #Nil])])) - #Nil])]))])] - (#Cons [["lux;imports" (#AppT [List Text])] - #Nil])])]))])) + (#RecordT (#Cons [## "lux;module-aliases" + (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) + (#Cons [## "lux;defs" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + ASTList])])]) + #Nil])])) + #Nil])]))]) + (#Cons [## "lux;imports" + (#AppT [List Text]) + (#Cons [## "lux;tags" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Int + (#Cons (#AppT [List Ident]) + #Nil))) + #Nil)))]) + #Nil])])])]))])) (_lux_export Module) ## (deftype #rec Compiler @@ -271,21 +333,31 @@ ## #seed Int ## #eval? Bool ## #expected Type -## #cursor Cursor)) +## #cursor Cursor +## )) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#RecordT (#Cons [["lux;source" Reader] - (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))])] - (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] - (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] - (#Cons [["lux;host" HostState] - (#Cons [["lux;seed" Int] - (#Cons [["lux;eval?" Bool] - (#Cons [["lux;expected" Type] - (#Cons [["lux;cursor" Cursor] + (#RecordT (#Cons [## "lux;source" + Reader + (#Cons [## "lux;modules" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))]) + (#Cons [## "lux;envs" + (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) + (#Cons [## "lux;types" + (#AppT [(#AppT [Bindings Int]) Type]) + (#Cons [## "lux;host" + HostState + (#Cons [## "lux;seed" + Int + (#Cons [## "lux;eval?" + Bool + (#Cons [## "lux;expected" + Type + (#Cons [## "lux;cursor" + Cursor #Nil])])])])])])])])]))]) Void])) (_lux_export Compiler) @@ -293,9 +365,9 @@ ## (deftype Macro ## (-> (List AST) (StateE Compiler (List AST)))) (_lux_def Macro - (#LambdaT [ASTList - (#AppT [(#AppT [StateE Compiler]) - ASTList])])) + (#LambdaT ASTList + (#AppT (#AppT StateE Compiler) + ASTList))) (_lux_export Macro) ## Base functions & macros @@ -309,11 +381,11 @@ ## (-> (AST' (Meta Cursor)) AST) ## (#Meta [["" -1 -1] data])) (_lux_def _meta - (_lux_: (#LambdaT [(#AppT [AST' - (#AppT [Meta Cursor])]) - AST]) + (_lux_: (#LambdaT (#AppT AST' + (#AppT Meta Cursor)) + AST) (_lux_lambda _ data - (#Meta [_cursor data])))) + (#Meta _cursor data)))) ## (def (return x) ## (All [a] @@ -321,16 +393,16 @@ ## (Either Text (, Compiler a)))) ## ...) (_lux_def return - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [(#BoundT "a") - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) + (_lux_: (#AllT (#Some #Nil) "" "a" + (#LambdaT (#BoundT "a") + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#TupleT (#Cons Compiler + (#Cons (#BoundT "a") + #Nil))))))) (_lux_lambda _ val (_lux_lambda _ state - (#Right [state val]))))) + (#Right state val))))) ## (def (fail msg) ## (All [a] @@ -338,49 +410,49 @@ ## (Either Text (, Compiler a)))) ## ...) (_lux_def fail - (_lux_: (#AllT [(#Some #Nil) "" "a" - (#LambdaT [Text - (#LambdaT [Compiler - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [Compiler - (#Cons [(#BoundT "a") - #Nil])]))])])])]) + (_lux_: (#AllT (#Some #Nil) "" "a" + (#LambdaT Text + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#TupleT (#Cons Compiler + (#Cons (#BoundT "a") + #Nil))))))) (_lux_lambda _ msg (_lux_lambda _ state (#Left msg))))) (_lux_def text$ - (_lux_: (#LambdaT [Text AST]) + (_lux_: (#LambdaT Text AST) (_lux_lambda _ text (_meta (#TextS text))))) (_lux_def int$ - (_lux_: (#LambdaT [Int AST]) + (_lux_: (#LambdaT Int AST) (_lux_lambda _ value (_meta (#IntS value))))) (_lux_def symbol$ - (_lux_: (#LambdaT [Ident AST]) + (_lux_: (#LambdaT Ident AST) (_lux_lambda _ ident (_meta (#SymbolS ident))))) (_lux_def tag$ - (_lux_: (#LambdaT [Ident AST]) + (_lux_: (#LambdaT Ident AST) (_lux_lambda _ ident (_meta (#TagS ident))))) (_lux_def form$ - (_lux_: (#LambdaT [(#AppT [List AST]) AST]) + (_lux_: (#LambdaT (#AppT List AST) AST) (_lux_lambda _ tokens (_meta (#FormS tokens))))) (_lux_def tuple$ - (_lux_: (#LambdaT [(#AppT [List AST]) AST]) + (_lux_: (#LambdaT (#AppT List AST) AST) (_lux_lambda _ tokens (_meta (#TupleS tokens))))) (_lux_def record$ - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))]) AST]) + (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) @@ -388,10 +460,10 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) - (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) - #Nil])) + (#Cons lhs (#Cons rhs (#Cons body #Nil))) + (return (#Cons (form$ (#Cons (symbol$ ["" "_lux_case"]) + (#Cons rhs (#Cons lhs (#Cons body #Nil))))) + #Nil)) _ (fail "Wrong syntax for let''"))))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0e58f530b..7810c415b 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -17,7 +17,8 @@ [host :as &host]) (lux.analyser [base :as &&] [lux :as &&lux] - [host :as &&host]))) + [host :as &&host] + [module :as &&module]))) ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] @@ -37,6 +38,14 @@ _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) +(defn ^:private parse-tag [ast] + (|case ast + (&/$Meta _ (&/$TagS "" name)) + (return name) + + _ + (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) + (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays @@ -431,6 +440,12 @@ (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) + (&/$Cons (&/$Meta _ (&/$TupleS tags)) + (&/$Nil)))) + (|do [tags* (&/map% parse-tag tags)] + (&&lux/analyse-declare-tags tags*)) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) (&/$Cons (&/$Meta _ (&/$TextS ?path)) (&/$Nil)))) @@ -492,7 +507,9 @@ (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) + (|do [[module tag-name] (&/normalize ?ident) + idx (&&module/tag-index module tag-name)] + (&&lux/analyse-variant analyse exo-type idx (&/|list))) (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) @@ -512,7 +529,10 @@ (|case token (&/$Meta meta ?token) (fn [state] - (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (catch Error e + (prn e) + (assert false (prn-str 'analyse-basic-ast (&/show-ast ?token))))) (&/$Right state* output) (return* state* output) @@ -540,11 +560,21 @@ )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] + ;; (prn 'analyse-ast (&/show-ast token)) (&/with-cursor (aget token 1 0) (&/with-expected-type exo-type (|case token + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) (fn [state] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 3484e869d..218fc6dd9 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -28,6 +28,7 @@ "ann" "def" "declare-macro" + "var" "captured" "jvm-getstatic" diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 2f35218d8..614b38799 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -24,7 +24,7 @@ (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) =return (body (&/update$ &/$ENVS (fn [stack] - (let [bound-unit (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER inc) (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 45177ce46..ba4a173f0 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -71,7 +71,7 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) -(defn analyse-variant [analyse exo-type ident ?values] +(defn analyse-variant [analyse exo-type idx ?values] (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -83,21 +83,50 @@ (&type/actual-type exo-type))] (|case exo-type* (&/$VariantT ?cases) - (|do [?tag (&&/resolved-ident ident)] - (if-let [vtype (&/|get ?tag ?cases)] - (|do [=value (analyse-variant-body analyse vtype ?values)] - (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) - exo-type)))) - (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (analyse-variant-body analyse vtype ?values)] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** ident ?values)))) + (analyse-variant analyse exo-type** idx ?values)))) _ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) +;; (defn analyse-variant [analyse exo-type ident ?values] +;; (|do [exo-type* (|case exo-type +;; (&/$VarT ?id) +;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] +;; (&type/actual-type exo-type*)) +;; (|do [_ (&type/set-var ?id &type/Type)] +;; (&type/actual-type &type/Type)))) + +;; _ +;; (&type/actual-type exo-type))] +;; (|case exo-type* +;; (&/$VariantT ?cases) +;; (|do [?tag (&&/resolved-ident ident)] +;; (if-let [vtype (&/|get ?tag ?cases)] +;; (|do [=value (analyse-variant-body analyse vtype ?values)] +;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) +;; exo-type)))) +;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + +;; (&/$AllT _) +;; (&type/with-var +;; (fn [$var] +;; (|do [exo-type** (&type/apply-type exo-type* $var)] +;; (analyse-variant analyse exo-type** ident ?values)))) + +;; _ +;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] (|do [exo-type* (|case exo-type @@ -158,7 +187,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] @@ -194,7 +223,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type)))) state) @@ -397,14 +426,39 @@ _ (do (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))] + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]] (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] - (|do [module-name &/get-module-name] - (|do [_ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] - (return (&/|list))))) + (|do [module-name &/get-module-name + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] + (return (&/|list)))) + +(defn ensure-undeclared-tags [module tags] + (|do [;; :let [_ (prn 'ensure-undeclared-tags/_0)] + tags-table (&&module/tags-by-module module) + ;; :let [_ (prn 'ensure-undeclared-tags/_1)] + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (return nil))) + tags) + ;; :let [_ (prn 'ensure-undeclared-tags/_2)] + ] + (return nil))) + +(defn analyse-declare-tags [tags] + (|do [;; :let [_ (prn 'analyse-declare-tags/_0)] + module-name &/get-module-name + ;; :let [_ (prn 'analyse-declare-tags/_1)] + _ (ensure-undeclared-tags module-name tags) + ;; :let [_ (prn 'analyse-declare-tags/_2)] + _ (&&module/declare-tags module-name tags) + ;; :let [_ (prn 'analyse-declare-tags/_3)] + ] + (return (&/|list)))) (defn analyse-import [analyse compile-module compile-token ?path] (|do [module-name &/get-module-name @@ -440,6 +494,6 @@ (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value)] + =value (analyse-1+ analyse ?value)] (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 35ae7e5b7..68554a019 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -18,14 +18,17 @@ ;; [Utils] (def ^:private $DEFS 0) -(def ^:private $ALIASES 1) -(def ^:private $IMPORTS 2) +(def ^:private $IMPORTS 1) +(def ^:private $ALIASES 2) +(def ^:private $tags 3) (def ^:private +init+ (&/R ;; "lux;defs" (&/|table) + ;; "lux;imports" + (&/|list) ;; "lux;module-aliases" (&/|table) - ;; "lux;imports" + ;; "lux;tags" (&/|list) )) @@ -235,12 +238,50 @@ (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) (defn create-module [name] + "(-> Text (Lux (,)))" (fn [state] (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) (defn enter-module [name] + "(-> Text (Lux (,)))" (fn [state] (return* (->> state (&/update$ &/$MODULES #(&/|put name +init+ %)) (&/set$ &/$ENVS (&/|list (&/env name)))) nil))) + +(defn tags-by-module [module] + "(-> Text (Lux (List (, Text (, Int (List Text))))))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (return* state (&/get$ $tags =module)) + (fail* (str "[Lux Error] Unknown module: " module))) + )) + +(defn declare-tags [module tag-names] + "(-> Text (List Text) (Lux (,)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$MODULES + (fn [=modules] + (&/|update module + #(&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags) table))) + (&/get$ $tags %) + (&/enumerate tag-names)) + %) + =modules)) + state) + nil)) + (fail* (str "[Lux Error] Unknown module: " module))))) + +(defn tag-index [module tag-name] + "(-> Text Text (Lux Int))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 0)) + (fail* (str "[Lux Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Lux Error] Unknown module: " module))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index f690ef65f..73b2bb684 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -13,47 +13,53 @@ ;; [Tags] (defmacro deftags [prefix & names] - `(do ~@(for [name names] - `(def ~(symbol (str "$" name)) ~(str prefix name))))) + `(do ~@(for [[name idx] (map vector names (range (count names)))] + `(def ~(symbol (str "$" name)) ~idx)))) ;; List -(def $Nil "lux;Nil") -(def $Cons "lux;Cons") +(deftags "" + "Nil" + "Cons") ;; Maybe -(def $None "lux;None") -(def $Some "lux;Some") +(deftags "" + "None" + "Some") ;; Meta -(def $Meta "lux;Meta") +(deftags "" + "Meta") ;; Either -(def $Left "lux;Left") -(def $Right "lux;Right") +(deftags "" + "Left" + "Right") ;; AST -(def $BoolS "lux;BoolS") -(def $IntS "lux;IntS") -(def $RealS "lux;RealS") -(def $CharS "lux;CharS") -(def $TextS "lux;TextS") -(def $SymbolS "lux;SymbolS") -(def $TagS "lux;TagS") -(def $FormS "lux;FormS") -(def $TupleS "lux;TupleS") -(def $RecordS "lux;RecordS") +(deftags "" + "BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS") ;; Type -(def $DataT "lux;DataT") -(def $TupleT "lux;TupleT") -(def $VariantT "lux;VariantT") -(def $RecordT "lux;RecordT") -(def $LambdaT "lux;LambdaT") -(def $VarT "lux;VarT") -(def $ExT "lux;ExT") -(def $BoundT "lux;BoundT") -(def $AppT "lux;AppT") -(def $AllT "lux;AllT") +(deftags "" + "DataT" + "TupleT" + "VariantT" + "RecordT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT") ;; [Fields] ;; Binding @@ -100,7 +106,7 @@ (defn T [& elems] (to-array elems)) -(defn V [tag value] +(defn V [^Long tag value] (to-array [tag value])) (defn R [& kvs] @@ -726,6 +732,7 @@ output))))) (defn show-ast [ast] + ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast ($Meta _ ($BoolS ?value)) (pr-str ?value) @@ -762,6 +769,10 @@ ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") + + _ + (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) + ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) )) (defn ident->text [ident] @@ -814,6 +825,7 @@ false)) (defn ^:private enumerate* [idx xs] + "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) (V $Cons (T (T idx x) @@ -824,6 +836,7 @@ )) (defn enumerate [xs] + "(All [a] (-> (List a) (List (, Int a))))" (enumerate* 0 xs)) (def modules @@ -836,3 +849,28 @@ (if test body (return nil))) + +(defn |at [idx xs] + "(All [a] (-> Int (List a) (Maybe a)))" + ;; (prn '|at idx (aget idx 0)) + (|case xs + ($Cons x xs*) + (cond (< idx 0) + (V $None nil) + + (= idx 0) + (V $Some x) + + :else ;; > 1 + (|at (dec idx) xs*)) + + ($Nil) + (V $None nil) + )) + +(defn normalize [ident] + "(-> Ident (Lux Ident))" + (|case ident + ["" name] (|do [module get-module-name] + (return (T module name))) + _ (return ident))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 490491bd0..7622e3002 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -61,13 +61,13 @@ (&a/$record ?elems) (&&lux/compile-record compile-expression ?type ?elems) - (&/$Local ?idx) + (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) (&a/$captured ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - (&/$Global ?owner-class ?name) + (&a/$var (&/$Global ?owner-class ?name)) (&&lux/compile-global compile-expression ?type ?owner-class ?name) (&a/$apply ?fn ?args) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 87327311c..9baefa21c 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -37,11 +37,13 @@ (do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW ) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] + :let [_ (try (doto *writer* + (.visitTypeInsn Opcodes/NEW ) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL "" )) + (catch Exception e + (assert false (prn-str ' (alength value) (aget value 0) (aget value 1)))))]] (return nil))) compile-int "java/lang/Long" "(J)V" long @@ -99,6 +101,7 @@ (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitLdcInsn ?tag) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)))] @@ -148,6 +151,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$TypeD) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -174,6 +178,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$ValueD) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI diff --git a/src/lux/type.clj b/src/lux/type.clj index 0a80d4fbc..553318daf 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -23,39 +23,73 @@ (def Unit (&/V &/$TupleT (&/|list))) (def $Void (&/V &/$VariantT (&/|list))) +(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) +(defn ^:private Bound$ [name] + (&/V &/$BoundT name)) +(defn ^:private Lambda$ [in out] + (&/V &/$LambdaT (&/T in out))) +(defn ^:private App$ [fun arg] + (&/V &/$AppT (&/T fun arg))) +(defn ^:private Tuple$ [members] + (&/V &/$TupleT members)) +(defn ^:private Variant$ [members] + (&/V &/$VariantT members)) +(defn ^:private Record$ [members] + (&/V &/$RecordT members)) + (def IO - (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" - (&/V &/$LambdaT (&/T Unit (&/V &/$BoundT "a")))))) + (&/V &/$AllT (&/T empty-env "IO" "a" + (Lambda$ Unit (Bound$ "a"))))) (def List - (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" - (&/V &/$VariantT (&/|list (&/T &/$Nil Unit) - (&/T &/$Cons (&/V &/$TupleT (&/|list (&/V &/$BoundT "a") - (&/V &/$AppT (&/T (&/V &/$BoundT "lux;List") - (&/V &/$BoundT "a"))))))))))) + (&/V &/$AllT (&/T empty-env "lux;List" "a" + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + ))))) (def Maybe - (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" - (&/V &/$VariantT (&/|list (&/T &/$None Unit) - (&/T &/$Some (&/V &/$BoundT "a"))))))) + (&/V &/$AllT (&/T empty-env "lux;Maybe" "a" + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + ))))) (def Type - (let [Type (&/V &/$AppT (&/T (&/V &/$BoundT "Type") (&/V &/$BoundT "_"))) - TypeEnv (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Type)))) - TypePair (&/V &/$TupleT (&/|list Type Type))] - (&/V &/$AppT (&/T (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" - (&/V &/$VariantT (&/|list (&/T &/$DataT Text) - (&/T &/$TupleT (&/V &/$AppT (&/T List Type))) - (&/T &/$VariantT TypeEnv) - (&/T &/$RecordT TypeEnv) - (&/T &/$LambdaT TypePair) - (&/T &/$BoundT Text) - (&/T &/$VarT Int) - (&/T &/$AllT (&/V &/$TupleT (&/|list (&/V &/$AppT (&/T Maybe TypeEnv)) Text Text Type))) - (&/T &/$AppT TypePair) - (&/T &/$ExT Int) - )))) - $Void)))) + (let [Type (App$ (Bound$ "Type") (Bound$ "_")) + TypeList (App$ List Type) + TypeEnv (App$ List (Tuple$ (&/|list Text Type))) + TypePair (Tuple$ (&/|list Type Type))] + (App$ (&/V &/$AllT (&/T empty-env "Type" "_" + (Variant$ (&/|list + ;; DataT + Text + ;; TupleT + (App$ List Type) + ;; VariantT + TypeList + ;; RecordT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + )))) + $Void))) (defn fAll [name arg body] (&/V &/$AllT (&/T (&/V &/$None nil) name arg body))) @@ -63,130 +97,187 @@ (def Bindings (fAll "lux;Bindings" "k" (fAll "" "v" - (&/V &/$RecordT (&/|list (&/T "lux;counter" Int) - (&/T "lux;mappings" (&/V &/$AppT (&/T List - (&/V &/$TupleT (&/|list (&/V &/$BoundT "k") - (&/V &/$BoundT "v"))))))))))) + (Record$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v"))))))))) (def Env - (let [bindings (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings (&/V &/$BoundT "k"))) - (&/V &/$BoundT "v")))] + (let [bindings (App$ (App$ Bindings (Bound$ "k")) + (Bound$ "v"))] (fAll "lux;Env" "k" (fAll "" "v" - (&/V &/$RecordT - (&/|list (&/T "lux;name" Text) - (&/T "lux;inner-closures" Int) - (&/T "lux;locals" bindings) - (&/T "lux;closure" bindings) - )))))) + (Record$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + )))))) (def Cursor - (&/V &/$TupleT (&/|list Text Int Int))) + (Tuple$ (&/|list Text Int Int))) (def Meta (fAll &/$Meta "m" (fAll "" "v" - (&/V &/$VariantT (&/|list (&/T &/$Meta (&/V &/$TupleT (&/|list (&/V &/$BoundT "m") - (&/V &/$BoundT "v"))))))))) + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ "m") + (Bound$ "v")))))))) -(def Ident (&/V &/$TupleT (&/|list Text Text))) +(def Ident (Tuple$ (&/|list Text Text))) (def AST* - (let [AST* (&/V &/$AppT (&/T (&/V &/$BoundT "w") - (&/V &/$AppT (&/T (&/V &/$BoundT "lux;AST'") - (&/V &/$BoundT "w"))))) - AST*List (&/V &/$AppT (&/T List AST*))] + (let [AST* (App$ (Bound$ "w") + (App$ (Bound$ "lux;AST'") + (Bound$ "w"))) + AST*List (App$ List AST*)] (fAll "lux;AST'" "w" - (&/V &/$VariantT (&/|list (&/T &/$BoolS Bool) - (&/T &/$IntS Int) - (&/T &/$RealS Real) - (&/T &/$CharS Char) - (&/T &/$TextS Text) - (&/T &/$SymbolS Ident) - (&/T &/$TagS Ident) - (&/T &/$FormS AST*List) - (&/T &/$TupleS AST*List) - (&/T &/$RecordS (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list AST* AST*)))))) - )))) + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + )))) (def AST - (let [w (&/V &/$AppT (&/T Meta Cursor))] - (&/V &/$AppT (&/T w (&/V &/$AppT (&/T AST* w)))))) + (let [w (App$ Meta Cursor)] + (App$ w (App$ AST* w)))) -(def ^:private ASTList (&/V &/$AppT (&/T List AST))) +(def ^:private ASTList (App$ List AST)) (def Either (fAll "lux;Either" "l" (fAll "" "r" - (&/V &/$VariantT (&/|list (&/T &/$Left (&/V &/$BoundT "l")) - (&/T &/$Right (&/V &/$BoundT "r"))))))) + (Variant$ (&/|list (&/T &/$Left (Bound$ "l")) + (&/T &/$Right (Bound$ "r"))))))) (def StateE (fAll "lux;StateE" "s" (fAll "" "a" - (&/V &/$LambdaT (&/T (&/V &/$BoundT "s") - (&/V &/$AppT (&/T (&/V &/$AppT (&/T Either Text)) - (&/V &/$TupleT (&/|list (&/V &/$BoundT "s") - (&/V &/$BoundT "a")))))))))) + (Lambda$ (Bound$ "s") + (App$ (App$ Either Text) + (Tuple$ (&/|list (Bound$ "s") + (Bound$ "a")))))))) (def Reader - (&/V &/$AppT (&/T List - (&/V &/$AppT (&/T (&/V &/$AppT (&/T Meta Cursor)) - Text))))) + (App$ List + (App$ (App$ Meta Cursor) + Text))) (def HostState - (&/V &/$RecordT - (&/|list (&/T "lux;writer" (&/V &/$DataT "org.objectweb.asm.ClassWriter")) - (&/T "lux;loader" (&/V &/$DataT "java.lang.ClassLoader")) - (&/T "lux;classes" (&/V &/$DataT "clojure.lang.Atom"))))) + (Record$ + (&/|list + ;; "lux;writer" + (&/V &/$DataT "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (&/V &/$DataT "java.lang.ClassLoader") + ;; "lux;classes" + (&/V &/$DataT "clojure.lang.Atom")))) (def DefData* (fAll "lux;DefData'" "" - (&/V &/$VariantT (&/|list (&/T "lux;TypeD" Type) - (&/T "lux;ValueD" (&/V &/$TupleT (&/|list Type Unit))) - (&/T "lux;MacroD" (&/V &/$BoundT "")) - (&/T "lux;AliasD" Ident))))) + (Variant$ (&/|list + ;; "lux;TypeD" + Type + ;; "lux;ValueD" + (Tuple$ (&/|list Type Unit)) + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + )))) (def LuxVar - (&/V &/$VariantT (&/|list (&/T "lux;Local" Int) - (&/T "lux;Global" Ident)))) + (Variant$ (&/|list + ;; "lux;Local" + Int + ;; "lux;Global" + Ident))) (def $Module (fAll "lux;$Module" "Compiler" - (&/V &/$RecordT - (&/|list (&/T "lux;module-aliases" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Text))))) - (&/T "lux;defs" (&/V &/$AppT (&/T List (&/V &/$TupleT - (&/|list Text - (&/V &/$TupleT (&/|list Bool - (&/V &/$AppT (&/T DefData* - (&/V &/$LambdaT (&/T ASTList - (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE (&/V &/$BoundT "Compiler"))) - ASTList))))))))))))) - (&/T "lux;imports" (&/V &/$AppT (&/T List Text))))))) + (Record$ + (&/|list + ;; "lux;module-aliases" + (App$ List (Tuple$ (&/|list Text Text))) + ;; "lux;defs" + (App$ List + (Tuple$ + (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (List Ident))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Int + (App$ List + Ident)))))) + )))) (def $Compiler - (&/V &/$AppT (&/T (fAll "lux;Compiler" "" - (&/V &/$RecordT - (&/|list (&/T "lux;source" Reader) - (&/T "lux;modules" (&/V &/$AppT (&/T List (&/V &/$TupleT - (&/|list Text - (&/V &/$AppT (&/T $Module (&/V &/$AppT (&/T (&/V &/$BoundT "lux;Compiler") (&/V &/$BoundT "")))))))))) - (&/T "lux;envs" (&/V &/$AppT (&/T List - (&/V &/$AppT (&/T (&/V &/$AppT (&/T Env Text)) - (&/V &/$TupleT (&/|list LuxVar Type))))))) - (&/T "lux;types" (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings Int)) Type))) - (&/T "lux;host" HostState) - (&/T "lux;seed" Int) - (&/T "lux;eval?" Bool) - (&/T "lux;expected" Type) - (&/T "lux;cursor" Cursor) - ))) - $Void))) + (App$ (fAll "lux;Compiler" "" + (Record$ + (&/|list + ;; "lux;source" + Reader + ;; "lux;modules" + (App$ List (Tuple$ + (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;host" + HostState + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;expected" + Type + ;; "lux;cursor" + Cursor + ))) + $Void)) (def Macro - (&/V &/$LambdaT (&/T ASTList - (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE $Compiler)) - ASTList))))) + (Lambda$ ASTList + (App$ (App$ StateE $Compiler) + ASTList))) (defn bound? [id] (fn [state] @@ -297,30 +388,24 @@ (&/$LambdaT ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] - (return (&/V &/$LambdaT (&/T =arg =return)))) + (return (Lambda$ =arg =return))) (&/$AppT ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] - (return (&/V &/$AppT (&/T =lambda =param)))) + (return (App$ =lambda =param))) (&/$TupleT ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (&/V &/$TupleT =members))) + (return (Tuple$ =members))) (&/$VariantT ?members) - (|do [=members (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?members)] - (return (&/V &/$VariantT =members))) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Variant$ =members))) (&/$RecordT ?members) - (|do [=members (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?members)] - (return (&/V &/$RecordT =members))) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Record$ =members))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -380,23 +465,14 @@ (if (&/|empty? cases) "(|)" (str "(| " (->> cases - (&/|map (fn [kv] - (|case kv - [k (&/$TupleT (&/$Nil))] - (str "#" k) - - [k v] - (str "(#" k " " (show-type v) ")")))) + (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) (&/$RecordT fields) (str "(& " (->> fields - (&/|map (fn [kv] - (|case kv - [k v] - (str "#" k " " (show-type v))))) + (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") @@ -429,7 +505,9 @@ [args body*]))] (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) - )) + + _ + (assert false (prn-str 'show-type (aget type 0))))) (defn type= [x y] (or (clojure.lang.Util/identical x y) @@ -438,24 +516,17 @@ (.equals ^Object xname yname) [(&/$TupleT xelems) (&/$TupleT yelems)] - (&/fold2 (fn [old x y] - (and old (type= x y))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) [(&/$VariantT xcases) (&/$VariantT ycases)] - (&/fold2 (fn [old xcase ycase] - (|let [[xname xtype] xcase - [yname ytype] ycase] - (and old (.equals ^Object xname yname) (type= xtype ytype)))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xcases ycases) [(&/$RecordT xslots) (&/$RecordT yslots)] - (&/fold2 (fn [old xslot yslot] - (|let [[xname xtype] xslot - [yname ytype] yslot] - (and old (.equals ^Object xname yname) (type= xtype ytype)))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xslots yslots) @@ -522,23 +593,17 @@ (defn beta-reduce [env type] (|case type - (&/$VariantT ?cases) - (&/V &/$VariantT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (beta-reduce env v)))) - ?cases)) + (&/$VariantT ?members) + (Variant$ (&/|map (partial beta-reduce env) ?members)) - (&/$RecordT ?fields) - (&/V &/$RecordT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (beta-reduce env v)))) - ?fields)) + (&/$RecordT ?members) + (Record$ (&/|map (partial beta-reduce env) ?members)) (&/$TupleT ?members) - (&/V &/$TupleT (&/|map (partial beta-reduce env) ?members)) + (Tuple$ (&/|map (partial beta-reduce env) ?members)) (&/$AppT ?type-fn ?type-arg) - (&/V &/$AppT (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) + (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env @@ -549,7 +614,7 @@ type) (&/$LambdaT ?input ?output) - (&/V &/$LambdaT (&/T (beta-reduce env ?input) (beta-reduce env ?output))) + (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output)) (&/$BoundT ?name) (if-let [bound (&/|get ?name env)] @@ -660,13 +725,13 @@ (|case ((|do [F1 (deref ?eid)] (fn [state] (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) state)] (&/$Right state* output) (return* state* output) (&/$Left _) - ((check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual) + ((check* class-loader fixpoints (App$ F1 A1) actual) state)))) state) (&/$Right state* output) @@ -674,7 +739,7 @@ (&/$Left _) (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints expected (App$ F2 A2))) state) (&/$Right state* output) (return* state* output) @@ -691,7 +756,7 @@ [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual)) + (check* class-loader fixpoints (App$ F1 A1) actual)) state) (&/$Right state* output) (return* state* output) @@ -713,7 +778,7 @@ [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints expected (App$ F2 A2))) state) (&/$Right state* output) (return* state* output) @@ -795,25 +860,17 @@ (return (&/T fixpoints* nil))) [(&/$VariantT e!cases) (&/$VariantT a!cases)] - (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] - (|let [[e!name e!type] e!case - [a!name a!type] a!case] - (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* class-loader fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) fixpoints e!cases a!cases)] (return (&/T fixpoints* nil))) [(&/$RecordT e!slots) (&/$RecordT a!slots)] - (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] - (|let [[e!name e!type] e!slot - [a!name a!type] a!slot] - (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* class-loader fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) fixpoints e!slots a!slots)] (return (&/T fixpoints* nil))) -- cgit v1.2.3 From 72a9ed29ca5518ca98658873f4616d5637db80af Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Aug 2015 23:55:56 -0400 Subject: - Changing tags so they're actually indices (part 2). - Fixed some bugs. - Now pattern-matching on variants works with indices, rather than text tags. --- source/lux.lux | 8 +- src/lux/analyser/base.clj | 2 +- src/lux/analyser/case.clj | 137 ++++++++++++++++-------------- src/lux/analyser/lux.clj | 15 ++-- src/lux/base.clj | 16 +++- src/lux/compiler/case.clj | 1 + src/lux/compiler/type.clj | 16 ++-- src/lux/type.clj | 212 ++++++++++++++++++++++++++-------------------- 8 files changed, 226 insertions(+), 181 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index d023406f8..91e00d317 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -563,8 +563,8 @@ #Nil])) _ - (fail "Wrong syntax for def") - )))) + (fail "Wrong syntax for def")) + ))) (_lux_declare-macro def'') (def'' (defmacro tokens) @@ -680,13 +680,13 @@ #Nil init - (#Cons [x xs']) + (#Cons x xs') (foldL f (f init x) xs'))) (def'' (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) - (foldL (lambda'' [tail head] (#Cons [head tail])) + (foldL (lambda'' [tail head] (#Cons head tail)) #Nil list)) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 218fc6dd9..58c01e642 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -148,4 +148,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/ident->text (&/T module* ?name)))))) + (return (&/T module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6cf070a52..6992c11a3 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -13,7 +13,8 @@ [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] - [env :as &env]))) + [env :as &env] + [module :as &module]))) ;; [Tags] (deftags "" @@ -66,6 +67,7 @@ (defn adjust-type* [up type] "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + ;; (prn 'adjust-type* (&type/show-type type)) (|case type (&/$AllT _aenv _aname _aarg _abody) (&type/with-var @@ -80,45 +82,43 @@ (&type/clean* _avar _abody)))) type up)] - (return (&/V &/$TupleT (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - (&/$RecordT ?fields) - (|do [(&/$RecordT ?fields*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V &/$RecordT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?fields*)))) - - (&/$VariantT ?cases) - (|do [(&/$VariantT ?cases*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V &/$VariantT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?cases*)))) + (return (&type/Tuple$ (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$RecordT ?members) + (|do [(&/$RecordT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$RecordT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$VariantT ?members) + (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) (&/$AppT ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] @@ -208,7 +208,8 @@ (|let [[sn sv] slot] (|case sn (&/$Meta _ (&/$TagS ?ident)) - (|do [=tag (&&/resolved-ident ?ident)] + (|do [=ident (&&/resolved-ident ?ident) + :let [=tag (&/ident->text =ident)]] (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] (return (&/T (&/|put =tag =test =tests) =kont))) @@ -225,23 +226,39 @@ (fail "[Pattern-matching Error] Record requires record-type."))) (&/$TagS ?ident) - (|do [=tag (&&/resolved-ident ?ident) + (|do [;; :let [_ (println "#00")] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#01")] value-type* (adjust-type value-type) - case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type unit kont)] - (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont))) + ;; :let [_ (println "#02")] + idx (&module/tag-index =module =name) + ;; :let [_ (println "#03")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#04")] + [=test =kont] (analyse-pattern case-type unit kont) + ;; :let [_ (println "#05")] + ] + (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) - (|do [=tag (&&/resolved-ident ?ident) + (|do [;; :let [_ (println "#10" ?ident)] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#11")] value-type* (adjust-type value-type) - case-type (&type/variant-case =tag value-type*) + ;; :let [_ (println "#12" (&type/show-type value-type*))] + idx (&module/tag-index =module =name) + ;; :let [_ (println "#13")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#14" (&type/show-type case-type))] [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))] - (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont))) + (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) + ;; :let [_ (println "#15")] + ] + (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] @@ -380,13 +397,10 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$RecordT ?fields) - (|do [totals (&/map% (fn [field] - (|let [[?tk ?tv] field] - (if-let [sub-struct (&/|get ?tk ?structs)] - (check-totality ?tv sub-struct) - (return false)))) - ?fields)] + (&/$RecordT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) _ @@ -397,13 +411,10 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$VariantT ?cases) - (|do [totals (&/map% (fn [case] - (|let [[?tk ?tv] case] - (if-let [sub-struct (&/|get ?tk ?structs)] - (check-totality ?tv sub-struct) - (return false)))) - ?cases)] + (&/$VariantT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) _ diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index ba4a173f0..e55d5fec8 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -158,7 +158,8 @@ =slots (&/map% (fn [kv] (|case kv [(&/$Meta _ (&/$TagS ?ident)) ?value] - (|do [?tag (&&/resolved-ident ?ident) + (|do [=ident (&&/resolved-ident ?ident) + :let [?tag (&/ident->text =ident)] slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) (fail (str "[Analyser Error] Record type does not have slot: " ?tag))) @@ -302,14 +303,14 @@ (|do [loader &/loader] (|let [[=fn-form =fn-type] =fn] (|case =fn-form - (&/$Global ?module ?name) - (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] + (&&/$var (&/$Global ?module ?name)) + (|do [[real-name $def] (&&module/find-def ?module ?name)] (|case $def (&/$MacroD macro) - (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] + (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) - ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] - :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] + ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] + ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (or (= "<>" r-name) ;; ;; (= &&/$struct r-name) ;; ) @@ -318,7 +319,7 @@ ;; (&/fold str "") ;; (prn (str r-module ";" r-name))))] ] - (&/flat-map% (partial analyse exo-type) macro-expansion*)) + (&/flat-map% (partial analyse exo-type) macro-expansion)) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 73b2bb684..a700a30c8 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -281,13 +281,23 @@ ($Cons x xs*) (V $Cons (T x (|++ xs* ys))))) +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + (defn |map [f xs] (|case xs ($Nil) xs ($Cons x xs*) - (V $Cons (T (f x) (|map f xs*))))) + (V $Cons (T (f x) (|map f xs*))) + + _ + (assert false (prn-str '|map f (adt->text xs))) + )) (defn |empty? [xs] (|case xs @@ -770,8 +780,8 @@ ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") - _ - (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) + ;; _ + ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) )) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index e2cbe77a2..b108d463c 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -132,6 +132,7 @@ (.visitLdcInsn (int 0)) (.visitInsn Opcodes/AALOAD) (.visitLdcInsn ?tag) + (&&/wrap-long) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/DUP) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index e9d3014db..3d2ef5070 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -51,23 +51,19 @@ $Nil (&/|reverse ?members))) - (&/$VariantT ?cases) + (&/$VariantT ?members) (variant$ &/$VariantT (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) + (Cons$ (->analysis head) tail)) $Nil - (&/|reverse ?cases))) + (&/|reverse ?members))) - (&/$RecordT ?slots) + (&/$RecordT ?members) (variant$ &/$RecordT (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) + (Cons$ (->analysis head) tail)) $Nil - (&/|reverse ?slots))) + (&/|reverse ?members))) (&/$LambdaT ?input ?output) (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 553318daf..94b0fbc5e 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -14,7 +14,18 @@ (declare show-type) -;; [Util] +;; [Utils] +(defn |list? [xs] + (|case xs + (&/$Nil) + true + + (&/$Cons x xs*) + (|list? xs*) + + _ + false)) + (def Bool (&/V &/$DataT "java.lang.Boolean")) (def Int (&/V &/$DataT "java.lang.Long")) (def Real (&/V &/$DataT "java.lang.Double")) @@ -24,79 +35,90 @@ (def $Void (&/V &/$VariantT (&/|list))) (def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) -(defn ^:private Bound$ [name] +(def ^:private no-env (&/V &/$None nil)) +(defn Data$ [name] + (&/V &/$DataT name)) +(defn Bound$ [name] (&/V &/$BoundT name)) -(defn ^:private Lambda$ [in out] +(defn Var$ [id] + (&/V &/$VarT id)) +(defn Lambda$ [in out] (&/V &/$LambdaT (&/T in out))) -(defn ^:private App$ [fun arg] +(defn App$ [fun arg] (&/V &/$AppT (&/T fun arg))) -(defn ^:private Tuple$ [members] + +(defn Tuple$ [members] + ;; (assert (|list? members)) (&/V &/$TupleT members)) -(defn ^:private Variant$ [members] + +(defn Variant$ [members] + ;; (assert (|list? members)) (&/V &/$VariantT members)) -(defn ^:private Record$ [members] + +(defn Record$ [members] + ;; (assert (|list? members)) (&/V &/$RecordT members)) +(defn All$ [env name arg body] + (&/V &/$AllT (&/T env name arg body))) + (def IO - (&/V &/$AllT (&/T empty-env "IO" "a" - (Lambda$ Unit (Bound$ "a"))))) + (All$ empty-env "IO" "a" + (Lambda$ Unit (Bound$ "a")))) (def List - (&/V &/$AllT (&/T empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - ))))) + (All$ empty-env "lux;List" "a" + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + )))) (def Maybe - (&/V &/$AllT (&/T empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - ))))) + (All$ empty-env "lux;Maybe" "a" + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + )))) (def Type (let [Type (App$ (Bound$ "Type") (Bound$ "_")) TypeList (App$ List Type) TypeEnv (App$ List (Tuple$ (&/|list Text Type))) TypePair (Tuple$ (&/|list Type Type))] - (App$ (&/V &/$AllT (&/T empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; TupleT - (App$ List Type) - ;; VariantT - TypeList - ;; RecordT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) - ;; AppT - TypePair - )))) + (App$ (All$ empty-env "Type" "_" + (Variant$ (&/|list + ;; DataT + Text + ;; TupleT + (App$ List Type) + ;; VariantT + TypeList + ;; RecordT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + ))) $Void))) -(defn fAll [name arg body] - (&/V &/$AllT (&/T (&/V &/$None nil) name arg body))) - (def Bindings - (fAll "lux;Bindings" "k" - (fAll "" "v" + (All$ empty-env "lux;Bindings" "k" + (All$ no-env "" "v" (Record$ (&/|list ;; "lux;counter" Int @@ -108,8 +130,8 @@ (def Env (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] - (fAll "lux;Env" "k" - (fAll "" "v" + (All$ empty-env "lux;Env" "k" + (All$ no-env "" "v" (Record$ (&/|list ;; "lux;name" @@ -126,8 +148,8 @@ (Tuple$ (&/|list Text Int Int))) (def Meta - (fAll &/$Meta "m" - (fAll "" "v" + (All$ empty-env "lux;Meta" "m" + (All$ no-env "" "v" (Variant$ (&/|list ;; &/$Meta (Tuple$ (&/|list (Bound$ "m") @@ -140,7 +162,7 @@ (App$ (Bound$ "lux;AST'") (Bound$ "w"))) AST*List (App$ List AST*)] - (fAll "lux;AST'" "w" + (All$ empty-env "lux;AST'" "w" (Variant$ (&/|list ;; &/$BoolS Bool @@ -171,14 +193,17 @@ (def ^:private ASTList (App$ List AST)) (def Either - (fAll "lux;Either" "l" - (fAll "" "r" - (Variant$ (&/|list (&/T &/$Left (Bound$ "l")) - (&/T &/$Right (Bound$ "r"))))))) + (All$ empty-env "lux;Either" "l" + (All$ no-env "" "r" + (Variant$ (&/|list + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r")))))) (def StateE - (fAll "lux;StateE" "s" - (fAll "" "a" + (All$ empty-env "lux;StateE" "s" + (All$ no-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) (Tuple$ (&/|list (Bound$ "s") @@ -193,14 +218,14 @@ (Record$ (&/|list ;; "lux;writer" - (&/V &/$DataT "org.objectweb.asm.ClassWriter") + (Data$ "org.objectweb.asm.ClassWriter") ;; "lux;loader" - (&/V &/$DataT "java.lang.ClassLoader") + (Data$ "java.lang.ClassLoader") ;; "lux;classes" - (&/V &/$DataT "clojure.lang.Atom")))) + (Data$ "clojure.lang.Atom")))) (def DefData* - (fAll "lux;DefData'" "" + (All$ empty-env "lux;DefData'" "" (Variant$ (&/|list ;; "lux;TypeD" Type @@ -220,20 +245,19 @@ Ident))) (def $Module - (fAll "lux;$Module" "Compiler" + (All$ empty-env "lux;$Module" "Compiler" (Record$ (&/|list ;; "lux;module-aliases" (App$ List (Tuple$ (&/|list Text Text))) ;; "lux;defs" (App$ List - (Tuple$ - (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))))) + (Tuple$ (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))))) ;; "lux;imports" (App$ List Text) ;; "lux;tags" @@ -246,15 +270,14 @@ )))) (def $Compiler - (App$ (fAll "lux;Compiler" "" + (App$ (All$ empty-env "lux;Compiler" "" (Record$ (&/|list ;; "lux;source" Reader ;; "lux;modules" - (App$ List (Tuple$ - (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) ;; "lux;envs" (App$ List (App$ (App$ Env Text) @@ -368,13 +391,13 @@ (defn with-var [k] (|do [id create-var - output (k (&/V &/$VarT id)) + output (k (Var$ id)) _ (delete-var id)] (return output))) (defn with-vars [amount k] (|do [=vars (&/map% (constantly create-var) (&/|range amount)) - output (k (&/|map #(&/V &/$VarT %) =vars)) + output (k (&/|map #(Var$ %) =vars)) _ (&/map% delete-var (&/|reverse =vars))] (return output))) @@ -419,7 +442,7 @@ ?env*)] (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] - (return (&/V &/$AllT (&/T =env ?name ?arg body*)))) + (return (All$ =env ?name ?arg body*))) _ (return type) @@ -608,7 +631,7 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (&/V &/$AllT (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) + (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) (&/$Some _) type) @@ -745,11 +768,11 @@ (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) + ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) state)))) - ;; (|do [_ (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) + ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) @@ -762,14 +785,14 @@ (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] @@ -784,14 +807,14 @@ (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] @@ -919,12 +942,15 @@ (return type) )) -(defn variant-case [case type] +(defn variant-case [tag type] (|case type (&/$VariantT ?cases) - (if-let [case-type (&/|get case ?cases)] + (|case (&/|at tag ?cases) + (&/$Some case-type) (return case-type) - (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) + + (&/$None) + (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) -- cgit v1.2.3 From 95e7125c36dfa04a29ac363f1fc7e4c59b505415 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 12 Aug 2015 00:14:53 -0400 Subject: - Changing tags so they're actually indices (part 3). - Added several bug fixes - Changed "Reader" to "Source" and "HostState" to "Host" in lux.lux - Set up indexing of records via tags. - Added lux.analyser.record namespace. - Removed some (now) unnecessary code for working with records. - Added the license (can't believe I missed it for so long.) --- epl-v10.html | 261 ++++++++++++++++++++++++++++++++++++++++++++ source/lux.lux | 108 +++++++++--------- src/lux/analyser/base.clj | 1 - src/lux/analyser/case.clj | 82 ++++---------- src/lux/analyser/env.clj | 24 ++-- src/lux/analyser/lambda.clj | 8 +- src/lux/analyser/lux.clj | 56 ++++------ src/lux/analyser/module.clj | 97 ++++++++-------- src/lux/analyser/record.clj | 158 +++++++++++++++++++++++++++ src/lux/base.clj | 130 ++++++++++++---------- src/lux/compiler.clj | 5 +- src/lux/compiler/cache.clj | 2 +- src/lux/compiler/case.clj | 23 ---- src/lux/compiler/lux.clj | 21 ---- src/lux/reader.clj | 10 +- src/lux/type.clj | 44 ++++---- 16 files changed, 689 insertions(+), 341 deletions(-) create mode 100644 epl-v10.html create mode 100644 src/lux/analyser/record.clj diff --git a/epl-v10.html b/epl-v10.html new file mode 100644 index 000000000..813c07d8c --- /dev/null +++ b/epl-v10.html @@ -0,0 +1,261 @@ + + + + + + +Eclipse Public License - Version 1.0 + + + + + + +

Eclipse Public License - v 1.0

+ +

THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE +PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR +DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS +AGREEMENT.

+ +

1. DEFINITIONS

+ +

"Contribution" means:

+ +

a) in the case of the initial Contributor, the initial +code and documentation distributed under this Agreement, and

+

b) in the case of each subsequent Contributor:

+

i) changes to the Program, and

+

ii) additions to the Program;

+

where such changes and/or additions to the Program +originate from and are distributed by that particular Contributor. A +Contribution 'originates' from a Contributor if it was added to the +Program by such Contributor itself or anyone acting on such +Contributor's behalf. Contributions do not include additions to the +Program which: (i) are separate modules of software distributed in +conjunction with the Program under their own license agreement, and (ii) +are not derivative works of the Program.

+ +

"Contributor" means any person or entity that distributes +the Program.

+ +

"Licensed Patents" mean patent claims licensable by a +Contributor which are necessarily infringed by the use or sale of its +Contribution alone or when combined with the Program.

+ +

"Program" means the Contributions distributed in accordance +with this Agreement.

+ +

"Recipient" means anyone who receives the Program under +this Agreement, including all Contributors.

+ +

2. GRANT OF RIGHTS

+ +

a) Subject to the terms of this Agreement, each +Contributor hereby grants Recipient a non-exclusive, worldwide, +royalty-free copyright license to reproduce, prepare derivative works +of, publicly display, publicly perform, distribute and sublicense the +Contribution of such Contributor, if any, and such derivative works, in +source code and object code form.

+ +

b) Subject to the terms of this Agreement, each +Contributor hereby grants Recipient a non-exclusive, worldwide, +royalty-free patent license under Licensed Patents to make, use, sell, +offer to sell, import and otherwise transfer the Contribution of such +Contributor, if any, in source code and object code form. This patent +license shall apply to the combination of the Contribution and the +Program if, at the time the Contribution is added by the Contributor, +such addition of the Contribution causes such combination to be covered +by the Licensed Patents. The patent license shall not apply to any other +combinations which include the Contribution. No hardware per se is +licensed hereunder.

+ +

c) Recipient understands that although each Contributor +grants the licenses to its Contributions set forth herein, no assurances +are provided by any Contributor that the Program does not infringe the +patent or other intellectual property rights of any other entity. Each +Contributor disclaims any liability to Recipient for claims brought by +any other entity based on infringement of intellectual property rights +or otherwise. As a condition to exercising the rights and licenses +granted hereunder, each Recipient hereby assumes sole responsibility to +secure any other intellectual property rights needed, if any. For +example, if a third party patent license is required to allow Recipient +to distribute the Program, it is Recipient's responsibility to acquire +that license before distributing the Program.

+ +

d) Each Contributor represents that to its knowledge it +has sufficient copyright rights in its Contribution, if any, to grant +the copyright license set forth in this Agreement.

+ +

3. REQUIREMENTS

+ +

A Contributor may choose to distribute the Program in object code +form under its own license agreement, provided that:

+ +

a) it complies with the terms and conditions of this +Agreement; and

+ +

b) its license agreement:

+ +

i) effectively disclaims on behalf of all Contributors +all warranties and conditions, express and implied, including warranties +or conditions of title and non-infringement, and implied warranties or +conditions of merchantability and fitness for a particular purpose;

+ +

ii) effectively excludes on behalf of all Contributors +all liability for damages, including direct, indirect, special, +incidental and consequential damages, such as lost profits;

+ +

iii) states that any provisions which differ from this +Agreement are offered by that Contributor alone and not by any other +party; and

+ +

iv) states that source code for the Program is available +from such Contributor, and informs licensees how to obtain it in a +reasonable manner on or through a medium customarily used for software +exchange.

+ +

When the Program is made available in source code form:

+ +

a) it must be made available under this Agreement; and

+ +

b) a copy of this Agreement must be included with each +copy of the Program.

+ +

Contributors may not remove or alter any copyright notices contained +within the Program.

+ +

Each Contributor must identify itself as the originator of its +Contribution, if any, in a manner that reasonably allows subsequent +Recipients to identify the originator of the Contribution.

+ +

4. COMMERCIAL DISTRIBUTION

+ +

Commercial distributors of software may accept certain +responsibilities with respect to end users, business partners and the +like. While this license is intended to facilitate the commercial use of +the Program, the Contributor who includes the Program in a commercial +product offering should do so in a manner which does not create +potential liability for other Contributors. Therefore, if a Contributor +includes the Program in a commercial product offering, such Contributor +("Commercial Contributor") hereby agrees to defend and +indemnify every other Contributor ("Indemnified Contributor") +against any losses, damages and costs (collectively "Losses") +arising from claims, lawsuits and other legal actions brought by a third +party against the Indemnified Contributor to the extent caused by the +acts or omissions of such Commercial Contributor in connection with its +distribution of the Program in a commercial product offering. The +obligations in this section do not apply to any claims or Losses +relating to any actual or alleged intellectual property infringement. In +order to qualify, an Indemnified Contributor must: a) promptly notify +the Commercial Contributor in writing of such claim, and b) allow the +Commercial Contributor to control, and cooperate with the Commercial +Contributor in, the defense and any related settlement negotiations. The +Indemnified Contributor may participate in any such claim at its own +expense.

+ +

For example, a Contributor might include the Program in a commercial +product offering, Product X. That Contributor is then a Commercial +Contributor. If that Commercial Contributor then makes performance +claims, or offers warranties related to Product X, those performance +claims and warranties are such Commercial Contributor's responsibility +alone. Under this section, the Commercial Contributor would have to +defend claims against the other Contributors related to those +performance claims and warranties, and if a court requires any other +Contributor to pay any damages as a result, the Commercial Contributor +must pay those damages.

+ +

5. NO WARRANTY

+ +

EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS +PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS +OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, +ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY +OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely +responsible for determining the appropriateness of using and +distributing the Program and assumes all risks associated with its +exercise of rights under this Agreement , including but not limited to +the risks and costs of program errors, compliance with applicable laws, +damage to or loss of data, programs or equipment, and unavailability or +interruption of operations.

+ +

6. DISCLAIMER OF LIABILITY

+ +

EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT +NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING +WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR +DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED +HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

+ +

7. GENERAL

+ +

If any provision of this Agreement is invalid or unenforceable under +applicable law, it shall not affect the validity or enforceability of +the remainder of the terms of this Agreement, and without further action +by the parties hereto, such provision shall be reformed to the minimum +extent necessary to make such provision valid and enforceable.

+ +

If Recipient institutes patent litigation against any entity +(including a cross-claim or counterclaim in a lawsuit) alleging that the +Program itself (excluding combinations of the Program with other +software or hardware) infringes such Recipient's patent(s), then such +Recipient's rights granted under Section 2(b) shall terminate as of the +date such litigation is filed.

+ +

All Recipient's rights under this Agreement shall terminate if it +fails to comply with any of the material terms or conditions of this +Agreement and does not cure such failure in a reasonable period of time +after becoming aware of such noncompliance. If all Recipient's rights +under this Agreement terminate, Recipient agrees to cease use and +distribution of the Program as soon as reasonably practicable. However, +Recipient's obligations under this Agreement and any licenses granted by +Recipient relating to the Program shall continue and survive.

+ +

Everyone is permitted to copy and distribute copies of this +Agreement, but in order to avoid inconsistency the Agreement is +copyrighted and may only be modified in the following manner. The +Agreement Steward reserves the right to publish new versions (including +revisions) of this Agreement from time to time. No one other than the +Agreement Steward has the right to modify this Agreement. The Eclipse +Foundation is the initial Agreement Steward. The Eclipse Foundation may +assign the responsibility to serve as the Agreement Steward to a +suitable separate entity. Each new version of the Agreement will be +given a distinguishing version number. The Program (including +Contributions) may always be distributed subject to the version of the +Agreement under which it was received. In addition, after a new version +of the Agreement is published, Contributor may elect to distribute the +Program (including its Contributions) under the new version. Except as +expressly stated in Sections 2(a) and 2(b) above, Recipient receives no +rights or licenses to the intellectual property of any Contributor under +this Agreement, whether expressly, by implication, estoppel or +otherwise. All rights in the Program not expressly granted under this +Agreement are reserved.

+ +

This Agreement is governed by the laws of the State of New York and +the intellectual property laws of the United States of America. No party +to this Agreement will bring a legal action under this Agreement more +than one year after the cause of action arose. Each party waives its +rights to a jury trial in any resulting litigation.

+ + + + diff --git a/source/lux.lux b/source/lux.lux index 91e00d317..04f9df811 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -122,6 +122,7 @@ #Nil])]))]) #Nil)))])])) (_lux_export Bindings) +(_lux_declare-tags [#counter #mappings]) ## (deftype (Env k v) ## (& #name Text @@ -143,6 +144,7 @@ (#BoundT "v")]) #Nil])])])]))])])) (_lux_export Env) +(_lux_declare-tags [#name #inner-closures #locals #closure]) ## (deftype Cursor ## (, Text Int Int)) @@ -243,19 +245,19 @@ (#Cons [(#BoundT "a") #Nil])]))])])])])) -## (deftype Reader +## (deftype Source ## (List (Meta Cursor Text))) -(_lux_def Reader +(_lux_def Source (#AppT [List (#AppT [(#AppT [Meta Cursor]) Text])])) -(_lux_export Reader) +(_lux_export Source) -## (deftype HostState +## (deftype Host ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader) ## #classes (^ clojure.lang.Atom))) -(_lux_def HostState +(_lux_def Host (#RecordT (#Cons [## "lux;writer" (#DataT "org.objectweb.asm.ClassWriter") (#Cons [## "lux;loader" @@ -263,6 +265,7 @@ (#Cons [## "lux;classes" (#DataT "clojure.lang.Atom") #Nil])])]))) +(_lux_declare-tags [#writer #loader #classes]) ## (deftype (DefData' m) ## (| (#TypeD Type) @@ -283,6 +286,7 @@ Ident #Nil])])])]))])) (_lux_export DefData') +(_lux_declare-tags [#TypeD #ValueD #MacroD #AliasD]) ## (deftype LuxVar ## (| (#Local Int) @@ -294,6 +298,7 @@ Ident #Nil])]))) (_lux_export LuxVar) +(_lux_declare-tags [#Local #Global]) ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) @@ -323,44 +328,46 @@ #Nil)))]) #Nil])])])]))])) (_lux_export Module) +(_lux_declare-tags [#module-aliases #defs #imports #tags]) ## (deftype #rec Compiler -## (& #source Reader +## (& #source Source +## #cursor Cursor ## #modules (List (, Text (Module Compiler))) ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) -## #host HostState +## #expected Type ## #seed Int ## #eval? Bool -## #expected Type -## #cursor Cursor +## #host Host ## )) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [## "lux;source" - Reader - (#Cons [## "lux;modules" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))]) - (#Cons [## "lux;envs" - (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) - (#Cons [## "lux;types" - (#AppT [(#AppT [Bindings Int]) Type]) - (#Cons [## "lux;host" - HostState - (#Cons [## "lux;seed" - Int - (#Cons [## "lux;eval?" - Bool - (#Cons [## "lux;expected" - Type - (#Cons [## "lux;cursor" - Cursor + Source + (#Cons [## "lux;cursor" + Cursor + (#Cons [## "lux;modules" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))]) + (#Cons [## "lux;envs" + (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) + (#Cons [## "lux;types" + (#AppT [(#AppT [Bindings Int]) Type]) + (#Cons [## "lux;expected" + Type + (#Cons [## "lux;seed" + Int + (#Cons [## "lux;eval?" + Bool + (#Cons [## "lux;host" + Host #Nil])])])])])])])])]))]) Void])) (_lux_export Compiler) +(_lux_declare-tags [#source #cursor #modules #envs #types #expected #seed #eval? #host]) ## (deftype Macro ## (-> (List AST) (StateE Compiler (List AST)))) @@ -1016,18 +1023,19 @@ (def''' Monad Type (All' [m] - (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] - ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))])))) + (#RecordT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b)))))))) +(_lux_declare-tags [#return #bind]) (def''' Maybe/Monad ($' Monad Maybe) - {#lux;return + {#return (lambda' return [x] (#Some x)) - #lux;bind + #bind (lambda' [f ma] (_lux_case ma #None #None @@ -1035,12 +1043,12 @@ (def''' Lux/Monad ($' Monad Lux) - {#lux;return + {#return (lambda' [x] (lambda' [state] (#Right [state x]))) - #lux;bind + #bind (lambda' [f ma] (lambda' [state] (_lux_case (ma state) @@ -1073,12 +1081,12 @@ (defmacro (do tokens) (_lux_case tokens - (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) + (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var - (#Meta [_ (#TagS ["" "let"])]) + (#Meta _ (#TagS "" "let")) (`' (;let' (~ value) (~ body'))) _ @@ -1108,11 +1116,11 @@ #Nil (wrap #Nil) - (#Cons [x xs']) + (#Cons x xs') (do m [y (f x) ys (map% m f xs')] - (wrap (#Cons [y ys]))) + (wrap (#Cons y ys))) ))) (def''' (. f g) @@ -1385,6 +1393,10 @@ (#Cons [[k' v] dict']) (#Cons [[k' v'] (put k v dict')])))) +(def''' (->text x) + (-> (^ java.lang.Object) Text) + (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) + (def''' (get-module-name state) ($' Lux Text) (_lux_case state @@ -1405,7 +1417,7 @@ ($' Maybe Macro)) (do Maybe/Monad [$module (get module modules) - gdef (let' [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] + gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags} (_lux_: ($' Module Compiler) $module)] (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] @@ -1432,7 +1444,7 @@ #envs envs #types types #host host #seed seed #eval? eval? #expected expected #cursor cursor} - (#Right [state (find-macro' modules current-module module name)])))))) + (#Right state (find-macro' modules current-module module name))))))) (def''' (list:join xs) (All [a] @@ -1494,10 +1506,6 @@ (as-pairs tokens))] (wrap (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) -(def''' (->text x) - (-> (^ java.lang.Object) Text) - (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) - (def''' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) @@ -2508,7 +2516,7 @@ (if export? (list name) (list))))) - (let [{#module-aliases _ #defs defs #imports _} =module] + (let [{#module-aliases _ #defs defs #imports _ #tags tags} =module] defs))] (#Right state (list:join to-alias))) @@ -2721,7 +2729,7 @@ #None #None - (#Some {#defs defs #module-aliases _ #imports _}) + (#Some {#defs defs #module-aliases _ #imports _ #tags tags}) (case (get v-name defs) #None #None @@ -2742,7 +2750,7 @@ ## #seed seed #eval? eval? #expected expected} state] ## (do Maybe/Monad ## [module (get v-prefix modules) -## #let [{#defs defs #module-aliases _ #imports _} module] +## #let [{#defs defs #module-aliases _ #imports _ #tags tags} module] ## def (get v-name defs) ## #let [[_ def-data] def]] ## (case def-data diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 58c01e642..fe1e0d55b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -21,7 +21,6 @@ "text" "variant" "tuple" - "record" "apply" "case" "lambda" diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6992c11a3..34cbf8b48 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -14,7 +14,8 @@ [type :as &type]) (lux.analyser [base :as &&] [env :as &env] - [module :as &module]))) + [module :as &module] + [record :as &&record]))) ;; [Tags] (deftags "" @@ -25,7 +26,6 @@ "CharTotal" "TextTotal" "TupleTotal" - "RecordTotal" "VariantTotal" ) @@ -37,7 +37,6 @@ "CharTestAC" "TextTestAC" "TupleTestAC" - "RecordTestAC" "VariantTestAC" ) @@ -194,33 +193,25 @@ _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - (&/$RecordS ?slots) - (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs) + ;; :let [_ (prn 'PRE (&type/show-type value-type))] value-type* (adjust-type value-type) ;; :let [_ (prn 'POST (&type/show-type value-type*))] ;; value-type* (resolve-type value-type) ] (|case value-type* - (&/$RecordT ?slot-types) - (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) - (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* slot] - (|let [[sn sv] slot] - (|case sn - (&/$Meta _ (&/$TagS ?ident)) - (|do [=ident (&&/resolved-ident ?ident) - :let [=tag (&/ident->text =ident)]] - (if-let [=slot-type (&/|get =tag ?slot-types)] - (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] - (return (&/T (&/|put =tag =test =tests) =kont))) - (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) - - _ - (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) + (&/$RecordT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) (|do [=kont kont] - (return (&/T (&/|table) =kont))) - (&/|reverse ?slots))] - (return (&/T (&/V $RecordTestAC =tests) =kont)))) + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) _ (fail "[Pattern-matching Error] Record requires record-type."))) @@ -320,34 +311,6 @@ (return (&/V $TupleTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [($DefaultTotal total?) ($RecordTestAC ?tests)] - (|do [structs (&/map% (fn [t] - (|let [[slot value] t] - (|do [struct* (merge-total (&/V $DefaultTotal total?) (&/T value ?body))] - (return (&/T slot struct*))))) - (->> ?tests - &/->seq - (sort compare-kv) - &/->list))] - (return (&/V $RecordTotal (&/T total? structs)))) - - [($RecordTotal total? ?values) ($RecordTestAC ?tests)] - (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map2% (fn [left right] - (|let [[lslot sub-struct] left - [rslot value]right] - (if (.equals ^Object lslot rslot) - (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] - (return (&/T lslot sub-struct*))) - (fail "[Pattern-matching Error] Record slots mismatch.")))) - ?values - (->> ?tests - &/->seq - (sort compare-kv) - &/->list))] - (return (&/V $RecordTotal (&/T total? structs)))) - (fail "[Pattern-matching Error] Inconsistent record-size.")) - [($DefaultTotal total?) ($VariantTestAC ?tag ?test)] (|do [sub-struct (merge-total (&/V $DefaultTotal total?) (&/T ?test ?body))] @@ -361,6 +324,7 @@ )))) (defn ^:private check-totality [value-type struct] + ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct ($BoolTotal ?total ?values) (return (or ?total @@ -389,14 +353,6 @@ ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) - _ - (fail "[Pattern-maching Error] Tuple is not total.")))) - - ($RecordTotal ?total ?structs) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* (&/$RecordT ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) @@ -404,7 +360,7 @@ (return (&/fold #(and %1 %2) true totals))) _ - (fail "[Pattern-maching Error] Record is not total.")))) + (fail "[Pattern-maching Error] Tuple is not total.")))) ($VariantTotal ?total ?structs) (if ?total @@ -422,6 +378,10 @@ ($DefaultTotal ?total) (return ?total) + + ;; _ + ;; (assert false (prn-str 'check-totality (&type/show-type value-type) + ;; (&/adt->text struct))) )) ;; [Exports] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 614b38799..4e9dcd79f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,28 +15,28 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) - =return (body (&/update$ &/$ENVS + (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$envs (fn [stack] - (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))] - (&/|cons (&/update$ &/$LOCALS #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) (&/|head stack)) (&/|tail stack)))) state))] (|case =return (&/$Right ?state ?value) - (return* (&/update$ &/$ENVS (fn [stack*] - (&/|cons (&/update$ &/$LOCALS #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS old-mappings)) + (return* (&/update$ &/$envs (fn [stack*] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) (&/|head stack*)) (&/|tail stack*))) ?state) @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 91cf3443b..aeb5a4814 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -27,10 +27,10 @@ (defn close-over [scope name register frame] (|let [[_ register-type] register register* (&/T (&/V &&/$captured (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) register)) register-type)] - (&/T register* (&/update$ &/$CLOSURE #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) + (&/T register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index e55d5fec8..449ef59c1 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,7 +18,8 @@ [lambda :as &&lambda] [case :as &&case] [env :as &&env] - [module :as &&module]))) + [module :as &&module] + [record :as &&record]))) (defn ^:private analyse-1+ [analyse ?token] (&type/with-var @@ -124,7 +125,7 @@ ;; (fn [$var] ;; (|do [exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-variant analyse exo-type** ident ?values)))) - + ;; _ ;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) @@ -150,26 +151,14 @@ (return ?table) _ - (fail (str "[Analyser Error] The type of a record must be a record type:\n" - (&type/show-type exo-type*) - "\n"))) + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) _ (&/assert! (= (&/|length types) (&/|length ?elems)) (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) - =slots (&/map% (fn [kv] - (|case kv - [(&/$Meta _ (&/$TagS ?ident)) ?value] - (|do [=ident (&&/resolved-ident ?ident) - :let [?tag (&/ident->text =ident)] - slot-type (if-let [slot-type (&/|get ?tag types)] - (return slot-type) - (fail (str "[Analyser Error] Record type does not have slot: " ?tag))) - =value (&&/analyse-1 analyse slot-type ?value)] - (return (&/T ?tag =value))) - - _ - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - ?elems)] - (return (&/|list (&/T (&/V &&/$record =slots) (&/V &/$RecordT exo-type)))))) + members (&&record/order-record ?elems) + =members (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + types members)] + (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -193,9 +182,9 @@ (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/get$ &/$ENVS state) - no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) - (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) + (|let [stack (&/get$ &/$envs state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -204,8 +193,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -235,21 +224,21 @@ (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get name))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state)))) + (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -311,13 +300,14 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= "<>" r-name) + ;; :let [_ (when (or (= ":" (aget real-name 1)) + ;; (= "type" (aget real-name 1)) ;; ;; (= &&/$struct r-name) ;; ) - ;; (->> (&/|map &/show-ast macro-expansion*) + ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn (str r-module ";" r-name))))] + ;; (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 68554a019..6cf25b738 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -11,23 +11,23 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return return* fail fail* |case]] + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] - [host :as &host]) - [lux.analyser.base :as &&])) + [host :as &host]))) ;; [Utils] -(def ^:private $DEFS 0) -(def ^:private $IMPORTS 1) -(def ^:private $ALIASES 2) -(def ^:private $tags 3) +(deftags "" + "module-aliases" + "defs" + "imports" + "tags") (def ^:private +init+ - (&/R ;; "lux;defs" + (&/R ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" (&/|table) ;; "lux;imports" (&/|list) - ;; "lux;module-aliases" - (&/|table) ;; "lux;tags" (&/|list) )) @@ -37,24 +37,24 @@ "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [ms] (&/|update current-module - (fn [m] (&/update$ $IMPORTS (partial &/|cons module) m)) + (fn [m] (&/update$ $imports (partial &/|cons module) m)) ms)) state) nil)))) (defn define [module name def-data type] (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T false def-data) %) m)) ms)))) @@ -66,8 +66,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] - (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -87,14 +87,14 @@ (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update a-module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) m)) ms)))) @@ -107,15 +107,15 @@ "(-> Text (Lux Bool))" (fn [state] (return* state - (->> state (&/get$ &/$MODULES) (&/|contains? name))))) + (->> state (&/get$ &/$modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update module - #(&/update$ $ALIASES + #(&/update$ $module-aliases (fn [aliases] (&/|put alias reference aliases)) %) @@ -125,7 +125,7 @@ (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/get$ &/$MODULES) (&/|get current-module) (&/get$ $ALIASES) (&/|get name))] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -133,9 +133,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -158,7 +158,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -168,11 +168,11 @@ (.getField "_datum") (.get nil))]] (fn [state*] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [$modules] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) m)) $modules)) @@ -190,18 +190,18 @@ (defn export [module name] (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/update$ &/$MODULES (fn [ms] + (&/update$ &/$modules (fn [ms] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T true ?data) %) m)) ms)))) @@ -230,30 +230,30 @@ _ (&/T ?exported? k "V"))))) - (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) + (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/update$ &/$MODULES #(&/|put name +init+ %)) - (&/set$ &/$ENVS (&/|list (&/env name)))) + (&/update$ &/$modules #(&/|put name +init+ %)) + (&/set$ &/$envs (&/|list (&/env name)))) nil))) (defn tags-by-module [module] "(-> Text (Lux (List (, Text (, Int (List Text))))))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (return* state (&/get$ $tags =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) @@ -261,9 +261,9 @@ (defn declare-tags [module tag-names] "(-> Text (List Text) (Lux (,)))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [=modules] (&/|update module #(&/set$ $tags (&/fold (fn [table idx+tag-name] @@ -280,8 +280,17 @@ (defn tag-index [module tag-name] "(-> Text Text (Lux Int))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] (return* state (aget idx+tags 0)) - (fail* (str "[Lux Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Lux Error] Unknown module: " module))))) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + +(defn tag-group [module tag-name] + "(-> Text Text (Lux (List Ident)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 1)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj new file mode 100644 index 000000000..2b4b7e095 --- /dev/null +++ b/src/lux/analyser/record.clj @@ -0,0 +1,158 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.analyser.record + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [deftags |let |do return fail |case]]) + (lux.analyser [base :as &&] + [module :as &&module]))) + +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + +;; [Exports] +(defn order-record [pairs] + "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" + (|do [tag-group (|case pairs + (&/$Nil) + (return (&/|list)) + + (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) + (|do [[module name] (&&/resolved-ident tag1)] + (&&module/tag-group module name)) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + =pairs (&/map% (fn [kv] + (|case kv + [(&/$Meta _ (&/$TagS k)) v] + (|do [=k (&&/resolved-ident k)] + (return (&/T (&/ident->text =k) v))) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + pairs)] + (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (fail (str "[Analyser Error] Unknown tag: " tag)))) + (&/|map &/ident->text tag-group)))) diff --git a/src/lux/base.clj b/src/lux/base.clj index a700a30c8..b8b7118f4 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -63,30 +63,34 @@ ;; [Fields] ;; Binding -(def $COUNTER 0) -(def $MAPPINGS 1) +(deftags "" + "counter" + "mappings") ;; Env -(def $CLOSURE 0) -(def $INNER-CLOSURES 1) -(def $LOCALS 2) -(def $NAME 3) +(deftags "" + "name" + "inner-closures" + "locals" + "closure") ;; Host -(def $CLASSES 0) -(def $LOADER 1) -(def $WRITER 2) +(deftags "" + "writer" + "loader" + "classes") ;; Compiler -(def $cursor 0) -(def $ENVS 1) -(def $EVAL? 2) -(def $EXPECTED 3) -(def $HOST 4) -(def $MODULES 5) -(def $SEED 6) -(def $SOURCE 7) -(def $TYPES 8) +(deftags "" + "source" + "cursor" + "modules" + "envs" + "types" + "expected" + "seed" + "eval?" + "host") ;; Vars (deftags "lux;" @@ -533,11 +537,11 @@ (def loader (fn [state] - (return* state (->> state (get$ $HOST) (get$ $LOADER))))) + (return* state (->> state (get$ $host) (get$ $loader))))) (def classes (fn [state] - (return* state (->> state (get$ $HOST) (get$ $CLASSES))))) + (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ (R ;; "lux;counter" @@ -546,14 +550,14 @@ (|table))) (defn env [name] - (R ;; "lux;closure" - +init-bindings+ + (R ;; "lux;name" + name ;; "lux;inner-closures" 0 ;; "lux;locals" +init-bindings+ - ;; "lux;name" - name + ;; "lux;closure" + +init-bindings+ )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String @@ -576,32 +580,32 @@ (defn host [_] (let [store (atom {})] - (R ;; "lux;classes" - store + (R ;; "lux;writer" + (V $None nil) ;; "lux;loader" (memory-class-loader store) - ;; "lux;writer" - (V $None nil)))) + ;; "lux;classes" + store))) (defn init-state [_] - (R ;; "lux;cursor" + (R ;; "lux;source" + (V $None nil) + ;; "lux;cursor" (T "" -1 -1) + ;; "lux;modules" + (|table) ;; "lux;envs" (|list) - ;; "lux;eval?" - false + ;; "lux;types" + +init-bindings+ ;; "lux;expected" (V $VariantT (|list)) - ;; "lux;host" - (host nil) - ;; "lux;modules" - (|table) ;; "lux;seed" 0 - ;; "lux;source" - (V $None nil) - ;; "lux;types" - +init-bindings+ + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) )) (defn save-module [body] @@ -609,8 +613,8 @@ (|case (body state) ($Right state* output) (return* (->> state* - (set$ $ENVS (get$ $ENVS state)) - (set$ $SOURCE (get$ $SOURCE state))) + (set$ $envs (get$ $envs state)) + (set$ $source (get$ $source state))) output) ($Left msg) @@ -618,20 +622,20 @@ (defn with-eval [body] (fn [state] - (|case (body (set$ $EVAL? true state)) + (|case (body (set$ $eval? true state)) ($Right state* output) - (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) + (return* (set$ $eval? (get$ $eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state (get$ $EVAL? state)))) + (return* state (get$ $eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] + (let [writer* (->> state (get$ $host) (get$ $writer))] (|case writer* ($Some datum) (return* state datum) @@ -641,15 +645,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head (get$ $ENVS state))] + (try (let [top (|head (get$ $envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed (get$ $SEED state)] - (return* (set$ $SEED (inc seed) state) seed)))) + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -671,19 +675,19 @@ (def get-module-name (fn [state] - (|case (|reverse (get$ $ENVS state)) + (|case (|reverse (get$ $envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state (get$ $NAME ?global))))) + (return* state (get$ $name ?global))))) (defn with-scope [name body] (fn [state] - (let [output (body (update$ $ENVS #(|cons (env name) %) state))] + (let [output (body (update$ $envs #(|cons (env name) %) state))] (|case output ($Right state* datum) - (return* (update$ $ENVS |tail state*) datum) + (return* (update$ $envs |tail state*) datum) _ output)))) @@ -693,23 +697,23 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $INNER-CLOSURES) str)))] + (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $ENVS #(|cons (update$ $INNER-CLOSURES inc (|head %)) + (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) (|tail %)) state)))))) (def get-scope-name (fn [state] - (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse)))) + (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $HOST #(set$ $WRITER (V $Some writer) %) state))] + (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) + (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) ?value) _ @@ -718,10 +722,10 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - (let [output (body (set$ $EXPECTED type state))] + (let [output (body (set$ $expected type state))] (|case output ($Right ?state ?value) - (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) + (return* (set$ $expected (get$ $expected state) ?state) ?value) _ @@ -852,7 +856,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys (get$ $MODULES state))))) + (return* state (|keys (get$ $modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -884,3 +888,9 @@ ["" name] (|do [module get-module-name] (return (T module name))) _ (return ident))) + +(defn ident= [x y] + (|let [[xmodule xname] x + [ymodule yname] y] + (and (= xmodule ymodule) + (= xname yname)))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 7622e3002..1814a97c0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -58,9 +58,6 @@ (&a/$tuple ?elems) (&&lux/compile-tuple compile-expression ?type ?elems) - (&a/$record ?elems) - (&&lux/compile-record compile-expression ?type ?elems) - (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -426,7 +423,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state)) + (&/set$ &/$source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 742ac69d8..85488553c 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index b108d463c..4d8ac2190 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -102,29 +102,6 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$RecordTestAC ?slots) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (-> (doto (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)) - (.visitInsn Opcodes/AALOAD) - (compile-match test $next $sub-else) - (.visitLabel $sub-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $next)) - (->> (|let [[idx [_ test]] idx+member - $next (new Label) - $sub-else (new Label)]) - (doseq [idx+member (->> ?slots - &/->seq - (sort compare-kv) - &/->list - &/enumerate - &/->seq)]))) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$VariantTestAC ?tag ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 9baefa21c..e2b9f0e89 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -72,27 +72,6 @@ (&/|range num-elems) ?elems)] (return nil))) -(defn compile-record [compile *type* ?elems] - (|do [^MethodVisitor *writer* &/get-writer - :let [elems* (->> ?elems - &/->seq - (sort #(compare (&/|first %1) (&/|first %2))) - &/->list) - num-elems (&/|length elems*) - _ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx kv] - (|let [[k v] kv] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile v) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret)))) - (&/|range num-elems) elems*)] - (return nil))) - (defn compile-variant [compile *type* ?tag ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 6aa8cca6d..e0195658f 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -21,7 +21,7 @@ ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/get$ &/$SOURCE state) + (|case (&/get$ &/$source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/set$ &/$SOURCE more state) + (return* (&/set$ &/$source more state) output) ($Yes output line*) - (return* (&/set$ &/$SOURCE (&/|cons line* more) state) + (return* (&/set$ &/$source (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/get$ &/$SOURCE state)) + (|case (body (&/get$ &/$source state)) (&/$Right reader* match) - (return* (&/set$ &/$SOURCE reader* state) + (return* (&/set$ &/$source reader* state) match) (&/$Left msg) diff --git a/src/lux/type.clj b/src/lux/type.clj index 94b0fbc5e..92c986985 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -209,12 +209,12 @@ (Tuple$ (&/|list (Bound$ "s") (Bound$ "a")))))))) -(def Reader +(def Source (App$ List (App$ (App$ Meta Cursor) Text))) -(def HostState +(def Host (Record$ (&/|list ;; "lux;writer" @@ -274,7 +274,9 @@ (Record$ (&/|list ;; "lux;source" - Reader + Source + ;; "lux;cursor" + Cursor ;; "lux;modules" (App$ List (Tuple$ (&/|list Text (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) @@ -284,16 +286,14 @@ (Tuple$ (&/|list LuxVar Type)))) ;; "lux;types" (App$ (App$ Bindings Int) Type) - ;; "lux;host" - HostState + ;; "lux;expected" + Type ;; "lux;seed" Int ;; "lux;eval?" Bool - ;; "lux;expected" - Type - ;; "lux;cursor" - Cursor + ;; "lux;host" + Host ))) $Void)) @@ -304,7 +304,7 @@ (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [type (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -315,7 +315,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -326,26 +326,26 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V &/$Some type) %) + (return* (&/update$ &/$types (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) ts)) state) nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length)))))) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$types) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + (let [id (->> state (&/get$ &/$types) (&/get$ &/$counter))] + (return* (&/update$ &/$types #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) state) id)))) @@ -380,11 +380,11 @@ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] + (->> state (&/get$ &/$types) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS (&/|remove id mappings*))) + (return* (&/update$ &/$types #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) state) nil))) state)))) -- cgit v1.2.3 From e60e9ef86b8653726ac8d99310640122c9242098 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 12 Aug 2015 00:15:51 -0400 Subject: - Changing tags so they're actually indices (part 4). - Bug fixes and adjustments. --- source/lux.lux | 27 ++++---------------------- src/lux/analyser/case.clj | 49 +++++++++++++++++++++++++++++++++-------------- src/lux/base.clj | 33 +++++++++++++++++++++++++++++++ src/lux/compiler/case.clj | 2 +- 4 files changed, 73 insertions(+), 38 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 04f9df811..22d49315b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -2140,14 +2140,7 @@ _ ($ text:++ "(| " (|> cases - (map (: (-> (, Text Type) Text) - (lambda [kv] - (case kv - [k (#TupleT #;Nil)] - ($ text:++ "#" k) - - [k v] - ($ text:++ "(#" k " " (type:show v) ")"))))) + (map type:show) (interpose " ") (foldL text:++ "")) ")")) @@ -2160,11 +2153,7 @@ _ ($ text:++ "(& " (|> fields - (map (: (-> (, Text Type) Text) - (: (-> (, Text Type) Text) - (lambda [kv] - (let [[k v] kv] - ($ text:++ "(#" k " " (type:show v) ")")))))) + (map type:show) (interpose " ") (foldL text:++ "")) ")")) @@ -2192,18 +2181,10 @@ (-> (List (, Text Type)) Type Type) (case type (#VariantT ?cases) - (#VariantT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?cases)) + (#VariantT (map (beta-reduce env) ?cases)) (#RecordT ?fields) - (#RecordT (map (: (-> (, Text Type) (, Text Type)) - (lambda [kv] - (let [[k v] kv] - [k (beta-reduce env v)]))) - ?fields)) + (#RecordT (map (beta-reduce env) ?fields)) (#TupleT ?members) (#TupleT (map (beta-reduce env) ?members)) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 34cbf8b48..148e2822a 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -223,13 +223,14 @@ value-type* (adjust-type value-type) ;; :let [_ (println "#02")] idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) ;; :let [_ (println "#03")] case-type (&type/variant-case idx value-type*) ;; :let [_ (println "#04")] [=test =kont] (analyse-pattern case-type unit kont) ;; :let [_ (println "#05")] ] - (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) @@ -239,6 +240,7 @@ value-type* (adjust-type value-type) ;; :let [_ (println "#12" (&type/show-type value-type*))] idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) ;; :let [_ (println "#13")] case-type (&type/variant-case idx value-type*) ;; :let [_ (println "#14" (&type/show-type case-type))] @@ -249,7 +251,7 @@ (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) ;; :let [_ (println "#15")] ] - (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] @@ -311,21 +313,40 @@ (return (&/V $TupleTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [($DefaultTotal total?) ($VariantTestAC ?tag ?test)] + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (&/V $DefaultTotal total?) - (&/T ?test ?body))] - (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct (&/|table)))))) - - [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?test)] - (|do [sub-struct (merge-total (or (&/|get ?tag ?branches) - (&/V $DefaultTotal total?)) - (&/T ?test ?body))] - (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct ?branches))))) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return (&/V $VariantTotal (&/T total? structs)))) + + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) + (&/$Some sub) + sub + + (&/$None) + (&/V $DefaultTotal total?)) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct ?branches) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return (&/V $VariantTotal (&/T total? structs)))) )))) (defn ^:private check-totality [value-type struct] ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct + ($DefaultTotal ?total) + (return ?total) + ($BoolTotal ?total ?values) (return (or ?total (= #{true false} (set (&/->seq ?values))))) @@ -369,6 +390,9 @@ (|case value-type* (&/$VariantT ?members) (|do [totals (&/map2% (fn [sub-struct ?member] + ;; (prn '$VariantTotal + ;; (&/adt->text sub-struct) + ;; (&type/show-type ?member)) (check-totality ?member sub-struct)) ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) @@ -376,9 +400,6 @@ _ (fail "[Pattern-maching Error] Variant is not total.")))) - ($DefaultTotal ?total) - (return ?total) - ;; _ ;; (assert false (prn-str 'check-totality (&type/show-type value-type) ;; (&/adt->text struct))) diff --git a/src/lux/base.clj b/src/lux/base.clj index b8b7118f4..89620ce97 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -116,6 +116,13 @@ (defn R [& kvs] (to-array kvs)) +;; Constructors +(def None$ (V $None nil)) +(defn Some$ [x] (V $Some x)) + +(def Nil$ (V $Nil nil)) +(defn Cons$ [h t] (V $Cons (T h t))) + (defn get$ [slot ^objects record] (aget record slot)) @@ -894,3 +901,29 @@ [ymodule yname] y] (and (= xmodule ymodule) (= xname yname)))) + +;; (defn |list-put [idx val xs] +;; (|case [idx xs] +;; [_ ($Nil)] +;; (V $None nil) + +;; [0 ($Cons x xs*)] +;; (V $Some (V $Cons (T val xs*))) + +;; [_ ($Cons x xs*)] +;; (|case (|list-put idx val xs*) +;; ($None) (V $None nil) +;; ($Some xs**) (V $Some (V $Cons (T x xs**)))))) + +(defn |list-put [idx val xs] + (|case xs + ($Nil) + (V $None nil) + + ($Cons x xs*) + (if (= idx 0) + (V $Some (V $Cons (T val xs*))) + (|case (|list-put (dec idx) val xs*) + ($None) (V $None nil) + ($Some xs**) (V $Some (V $Cons (T x xs**)))) + ))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 4d8ac2190..dd3258059 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -102,7 +102,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$VariantTestAC ?tag ?test) + (&a-case/$VariantTestAC ?tag ?count ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) -- cgit v1.2.3 From 9ccdc7b5b59c2f0ffea49fc32d7b37eb2308bb9c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Aug 2015 12:48:18 -0400 Subject: - Some clean-up of needless code. - some adjustments to the new format for types. --- source/lux.lux | 276 ++++++++++++++++++++++----------------------------------- 1 file changed, 105 insertions(+), 171 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 22d49315b..824113b92 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1462,50 +1462,6 @@ _ (return ident))) -(defmacro #export (| tokens) - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> AST ($' Lux AST)) - (lambda' [token] - (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux/Monad - [ident (normalize ident)] - (wrap (`' [(~ (text$ (ident->text ident))) (;,)]))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) - (do Lux/Monad - [ident (normalize ident) - #let [case-body (_lux_: AST - (_lux_case values - #Nil (`' Unit) - (#Cons value #Nil) value - _ (`' (, (~@ values)))))]] - (wrap (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) - - _ - (fail "Wrong syntax for |")))) - tokens)] - (wrap (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) - -(defmacro #export (& tokens) - (if (not (multiple? 2 (length tokens))) - (fail "& expects an even number of arguments.") - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> (, AST AST) ($' Lux AST)) - (lambda' [pair] - (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux/Monad - [ident (normalize ident)] - (wrap (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) - (as-pairs tokens))] - (wrap (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) - (def''' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) @@ -1626,6 +1582,59 @@ #Nil true _ false)) +(do-template [ ] + [(def''' ( xy) + (All [a b] (-> (, a b) )) + (let' [[x y] xy] ))] + + [first a x] + [second b y]) + +(def''' (unfold-type-def type) + (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) + (_lux_case type + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "|")) cases))) + (do Lux/Monad + [members (map% Lux/Monad + (: (-> AST ($' Lux (, Text AST))) + (lambda' [case] + (_lux_case case + (#Meta _ (#TagS "" member-name)) + (return [member-name (`' Unit)]) + + (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "" member-name)) (#Cons member-type #Nil)))) + (return [member-name member-type]) + + _ + (fail "Wrong syntax for variant case.")))) + cases)] + (return [(`' (#VariantT (~ (untemplate-list (map second members))))) + (#Some (|> members + (map first) + (map (: (-> Text AST) + (lambda' [name] (tag$ ["" name]))))))])) + + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "&")) pairs))) + (do Lux/Monad + [members (map% Lux/Monad + (: (-> (, AST AST) ($' Lux (, Text AST))) + (lambda' [pair] + (_lux_case pair + [(#Meta _ (#TagS "" member-name)) member-type] + (return [member-name member-type]) + + _ + (fail "Wrong syntax for variant case.")))) + (as-pairs pairs))] + (return [(`' (#RecordT (~ (untemplate-list (map second members))))) + (#Some (|> members + (map first) + (map (: (-> Text AST) + (lambda' [name] (tag$ ["" name]))))))])) + + _ + (return [type #None]))) + (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens @@ -1653,73 +1662,46 @@ #None))] (_lux_case parts (#Some name args type) - (let' [with-export (: (List AST) - (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) - #Nil)) - type' (: (Maybe AST) - (if rec? - (if (empty? args) - (let' [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] - (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) - ;Void)))) - #None) - (_lux_case args - #Nil - (#Some type) - - _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) - with-export)) - - #None - (fail "Wrong syntax for deftype"))) + (do Lux/Monad + [type+tags?? (unfold-type-def type)] + (let' [[type tags??] type+tags?? + with-export (: (List AST) + (if export? + (list (`' (_lux_export (~ (symbol$ ["" name]))))) + #Nil)) + with-tags (: (List AST) + (_lux_case tags?? + (#Some tags) + (list (`' (_lux_declare-tags [(~@ tags)]))) + + _ + (list))) + type' (: (Maybe AST) + (if rec? + (if (empty? args) + (let' [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] + (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) + ;Void)))) + #None) + (_lux_case args + #Nil + (#Some type) + + _ + (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + (list:++ with-export with-tags))) + + #None + (fail "Wrong syntax for deftype")))) #None (fail "Wrong syntax for deftype")) )) -## (defmacro #export (deftype tokens) -## (let' [[export? tokens'] (: (, Bool (List AST)) -## (_lux_case (:! (List AST) tokens) -## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) -## [true (:! (List AST) tokens')] - -## _ -## [false (:! (List AST) tokens)])) -## parts (: (Maybe (, AST (List AST) AST)) -## (_lux_case tokens' -## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) #Nil type]) - -## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) -## (#Some (symbol$ name) args type) - -## _ -## #None))] -## (_lux_case parts -## (#Some name args type]) -## (let' [with-export (: (List AST) -## (if export? -## (list (`' (_lux_export (~ name)))) -## #Nil)) -## type' (: AST -## (_lux_case args -## #Nil -## type - -## _ -## (`' (;All (~ name) [(~@ args)] (~ type)))))] -## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) -## with-export))) - -## #None -## (fail "Wrong syntax for deftype")) -## )) (defmacro #export (exec tokens) (_lux_case (reverse tokens) @@ -1920,8 +1902,8 @@ (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) (#Some ["" ""] head tail body) - (\ (list (#Meta _ (#SymbolS ident)) (#Meta _ (#TupleS (#Cons head tail))) body)) - (#Some ident head tail body) + (\ (list (#Meta _ (#SymbolS [_ name])) (#Meta _ (#TupleS (#Cons head tail))) body)) + (#Some ["" name] head tail body) _ #None)) @@ -2260,35 +2242,19 @@ (defmacro #export (struct tokens) (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - struct-type expected-type] - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (do Lux/Monad - [#let [translations (map (: (-> (, Text Type) (, Text Ident)) - (lambda [[sname _]] - (let [[module name] (split-slot sname)] - [name [module name]]))) - slots)] - members (map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [token] - (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS ["" name])) value)))) - (case (get name translations) - (#Some tag-name) - (wrap (: (, AST AST) [(tag$ tag-name) value])) - - _ - (fail "Structures require defined members")) + [tokens' (map% Lux/Monad macro-expand tokens)] + (do Lux/Monad + [members (map% Lux/Monad + (: (-> AST (Lux (, AST AST))) + (lambda [token] + (case token + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS tag-name)) value)))) + (wrap (: (, AST AST) [(tag$ tag-name) value])) - _ - (fail "Structures members must be unqualified.")))) - (list:join tokens'))] - (wrap (list (record$ members)))) - - _ - (fail "struct can only use records.")))) + _ + (fail "Structures members must be unqualified.")))) + (list:join tokens'))] + (wrap (list (record$ members)))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) @@ -2721,24 +2687,6 @@ (#ValueD [type _]) (#Some type) (#MacroD m) (#Some Macro) (#AliasD name') (find-in-defs name' state)))))) -## (def (find-in-defs name state) -## (-> Ident Compiler (Maybe Type)) -## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] -## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")]) -## (let [[v-prefix v-name] name -## {#source source #modules modules -## #envs envs #types types #host host -## #seed seed #eval? eval? #expected expected} state] -## (do Maybe/Monad -## [module (get v-prefix modules) -## #let [{#defs defs #module-aliases _ #imports _ #tags tags} module] -## def (get v-name defs) -## #let [[_ def-data] def]] -## (case def-data -## #TypeD (wrap Type) -## (#ValueD type) (wrap type) -## (#MacroD m) (wrap Macro) -## (#AliasD name') (find-in-defs name' state)))))) (def (find-var-type ident) (-> Ident (Lux Type)) @@ -3065,14 +3013,6 @@ _ (fail "Wrong syntax for \\template"))) -(do-template [ ] - [(def ( [x y]) - (All [a b] (-> (, a b) )) - )] - - [first a x] - [second b y]) - (def (interleave xs ys) (All [a] (-> (List a) (List a) (List a))) (case xs @@ -3105,16 +3045,10 @@ (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) (#VariantT cases) - (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) AST) - (lambda [[label type]] - (tuple$ (list (text$ label) (type->syntax type))))) - cases))))) + (` (#VariantT (~ (untemplate-list (map type->syntax cases))))) (#RecordT fields) - (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) AST) - (lambda [[label type]] - (tuple$ (list (text$ label) (type->syntax type))))) - fields))))) + (` (#RecordT (~ (untemplate-list (map type->syntax fields))))) (#LambdaT in out) (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) -- cgit v1.2.3 From 3d18954a2307b48c955f5bdd3790a92ffeb7284c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Aug 2015 13:28:07 -0400 Subject: Unified tuples & records. --- source/lux.lux | 331 ++++++++++++++++++++------------------------ src/lux/analyser/case.clj | 27 +--- src/lux/analyser/lux.clj | 2 +- src/lux/analyser/module.clj | 2 +- src/lux/base.clj | 14 +- src/lux/compiler/type.clj | 7 - src/lux/type.clj | 57 ++------ 7 files changed, 174 insertions(+), 266 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 824113b92..4c4b02f8a 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -10,7 +10,7 @@ (_jvm_interface "Function" [] ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) -(_lux_declare-tags [#DataT #TupleT #VariantT #RecordT #LambdaT #BoundT #VarT #ExT #AllT #AppT]) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT]) (_lux_declare-tags [#None #Some]) (_lux_declare-tags [#Nil #Cons]) @@ -67,9 +67,8 @@ ## (deftype #rec Type ## (| (#DataT Text) -## (#TupleT (List Type)) ## (#VariantT (List Type)) -## (#RecordT (List Type)) +## (#TupleT (List Type)) ## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) @@ -85,25 +84,23 @@ (#AppT (#AllT (#Some #Nil) "Type" "_" (#VariantT (#Cons ## "lux;DataT" Text - (#Cons ## "lux;TupleT" + (#Cons ## "lux;VariantT" TypeList - (#Cons ## "lux;VariantT" + (#Cons ## "lux;TupleT" TypeList - (#Cons ## "lux;RecordT" - TypeList - (#Cons ## "lux;LambdaT" - (#TupleT (#Cons Type (#Cons Type #Nil))) - (#Cons ## "lux;BoundT" - Text - (#Cons ## "lux;VarT" + (#Cons ## "lux;LambdaT" + (#TupleT (#Cons Type (#Cons Type #Nil))) + (#Cons ## "lux;BoundT" + Text + (#Cons ## "lux;VarT" + Int + (#Cons ## "lux;ExT" Int - (#Cons ## "lux;ExT" - Int - (#Cons ## "lux;AllT" - (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil))))) - (#Cons ## "lux;AppT" - (#TupleT (#Cons Type (#Cons Type #Nil))) - #Nil)))))))))))) + (#Cons ## "lux;AllT" + (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil))))) + (#Cons ## "lux;AppT" + (#TupleT (#Cons Type (#Cons Type #Nil))) + #Nil))))))))))) Void))))) (_lux_export Type) @@ -113,14 +110,14 @@ (_lux_def Bindings (#AllT [(#Some #Nil) "lux;Bindings" "k" (#AllT [#None "" "v" - (#RecordT (#Cons ## "lux;counter" - Int - (#Cons ## "lux;mappings" - (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))]) - #Nil)))])])) + (#TupleT (#Cons ## "lux;counter" + Int + (#Cons ## "lux;mappings" + (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))]) + #Nil)))])])) (_lux_export Bindings) (_lux_declare-tags [#counter #mappings]) @@ -130,38 +127,38 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (_lux_def Env - (#AllT [(#Some #Nil) "lux;Env" "k" - (#AllT [#None "" "v" - (#RecordT (#Cons [## "lux;name" - Text - (#Cons [## "lux;inner-closures" - Int - (#Cons [## "lux;locals" - (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")]) - (#Cons [## "lux;closure" - (#AppT [(#AppT [Bindings (#BoundT "k")]) - (#BoundT "v")]) - #Nil])])])]))])])) + (#AllT (#Some #Nil) "lux;Env" "k" + (#AllT #None "" "v" + (#TupleT (#Cons ## "lux;name" + Text + (#Cons ## "lux;inner-closures" + Int + (#Cons ## "lux;locals" + (#AppT (#AppT Bindings (#BoundT "k")) + (#BoundT "v")) + (#Cons ## "lux;closure" + (#AppT (#AppT Bindings (#BoundT "k")) + (#BoundT "v")) + #Nil)))))))) (_lux_export Env) (_lux_declare-tags [#name #inner-closures #locals #closure]) ## (deftype Cursor ## (, Text Int Int)) (_lux_def Cursor - (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) + (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil))))) (_lux_export Cursor) ## (deftype (Meta m v) ## (| (#Meta m v))) (_lux_def Meta - (#AllT [(#Some #Nil) "lux;Meta" "m" - (#AllT [#None "" "v" - (#VariantT (#Cons [## "lux;Meta" - (#TupleT (#Cons [(#BoundT "m") - (#Cons [(#BoundT "v") - #Nil])])) - #Nil]))])])) + (#AllT (#Some #Nil) "lux;Meta" "m" + (#AllT #None "" "v" + (#VariantT (#Cons ## "lux;Meta" + (#TupleT (#Cons (#BoundT "m") + (#Cons (#BoundT "v") + #Nil))) + #Nil))))) (_lux_export Meta) (_lux_declare-tags [#Meta]) @@ -177,60 +174,60 @@ ## (#TupleS (List (w (AST' w)))) ## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) (_lux_def AST' - (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "lux;AST'") - (#BoundT "w")])]) + (_lux_case (#AppT (#BoundT "w") + (#AppT (#BoundT "lux;AST'") + (#BoundT "w"))) AST (_lux_case (#AppT [List AST]) ASTList - (#AllT [(#Some #Nil) "lux;AST'" "w" - (#VariantT (#Cons [## "lux;BoolS" - Bool - (#Cons [## "lux;IntS" - Int - (#Cons [## "lux;RealS" - Real - (#Cons [## "lux;CharS" - Char - (#Cons [## "lux;TextS" - Text - (#Cons [## "lux;SymbolS" - Ident - (#Cons [## "lux;TagS" - Ident - (#Cons [## "lux;FormS" - ASTList - (#Cons [## "lux;TupleS" - ASTList - (#Cons [## "lux;RecordS" - (#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))]) - #Nil]) - ])])])])])])])])]) - )])))) + (#AllT (#Some #Nil) "lux;AST'" "w" + (#VariantT (#Cons ## "lux;BoolS" + Bool + (#Cons ## "lux;IntS" + Int + (#Cons ## "lux;RealS" + Real + (#Cons ## "lux;CharS" + Char + (#Cons ## "lux;TextS" + Text + (#Cons ## "lux;SymbolS" + Ident + (#Cons ## "lux;TagS" + Ident + (#Cons ## "lux;FormS" + ASTList + (#Cons ## "lux;TupleS" + ASTList + (#Cons ## "lux;RecordS" + (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) + #Nil) + ))))))))) + ))))) (_lux_export AST') (_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS]) ## (deftype AST ## (Meta Cursor (AST' (Meta Cursor)))) (_lux_def AST - (_lux_case (#AppT [Meta Cursor]) + (_lux_case (#AppT Meta Cursor) w - (#AppT [w (#AppT [AST' w])]))) + (#AppT w (#AppT AST' w)))) (_lux_export AST) -(_lux_def ASTList (#AppT [List AST])) +(_lux_def ASTList (#AppT List AST)) ## (deftype (Either l r) ## (| (#Left l) ## (#Right r))) (_lux_def Either - (#AllT [(#Some #Nil) "lux;Either" "l" - (#AllT [#None "" "r" - (#VariantT (#Cons [## "lux;Left" - (#BoundT "l") - (#Cons [## "lux;Right" - (#BoundT "r") - #Nil])]))])])) + (#AllT (#Some #Nil) "lux;Either" "l" + (#AllT #None "" "r" + (#VariantT (#Cons ## "lux;Left" + (#BoundT "l") + (#Cons ## "lux;Right" + (#BoundT "r") + #Nil)))))) (_lux_export Either) (_lux_declare-tags [#Left #Right]) @@ -258,13 +255,13 @@ ## #loader (^ java.net.URLClassLoader) ## #classes (^ clojure.lang.Atom))) (_lux_def Host - (#RecordT (#Cons [## "lux;writer" - (#DataT "org.objectweb.asm.ClassWriter") - (#Cons [## "lux;loader" - (#DataT "java.lang.ClassLoader") - (#Cons [## "lux;classes" - (#DataT "clojure.lang.Atom") - #Nil])])]))) + (#TupleT (#Cons [## "lux;writer" + (#DataT "org.objectweb.asm.ClassWriter") + (#Cons [## "lux;loader" + (#DataT "java.lang.ClassLoader") + (#Cons [## "lux;classes" + (#DataT "clojure.lang.Atom") + #Nil])])]))) (_lux_declare-tags [#writer #loader #classes]) ## (deftype (DefData' m) @@ -308,25 +305,25 @@ ## )) (_lux_def Module (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#RecordT (#Cons [## "lux;module-aliases" - (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) - (#Cons [## "lux;defs" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - ASTList])])]) - #Nil])])) - #Nil])]))]) - (#Cons [## "lux;imports" - (#AppT [List Text]) - (#Cons [## "lux;tags" - (#AppT [List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons Int - (#Cons (#AppT [List Ident]) - #Nil))) - #Nil)))]) - #Nil])])])]))])) + (#TupleT (#Cons [## "lux;module-aliases" + (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) + (#Cons [## "lux;defs" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + ASTList])])]) + #Nil])])) + #Nil])]))]) + (#Cons [## "lux;imports" + (#AppT [List Text]) + (#Cons [## "lux;tags" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Int + (#Cons (#AppT [List Ident]) + #Nil))) + #Nil)))]) + #Nil])])])]))])) (_lux_export Module) (_lux_declare-tags [#module-aliases #defs #imports #tags]) @@ -343,28 +340,28 @@ ## )) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#RecordT (#Cons [## "lux;source" - Source - (#Cons [## "lux;cursor" - Cursor - (#Cons [## "lux;modules" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))]) - (#Cons [## "lux;envs" - (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) - (#Cons [## "lux;types" - (#AppT [(#AppT [Bindings Int]) Type]) - (#Cons [## "lux;expected" - Type - (#Cons [## "lux;seed" - Int - (#Cons [## "lux;eval?" - Bool - (#Cons [## "lux;host" - Host - #Nil])])])])])])])])]))]) + (#TupleT (#Cons [## "lux;source" + Source + (#Cons [## "lux;cursor" + Cursor + (#Cons [## "lux;modules" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))]) + (#Cons [## "lux;envs" + (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) + (#Cons [## "lux;types" + (#AppT [(#AppT [Bindings Int]) Type]) + (#Cons [## "lux;expected" + Type + (#Cons [## "lux;seed" + Int + (#Cons [## "lux;eval?" + Bool + (#Cons [## "lux;host" + Host + #Nil])])])])])])])])]))]) Void])) (_lux_export Compiler) (_lux_declare-tags [#source #cursor #modules #envs #types #expected #seed #eval? #host]) @@ -1023,10 +1020,10 @@ (def''' Monad Type (All' [m] - (#RecordT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) - (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b)))))))) + (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b)))))))) (_lux_declare-tags [#return #bind]) (def''' Maybe/Monad @@ -1626,7 +1623,7 @@ _ (fail "Wrong syntax for variant case.")))) (as-pairs pairs))] - (return [(`' (#RecordT (~ (untemplate-list (map second members))))) + (return [(`' (#TupleT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) @@ -2106,39 +2103,21 @@ (#DataT name) ($ text:++ "(^ " name ")") - (#TupleT elems) - (case elems + (#TupleT members) + (case members #;Nil "(,)" _ - ($ text:++ "(, " (|> elems (map type:show) (interpose " ") (foldL text:++ "")) ")")) + ($ text:++ "(, " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) - (#VariantT cases) - (case cases + (#VariantT members) + (case members #;Nil "(|)" _ - ($ text:++ "(| " - (|> cases - (map type:show) - (interpose " ") - (foldL text:++ "")) - ")")) - - (#RecordT fields) - (case fields - #;Nil - "(&)" - - _ - ($ text:++ "(& " - (|> fields - (map type:show) - (interpose " ") - (foldL text:++ "")) - ")")) + ($ text:++ "(| " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) (#LambdaT input output) ($ text:++ "(-> " (type:show input) " " (type:show output) ")") @@ -2165,9 +2144,6 @@ (#VariantT ?cases) (#VariantT (map (beta-reduce env) ?cases)) - (#RecordT ?fields) - (#RecordT (map (beta-reduce env) ?fields)) - (#TupleT ?members) (#TupleT (map (beta-reduce env) ?members)) @@ -2219,7 +2195,7 @@ (def (resolve-struct-type type) (-> Type (Maybe Type)) (case type - (#RecordT slots) + (#TupleT slots) (#Some type) (#AppT fun arg) @@ -2727,7 +2703,7 @@ (let [[module name] (split-slot field-name) pattern (: AST (case (resolve-struct-type type) - (#Some (#RecordT slots)) + (#Some (#TupleT slots)) (record$ (map (: (-> (, Text Type) (, AST AST)) (lambda [[sname stype]] (use-field sname stype))) slots)) @@ -2744,7 +2720,7 @@ (do Lux/Monad [struct-type (find-var-type name)] (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) + (#Some (#TupleT slots)) (let [pattern (record$ (map (: (-> (, Text Type) (, AST AST)) (lambda [[sname stype]] (use-field sname stype))) slots))] @@ -2794,7 +2770,7 @@ g!blank (gensym "") g!output (gensym "")] (case (resolve-struct-type type) - (#Some (#RecordT slots)) + (#Some (#TupleT slots)) (do Lux/Monad [slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) @@ -2826,7 +2802,7 @@ (let [[module name] (split-slot field-name) source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))] (case (resolve-struct-type type) - (#Some (#RecordT slots)) + (#Some (#TupleT slots)) (list:join (map (: (-> (, Text Type) (List AST)) (lambda [[sname stype]] (open-field prefix sname source+ stype))) slots)) @@ -2847,7 +2823,7 @@ struct-type (find-var-type struct-name) #let [source (symbol$ struct-name)]] (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) + (#Some (#TupleT slots)) (return (list:join (map (: (-> (, Text Type) (List AST)) (lambda [[sname stype]] (open-field prefix sname source stype))) slots))) @@ -2902,7 +2878,7 @@ (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) - (#Some (#RecordT slots)) + (#Some (#TupleT slots)) (do Lux/Monad [pattern' (map% Lux/Monad (: (-> (, Text Type) (Lux (, Text AST))) @@ -2950,7 +2926,7 @@ (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) - (#Some (#RecordT slots)) + (#Some (#TupleT slots)) (do Lux/Monad [pattern' (map% Lux/Monad (: (-> (, Text Type) (Lux (, Text AST))) @@ -3041,14 +3017,11 @@ (#DataT name) (` (#DataT (~ (text$ name)))) - (#TupleT parts) - (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) - (#VariantT cases) (` (#VariantT (~ (untemplate-list (map type->syntax cases))))) - - (#RecordT fields) - (` (#RecordT (~ (untemplate-list (map type->syntax fields))))) + + (#TupleT parts) + (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) (#LambdaT in out) (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 148e2822a..395ae6976 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -89,21 +89,6 @@ up)) ?members*)))) - (&/$RecordT ?members) - (|do [(&/$RecordT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V &/$RecordT (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - (&/$VariantT ?members) (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] @@ -128,8 +113,8 @@ (fail "##9##")))] (adjust-type* up type*)) - ;; [_] - ;; (assert false (aget type 0)) + _ + (assert false (prn 'adjust-type* (&type/show-type type))) )) (defn adjust-type [type] @@ -201,7 +186,7 @@ ;; value-type* (resolve-type value-type) ] (|case value-type* - (&/$RecordT ?member-types) + (&/$TupleT ?member-types) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) (|do [[=tests =kont] (&/fold (fn [kont* vm] @@ -374,12 +359,6 @@ ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) - (&/$RecordT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) - _ (fail "[Pattern-maching Error] Tuple is not total.")))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 449ef59c1..79b804088 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -147,7 +147,7 @@ _ (&type/actual-type exo-type)) types (|case exo-type* - (&/$RecordT ?table) + (&/$TupleT ?table) (return ?table) _ diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 6cf25b738..08ad0b9a5 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -22,7 +22,7 @@ "imports" "tags") (def ^:private +init+ - (&/R ;; "lux;module-aliases" + (&/T ;; "lux;module-aliases" (&/|table) ;; "lux;defs" (&/|table) diff --git a/src/lux/base.clj b/src/lux/base.clj index 89620ce97..e39f76409 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -51,9 +51,8 @@ ;; Type (deftags "" "DataT" - "TupleT" "VariantT" - "RecordT" + "TupleT" "LambdaT" "BoundT" "VarT" @@ -113,9 +112,6 @@ (defn V [^Long tag value] (to-array [tag value])) -(defn R [& kvs] - (to-array kvs)) - ;; Constructors (def None$ (V $None nil)) (defn Some$ [x] (V $Some x)) @@ -551,13 +547,13 @@ (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ - (R ;; "lux;counter" + (T ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - (R ;; "lux;name" + (T ;; "lux;name" name ;; "lux;inner-closures" 0 @@ -587,7 +583,7 @@ (defn host [_] (let [store (atom {})] - (R ;; "lux;writer" + (T ;; "lux;writer" (V $None nil) ;; "lux;loader" (memory-class-loader store) @@ -595,7 +591,7 @@ store))) (defn init-state [_] - (R ;; "lux;source" + (T ;; "lux;source" (V $None nil) ;; "lux;cursor" (T "" -1 -1) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 3d2ef5070..a7c5176ad 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -58,13 +58,6 @@ $Nil (&/|reverse ?members))) - (&/$RecordT ?members) - (variant$ &/$RecordT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) - (&/$LambdaT ?input ?output) (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 92c986985..2516fbc1d 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -55,10 +55,6 @@ ;; (assert (|list? members)) (&/V &/$VariantT members)) -(defn Record$ [members] - ;; (assert (|list? members)) - (&/V &/$RecordT members)) - (defn All$ [env name arg body] (&/V &/$AllT (&/T env name arg body))) @@ -95,11 +91,9 @@ (Variant$ (&/|list ;; DataT Text - ;; TupleT - (App$ List Type) ;; VariantT TypeList - ;; RecordT + ;; TupleT TypeList ;; LambdaT TypePair @@ -119,20 +113,20 @@ (def Bindings (All$ empty-env "lux;Bindings" "k" (All$ no-env "" "v" - (Record$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v"))))))))) + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v"))))))))) (def Env (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" (All$ no-env "" "v" - (Record$ + (Tuple$ (&/|list ;; "lux;name" Text @@ -215,7 +209,7 @@ Text))) (def Host - (Record$ + (Tuple$ (&/|list ;; "lux;writer" (Data$ "org.objectweb.asm.ClassWriter") @@ -246,7 +240,7 @@ (def $Module (All$ empty-env "lux;$Module" "Compiler" - (Record$ + (Tuple$ (&/|list ;; "lux;module-aliases" (App$ List (Tuple$ (&/|list Text Text))) @@ -271,7 +265,7 @@ (def $Compiler (App$ (All$ empty-env "lux;Compiler" "" - (Record$ + (Tuple$ (&/|list ;; "lux;source" Source @@ -426,10 +420,6 @@ (|do [=members (&/map% (partial clean* ?tid) ?members)] (return (Variant$ =members))) - (&/$RecordT ?members) - (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (Record$ =members))) - (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env (&/$None) @@ -492,13 +482,6 @@ (&/|interpose " ") (&/fold str "")) ")")) - - (&/$RecordT fields) - (str "(& " (->> fields - (&/|map show-type) - (&/|interpose " ") - (&/fold str "")) ")") - (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) @@ -548,11 +531,6 @@ true xcases ycases) - [(&/$RecordT xslots) (&/$RecordT yslots)] - (&/fold2 (fn [old x y] (and old (type= x y))) - true - xslots yslots) - [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) @@ -619,9 +597,6 @@ (&/$VariantT ?members) (Variant$ (&/|map (partial beta-reduce env) ?members)) - (&/$RecordT ?members) - (Record$ (&/|map (partial beta-reduce env) ?members)) - (&/$TupleT ?members) (Tuple$ (&/|map (partial beta-reduce env) ?members)) @@ -890,14 +865,6 @@ e!cases a!cases)] (return (&/T fixpoints* nil))) - [(&/$RecordT e!slots) (&/$RecordT a!slots)] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] - (return fp*))) - fixpoints - e!slots a!slots)] - (return (&/T fixpoints* nil))) - [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) -- cgit v1.2.3 From df3e4ba2df6462812174e69ea5c334a7edbbd5c7 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Aug 2015 15:37:46 -0400 Subject: Introduced named types (#NamedT Ident Type). --- source/lux.lux | 429 +++++++++++++++++++++++++--------------------- src/lux/analyser.clj | 2 +- src/lux/analyser/case.clj | 7 +- src/lux/analyser/lux.clj | 14 +- src/lux/base.clj | 25 +-- src/lux/type.clj | 389 ++++++++++++++++++++++------------------- 6 files changed, 474 insertions(+), 392 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 4c4b02f8a..b6d71e893 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -10,59 +10,69 @@ (_jvm_interface "Function" [] ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) -(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT]) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT]) (_lux_declare-tags [#None #Some]) (_lux_declare-tags [#Nil #Cons]) ## Basic types -(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_def Bool (#NamedT ["lux" "Bool"] + (#DataT "java.lang.Boolean"))) (_lux_export Bool) -(_lux_def Int (#DataT "java.lang.Long")) +(_lux_def Int (#NamedT ["lux" "Int"] + (#DataT "java.lang.Long"))) (_lux_export Int) -(_lux_def Real (#DataT "java.lang.Double")) +(_lux_def Real (#NamedT ["lux" "Real"] + (#DataT "java.lang.Double"))) (_lux_export Real) -(_lux_def Char (#DataT "java.lang.Character")) +(_lux_def Char (#NamedT ["lux" "Char"] + (#DataT "java.lang.Character"))) (_lux_export Char) -(_lux_def Text (#DataT "java.lang.String")) +(_lux_def Text (#NamedT ["lux" "Text"] + (#DataT "java.lang.String"))) (_lux_export Text) -(_lux_def Unit (#TupleT #Nil)) +(_lux_def Unit (#NamedT ["lux" "Unit"] + (#TupleT #Nil))) (_lux_export Unit) -(_lux_def Void (#VariantT #Nil)) +(_lux_def Void (#NamedT ["lux" "Void"] + (#VariantT #Nil))) (_lux_export Void) -(_lux_def Ident (#TupleT (#Cons Text (#Cons Text #Nil)))) +(_lux_def Ident (#NamedT ["lux" "Ident"] + (#TupleT (#Cons Text (#Cons Text #Nil))))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons a (List a)))) (_lux_def List - (#AllT (#Some #Nil) "lux;List" "a" - (#VariantT (#Cons ## "lux;Nil" - (#TupleT #Nil) - (#Cons ## "lux;Cons" - (#TupleT (#Cons (#BoundT "a") - (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a")) - #Nil))) - #Nil))))) + (#NamedT ["lux" "List"] + (#AllT (#Some #Nil) "lux;List" "a" + (#VariantT (#Cons ## "lux;Nil" + (#TupleT #Nil) + (#Cons ## "lux;Cons" + (#TupleT (#Cons (#BoundT "a") + (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a")) + #Nil))) + #Nil)))))) (_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT (#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons ## "lux;None" - (#TupleT #Nil) - (#Cons ## "lux;Some" - (#BoundT "a") - #Nil))))) + (#NamedT ["lux" "Maybe"] + (#AllT (#Some #Nil) "lux;Maybe" "a" + (#VariantT (#Cons ## "lux;None" + (#TupleT #Nil) + (#Cons ## "lux;Some" + (#BoundT "a") + #Nil)))))) (_lux_export Maybe) ## (deftype #rec Type @@ -73,51 +83,57 @@ ## (#BoundT Text) ## (#VarT Int) ## (#AllT (Maybe (List (, Text Type))) Text Text Type) -## (#AppT Type Type))) +## (#AppT Type Type) +## (#NamedT Ident Type) +## )) (_lux_def Type - (_lux_case (#AppT (#BoundT "Type") (#BoundT "_")) - Type - (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil)))) - TypeEnv - (_lux_case (#AppT List Type) - TypeList - (#AppT (#AllT (#Some #Nil) "Type" "_" - (#VariantT (#Cons ## "lux;DataT" - Text - (#Cons ## "lux;VariantT" - TypeList - (#Cons ## "lux;TupleT" - TypeList - (#Cons ## "lux;LambdaT" - (#TupleT (#Cons Type (#Cons Type #Nil))) - (#Cons ## "lux;BoundT" - Text - (#Cons ## "lux;VarT" - Int - (#Cons ## "lux;ExT" - Int - (#Cons ## "lux;AllT" - (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil))))) - (#Cons ## "lux;AppT" - (#TupleT (#Cons Type (#Cons Type #Nil))) - #Nil))))))))))) - Void))))) + (#NamedT ["lux" "Type"] + (_lux_case (#AppT (#BoundT "Type") (#BoundT "_")) + Type + (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil)))) + TypeEnv + (_lux_case (#AppT List Type) + TypeList + (#AppT (#AllT (#Some #Nil) "Type" "_" + (#VariantT (#Cons ## "lux;DataT" + Text + (#Cons ## "lux;VariantT" + TypeList + (#Cons ## "lux;TupleT" + TypeList + (#Cons ## "lux;LambdaT" + (#TupleT (#Cons Type (#Cons Type #Nil))) + (#Cons ## "lux;BoundT" + Text + (#Cons ## "lux;VarT" + Int + (#Cons ## "lux;ExT" + Int + (#Cons ## "lux;AllT" + (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil))))) + (#Cons ## "lux;AppT" + (#TupleT (#Cons Type (#Cons Type #Nil))) + (#Cons ## "lux;NamedT" + (#TupleT (#Cons Ident (#Cons Type #Nil))) + #Nil)))))))))))) + Void)))))) (_lux_export Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings - (#AllT [(#Some #Nil) "lux;Bindings" "k" - (#AllT [#None "" "v" - (#TupleT (#Cons ## "lux;counter" - Int - (#Cons ## "lux;mappings" - (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))]) - #Nil)))])])) + (#NamedT ["lux" "Bindings"] + (#AllT [(#Some #Nil) "lux;Bindings" "k" + (#AllT [#None "" "v" + (#TupleT (#Cons ## "lux;counter" + Int + (#Cons ## "lux;mappings" + (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))]) + #Nil)))])]))) (_lux_export Bindings) (_lux_declare-tags [#counter #mappings]) @@ -127,38 +143,41 @@ ## #locals (Bindings k v) ## #closure (Bindings k v))) (_lux_def Env - (#AllT (#Some #Nil) "lux;Env" "k" - (#AllT #None "" "v" - (#TupleT (#Cons ## "lux;name" - Text - (#Cons ## "lux;inner-closures" - Int - (#Cons ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v")) - (#Cons ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v")) - #Nil)))))))) + (#NamedT ["lux" "Env"] + (#AllT (#Some #Nil) "lux;Env" "k" + (#AllT #None "" "v" + (#TupleT (#Cons ## "lux;name" + Text + (#Cons ## "lux;inner-closures" + Int + (#Cons ## "lux;locals" + (#AppT (#AppT Bindings (#BoundT "k")) + (#BoundT "v")) + (#Cons ## "lux;closure" + (#AppT (#AppT Bindings (#BoundT "k")) + (#BoundT "v")) + #Nil))))))))) (_lux_export Env) (_lux_declare-tags [#name #inner-closures #locals #closure]) ## (deftype Cursor ## (, Text Int Int)) (_lux_def Cursor - (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil))))) + (#NamedT ["lux" "Cursor"] + (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) (_lux_export Cursor) ## (deftype (Meta m v) ## (| (#Meta m v))) (_lux_def Meta - (#AllT (#Some #Nil) "lux;Meta" "m" - (#AllT #None "" "v" - (#VariantT (#Cons ## "lux;Meta" - (#TupleT (#Cons (#BoundT "m") - (#Cons (#BoundT "v") - #Nil))) - #Nil))))) + (#NamedT ["lux" "Meta"] + (#AllT (#Some #Nil) "lux;Meta" "m" + (#AllT #None "" "v" + (#VariantT (#Cons ## "lux;Meta" + (#TupleT (#Cons (#BoundT "m") + (#Cons (#BoundT "v") + #Nil))) + #Nil)))))) (_lux_export Meta) (_lux_declare-tags [#Meta]) @@ -174,45 +193,47 @@ ## (#TupleS (List (w (AST' w)))) ## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) (_lux_def AST' - (_lux_case (#AppT (#BoundT "w") - (#AppT (#BoundT "lux;AST'") - (#BoundT "w"))) - AST - (_lux_case (#AppT [List AST]) - ASTList - (#AllT (#Some #Nil) "lux;AST'" "w" - (#VariantT (#Cons ## "lux;BoolS" - Bool - (#Cons ## "lux;IntS" - Int - (#Cons ## "lux;RealS" - Real - (#Cons ## "lux;CharS" - Char - (#Cons ## "lux;TextS" - Text - (#Cons ## "lux;SymbolS" - Ident - (#Cons ## "lux;TagS" - Ident - (#Cons ## "lux;FormS" - ASTList - (#Cons ## "lux;TupleS" - ASTList - (#Cons ## "lux;RecordS" - (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) - #Nil) - ))))))))) - ))))) + (#NamedT ["lux" "AST'"] + (_lux_case (#AppT (#BoundT "w") + (#AppT (#BoundT "lux;AST'") + (#BoundT "w"))) + AST + (_lux_case (#AppT [List AST]) + ASTList + (#AllT (#Some #Nil) "lux;AST'" "w" + (#VariantT (#Cons ## "lux;BoolS" + Bool + (#Cons ## "lux;IntS" + Int + (#Cons ## "lux;RealS" + Real + (#Cons ## "lux;CharS" + Char + (#Cons ## "lux;TextS" + Text + (#Cons ## "lux;SymbolS" + Ident + (#Cons ## "lux;TagS" + Ident + (#Cons ## "lux;FormS" + ASTList + (#Cons ## "lux;TupleS" + ASTList + (#Cons ## "lux;RecordS" + (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) + #Nil) + ))))))))) + )))))) (_lux_export AST') (_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS]) ## (deftype AST ## (Meta Cursor (AST' (Meta Cursor)))) (_lux_def AST - (_lux_case (#AppT Meta Cursor) - w - (#AppT w (#AppT AST' w)))) + (#NamedT ["lux" "AST"] + (_lux_case (#AppT Meta Cursor) + w + (#AppT w (#AppT AST' w))))) (_lux_export AST) (_lux_def ASTList (#AppT List AST)) @@ -221,13 +242,14 @@ ## (| (#Left l) ## (#Right r))) (_lux_def Either - (#AllT (#Some #Nil) "lux;Either" "l" - (#AllT #None "" "r" - (#VariantT (#Cons ## "lux;Left" - (#BoundT "l") - (#Cons ## "lux;Right" - (#BoundT "r") - #Nil)))))) + (#NamedT ["lux" "Either"] + (#AllT (#Some #Nil) "lux;Either" "l" + (#AllT #None "" "r" + (#VariantT (#Cons ## "lux;Left" + (#BoundT "l") + (#Cons ## "lux;Right" + (#BoundT "r") + #Nil))))))) (_lux_export Either) (_lux_declare-tags [#Left #Right]) @@ -245,9 +267,10 @@ ## (deftype Source ## (List (Meta Cursor Text))) (_lux_def Source - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])])) + (#NamedT ["lux" "Source"] + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])]))) (_lux_export Source) ## (deftype Host @@ -255,13 +278,14 @@ ## #loader (^ java.net.URLClassLoader) ## #classes (^ clojure.lang.Atom))) (_lux_def Host - (#TupleT (#Cons [## "lux;writer" - (#DataT "org.objectweb.asm.ClassWriter") - (#Cons [## "lux;loader" - (#DataT "java.lang.ClassLoader") - (#Cons [## "lux;classes" - (#DataT "clojure.lang.Atom") - #Nil])])]))) + (#NamedT ["lux" "Host"] + (#TupleT (#Cons [## "lux;writer" + (#DataT "org.objectweb.asm.ClassWriter") + (#Cons [## "lux;loader" + (#DataT "java.lang.ClassLoader") + (#Cons [## "lux;classes" + (#DataT "clojure.lang.Atom") + #Nil])])])))) (_lux_declare-tags [#writer #loader #classes]) ## (deftype (DefData' m) @@ -289,11 +313,12 @@ ## (| (#Local Int) ## (#Global Ident))) (_lux_def LuxVar - (#VariantT (#Cons [## "lux;Local" - Int - (#Cons [## "lux;Global" - Ident - #Nil])]))) + (#NamedT ["lux" "LuxVar"] + (#VariantT (#Cons [## "lux;Local" + Int + (#Cons [## "lux;Global" + Ident + #Nil])])))) (_lux_export LuxVar) (_lux_declare-tags [#Local #Global]) @@ -339,39 +364,41 @@ ## #host Host ## )) (_lux_def Compiler - (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#TupleT (#Cons [## "lux;source" - Source - (#Cons [## "lux;cursor" - Cursor - (#Cons [## "lux;modules" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))]) - (#Cons [## "lux;envs" - (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) - (#Cons [## "lux;types" - (#AppT [(#AppT [Bindings Int]) Type]) - (#Cons [## "lux;expected" - Type - (#Cons [## "lux;seed" - Int - (#Cons [## "lux;eval?" - Bool - (#Cons [## "lux;host" - Host - #Nil])])])])])])])])]))]) - Void])) + (#NamedT ["lux" "Compiler"] + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#TupleT (#Cons [## "lux;source" + Source + (#Cons [## "lux;cursor" + Cursor + (#Cons [## "lux;modules" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))]) + (#Cons [## "lux;envs" + (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) + (#Cons [## "lux;types" + (#AppT [(#AppT [Bindings Int]) Type]) + (#Cons [## "lux;expected" + Type + (#Cons [## "lux;seed" + Int + (#Cons [## "lux;eval?" + Bool + (#Cons [## "lux;host" + Host + #Nil])])])])])])])])]))]) + Void]))) (_lux_export Compiler) (_lux_declare-tags [#source #cursor #modules #envs #types #expected #seed #eval? #host]) ## (deftype Macro ## (-> (List AST) (StateE Compiler (List AST)))) (_lux_def Macro - (#LambdaT ASTList - (#AppT (#AppT StateE Compiler) - ASTList))) + (#NamedT ["lux" "Macro"] + (#LambdaT ASTList + (#AppT (#AppT StateE Compiler) + ASTList)))) (_lux_export Macro) ## Base functions & macros @@ -477,35 +504,35 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS ["" ""])) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) - - (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) - (#Cons [(_meta (#SymbolS self)) - (#Cons [arg - (#Cons [(_lux_case args' - #Nil - body - - _ - (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda''"])) - (#Cons [(_meta (#TupleS args')) - (#Cons [body #Nil])])])))) - #Nil])])])]))) - #Nil])) + (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)) + (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) + (#Cons (_meta (#SymbolS "" "")) + (#Cons arg + (#Cons (_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) + (#Cons (_meta (#TupleS args')) + (#Cons body #Nil)))))) + #Nil)))))) + #Nil)) + + (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))) + (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) + (#Cons (_meta (#SymbolS self)) + (#Cons arg + (#Cons (_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons (_meta (#SymbolS "lux" "lambda''")) + (#Cons (_meta (#TupleS args')) + (#Cons body #Nil)))))) + #Nil)))))) + #Nil)) _ (fail "Wrong syntax for lambda"))))) @@ -2136,6 +2163,9 @@ (#AllT ?env ?name ?arg ?body) ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") + + (#NamedT name type) + (ident->text name) )) (def (beta-reduce env type) @@ -2169,6 +2199,9 @@ _ type) + (#NamedT name type) + (beta-reduce env type) + _ type )) @@ -2188,6 +2221,9 @@ (do Maybe/Monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) + + (#NamedT name type) + (apply-type type param) _ #None)) @@ -2204,6 +2240,8 @@ (#AllT _ _ _ body) (resolve-struct-type body) + (#NamedT name type) + (resolve-struct-type type) _ #None)) @@ -3046,7 +3084,10 @@ (` (#AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) (#AppT fun arg) - (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))))) + (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) + + (#NamedT [module name] type) + (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type)))))) (defmacro #export (loop tokens) (case tokens diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 7810c415b..3b6a93005 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -532,7 +532,7 @@ (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) (catch Error e (prn e) - (assert false (prn-str 'analyse-basic-ast (&/show-ast ?token))))) + (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) (&/$Right state* output) (return* state* output) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 395ae6976..483002adc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -113,6 +113,9 @@ (fail "##9##")))] (adjust-type* up type*)) + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + _ (assert false (prn 'adjust-type* (&type/show-type type))) )) @@ -202,7 +205,7 @@ (fail "[Pattern-matching Error] Record requires record-type."))) (&/$TagS ?ident) - (|do [;; :let [_ (println "#00")] + (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] [=module =name] (&&/resolved-ident ?ident) ;; :let [_ (println "#01")] value-type* (adjust-type value-type) @@ -219,7 +222,7 @@ (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) - (|do [;; :let [_ (println "#10" ?ident)] + (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] [=module =name] (&&/resolved-ident ?ident) ;; :let [_ (println "#11")] value-type* (adjust-type value-type) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 79b804088..8a79e0494 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -401,6 +401,7 @@ ;; (when (= "PList/Dict" ?name) ;; (prn 'DEF ?name (&/show-ast ?value))) (|do [module-name &/get-module-name + ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))] ? (&&module/defined? module-name ?name)] (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) @@ -416,15 +417,20 @@ (return (&/|list))) _ - (do (println 'DEF (str module-name ";" ?name)) + (do ;; (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) - :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]] + :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) + _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] - (|do [module-name &/get-module-name - _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] + (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] + module-name &/get-module-name + ;; :let [_ (prn 'analyse-declare-macro ?name "1")] + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) + ;; :let [_ (prn 'analyse-declare-macro ?name "2")] + ] (return (&/|list)))) (defn ensure-undeclared-tags [module tags] diff --git a/src/lux/base.clj b/src/lux/base.clj index e39f76409..44875d1df 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -58,7 +58,8 @@ "VarT" "ExT" "AllT" - "AppT") + "AppT" + "NamedT") ;; [Fields] ;; Binding @@ -229,7 +230,7 @@ (defn |head [xs] (|case xs ($Nil) - (assert false) + (assert false (prn-str '|head)) ($Cons x _) x)) @@ -237,7 +238,7 @@ (defn |tail [xs] (|case xs ($Nil) - (assert false) + (assert false (prn-str '|tail)) ($Cons _ xs*) xs*)) @@ -787,9 +788,8 @@ ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") - ;; _ - ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) - ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) + _ + (assert false (prn-str 'show-ast (adt->text ast))) )) (defn ident->text [ident] @@ -898,19 +898,6 @@ (and (= xmodule ymodule) (= xname yname)))) -;; (defn |list-put [idx val xs] -;; (|case [idx xs] -;; [_ ($Nil)] -;; (V $None nil) - -;; [0 ($Cons x xs*)] -;; (V $Some (V $Cons (T val xs*))) - -;; [_ ($Cons x xs*)] -;; (|case (|list-put idx val xs*) -;; ($None) (V $None nil) -;; ($Some xs**) (V $Some (V $Cons (T x xs**)))))) - (defn |list-put [idx val xs] (|case xs ($Nil) diff --git a/src/lux/type.clj b/src/lux/type.clj index 2516fbc1d..e78b5616a 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -26,14 +26,6 @@ _ false)) -(def Bool (&/V &/$DataT "java.lang.Boolean")) -(def Int (&/V &/$DataT "java.lang.Long")) -(def Real (&/V &/$DataT "java.lang.Double")) -(def Char (&/V &/$DataT "java.lang.Character")) -(def Text (&/V &/$DataT "java.lang.String")) -(def Unit (&/V &/$TupleT (&/|list))) -(def $Void (&/V &/$VariantT (&/|list))) - (def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) (def ^:private no-env (&/V &/$None nil)) (defn Data$ [name] @@ -46,154 +38,174 @@ (&/V &/$LambdaT (&/T in out))) (defn App$ [fun arg] (&/V &/$AppT (&/T fun arg))) - (defn Tuple$ [members] ;; (assert (|list? members)) (&/V &/$TupleT members)) - (defn Variant$ [members] ;; (assert (|list? members)) (&/V &/$VariantT members)) - (defn All$ [env name arg body] (&/V &/$AllT (&/T env name arg body))) +(defn Named$ [name type] + (&/V &/$NamedT (&/T name type))) + + +(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) +(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) +(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) +(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) +(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) +(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) +(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) +(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO - (All$ empty-env "IO" "a" - (Lambda$ Unit (Bound$ "a")))) + (Named$ (&/T "lux/data" "IO") + (All$ empty-env "IO" "a" + (Lambda$ Unit (Bound$ "a"))))) (def List - (All$ empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - )))) + (Named$ (&/T "lux" "List") + (All$ empty-env "lux;List" "a" + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + ))))) (def Maybe - (All$ empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - )))) + (Named$ (&/T "lux" "Maybe") + (All$ empty-env "lux;Maybe" "a" + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + ))))) (def Type - (let [Type (App$ (Bound$ "Type") (Bound$ "_")) - TypeList (App$ List Type) - TypeEnv (App$ List (Tuple$ (&/|list Text Type))) - TypePair (Tuple$ (&/|list Type Type))] - (App$ (All$ empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; VariantT - TypeList - ;; TupleT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) - ;; AppT - TypePair - ))) - $Void))) + (Named$ (&/T "lux" "Type") + (let [Type (App$ (Bound$ "Type") (Bound$ "_")) + TypeList (App$ List Type) + TypeEnv (App$ List (Tuple$ (&/|list Text Type))) + TypePair (Tuple$ (&/|list Type Type))] + (App$ (All$ empty-env "Type" "_" + (Variant$ (&/|list + ;; DataT + Text + ;; VariantT + TypeList + ;; TupleT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + ;; NamedT + (Tuple$ (&/|list Ident Type)) + ))) + $Void)))) (def Bindings - (All$ empty-env "lux;Bindings" "k" - (All$ no-env "" "v" - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v"))))))))) + (Named$ (&/T "lux" "Bindings") + (All$ empty-env "lux;Bindings" "k" + (All$ no-env "" "v" + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v")))))))))) (def Env - (let [bindings (App$ (App$ Bindings (Bound$ "k")) - (Bound$ "v"))] - (All$ empty-env "lux;Env" "k" - (All$ no-env "" "v" - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - )))))) + (Named$ (&/T "lux" "Env") + (let [bindings (App$ (App$ Bindings (Bound$ "k")) + (Bound$ "v"))] + (All$ empty-env "lux;Env" "k" + (All$ no-env "" "v" + (Tuple$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + ))))))) (def Cursor - (Tuple$ (&/|list Text Int Int))) + (Named$ (&/T "lux" "Cursor") + (Tuple$ (&/|list Text Int Int)))) (def Meta - (All$ empty-env "lux;Meta" "m" - (All$ no-env "" "v" - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ "m") - (Bound$ "v")))))))) - -(def Ident (Tuple$ (&/|list Text Text))) + (Named$ (&/T "lux" "Meta") + (All$ empty-env "lux;Meta" "m" + (All$ no-env "" "v" + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ "m") + (Bound$ "v"))))))))) (def AST* - (let [AST* (App$ (Bound$ "w") - (App$ (Bound$ "lux;AST'") - (Bound$ "w"))) - AST*List (App$ List AST*)] - (All$ empty-env "lux;AST'" "w" - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - )))) + (Named$ (&/T "lux" "AST'") + (let [AST* (App$ (Bound$ "w") + (App$ (Bound$ "lux;AST'") + (Bound$ "w"))) + AST*List (App$ List AST*)] + (All$ empty-env "lux;AST'" "w" + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + ))))) (def AST - (let [w (App$ Meta Cursor)] - (App$ w (App$ AST* w)))) + (Named$ (&/T "lux" "AST") + (let [w (App$ Meta Cursor)] + (App$ w (App$ AST* w))))) (def ^:private ASTList (App$ List AST)) (def Either - (All$ empty-env "lux;Either" "l" - (All$ no-env "" "r" - (Variant$ (&/|list - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r")))))) + (Named$ (&/T "lux" "Either") + (All$ empty-env "lux;Either" "l" + (All$ no-env "" "r" + (Variant$ (&/|list + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r"))))))) (def StateE (All$ empty-env "lux;StateE" "s" @@ -204,19 +216,21 @@ (Bound$ "a")))))))) (def Source - (App$ List - (App$ (App$ Meta Cursor) - Text))) + (Named$ (&/T "lux" "Source") + (App$ List + (App$ (App$ Meta Cursor) + Text)))) (def Host - (Tuple$ - (&/|list - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") - ;; "lux;loader" - (Data$ "java.lang.ClassLoader") - ;; "lux;classes" - (Data$ "clojure.lang.Atom")))) + (Named$ (&/T "lux" "Host") + (Tuple$ + (&/|list + ;; "lux;writer" + (Data$ "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (Data$ "java.lang.ClassLoader") + ;; "lux;classes" + (Data$ "clojure.lang.Atom"))))) (def DefData* (All$ empty-env "lux;DefData'" "" @@ -232,11 +246,12 @@ )))) (def LuxVar - (Variant$ (&/|list - ;; "lux;Local" - Int - ;; "lux;Global" - Ident))) + (Named$ (&/T "lux" "LuxVar") + (Variant$ (&/|list + ;; "lux;Local" + Int + ;; "lux;Global" + Ident)))) (def $Module (All$ empty-env "lux;$Module" "Compiler" @@ -264,37 +279,39 @@ )))) (def $Compiler - (App$ (All$ empty-env "lux;Compiler" "" - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) - $Void)) + (Named$ (&/T "lux" "Compiler") + (App$ (All$ empty-env "lux;Compiler" "" + (Tuple$ + (&/|list + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + ))) + $Void))) (def Macro - (Lambda$ ASTList - (App$ (App$ StateE $Compiler) - ASTList))) + (Named$ (&/T "lux" "Macro") + (Lambda$ ASTList + (App$ (App$ StateE $Compiler) + ASTList)))) (defn bound? [id] (fn [state] @@ -512,8 +529,11 @@ (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) + (&/$NamedT ?name ?type) + (&/ident->text ?name) + _ - (assert false (prn-str 'show-type (aget type 0))))) + (assert false (prn-str 'show-type (&/adt->text type))))) (defn type= [x y] (or (clojure.lang.Util/identical x y) @@ -566,6 +586,12 @@ (type= xbody ybody) ) + [(&/$NamedT ?xname ?xtype) _] + (type= ?xtype y) + + [_ (&/$NamedT ?yname ?ytype)] + (type= x ?ytype) + [_ _] false )] @@ -640,9 +666,12 @@ (&/$AppT F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) + + (&/$NamedT ?name ?type) + (apply-type ?type param) _ - (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) + (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] (case class @@ -805,7 +834,7 @@ (show-type a))))) (&/|interpose "\n\n") (&/fold str ""))) - (assert false))] + (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] (|case (fp-get fp-pair fixpoints) (&/$Some ?) (if ? @@ -870,6 +899,12 @@ (return (&/T fixpoints nil)) (fail (check-error expected actual))) + [(&/$NamedT ?ename ?etype) _] + (check* class-loader fixpoints ?etype actual) + + [_ (&/$NamedT ?aname ?atype)] + (check* class-loader fixpoints expected ?atype) + [_ _] (fail (check-error expected actual)) ))) @@ -892,11 +927,15 @@ =return (apply-lambda func* param)] (clean $var =return)))) + (&/$NamedT ?name ?type) + (apply-lambda ?type param) + _ (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] + "(-> Type (Lux Type))" (|case type (&/$AppT ?all ?param) (|do [type* (apply-type ?all ?param)] @@ -904,6 +943,9 @@ (&/$VarT ?id) (deref ?id) + + (&/$NamedT ?name ?type) + (actual-type ?type) _ (return type) @@ -911,6 +953,9 @@ (defn variant-case [tag type] (|case type + (&/$NamedT ?name ?type) + (variant-case tag ?type) + (&/$VariantT ?cases) (|case (&/|at tag ?cases) (&/$Some case-type) -- cgit v1.2.3 From 1b48e9e06cb90187b28381bcadbeeba60806964d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 17 Aug 2015 16:59:18 -0400 Subject: - Finished turning tags into indices. - As an unexpected bonus, the compiler has become 2.5x faster. - Fixed some minor bugs. - Tag declarations now include associated types. - Tag declarations info is now stored twice (one from the perspective of tags, the other from the perspective of types). - Changed the named of the "types" member of the Compiler type, to "type-vars" to avoid collision with the "types" member of the Module type. --- source/lux.lux | 752 ++++++++++++++++++++++------------------ source/lux/codata/function.lux | 4 +- source/lux/codata/lazy.lux | 12 +- source/lux/codata/reader.lux | 12 +- source/lux/codata/state.lux | 12 +- source/lux/codata/stream.lux | 8 +- source/lux/data/bool.lux | 8 +- source/lux/data/char.lux | 4 +- source/lux/data/error.lux | 8 +- source/lux/data/id.lux | 14 +- source/lux/data/io.lux | 8 +- source/lux/data/list.lux | 28 +- source/lux/data/maybe.lux | 14 +- source/lux/data/number/int.lux | 40 +-- source/lux/data/number/real.lux | 40 +-- source/lux/data/text.lux | 18 +- source/lux/data/writer.lux | 8 +- source/lux/meta/lux.lux | 16 +- source/lux/meta/syntax.lux | 8 +- src/lux/analyser.clj | 5 +- src/lux/analyser/lux.clj | 43 +-- src/lux/analyser/module.clj | 97 ++++-- src/lux/base.clj | 2 +- src/lux/compiler/host.clj | 8 +- src/lux/compiler/type.clj | 4 + src/lux/host.clj | 7 + src/lux/parser.clj | 4 +- src/lux/reader.clj | 14 +- src/lux/type.clj | 54 ++- 29 files changed, 696 insertions(+), 556 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index b6d71e893..4120b262c 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -10,70 +10,68 @@ (_jvm_interface "Function" [] ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) -(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT]) -(_lux_declare-tags [#None #Some]) -(_lux_declare-tags [#Nil #Cons]) - ## Basic types -(_lux_def Bool (#NamedT ["lux" "Bool"] - (#DataT "java.lang.Boolean"))) +(_lux_def Bool (9 ["lux" "Bool"] + (0 "java.lang.Boolean"))) (_lux_export Bool) -(_lux_def Int (#NamedT ["lux" "Int"] - (#DataT "java.lang.Long"))) +(_lux_def Int (9 ["lux" "Int"] + (0 "java.lang.Long"))) (_lux_export Int) -(_lux_def Real (#NamedT ["lux" "Real"] - (#DataT "java.lang.Double"))) +(_lux_def Real (9 ["lux" "Real"] + (0 "java.lang.Double"))) (_lux_export Real) -(_lux_def Char (#NamedT ["lux" "Char"] - (#DataT "java.lang.Character"))) +(_lux_def Char (9 ["lux" "Char"] + (0 "java.lang.Character"))) (_lux_export Char) -(_lux_def Text (#NamedT ["lux" "Text"] - (#DataT "java.lang.String"))) +(_lux_def Text (9 ["lux" "Text"] + (0 "java.lang.String"))) (_lux_export Text) -(_lux_def Unit (#NamedT ["lux" "Unit"] - (#TupleT #Nil))) +(_lux_def Unit (9 ["lux" "Unit"] + (2 (0)))) (_lux_export Unit) -(_lux_def Void (#NamedT ["lux" "Void"] - (#VariantT #Nil))) +(_lux_def Void (9 ["lux" "Void"] + (1 (0)))) (_lux_export Void) -(_lux_def Ident (#NamedT ["lux" "Ident"] - (#TupleT (#Cons Text (#Cons Text #Nil))))) +(_lux_def Ident (9 ["lux" "Ident"] + (2 (1 Text (1 Text (0)))))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons a (List a)))) (_lux_def List - (#NamedT ["lux" "List"] - (#AllT (#Some #Nil) "lux;List" "a" - (#VariantT (#Cons ## "lux;Nil" - (#TupleT #Nil) - (#Cons ## "lux;Cons" - (#TupleT (#Cons (#BoundT "a") - (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a")) - #Nil))) - #Nil)))))) + (9 ["lux" "List"] + (7 (1 (0)) "lux;List" "a" + (1 (1 ## "lux;Nil" + (2 (0)) + (1 ## "lux;Cons" + (2 (1 (4 "a") + (1 (8 (4 "lux;List") (4 "a")) + (0)))) + (0))))))) (_lux_export List) +(_lux_declare-tags [#Nil #Cons] List) ## (deftype (Maybe a) ## (| #None -## (#Some a))) +## (1 a))) (_lux_def Maybe - (#NamedT ["lux" "Maybe"] - (#AllT (#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons ## "lux;None" - (#TupleT #Nil) - (#Cons ## "lux;Some" - (#BoundT "a") - #Nil)))))) + (9 ["lux" "Maybe"] + (7 (1 (0)) "lux;Maybe" "a" + (1 (1 ## "lux;None" + (2 (0)) + (1 ## "lux;Some" + (4 "a") + (0))))))) (_lux_export Maybe) +(_lux_declare-tags [#None #Some] Maybe) ## (deftype #rec Type ## (| (#DataT Text) @@ -87,37 +85,38 @@ ## (#NamedT Ident Type) ## )) (_lux_def Type - (#NamedT ["lux" "Type"] - (_lux_case (#AppT (#BoundT "Type") (#BoundT "_")) - Type - (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil)))) - TypeEnv - (_lux_case (#AppT List Type) - TypeList - (#AppT (#AllT (#Some #Nil) "Type" "_" - (#VariantT (#Cons ## "lux;DataT" - Text - (#Cons ## "lux;VariantT" - TypeList - (#Cons ## "lux;TupleT" - TypeList - (#Cons ## "lux;LambdaT" - (#TupleT (#Cons Type (#Cons Type #Nil))) - (#Cons ## "lux;BoundT" - Text - (#Cons ## "lux;VarT" - Int - (#Cons ## "lux;ExT" - Int - (#Cons ## "lux;AllT" - (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil))))) - (#Cons ## "lux;AppT" - (#TupleT (#Cons Type (#Cons Type #Nil))) - (#Cons ## "lux;NamedT" - (#TupleT (#Cons Ident (#Cons Type #Nil))) - #Nil)))))))))))) - Void)))))) + (9 ["lux" "Type"] + (_lux_case (8 (4 "Type") (4 "_")) + Type + (_lux_case (8 List (2 (1 Text (1 Type (0))))) + TypeEnv + (_lux_case (8 List Type) + TypeList + (8 (7 (1 (0)) "Type" "_" + (1 (1 ## "lux;DataT" + Text + (1 ## "lux;VariantT" + TypeList + (1 ## "lux;TupleT" + TypeList + (1 ## "lux;LambdaT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;BoundT" + Text + (1 ## "lux;VarT" + Int + (1 ## "lux;ExT" + Int + (1 ## "lux;AllT" + (2 (1 (8 Maybe TypeEnv) (1 Text (1 Text (1 Type (0)))))) + (1 ## "lux;AppT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;NamedT" + (2 (1 Ident (1 Type (0)))) + (0))))))))))))) + Void)))))) (_lux_export Type) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) ## (deftype (Bindings k v) ## (& #counter Int @@ -135,7 +134,7 @@ #Nil])]))]) #Nil)))])]))) (_lux_export Bindings) -(_lux_declare-tags [#counter #mappings]) +(_lux_declare-tags [#counter #mappings] Bindings) ## (deftype (Env k v) ## (& #name Text @@ -158,7 +157,7 @@ (#BoundT "v")) #Nil))))))))) (_lux_export Env) -(_lux_declare-tags [#name #inner-closures #locals #closure]) +(_lux_declare-tags [#name #inner-closures #locals #closure] Env) ## (deftype Cursor ## (, Text Int Int)) @@ -179,7 +178,7 @@ #Nil))) #Nil)))))) (_lux_export Meta) -(_lux_declare-tags [#Meta]) +(_lux_declare-tags [#Meta] Meta) ## (deftype (AST' w) ## (| (#BoolS Bool) @@ -225,7 +224,7 @@ ))))))))) )))))) (_lux_export AST') -(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS]) +(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') ## (deftype AST ## (Meta Cursor (AST' (Meta Cursor)))) @@ -251,7 +250,7 @@ (#BoundT "r") #Nil))))))) (_lux_export Either) -(_lux_declare-tags [#Left #Right]) +(_lux_declare-tags [#Left #Right] Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) @@ -286,7 +285,7 @@ (#Cons [## "lux;classes" (#DataT "clojure.lang.Atom") #Nil])])])))) -(_lux_declare-tags [#writer #loader #classes]) +(_lux_declare-tags [#writer #loader #classes] Host) ## (deftype (DefData' m) ## (| (#TypeD Type) @@ -294,20 +293,21 @@ ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' - (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [## "lux;TypeD" - Type - (#Cons [## "lux;ValueD" - (#TupleT (#Cons [Type - (#Cons [Unit - #Nil])])) - (#Cons [## "lux;MacroD" - (#BoundT "") - (#Cons [## "lux;AliasD" - Ident - #Nil])])])]))])) + (#NamedT ["lux" "DefData'"] + (#AllT [(#Some #Nil) "lux;DefData'" "" + (#VariantT (#Cons [## "lux;ValueD" + (#TupleT (#Cons [Type + (#Cons [Unit + #Nil])])) + (#Cons [## "lux;TypeD" + Type + (#Cons [## "lux;MacroD" + (#BoundT "") + (#Cons [## "lux;AliasD" + Ident + #Nil])])])]))]))) (_lux_export DefData') -(_lux_declare-tags [#TypeD #ValueD #MacroD #AliasD]) +(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData') ## (deftype LuxVar ## (| (#Local Int) @@ -320,44 +320,54 @@ Ident #Nil])])))) (_lux_export LuxVar) -(_lux_declare-tags [#Local #Global]) +(_lux_declare-tags [#Local #Global] LuxVar) ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) ## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) ## #imports (List Text) -## #tags (List (, Text (, Int (List Ident)))) +## #tags (List (, Text (, Int (List Ident) Type))) +## #types (List (, Text (, (List Ident) Type))) ## )) (_lux_def Module - (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#TupleT (#Cons [## "lux;module-aliases" - (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) - (#Cons [## "lux;defs" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - ASTList])])]) - #Nil])])) - #Nil])]))]) - (#Cons [## "lux;imports" - (#AppT [List Text]) - (#Cons [## "lux;tags" - (#AppT [List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons Int - (#Cons (#AppT [List Ident]) - #Nil))) - #Nil)))]) - #Nil])])])]))])) + (#NamedT ["lux" "Module"] + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#TupleT (#Cons [## "lux;module-aliases" + (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) + (#Cons [## "lux;defs" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + ASTList])])]) + #Nil])])) + #Nil])]))]) + (#Cons [## "lux;imports" + (#AppT [List Text]) + (#Cons [## "lux;tags" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Int + (#Cons (#AppT [List Ident]) + (#Cons Type + #Nil)))) + #Nil)))]) + (#Cons [## "lux;types" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons (#AppT [List Ident]) + (#Cons Type + #Nil))) + #Nil)))]) + #Nil])])])])]))]))) (_lux_export Module) -(_lux_declare-tags [#module-aliases #defs #imports #tags]) +(_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) ## (deftype #rec Compiler ## (& #source Source ## #cursor Cursor ## #modules (List (, Text (Module Compiler))) ## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) +## #type-vars (Bindings Int Type) ## #expected Type ## #seed Int ## #eval? Bool @@ -377,7 +387,7 @@ (#Cons [## "lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) - (#Cons [## "lux;types" + (#Cons [## "lux;type-vars" (#AppT [(#AppT [Bindings Int]) Type]) (#Cons [## "lux;expected" Type @@ -390,7 +400,7 @@ #Nil])])])])])])])])]))]) Void]))) (_lux_export Compiler) -(_lux_declare-tags [#source #cursor #modules #envs #types #expected #seed #eval? #host]) +(_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) ## (deftype Macro ## (-> (List AST) (StateE Compiler (List AST)))) @@ -1046,12 +1056,13 @@ ## bind)) (def''' Monad Type - (All' [m] - (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) - (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b)))))))) -(_lux_declare-tags [#return #bind]) + (#NamedT ["lux" "Monad"] + (All' [m] + (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b))))))))) +(_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad ($' Monad Maybe) @@ -1070,7 +1081,7 @@ {#return (lambda' [x] (lambda' [state] - (#Right [state x]))) + (#Right state x))) #bind (lambda' [f ma] @@ -1079,12 +1090,12 @@ (#Left msg) (#Left msg) - (#Right [state' a]) + (#Right state' a) (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil) (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ @@ -1092,8 +1103,8 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (list (foldL (lambda' [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + (#Cons output inputs) + (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))) output inputs))) @@ -1425,7 +1436,7 @@ ($' Lux Text) (_lux_case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (_lux_case (reverse envs) @@ -1441,7 +1452,7 @@ ($' Maybe Macro)) (do Maybe/Monad [$module (get module modules) - gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags} (_lux_: ($' Module Compiler) $module)] + gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} (_lux_: ($' Module Compiler) $module)] (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] @@ -1465,7 +1476,7 @@ (lambda' [state] (_lux_case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (#Right state (find-macro' modules current-module module name))))))) @@ -1632,7 +1643,7 @@ _ (fail "Wrong syntax for variant case.")))) cases)] - (return [(`' (#VariantT (~ (untemplate-list (map second members))))) + (return [(`' (#;VariantT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) @@ -1687,16 +1698,18 @@ (_lux_case parts (#Some name args type) (do Lux/Monad - [type+tags?? (unfold-type-def type)] - (let' [[type tags??] type+tags?? + [type+tags?? (unfold-type-def type) + module-name get-module-name] + (let' [type-name (symbol$ ["" name]) + [type tags??] type+tags?? with-export (: (List AST) (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) + (list (`' (_lux_export (~ type-name)))) #Nil)) with-tags (: (List AST) (_lux_case tags?? (#Some tags) - (list (`' (_lux_declare-tags [(~@ tags)]))) + (list (`' (_lux_declare-tags [(~@ tags)] (~ type-name)))) _ (list))) @@ -1714,10 +1727,12 @@ (#Some type) _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (#Some (`' (;All (~ type-name) [(~@ args)] (~ type)))))))] (_lux_case type' (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + (return (list& (`' (_lux_def (~ type-name) (;type (#;NamedT [(~ (text$ module-name)) + (~ (text$ name))] + (~ type''))))) (list:++ with-export with-tags))) #None @@ -2001,37 +2016,15 @@ (-> Text (Lux AST)) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (#Right {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed (i+ 1 seed) #eval? eval? #expected expected #cursor cursor} (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) -(defmacro #export (sig tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - members (map% Lux/Monad - (: (-> AST (Lux (, Ident AST))) - (lambda [token] - (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) - (do Lux/Monad - [name' (normalize name)] - (wrap (: (, Ident AST) [name' type]))) - - _ - (fail "Signatures require typed members!")))) - (list:join tokens'))] - (wrap (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident AST) AST) - (lambda [pair] - (let [[name type] pair] - (` [(~ (|> name ident->text text$)) - (~ type)])))) - members))))))))) - (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens @@ -2040,28 +2033,48 @@ _ [false tokens])) - ?parts (: (Maybe (, AST (List AST) (List AST))) + ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& (#Meta _ (#FormS (list& name args))) sigs)) + (\ (list& (#Meta _ (#FormS (list& (#Meta _ (#SymbolS name)) args))) sigs)) (#Some name args sigs) - (\ (list& name sigs)) + (\ (list& (#Meta _ (#SymbolS name)) sigs)) (#Some name #Nil sigs) _ #None))] (case ?parts (#Some name args sigs) - (let [sigs' (: AST - (case args - #Nil - (` (;sig (~@ sigs))) - - _ - (` (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (` (_lux_def (~ name) (~ sigs'))) + (do Lux/Monad + [name+ (normalize name) + sigs' (map% Lux/Monad macro-expand sigs) + members (map% Lux/Monad + (: (-> AST (Lux (, Text AST))) + (lambda [token] + (case token + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS ["" name])))))) + (wrap (: (, Text AST) [name type])) + + _ + (fail "Signatures require typed members!")))) + (list:join sigs')) + #let [[_module _name] name+ + def-name (symbol$ name) + tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) + types (map second members) + sig-type (: AST (` (#;TupleT (~ (untemplate-list types))))) + sig-decl (: AST (` (_lux_declare-tags [(~@ tags)] (~ def-name)))) + sig+ (: AST + (case args + #Nil + sig-type + + _ + (` (#;NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type))))))]] + (return (list& (` (_lux_def (~ def-name) (~ sig+))) + sig-decl (if export? - (list (` (_lux_export (~ name)))) + (list (` (_lux_export (~ def-name)))) #Nil)))) #None @@ -2229,27 +2242,90 @@ #None)) (def (resolve-struct-type type) - (-> Type (Maybe Type)) + (-> Type (Maybe (List Type))) (case type (#TupleT slots) - (#Some type) + (#Some slots) (#AppT fun arg) - (apply-type fun arg) + (do Maybe/Monad + [output (apply-type fun arg)] + (resolve-struct-type output)) (#AllT _ _ _ body) (resolve-struct-type body) (#NamedT name type) (resolve-struct-type type) + _ #None)) +(def (find-module name) + (-> Text (Lux (Module Compiler))) + (lambda [state] + (let [{#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (case (get name modules) + (#Some module) + (#Right state module) + + _ + (#Left ($ text:++ "Unknown module: " name)))))) + +(def get-current-module + (Lux (Module Compiler)) + (do Lux/Monad + [module-name get-module-name] + (find-module module-name))) + +(def (resolve-tag [module name]) + (-> Ident (Lux (, Int (List Ident) Type))) + (do Lux/Monad + [=module (find-module module) + #let [{#module-aliases _ #defs bindings #imports _ #tags tags-table #types types} =module]] + (case (get name tags-table) + (#Some output) + (return output) + + _ + (fail (text:++ "Unknown tag: " (ident->text [module name])))))) + +(def (resolve-type-tags type) + (-> Type (Lux (Maybe (, (List Ident) (List Type))))) + (case type + (#AppT fun arg) + (resolve-type-tags fun) + + (#AllT env name arg body) + (resolve-type-tags body) + + (#NamedT [module name] _) + (do Lux/Monad + [=module (find-module module) + #let [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} =module]] + (case (get name types) + (#Some [tags (#NamedT _ _type)]) + (case (resolve-struct-type _type) + (#Some members) + (return (#Some [tags members])) + + _ + (return #None)) + + _ + (return #None))) + + _ + (return #None))) + (def expected-type (Lux Type) (lambda [state] (let [{#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] (#Right state expected)))) @@ -2450,7 +2526,7 @@ (-> Text (Lux Bool)) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (case (get module modules) @@ -2465,7 +2541,7 @@ (-> Text (Lux (List Text))) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (case (get module modules) @@ -2477,7 +2553,7 @@ (if export? (list name) (list))))) - (let [{#module-aliases _ #defs defs #imports _ #tags tags} =module] + (let [{#module-aliases _ #defs defs #imports _ #tags tags #types types} =module] defs))] (#Right state (list:join to-alias))) @@ -2648,7 +2724,7 @@ (-> Text Compiler (Maybe Type)) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) @@ -2683,22 +2759,22 @@ (-> Ident Compiler (Maybe Type)) (let [[v-prefix v-name] name {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] (case (get v-prefix modules) #None #None - (#Some {#defs defs #module-aliases _ #imports _ #tags tags}) + (#Some {#defs defs #module-aliases _ #imports _ #tags tags #types types}) (case (get v-name defs) #None #None - (#Some _ def-data) + (#Some [_ def-data]) (case def-data (#TypeD _) (#Some Type) - (#ValueD [type _]) (#Some type) + (#ValueD type _) (#Some type) (#MacroD m) (#Some Macro) (#AliasD name') (find-in-defs name' state)))))) @@ -2720,7 +2796,7 @@ _ (let [{#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) @@ -2730,25 +2806,43 @@ _ (let [{#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) ))) -(def (use-field field-name type) - (-> Text Type (, AST AST)) - (let [[module name] (split-slot field-name) - pattern (: AST - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (record$ (map (: (-> (, Text Type) (, AST AST)) - (lambda [[sname stype]] (use-field sname stype))) - slots)) +(def (zip2 xs ys) + (All [a b] (-> (List a) (List b) (List (, a b)))) + (case xs + (#Cons x xs') + (case ys + (#Cons y ys') + (list& [x y] (zip2 xs' ys')) - _ - (symbol$ ["" name])))] - [(tag$ [module name]) pattern])) + _ + (list)) + + _ + (list))) + +(def (use-field [module name] type) + (-> Ident Type (Lux (, AST AST))) + (do Lux/Monad + [output (resolve-type-tags type) + pattern (: (Lux AST) + (case output + (#Some [tags members]) + (do Lux/Monad + [slots (map% Lux/Monad + (: (-> (, Ident Type) (Lux (, AST AST))) + (lambda [[sname stype]] (use-field sname stype))) + (zip2 tags members))] + (return (record$ slots))) + + #None + (return (symbol$ ["" name]))))] + (return [(tag$ [module name]) pattern]))) (defmacro #export (using tokens) (case tokens @@ -2756,12 +2850,15 @@ (case struct (#Meta _ (#SymbolS name)) (do Lux/Monad - [struct-type (find-var-type name)] - (case (resolve-struct-type struct-type) - (#Some (#TupleT slots)) - (let [pattern (record$ (map (: (-> (, Text Type) (, AST AST)) - (lambda [[sname stype]] (use-field sname stype))) - slots))] + [struct-type (find-var-type name) + output (resolve-type-tags struct-type)] + (case output + (#Some [tags members]) + (do Lux/Monad + [slots (map% Lux/Monad (: (-> (, Ident Type) (Lux (, AST AST))) + (lambda [[sname stype]] (use-field sname stype))) + (zip2 tags members)) + #let [pattern (record$ slots)]] (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) _ @@ -2798,73 +2895,82 @@ _ (fail "Wrong syntax for cond")))) +(def (enumerate' idx xs) + (All [a] (-> Int (List a) (List (, Int a)))) + (case xs + (#Cons x xs') + (#Cons [idx x] (enumerate' (i+ 1 idx) xs')) + + #Nil + #Nil)) + +(def (enumerate xs) + (All [a] (-> (List a) (List (, Int a)))) + (enumerate' 0 xs)) + (defmacro #export (get@ tokens) (case tokens (\ (list (#Meta _ (#TagS slot')) record)) - (case record - (#Meta _ (#SymbolS name)) - (do Lux/Monad - [type (find-var-type name) - g!blank (gensym "") - g!output (gensym "")] - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (do Lux/Monad - [slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Type) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-type] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - g!output - g!blank)]))) - slots))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output))))))) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output] + g!_ (gensym "_") + g!output (gensym "")] + (case (resolve-struct-type type) + (#Some members) + (let [pattern (record$ (map (: (-> (, Ident (, Int Type)) (, AST AST)) + (lambda [[[r-prefix r-name] [r-idx r-type]]] + [(tag$ [r-prefix r-name]) (if (i= idx r-idx) + g!output + g!_)])) + (zip2 tags (enumerate members))))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output)))))) - _ - (fail "get@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (get@ (~ (tag$ slot')) (~ _record)))))))) + _ + (fail "get@ can only use records."))) _ (fail "Wrong syntax for get@"))) -(def (open-field prefix field-name source type) - (-> Text Text AST Type (List AST)) - (let [[module name] (split-slot field-name) - source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))] - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (list:join (map (: (-> (, Text Type) (List AST)) +(def (open-field prefix [module name] source type) + (-> Text Ident AST Type (Lux (List AST))) + (do Lux/Monad + [output (resolve-type-tags type) + #let [source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))]] + (case output + (#Some [tags members]) + (do Lux/Monad + [decls' (map% Lux/Monad + (: (-> (, Ident Type) (Lux (List AST))) (lambda [[sname stype]] (open-field prefix sname source+ stype))) - slots)) + (zip2 tags members))] + (return (list:join decls'))) _ - (list (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+))))))) + (return (list (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+)))))))) (defmacro #export (open tokens) (case tokens (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) (do Lux/Monad - [#let [prefix (case tokens' + [@module get-module-name + #let [prefix (case tokens' (\ (list (#Meta _ (#TextS prefix)))) prefix _ "")] struct-type (find-var-type struct-name) + output (resolve-type-tags struct-type) #let [source (symbol$ struct-name)]] - (case (resolve-struct-type struct-type) - (#Some (#TupleT slots)) - (return (list:join (map (: (-> (, Text Type) (List AST)) - (lambda [[sname stype]] (open-field prefix sname source stype))) - slots))) + (case output + (#Some [tags members]) + (do Lux/Monad + [decls' (map% Lux/Monad (: (-> (, Ident Type) (Lux (List AST))) + (lambda [[sname stype]] (open-field prefix sname source stype))) + (zip2 tags members))] + (return (list:join decls'))) _ (fail "Can only \"open\" records."))) @@ -2911,47 +3017,34 @@ (defmacro #export (set@ tokens) (case tokens (\ (list (#Meta _ (#TagS slot')) value record)) - (case record - (#Meta _ (#SymbolS name)) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text AST))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text AST) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text AST) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - value - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) + (lambda [[r-slot-name [r-idx r-type]]] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (i= idx r-idx) + value + r-var)])) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) - _ - (fail "set@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) + _ + (fail "set@ can only use records."))) _ (fail "Wrong syntax for set@"))) @@ -2959,47 +3052,34 @@ (defmacro #export (update@ tokens) (case tokens (\ (list (#Meta _ (#TagS slot')) fun record)) - (case record - (#Meta _ (#SymbolS name)) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text AST))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text AST) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text AST) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - (` ((~ fun) (~ r-var))) - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) + (lambda [[r-slot-name [r-idx r-type]]] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (i= idx r-idx) + (` ((~ fun) (~ r-var))) + r-var)])) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) - _ - (fail "update@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) + _ + (fail "update@ can only use records."))) _ (fail "Wrong syntax for update@"))) @@ -3053,25 +3133,25 @@ (-> Type AST) (case type (#DataT name) - (` (#DataT (~ (text$ name)))) + (` (#;DataT (~ (text$ name)))) - (#VariantT cases) - (` (#VariantT (~ (untemplate-list (map type->syntax cases))))) + (#;VariantT cases) + (` (#;VariantT (~ (untemplate-list (map type->syntax cases))))) (#TupleT parts) - (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) + (` (#;TupleT (~ (untemplate-list (map type->syntax parts))))) (#LambdaT in out) - (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) + (` (#;LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) (#BoundT name) - (` (#BoundT (~ (text$ name)))) + (` (#;BoundT (~ (text$ name)))) (#VarT id) - (` (#VarT (~ (int$ id)))) + (` (#;VarT (~ (int$ id)))) (#ExT id) - (` (#ExT (~ (int$ id)))) + (` (#;ExT (~ (int$ id)))) (#AllT env name arg type) (let [env' (: AST @@ -3081,13 +3161,13 @@ (lambda [[label type]] (tuple$ (list (text$ label) (type->syntax type))))) _env)))))))] - (` (#AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) + (` (#;AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) (#AppT fun arg) - (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) + (` (#;AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) (#NamedT [module name] type) - (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type)))))) + (` (#;NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type)))))) (defmacro #export (loop tokens) (case tokens diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux index 8eb87c00b..7898e998d 100644 --- a/source/lux/codata/function.lux +++ b/source/lux/codata/function.lux @@ -26,5 +26,5 @@ ## [Structures] (defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) - (def unit id) - (def ++ .)) + (def m;unit id) + (def m;++ .)) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index de5c40eef..893c74d9e 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -9,8 +9,8 @@ (;import lux (lux (meta macro ast) - (control functor - monad) + (control (functor #as F #refer #all) + (monad #as M #refer #all)) (data list)) (.. function)) @@ -37,13 +37,13 @@ ## [Structs] (defstruct #export Lazy/Functor (Functor Lazy) - (def (map f ma) + (def (F;map f ma) (lambda [k] (ma (. k f))))) (defstruct #export Lazy/Monad (Monad Lazy) - (def _functor Lazy/Functor) + (def M;_functor Lazy/Functor) - (def (wrap a) + (def (M;wrap a) (... a)) - (def join !)) + (def M;join !)) diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux index ee1798793..e91687c3a 100644 --- a/source/lux/codata/reader.lux +++ b/source/lux/codata/reader.lux @@ -7,8 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import (lux #refer (#exclude Reader)) - (lux/control functor - monad)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) ## [Types] (deftype #export (Reader r a) @@ -17,17 +17,17 @@ ## [Structures] (defstruct #export Reader/Functor (All [r] (Functor (Reader r))) - (def (map f fa) + (def (F;map f fa) (lambda [env] (f (fa env))))) (defstruct #export Reader/Monad (All [r] (Monad (Reader r))) - (def _functor Reader/Functor) + (def M;_functor Reader/Functor) - (def (wrap x) + (def (M;wrap x) (lambda [env] x)) - (def (join mma) + (def (M;join mma) (lambda [env] (mma env env)))) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index c6fd8397d..bc9858a29 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -7,8 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control functor - monad)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) ## [Types] (deftype #export (State s a) @@ -16,20 +16,20 @@ ## [Structures] (defstruct #export State/Functor (Functor State) - (def (map f ma) + (def (F;map f ma) (lambda [state] (let [[state' a] (ma state)] [state' (f a)])))) (defstruct #export State/Monad (All [s] (Monad (State s))) - (def _functor State/Functor) + (def M;_functor State/Functor) - (def (wrap x) + (def (M;wrap x) (lambda [state] [state x])) - (def (join mma) + (def (M;join mma) (lambda [state] (let [[state' ma] (mma state)] (ma state'))))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 728adc174..64491eb5c 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -113,14 +113,14 @@ ## [Structures] (defstruct #export Stream/Functor (Functor Stream) - (def (map f fa) + (def (F;map f fa) (let [[h t] (! fa)] (... [(f h) (map f t)])))) (defstruct #export Stream/CoMonad (CoMonad Stream) - (def _functor Stream/Functor) - (def unwrap head) - (def (split wa) + (def CM;_functor Stream/Functor) + (def CM;unwrap head) + (def (CM;split wa) (:: Stream/Functor (F;map repeat wa)))) ## [Pattern-matching] diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index 8f7a3bd13..92f5486ef 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -14,19 +14,19 @@ ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) - (def (= x y) + (def (E;= x y) (if x y (not y)))) (defstruct #export Bool/Show (S;Show Bool) - (def (show x) + (def (S;show x) (if x "true" "false"))) (do-template [ ] [(defstruct #export (m;Monoid Bool) - (def unit ) - (def (++ x y) + (def m;unit ) + (def (m;++ x y) ( x y)))] [ Or/Monoid false or] diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 04579c3a7..b97ec644d 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -13,9 +13,9 @@ ## [Structures] (defstruct #export Char/Eq (E;Eq Char) - (def (= x y) + (def (E;= x y) (_jvm_ceq x y))) (defstruct #export Char/Show (S;Show Char) - (def (show x) + (def (S;show x) ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux index 7388dd786..cb5c309a6 100644 --- a/source/lux/data/error.lux +++ b/source/lux/data/error.lux @@ -17,18 +17,18 @@ ## [Structures] (defstruct #export Error/Functor (Functor Error) - (def (map f ma) + (def (F;map f ma) (case ma (#Fail msg) (#Fail msg) (#Ok datum) (#Ok (f datum))))) (defstruct #export Error/Monad (Monad Error) - (def _functor Error/Functor) + (def M;_functor Error/Functor) - (def (wrap a) + (def (M;wrap a) (#Ok a)) - (def (join mma) + (def (M;join mma) (case mma (#Fail msg) (#Fail msg) (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 58e7360b8..3ad6b056b 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -17,16 +17,16 @@ ## [Structures] (defstruct #export Id/Functor (Functor Id) - (def (map f fa) + (def (F;map f fa) (let [(#Id a) fa] (#Id (f a))))) (defstruct #export Id/Monad (Monad Id) - (def _functor Id/Functor) - (def (wrap a) (#Id a)) - (def (join mma) (let [(#Id ma) mma] ma))) + (def M;_functor Id/Functor) + (def (M;wrap a) (#Id a)) + (def (M;join mma) (let [(#Id ma) mma] ma))) (defstruct #export Id/CoMonad (CoMonad Id) - (def _functor Id/Functor) - (def (unwrap wa) (let [(#Id a) wa] a)) - (def (split wa) (#Id wa))) + (def CM;_functor Id/Functor) + (def (CM;unwrap wa) (let [(#Id a) wa] a)) + (def (CM;split wa) (#Id wa))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index ae71f9f34..f03dbddc6 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -30,16 +30,16 @@ ## [Structures] (defstruct #export IO/Functor (F;Functor IO) - (def (map f ma) + (def (F;map f ma) (io (f (ma []))))) (defstruct #export IO/Monad (M;Monad IO) - (def _functor IO/Functor) + (def M;_functor IO/Functor) - (def (wrap x) + (def (M;wrap x) (io x)) - (def (join mma) + (def (M;join mma) (mma []))) ## [Functions] diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 87afe7fe9..5a8357251 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -258,30 +258,30 @@ (defstruct #export List/Monoid (All [a] (Monoid (List a))) - (def unit #;Nil) - (def (++ xs ys) + (def m;unit #;Nil) + (def (m;++ xs ys) (case xs #;Nil ys (#;Cons [x xs']) (#;Cons [x (++ xs' ys)])))) (defstruct #export List/Functor (Functor List) - (def (map f ma) + (def (F;map f ma) (case ma #;Nil #;Nil (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) (defstruct #export List/Monad (Monad List) - (def _functor List/Functor) + (def M;_functor List/Functor) - (def (wrap a) + (def (M;wrap a) (#;Cons [a #;Nil])) - (def (join mma) + (def (M;join mma) (using List/Monoid (foldL ++ unit mma)))) (defstruct #export PList/Dict (Dict PList) - (def (get k (#PList [eq kvs])) + (def (D;get k (#PList [eq kvs])) (loop [kvs kvs] (case kvs #;Nil @@ -292,7 +292,7 @@ (#;Some v') (recur kvs'))))) - (def (put k v (#PList [eq kvs])) + (def (D;put k v (#PList [eq kvs])) (#PList [eq (loop [kvs kvs] (case kvs #;Nil @@ -303,7 +303,7 @@ (#;Cons [k v] kvs') (#;Cons [k' v'] (recur kvs')))))])) - (def (remove k (#PList [eq kvs])) + (def (D;remove k (#PList [eq kvs])) (#PList [eq (loop [kvs kvs] (case kvs #;Nil @@ -315,18 +315,18 @@ (#;Cons [[k' v'] (recur kvs')]))))]))) (defstruct #export List/Stack (S;Stack List) - (def empty (list)) - (def (empty? xs) + (def S;empty (list)) + (def (S;empty? xs) (case xs #;Nil true _ false)) - (def (push x xs) + (def (S;push x xs) (#;Cons x xs)) - (def (pop xs) + (def (S;pop xs) (case xs #;Nil #;None (#;Cons x xs') (#;Some xs'))) - (def (top xs) + (def (S;top xs) (case xs #;Nil #;None (#;Cons x xs') (#;Some x)))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index e23dbe291..9405c3a60 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -20,26 +20,26 @@ ## (#;Some a))) ## [Structures] -(defstruct #export Maybe/Monoid (Monoid Maybe) - (def unit #;None) - (def (++ xs ys) +(defstruct #export Maybe/Monoid (All [a] (Monoid (Maybe a))) + (def m;unit #;None) + (def (m;++ xs ys) (case xs #;None ys (#;Some x) (#;Some x)))) (defstruct #export Maybe/Functor (Functor Maybe) - (def (map f ma) + (def (F;map f ma) (case ma #;None #;None (#;Some a) (#;Some (f a))))) (defstruct #export Maybe/Monad (Monad Maybe) - (def _functor Maybe/Functor) + (def M;_functor Maybe/Functor) - (def (wrap x) + (def (M;wrap x) (#;Some x)) - (def (join mma) + (def (M;join mma) (case mma #;None #;None (#;Some xs) xs))) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index f3c81ef4e..35c8d34bf 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -18,20 +18,20 @@ ## Number (do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] [(defstruct #export (N;Number ) - (def (+ x y) (<+> x y)) - (def (- x y) (<-> x y)) - (def (* x y) (<*> x y)) - (def (/ x y) ( x y)) - (def (% x y) (<%> x y)) - (def (from-int x) + (def (N;+ x y) (<+> x y)) + (def (N;- x y) (<-> x y)) + (def (N;* x y) (<*> x y)) + (def (N;/ x y) ( x y)) + (def (N;% x y) (<%> x y)) + (def (N;from-int x) ( x)) - (def (negate x) + (def (N;negate x) (<*> <-1> x)) - (def (abs x) + (def (N;abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (signum x) + (def (N;signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else @@ -42,18 +42,18 @@ ## Eq (defstruct #export Int/Eq (E;Eq Int) - (def (= x y) (_jvm_leq x y))) + (def (E;= x y) (_jvm_leq x y))) ## Ord (do-template [ <=> ] [(defstruct #export (O;Ord ) - (def _eq ) - (def (< x y) ( x y)) - (def (<= x y) + (def O;_eq ) + (def (O;< x y) ( x y)) + (def (O;<= x y) (or ( x y) (<=> x y))) - (def (> x y) ( x y)) - (def (>= x y) + (def (O;> x y) ( x y)) + (def (O;>= x y) (or ( x y) (<=> x y))))] @@ -62,16 +62,16 @@ ## Bounded (do-template [ ] [(defstruct #export (B;Bounded ) - (def top ) - (def bottom ))] + (def B;top ) + (def B;bottom ))] [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) ## Monoid (do-template [ <++>] [(defstruct #export (m;Monoid ) - (def unit ) - (def (++ x y) (<++> x y)))] + (def m;unit ) + (def (m;++ x y) (<++> x y)))] [ IntAdd/Monoid Int 0 _jvm_ladd] [ IntMul/Monoid Int 1 _jvm_lmul] @@ -82,7 +82,7 @@ ## Show (do-template [ ] [(defstruct #export (S;Show ) - (def (show x) + (def (S;show x) ))] [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux index 9ba05df62..4f9e4fa5f 100644 --- a/source/lux/data/number/real.lux +++ b/source/lux/data/number/real.lux @@ -18,20 +18,20 @@ ## Number (do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] [(defstruct #export (N;Number ) - (def (+ x y) (<+> x y)) - (def (- x y) (<-> x y)) - (def (* x y) (<*> x y)) - (def (/ x y) ( x y)) - (def (% x y) (<%> x y)) - (def (from-int x) + (def (N;+ x y) (<+> x y)) + (def (N;- x y) (<-> x y)) + (def (N;* x y) (<*> x y)) + (def (N;/ x y) ( x y)) + (def (N;% x y) (<%> x y)) + (def (N;from-int x) ( x)) - (def (negate x) + (def (N;negate x) (<*> <-1> x)) - (def (abs x) + (def (N;abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (signum x) + (def (N;signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else @@ -42,18 +42,18 @@ ## Eq (defstruct #export Real/Eq (E;Eq Real) - (def (= x y) (_jvm_deq x y))) + (def (E;= x y) (_jvm_deq x y))) ## Ord (do-template [ <=> ] [(defstruct #export (O;Ord ) - (def _eq ) - (def (< x y) ( x y)) - (def (<= x y) + (def O;_eq ) + (def (O;< x y) ( x y)) + (def (O;<= x y) (or ( x y) (<=> x y))) - (def (> x y) ( x y)) - (def (>= x y) + (def (O;> x y) ( x y)) + (def (O;>= x y) (or ( x y) (<=> x y))))] @@ -62,16 +62,16 @@ ## Bounded (do-template [ ] [(defstruct #export (B;Bounded ) - (def top ) - (def bottom ))] + (def B;top ) + (def B;bottom ))] [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) ## Monoid (do-template [ <++>] [(defstruct #export (m;Monoid ) - (def unit ) - (def (++ x y) (<++> x y)))] + (def m;unit ) + (def (m;++ x y) (<++> x y)))] [RealAdd/Monoid Real 0.0 _jvm_dadd] [RealMul/Monoid Real 1.0 _jvm_dmul] @@ -82,7 +82,7 @@ ## Show (do-template [ ] [(defstruct #export (S;Show ) - (def (show x) + (def (S;show x) ))] [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 81a642698..d1c06b6a7 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -118,12 +118,12 @@ ## [Structures] (defstruct #export Text/Eq (E;Eq Text) - (def (= x y) + (def (E;= x y) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y]))) (defstruct #export Text/Ord (O;Ord Text) - (def _eq Text/Eq) + (def O;_eq Text/Eq) (do-template [ ] [(def ( x y) @@ -131,17 +131,17 @@ x [y])) 0))] - [< i<] - [<= i<=] - [> i>] - [>= i>=])) + [O;< i<] + [O;<= i<=] + [O;> i>] + [O;>= i>=])) (defstruct #export Text/Show (S;Show Text) - (def show id)) + (def S;show id)) (defstruct #export Text/Monoid (m;Monoid Text) - (def unit "") - (def (++ x y) + (def m;unit "") + (def (m;++ x y) (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y]))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux index 7c6831e85..f71492e35 100644 --- a/source/lux/data/writer.lux +++ b/source/lux/data/writer.lux @@ -18,17 +18,17 @@ ## [Structures] (defstruct #export Writer/Functor (All [l] (Functor (Writer l))) - (def (map f fa) + (def (F;map f fa) (let [[log datum] fa] [log (f datum)]))) (defstruct #export (Writer/Monad mon) (All [l] (-> (Monoid l) (Monad (Writer l)))) - (def _functor Writer/Functor) + (def M;_functor Writer/Functor) - (def (wrap x) + (def (M;wrap x) [(:: mon m;unit) x]) - (def (join mma) + (def (M;join mma) (let [[log1 [log2 a]] mma] [(:: mon (m;++ log1 log2)) a]))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index d1bc4e219..057345622 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -29,7 +29,7 @@ ## [Structures] (defstruct #export Lux/Functor (F;Functor Lux) - (def (map f fa) + (def (F;map f fa) (lambda [state] (case (fa state) (#;Left msg) @@ -39,11 +39,11 @@ (#;Right [state' (f a)]))))) (defstruct #export Lux/Monad (M;Monad Lux) - (def _functor Lux/Functor) - (def (wrap x) + (def M;_functor Lux/Functor) + (def (M;wrap x) (lambda [state] (#;Right [state x]))) - (def (join mma) + (def (M;join mma) (lambda [state] (case (mma state) (#;Left msg) @@ -254,7 +254,7 @@ (let [vname' (ident->text name)] (case state {#;source source #;modules modules - #;envs envs #;types types #;host host + #;envs envs #;type-vars types #;host host #;seed seed #;eval? eval? #;expected expected #;cursor cursor} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) @@ -275,14 +275,14 @@ (-> Ident Compiler (Maybe Type)) (let [[v-prefix v-name] name {#;source source #;modules modules - #;envs envs #;types types #;host host + #;envs envs #;type-vars types #;host host #;seed seed #;eval? eval? #;expected expected #;cursor cursor} state] (case (get v-prefix modules) #;None #;None - (#;Some {#;defs defs #;module-aliases _ #;imports _}) + (#;Some {#;defs defs #;module-aliases _ #;imports _ #;tags _ #;types _}) (case (get v-name defs) #;None #;None @@ -311,7 +311,7 @@ _ (let [{#;source source #;modules modules - #;envs envs #;types types #;host host + #;envs envs #;type-vars types #;host host #;seed seed #;eval? eval? #;expected expected #;cursor cursor} state] (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index f1644cdb5..b9834f972 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -38,7 +38,7 @@ ## [Structures] (defstruct #export Parser/Functor (F;Functor Parser) - (def (map f ma) + (def (F;map f ma) (lambda [tokens] (case (ma tokens) #;None @@ -48,12 +48,12 @@ (#;Some [tokens' (f a)]))))) (defstruct #export Parser/Monad (M;Monad Parser) - (def _functor Parser/Functor) + (def M;_functor Parser/Functor) - (def (wrap x tokens) + (def (M;wrap x tokens) (#;Some [tokens x])) - (def (join mma) + (def (M;join mma) (lambda [tokens] (case (mma tokens) #;None diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3b6a93005..8c88328f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -442,9 +442,10 @@ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) (&/$Cons (&/$Meta _ (&/$TupleS tags)) - (&/$Nil)))) + (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) + (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] - (&&lux/analyse-declare-tags tags*)) + (&&lux/analyse-declare-tags tags* type-name)) (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) (&/$Cons (&/$Meta _ (&/$TextS ?path)) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 8a79e0494..d241201f4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -300,8 +300,8 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= ":" (aget real-name 1)) - ;; (= "type" (aget real-name 1)) + ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; ;; (= "type" (aget real-name 1)) ;; ;; (= &&/$struct r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion) @@ -409,7 +409,7 @@ (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] (|case =value - [(&/$Global ?r-module ?r-name) _] + [(&&/$var (&/$Global ?r-module ?r-name)) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] @@ -418,10 +418,10 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) - :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - _ (println 'DEF (str module-name ";" ?name))]] - (return (&/|list))))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) + _ (println 'DEF (str module-name ";" ?name))]] + (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] @@ -433,28 +433,13 @@ ] (return (&/|list)))) -(defn ensure-undeclared-tags [module tags] - (|do [;; :let [_ (prn 'ensure-undeclared-tags/_0)] - tags-table (&&module/tags-by-module module) - ;; :let [_ (prn 'ensure-undeclared-tags/_1)] - _ (&/map% (fn [tag] - (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) - (return nil))) - tags) - ;; :let [_ (prn 'ensure-undeclared-tags/_2)] - ] - (return nil))) - -(defn analyse-declare-tags [tags] - (|do [;; :let [_ (prn 'analyse-declare-tags/_0)] - module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags/_1)] - _ (ensure-undeclared-tags module-name tags) - ;; :let [_ (prn 'analyse-declare-tags/_2)] - _ (&&module/declare-tags module-name tags) - ;; :let [_ (prn 'analyse-declare-tags/_3)] - ] +(defn analyse-declare-tags [tags type-name] + (|do [module-name &/get-module-name + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] + [_ def-data] (&&module/find-def module-name type-name) + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + def-type (&&module/ensure-type-def def-data) + _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) (defn analyse-import [analyse compile-module compile-token ?path] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 08ad0b9a5..5190e2dcf 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -8,7 +8,8 @@ (ns lux.analyser.module (:refer-clojure :exclude [alias]) - (:require [clojure.string :as string] + (:require (clojure [string :as string] + [template :refer [do-template]]) clojure.core.match clojure.core.match.array (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] @@ -20,7 +21,8 @@ "module-aliases" "defs" "imports" - "tags") + "tags" + "types") (def ^:private +init+ (&/T ;; "lux;module-aliases" (&/|table) @@ -29,7 +31,9 @@ ;; "lux;imports" (&/|list) ;; "lux;tags" - (&/|list) + (&/|table) + ;; "lux;types" + (&/|table) )) ;; [Exports] @@ -46,6 +50,7 @@ nil)))) (defn define [module name def-data type] + ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) @@ -151,6 +156,15 @@ (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) +(defn ensure-type-def [def-data] + "(-> DefData (Lux Type))" + (|case def-data + (&/$TypeD type) + (return type) + + _ + (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data))))) + (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def module name)] (return true)) @@ -250,32 +264,59 @@ (&/set$ &/$envs (&/|list (&/env name)))) nil))) -(defn tags-by-module [module] - "(-> Text (Lux (List (, Text (, Int (List Text))))))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ $tags =module)) - (fail* (str "[Lux Error] Unknown module: " module))) - )) +(do-template [ ] + (defn [module] + + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ =module)) + (fail* (str "[Lux Error] Unknown module: " module))) + )) -(defn declare-tags [module tag-names] - "(-> Text (List Text) (Lux (,)))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] - (return* (&/update$ &/$modules - (fn [=modules] - (&/|update module - #(&/set$ $tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name (&/T idx tags) table))) - (&/get$ $tags %) - (&/enumerate tag-names)) - %) - =modules)) - state) - nil)) - (fail* (str "[Lux Error] Unknown module: " module))))) + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + ) + +(defn ensure-undeclared-tags [module tags] + (|do [tags-table (tags-by-module module) + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (return nil))) + tags)] + (return nil))) + +(defn ensure-undeclared-type [module name] + (|do [types-table (types-by-module module) + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] + (return nil))) + +(defn declare-tags [module tag-names type] + "(-> Text (List Text) Type (Lux (,)))" + (|do [;; :let [_ (prn 'declare-tags (&/->seq tag-names) (&/adt->text type))] + _ (ensure-undeclared-tags module tag-names) + type-name (&type/type-name type) + :let [[_module _name] type-name] + _ (&/assert! (= module _module) + (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) + _ (ensure-undeclared-type _module _name)] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags type) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T tags type)))) + =modules)) + state) + nil)) + (fail* (str "[Lux Error] Unknown module: " module)))))) (defn tag-index [module tag-name] "(-> Text Text (Lux Int))" diff --git a/src/lux/base.clj b/src/lux/base.clj index 44875d1df..84b09bcac 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -86,7 +86,7 @@ "cursor" "modules" "envs" - "types" + "type-vars" "expected" "seed" "eval?" diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 78b9e72f6..0ae4ce2da 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -80,7 +80,13 @@ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) (&/$DataT _) - nil) + nil + + (&/$NamedT ?name ?type) + (prepare-return! *writer* ?type) + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*)))) *writer*)) ;; [Resources] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index a7c5176ad..7e2bc6961 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -84,4 +84,8 @@ (&/$AppT ?fun ?arg) (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + + (&/$NamedT [?module ?name] ?type) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) + (->analysis ?type)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 8ffe77b96..dfd4df23d 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -68,6 +68,7 @@ )) (defn ->java-sig [^objects type] + "(-> Type Text)" (|case type (&/$DataT ?name) (->type-signature ?name) @@ -77,6 +78,12 @@ (&/$TupleT (&/$Nil)) "V" + + (&/$NamedT ?name ?type) + (->java-sig ?type) + + _ + (assert false (str '->java-sig " " (&type/show-type type))) )) (do-template [ ] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index a8b2cfc16..eaa22db20 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -76,10 +76,10 @@ (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) ($Int ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Integer/parseInt ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) ($Real ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Float/parseFloat ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) ($Char ^String ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index e0195658f..e3f95b5f9 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -26,7 +26,7 @@ (fail* "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] line] - more) + more) (|case (body file-name line-num column-num line) ($No msg) (fail* msg) @@ -87,7 +87,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) match)) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] @@ -100,7 +100,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] @@ -113,7 +113,7 @@ (&/V &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] - reader**) + reader**) (if-let [^String match (do ;; (prn 'read-regex+ regex line) (re-find1! regex column-num line))] (let [match-length (.length match) @@ -121,8 +121,8 @@ (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) - reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) + reader**) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] @@ -135,7 +135,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) text)) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") diff --git a/src/lux/type.clj b/src/lux/type.clj index e78b5616a..9f3adb036 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -235,10 +235,10 @@ (def DefData* (All$ empty-env "lux;DefData'" "" (Variant$ (&/|list - ;; "lux;TypeD" - Type ;; "lux;ValueD" (Tuple$ (&/|list Type Unit)) + ;; "lux;TypeD" + Type ;; "lux;MacroD" (Bound$ "") ;; "lux;AliasD" @@ -270,12 +270,18 @@ ;; "lux;imports" (App$ List Text) ;; "lux;tags" - ;; (List (, Text (List Ident))) + ;; (List (, Text (, Int (List Ident) Type))) (App$ List (Tuple$ (&/|list Text (Tuple$ (&/|list Int - (App$ List - Ident)))))) + (App$ List Ident) + Type))))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list (App$ List Ident) + Type))))) )))) (def $Compiler @@ -315,7 +321,7 @@ (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -326,7 +332,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -337,26 +343,26 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$types (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) - ts)) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) + ts)) state) nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$types) (&/get$ &/$mappings) &/|length)))))) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$types) (&/get$ &/$counter))] - (return* (&/update$ &/$types #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) state) id)))) @@ -391,11 +397,11 @@ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/get$ &/$types) (&/get$ &/$mappings)))] + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$types #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings (&/|remove id mappings*))) + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) state) nil))) state)))) @@ -966,3 +972,13 @@ _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) + +(defn type-name [type] + "(-> Type (Lux Ident))" + (|case type + (&/$NamedT name _) + (return name) + + _ + (fail (str "[Type Error] Type is not named: " (show-type type))) + )) -- cgit v1.2.3 From b059fa2a5efb4cab8b62d895e8c9adf1434bde2d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 18 Aug 2015 23:30:50 -0400 Subject: - Tags data is now stored in the cache. - Fixed a caching bug wherein imports data wasn't being installed when loading cached modules. - Fixed a compilation error regarding tags in compile-program. - Refactored the names of fields inside the generated classes, and also the named of the "module class". - Refactored some of the details of how module info is stored inside the fields of module classes. --- src/lux/analyser/module.clj | 30 ++++++++++++++++++++++++++-- src/lux/base.clj | 48 +++++++++++++++++++++++++++++++++------------ src/lux/compiler.clj | 37 +++++++++++++++++++++++----------- src/lux/compiler/base.clj | 10 ++++++++++ src/lux/compiler/cache.clj | 39 ++++++++++++++++++++++++++---------- src/lux/compiler/host.clj | 2 ++ src/lux/compiler/lux.clj | 19 +++++++++--------- src/lux/compiler/module.clj | 28 ++++++++++++++++++++++++++ 8 files changed, 168 insertions(+), 45 deletions(-) create mode 100644 src/lux/compiler/module.clj diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 5190e2dcf..d23953f5e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -49,6 +49,18 @@ state) nil)))) +(defn set-imports [imports] + "(-> (List Text) (Lux (,)))" + (|do [current-module &/get-module-name] + (fn [state] + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) + nil)))) + (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] @@ -89,6 +101,20 @@ (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) (fail* (str "[Analyser Error] Unknown module: " module))))) +(defn type-def [module name] + "(-> Text Text (Lux Type))" + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + [_ (&/$TypeD _type)] + (return* state _type) + + _ + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown module: " module))))) + (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] @@ -179,7 +205,7 @@ ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) - (.getField "_datum") + (.getField &/datum-field) (.get nil))]] (fn [state*] (return* (&/update$ &/$modules @@ -293,7 +319,7 @@ (defn declare-tags [module tag-names type] "(-> Text (List Text) Type (Lux (,)))" - (|do [;; :let [_ (prn 'declare-tags (&/->seq tag-names) (&/adt->text type))] + (|do [;; :let [_ (prn 'declare-tags module (&/->seq tag-names) (&type/show-type type))] _ (ensure-undeclared-tags module tag-names) type-name (&type/type-name type) :let [[_module _name] type-name] diff --git a/src/lux/base.clj b/src/lux/base.clj index 84b09bcac..6247524af 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -61,7 +61,18 @@ "AppT" "NamedT") -;; [Fields] +;; Vars +(deftags "lux;" + "Local" + "Global") + +;; Definitions +(deftags "lux;" + "ValueD" + "TypeD" + "MacroD" + "AliasD") + ;; Binding (deftags "" "counter" @@ -92,19 +103,18 @@ "eval?" "host") -;; Vars -(deftags "lux;" - "Local" - "Global") - -;; Definitions -(deftags "lux;" - "ValueD" - "TypeD" - "MacroD" - "AliasD") - ;; [Exports] +(def datum-field "_datum") +(def meta-field "_meta") +(def name-field "_name") +(def hash-field "_hash") +(def compiler-field "_compiler") +(def imports-field "_imports") +(def defs-field "_defs") +(def eval-field "_eval") +(def tags-field "_tags") +(def module-class-name "_") + (def +name-separator+ ";") (defn T [& elems] @@ -686,6 +696,18 @@ ($Cons ?global _) (return* state (get$ $name ?global))))) +(defn find-module [name] + "(-> Text (Lux (Module Compiler)))" + (fn [state] + (if-let [module (|get name (get$ $modules state))] + (return* state module) + (fail* (str "Unknown module: " name))))) + +(def get-current-module + "(Lux (Module Compiler))" + (|do [module-name get-module-name] + (find-module module-name))) + (defn with-scope [name body] (fn [state] (let [output (body (update$ $envs #(|cons (env name) %) state))] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 1814a97c0..79d2c84f8 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -30,6 +30,7 @@ [case :as &&case] [lambda :as &&lambda] [package :as &&package] + [module :as &&module] [io :as &&io])) (:import (org.objectweb.asm Opcodes Label @@ -378,14 +379,14 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) (doto (.visitEnd))))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitCode *writer*)] _ (compile-expression expr) :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] @@ -395,7 +396,7 @@ _ (&&/save-class! (str id) bytecode) loader &/loader] (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id)) - (.getField "_eval") + (.getField &/eval-field) (.get nil) return)))) @@ -414,9 +415,9 @@ :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/hash-field "I" nil file-hash) .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version) .visitEnd)) ;; _ (prn 'compile-module name =class) ]] @@ -427,22 +428,36 @@ (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports + tag-groups &&module/tag-groups :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/defs-field "Ljava/lang/String;" nil (->> defs (&/|map (fn [_def] (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") + (str (if ?exported &&/exported-true &&/exported-false) + &&/exported-separator + ?name + &&/exported-separator + ?ann)))) + (&/|interpose &&/def-separator) (&/fold str ""))) .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/imports-field "Ljava/lang/String;" nil + (->> imports (&/|interpose &&/import-separator) (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/tags-field "Ljava/lang/String;" nil + (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags (&/|interpose &&/tag-separator) (&/fold str "") + (str type &&/type-separator))))) + (&/|interpose &&/tag-group-separator) + (&/fold str ""))) .visitEnd) (.visitEnd)) ;; _ (prn 'CLOSED name =class) ]] - (&&/save-class! "_" (.toByteArray =class))) + (&&/save-class! &/module-class-name (.toByteArray =class))) ?state) (&/$Left ?message) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 03fae9fec..1e5f3a024 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -33,11 +33,21 @@ (def ^String output-package (str output-dir "/program.jar")) (def ^String function-class "lux/Function") +;; Formats (def ^String local-prefix "l") (def ^String partial-prefix "p") (def ^String closure-prefix "c") (def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") +(def exported-true "1") +(def exported-false "0") +(def exported-separator " ") +(def def-separator "\t") +(def import-separator "\t") +(def tag-separator " ") +(def type-separator "\t") +(def tag-group-separator "\n") + ;; [Utils] (defn ^:private write-file [^String file ^bytes data] (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 85488553c..dc224f52e 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -12,7 +12,7 @@ [clojure.java.io :as io] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |case]] + (lux [base :as & :refer [|do return* return fail fail* |case |let]] [type :as &type] [host :as &host]) (lux.analyser [base :as &a] @@ -88,9 +88,9 @@ class-name (str module* "._") ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= &&/version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + (if (and (= module-hash (get-field &/hash-field module-meta)) + (= &&/version (get-field &/compiler-field module-meta))) + (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator))) ;; _ (prn 'load/IMPORTS module imports) ] (|do [loads (&/map% (fn [_import] @@ -108,24 +108,38 @@ ;; _ (prn 'load module real-name) ] (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator))) + ;; _ (prn module '(get-field &/tags-field module-meta) + ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))) + tag-groups (let [all-tags (get-field &/tags-field module-meta)] + (if (= "" all-tags) + (&/|list) + (-> all-tags + (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) + (->> (map (fn [_group] + ;; (prn '_group _group) + (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] + ;; (prn '[_type _tags] [_type _tags]) + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) + _ (&a-module/set-imports imports) _ (&/map% (fn [_def] (let [[_exported? _name _ann] (string/split _def #" ") ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) ] (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field "_datum" def-class)] + def-value (get-field &/datum-field def-class)] (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field "_datum" def-class)] + def-value (get-field &/datum-field def-class)] (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-meta (get-field "_meta" def-class)] + def-meta (get-field &/meta-field def-class)] (|case def-meta (&/$ValueD def-type _) (&a-module/define module _name def-meta def-type))) @@ -134,13 +148,18 @@ (|do [__type (&a-module/def-type __module __name)] (do ;; (prn '__type [__module __name] (&type/show-type __type)) (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) + (if (= &&/exported-true _exported?) (&a-module/export module _name) (return nil))) )) (if (= [""] defs) (&/|list) - (&/->list defs)))] + (&/->list defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [=type (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags =type)))) + tag-groups)] (return true)))) redo-cache))) redo-cache) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 0ae4ce2da..26ef73cb7 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -571,6 +571,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$Nil) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -616,6 +617,7 @@ (.visitInsn Opcodes/DUP) ;; I2VV (.visitLdcInsn (int 0)) ;; I2VVI (.visitLdcInsn &/$Cons) ;; I2VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; I2V (.visitInsn Opcodes/DUP_X1) ;; IV2V (.visitInsn Opcodes/SWAP) ;; IVV2 diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index e2b9f0e89..83e294c1a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -73,6 +73,7 @@ (return nil))) (defn compile-variant [compile *type* ?tag ?value] + ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) @@ -105,7 +106,7 @@ (defn compile-global [compile *type* ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) &/datum-field "Ljava/lang/Object;")]] (return nil))) (defn compile-apply [compile *type* ?fn ?args] @@ -134,7 +135,7 @@ (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI - (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") ;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN (.visitInsn Opcodes/AASTORE) ;; V )] @@ -173,7 +174,7 @@ :let [_ (doto **writer** (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI - (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") (.visitInsn Opcodes/AASTORE))] :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] (return nil))) @@ -194,19 +195,19 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) current-class nil "java/lang/Object" (into-array [&&/function-class])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_name" "Ljava/lang/String;" nil ?name) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/name-field "Ljava/lang/String;" nil ?name) (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_datum" datum-sig nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/datum-field datum-sig nil nil) (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_meta" datum-sig nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/meta-field datum-sig nil nil) (doto (.visitEnd))))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] _ (compile ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)] + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] _ (compile-def-type compile current-class ?body def-type) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_meta" datum-sig)] + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] :let [_ (doto **writer** (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -216,7 +217,7 @@ _ (&&/save-class! def-name (.toByteArray =class)) class-loader &/loader :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] - _ (&a-module/define module-name ?name (-> def-class (.getField "_meta") (.get nil)) =value-type)] + _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] (return nil))) (defn compile-ann [compile *type* ?value-ex ?type-ex] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj new file mode 100644 index 000000000..db73e8bb4 --- /dev/null +++ b/src/lux/compiler/module.clj @@ -0,0 +1,28 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.module + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]) + [lux.analyser.module :as &module])) + +;; [Exports] +(def tag-groups + "(Lux (List (, Text (List Text))))" + (|do [module &/get-current-module] + (return (&/|map (fn [pair] + (|case pair + [name [tags _]] + (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&/get$ &module/$types module))) + )) -- cgit v1.2.3 From 9606c19f9947c8f2ff5647b4613ac2029ac3881f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 02:54:00 -0400 Subject: - Restructuring how sums & products work [part 1] --- source/lux.lux | 489 +++++++++++++++++----------------- src/lux/analyser.clj | 401 ++++++++++++++-------------- src/lux/analyser/base.clj | 230 ++++++++-------- src/lux/analyser/case.clj | 355 +++++++++++-------------- src/lux/analyser/env.clj | 38 +-- src/lux/analyser/host.clj | 158 +++++------ src/lux/analyser/lambda.clj | 22 +- src/lux/analyser/lux.clj | 255 ++++++++---------- src/lux/analyser/module.clj | 247 ++++++++--------- src/lux/analyser/record.clj | 122 +-------- src/lux/base.clj | 527 +++++++++++++++++++++---------------- src/lux/compiler.clj | 18 +- src/lux/compiler/base.clj | 44 ++-- src/lux/compiler/cache.clj | 8 +- src/lux/compiler/case.clj | 89 ++++--- src/lux/compiler/host.clj | 26 +- src/lux/compiler/lux.clj | 75 +++--- src/lux/compiler/module.clj | 4 +- src/lux/compiler/type.clj | 89 ++++--- src/lux/host.clj | 6 +- src/lux/lexer.clj | 66 ++--- src/lux/parser.clj | 62 ++--- src/lux/reader.clj | 54 ++-- src/lux/type.clj | 627 ++++++++++++++++++++++---------------------- 24 files changed, 1959 insertions(+), 2053 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 4120b262c..7c5fd5c8d 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -11,51 +11,50 @@ ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) ## Basic types -(_lux_def Bool (9 ["lux" "Bool"] - (0 "java.lang.Boolean"))) +(_lux_def Bool (11 ["lux" "Bool"] + (4 "java.lang.Boolean"))) (_lux_export Bool) -(_lux_def Int (9 ["lux" "Int"] - (0 "java.lang.Long"))) +(_lux_def Int (11 ["lux" "Int"] + (4 "java.lang.Long"))) (_lux_export Int) -(_lux_def Real (9 ["lux" "Real"] - (0 "java.lang.Double"))) +(_lux_def Real (11 ["lux" "Real"] + (4 "java.lang.Double"))) (_lux_export Real) -(_lux_def Char (9 ["lux" "Char"] - (0 "java.lang.Character"))) +(_lux_def Char (11 ["lux" "Char"] + (4 "java.lang.Character"))) (_lux_export Char) -(_lux_def Text (9 ["lux" "Text"] - (0 "java.lang.String"))) +(_lux_def Text (11 ["lux" "Text"] + (4 "java.lang.String"))) (_lux_export Text) -(_lux_def Unit (9 ["lux" "Unit"] - (2 (0)))) -(_lux_export Unit) - -(_lux_def Void (9 ["lux" "Void"] - (1 (0)))) +(_lux_def Void (11 ["lux" "Void"] + (0 []))) (_lux_export Void) -(_lux_def Ident (9 ["lux" "Ident"] - (2 (1 Text (1 Text (0)))))) +(_lux_def Unit (11 ["lux" "Unit"] + (1 []))) +(_lux_export Unit) + +(_lux_def Ident (11 ["lux" "Ident"] + (3 Text Text))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons a (List a)))) (_lux_def List - (9 ["lux" "List"] - (7 (1 (0)) "lux;List" "a" - (1 (1 ## "lux;Nil" - (2 (0)) - (1 ## "lux;Cons" - (2 (1 (4 "a") - (1 (8 (4 "lux;List") (4 "a")) - (0)))) - (0))))))) + (11 ["lux" "List"] + (9 (1 (0)) "lux;List" "a" + (2 ## "lux;Nil" + Unit + ## "lux;Cons" + (3 (6 "a") + (10 (6 "lux;List") (6 "a"))) + )))) (_lux_export List) (_lux_declare-tags [#Nil #Cons] List) @@ -63,76 +62,78 @@ ## (| #None ## (1 a))) (_lux_def Maybe - (9 ["lux" "Maybe"] - (7 (1 (0)) "lux;Maybe" "a" - (1 (1 ## "lux;None" - (2 (0)) - (1 ## "lux;Some" - (4 "a") - (0))))))) + (11 ["lux" "Maybe"] + (9 (1 (0)) "lux;Maybe" "a" + (2 ## "lux;None" + Unit + ## "lux;Some" + (6 "a") + )))) (_lux_export Maybe) (_lux_declare-tags [#None #Some] Maybe) ## (deftype #rec Type -## (| (#DataT Text) -## (#VariantT (List Type)) -## (#TupleT (List Type)) +## (| #VoidT +## #UnitT +## (#SumT Type Type) +## (#ProdT Type Type) +## (#DataT Text) ## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) +## (#ExT Int) ## (#AllT (Maybe (List (, Text Type))) Text Text Type) ## (#AppT Type Type) ## (#NamedT Ident Type) -## )) +## )) (_lux_def Type - (9 ["lux" "Type"] - (_lux_case (8 (4 "Type") (4 "_")) - Type - (_lux_case (8 List (2 (1 Text (1 Type (0))))) - TypeEnv - (_lux_case (8 List Type) - TypeList - (8 (7 (1 (0)) "Type" "_" - (1 (1 ## "lux;DataT" - Text - (1 ## "lux;VariantT" - TypeList - (1 ## "lux;TupleT" - TypeList - (1 ## "lux;LambdaT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;BoundT" - Text - (1 ## "lux;VarT" + (11 ["lux" "Type"] + (_lux_case (10 (6 "Type") (6 "_")) + Type + (_lux_case (10 List (3 Text Type)) + TypeEnv + (10 (9 (1 (0)) "Type" "_" + (2 ## lux;VoidT + Unit + (2 ## lux;UnitT + Unit + (2 ## lux;SumT + (3 Type Type) + (2 ## lux;ProdT + (3 Type Type) + (2 ## "lux;DataT" + Text + (2 ## "lux;LambdaT" + (3 Type Type) + (2 ## "lux;BoundT" + Text + (2 ## "lux;VarT" + Int + (2 ## "lux;ExT" Int - (1 ## "lux;ExT" - Int - (1 ## "lux;AllT" - (2 (1 (8 Maybe TypeEnv) (1 Text (1 Text (1 Type (0)))))) - (1 ## "lux;AppT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;NamedT" - (2 (1 Ident (1 Type (0)))) - (0))))))))))))) - Void)))))) + (2 ## "lux;AllT" + (3 (10 Maybe TypeEnv) (3 Text (3 Text Type))) + (2 ## "lux;AppT" + (3 Type Type) + ## "lux;NamedT" + (3 Ident Type))))))))))))) + Void))))) (_lux_export Type) -(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) +(_lux_declare-tags [#VoidT #UnitT #SumT #ProdT #DataT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings (#NamedT ["lux" "Bindings"] - (#AllT [(#Some #Nil) "lux;Bindings" "k" - (#AllT [#None "" "v" - (#TupleT (#Cons ## "lux;counter" - Int - (#Cons ## "lux;mappings" - (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))]) - #Nil)))])]))) + (#AllT (#Some #Nil) "lux;Bindings" "k" + (#AllT #None "" "v" + (#ProdT ## lux;counter + Int + ## lux;mappings + (#AppT List + (#ProdT (#BoundT "k") + (#BoundT "v")))))))) (_lux_export Bindings) (_lux_declare-tags [#counter #mappings] Bindings) @@ -145,17 +146,16 @@ (#NamedT ["lux" "Env"] (#AllT (#Some #Nil) "lux;Env" "k" (#AllT #None "" "v" - (#TupleT (#Cons ## "lux;name" - Text - (#Cons ## "lux;inner-closures" - Int - (#Cons ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v")) - (#Cons ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v")) - #Nil))))))))) + (#ProdT ## "lux;name" + Text + (#ProdT ## "lux;inner-closures" + Int + (#ProdT ## "lux;locals" + (#AppT (#AppT Bindings (#BoundT "k")) + (#BoundT "v")) + ## "lux;closure" + (#AppT (#AppT Bindings (#BoundT "k")) + (#BoundT "v"))))))))) (_lux_export Env) (_lux_declare-tags [#name #inner-closures #locals #closure] Env) @@ -163,7 +163,7 @@ ## (, Text Int Int)) (_lux_def Cursor (#NamedT ["lux" "Cursor"] - (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) + (#ProdT Text (#ProdT Int Int)))) (_lux_export Cursor) ## (deftype (Meta m v) @@ -172,13 +172,9 @@ (#NamedT ["lux" "Meta"] (#AllT (#Some #Nil) "lux;Meta" "m" (#AllT #None "" "v" - (#VariantT (#Cons ## "lux;Meta" - (#TupleT (#Cons (#BoundT "m") - (#Cons (#BoundT "v") - #Nil))) - #Nil)))))) + (#ProdT (#BoundT "m") + (#BoundT "v")))))) (_lux_export Meta) -(_lux_declare-tags [#Meta] Meta) ## (deftype (AST' w) ## (| (#BoolS Bool) @@ -200,29 +196,28 @@ (_lux_case (#AppT [List AST]) ASTList (#AllT (#Some #Nil) "lux;AST'" "w" - (#VariantT (#Cons ## "lux;BoolS" - Bool - (#Cons ## "lux;IntS" - Int - (#Cons ## "lux;RealS" - Real - (#Cons ## "lux;CharS" - Char - (#Cons ## "lux;TextS" - Text - (#Cons ## "lux;SymbolS" - Ident - (#Cons ## "lux;TagS" - Ident - (#Cons ## "lux;FormS" - ASTList - (#Cons ## "lux;TupleS" - ASTList - (#Cons ## "lux;RecordS" - (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) - #Nil) - ))))))))) - )))))) + (#SumT ## "lux;BoolS" + Bool + (#SumT ## "lux;IntS" + Int + (#SumT ## "lux;RealS" + Real + (#SumT ## "lux;CharS" + Char + (#SumT ## "lux;TextS" + Text + (#SumT ## "lux;SymbolS" + Ident + (#SumT ## "lux;TagS" + Ident + (#SumT ## "lux;FormS" + ASTList + (#SumT ## "lux;TupleS" + ASTList + ## "lux;RecordS" + (#AppT List (#ProdT AST AST)) + )))))))) + )))))) (_lux_export AST') (_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') @@ -244,32 +239,30 @@ (#NamedT ["lux" "Either"] (#AllT (#Some #Nil) "lux;Either" "l" (#AllT #None "" "r" - (#VariantT (#Cons ## "lux;Left" - (#BoundT "l") - (#Cons ## "lux;Right" - (#BoundT "r") - #Nil))))))) + (#SumT ## "lux;Left" + (#BoundT "l") + ## "lux;Right" + (#BoundT "r")))))) (_lux_export Either) (_lux_declare-tags [#Left #Right] Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [(#Some #Nil) "lux;StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) + (#AllT (#Some #Nil) "lux;StateE" "s" + (#AllT #None "" "a" + (#LambdaT (#BoundT "s") + (#AppT (#AppT [Either Text]) + (#ProdT (#BoundT "s") + (#BoundT "a"))))))) ## (deftype Source ## (List (Meta Cursor Text))) (_lux_def Source (#NamedT ["lux" "Source"] - (#AppT [List - (#AppT [(#AppT [Meta Cursor]) - Text])]))) + (#AppT List + (#AppT (#AppT Meta Cursor) + Text)))) (_lux_export Source) ## (deftype Host @@ -278,13 +271,12 @@ ## #classes (^ clojure.lang.Atom))) (_lux_def Host (#NamedT ["lux" "Host"] - (#TupleT (#Cons [## "lux;writer" - (#DataT "org.objectweb.asm.ClassWriter") - (#Cons [## "lux;loader" - (#DataT "java.lang.ClassLoader") - (#Cons [## "lux;classes" - (#DataT "clojure.lang.Atom") - #Nil])])])))) + (#ProdT ## "lux;writer" + (#DataT "org.objectweb.asm.ClassWriter") + (#ProdT ## "lux;loader" + (#DataT "java.lang.ClassLoader") + ## "lux;classes" + (#DataT "clojure.lang.Atom"))))) (_lux_declare-tags [#writer #loader #classes] Host) ## (deftype (DefData' m) @@ -295,17 +287,15 @@ (_lux_def DefData' (#NamedT ["lux" "DefData'"] (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [## "lux;ValueD" - (#TupleT (#Cons [Type - (#Cons [Unit - #Nil])])) - (#Cons [## "lux;TypeD" - Type - (#Cons [## "lux;MacroD" - (#BoundT "") - (#Cons [## "lux;AliasD" - Ident - #Nil])])])]))]))) + (#SumT ## "lux;ValueD" + (#ProdT Type + Unit) + (#SumT ## "lux;TypeD" + Type + (#SumT ## "lux;MacroD" + (#BoundT "") + ## "lux;AliasD" + Ident)))]))) (_lux_export DefData') (_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData') @@ -314,11 +304,10 @@ ## (#Global Ident))) (_lux_def LuxVar (#NamedT ["lux" "LuxVar"] - (#VariantT (#Cons [## "lux;Local" - Int - (#Cons [## "lux;Global" - Ident - #Nil])])))) + (#SumT ## "lux;Local" + Int + ## "lux;Global" + Ident))) (_lux_export LuxVar) (_lux_declare-tags [#Local #Global] LuxVar) @@ -331,34 +320,28 @@ ## )) (_lux_def Module (#NamedT ["lux" "Module"] - (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#TupleT (#Cons [## "lux;module-aliases" - (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) - (#Cons [## "lux;defs" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - ASTList])])]) - #Nil])])) - #Nil])]))]) - (#Cons [## "lux;imports" - (#AppT [List Text]) - (#Cons [## "lux;tags" - (#AppT [List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons Int - (#Cons (#AppT [List Ident]) - (#Cons Type - #Nil)))) - #Nil)))]) - (#Cons [## "lux;types" - (#AppT [List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons (#AppT [List Ident]) - (#Cons Type - #Nil))) - #Nil)))]) - #Nil])])])])]))]))) + (#AllT (#Some #Nil) "lux;Module" "Compiler" + (#ProdT ## "lux;module-aliases" + (#AppT List (#ProdT Text Text)) + (#ProdT ## "lux;defs" + (#AppT List (#ProdT Text + (#ProdT Bool + (#AppT DefData' (#LambdaT ASTList + (#AppT (#AppT StateE (#BoundT "Compiler")) + ASTList)))))) + (#ProdT ## "lux;imports" + (#AppT List Text) + (#ProdT ## "lux;tags" + (#AppT List + (#ProdT Text + (#ProdT Int + (#ProdT (#AppT List Ident) + Type)))) + ## "lux;types" + (#AppT List + (#ProdT Text + (#ProdT (#AppT List Ident) + Type)))))))))) (_lux_export Module) (_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) @@ -375,30 +358,28 @@ ## )) (_lux_def Compiler (#NamedT ["lux" "Compiler"] - (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" - (#TupleT (#Cons [## "lux;source" - Source - (#Cons [## "lux;cursor" - Cursor - (#Cons [## "lux;modules" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))]) - (#Cons [## "lux;envs" - (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) - (#Cons [## "lux;type-vars" - (#AppT [(#AppT [Bindings Int]) Type]) - (#Cons [## "lux;expected" - Type - (#Cons [## "lux;seed" - Int - (#Cons [## "lux;eval?" - Bool - (#Cons [## "lux;host" - Host - #Nil])])])])])])])])]))]) - Void]))) + (#AppT (#AllT (#Some #Nil) "lux;Compiler" "" + (#ProdT ## "lux;source" + Source + (#ProdT ## "lux;cursor" + Cursor + (#ProdT ## "lux;modules" + (#AppT List (#ProdT Text + (#AppT Module (#AppT (#BoundT "lux;Compiler") (#BoundT ""))))) + (#ProdT ## "lux;envs" + (#AppT List (#AppT (#AppT [Env Text]) + (#ProdT LuxVar Type))) + (#ProdT ## "lux;type-vars" + (#AppT (#AppT Bindings Int) Type) + (#ProdT ## "lux;expected" + Type + (#ProdT ## "lux;seed" + Int + (#ProdT ## "lux;eval?" + Bool + ## "lux;host" + Host))))))))) + Void))) (_lux_export Compiler) (_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) @@ -426,7 +407,7 @@ (#AppT Meta Cursor)) AST) (_lux_lambda _ data - (#Meta _cursor data)))) + [_cursor data]))) ## (def (return x) ## (All [a] @@ -438,9 +419,8 @@ (#LambdaT (#BoundT "a") (#LambdaT Compiler (#AppT (#AppT Either Text) - (#TupleT (#Cons Compiler - (#Cons (#BoundT "a") - #Nil))))))) + (#ProdT Compiler + (#BoundT "a")))))) (_lux_lambda _ val (_lux_lambda _ state (#Right state val))))) @@ -455,9 +435,8 @@ (#LambdaT Text (#LambdaT Compiler (#AppT (#AppT Either Text) - (#TupleT (#Cons Compiler - (#Cons (#BoundT "a") - #Nil))))))) + (#ProdT Compiler + (#BoundT "a")))))) (_lux_lambda _ msg (_lux_lambda _ state (#Left msg))))) @@ -493,7 +472,7 @@ (_meta (#TupleS tokens))))) (_lux_def record$ - (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST) + (_lux_: (#LambdaT (#AppT List (#ProdT AST AST)) AST) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) @@ -1068,30 +1047,30 @@ ($' Monad Maybe) {#return (lambda' return [x] - (#Some x)) + (#Some x)) #bind (lambda' [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) + (_lux_case ma + #None #None + (#Some a) (f a)))}) (def''' Lux/Monad ($' Monad Lux) {#return (lambda' [x] - (lambda' [state] - (#Right state x))) + (lambda' [state] + (#Right state x))) #bind (lambda' [f ma] - (lambda' [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) + (lambda' [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right state' a) - (f a state'))))}) + (#Right state' a) + (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens @@ -1119,16 +1098,16 @@ (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] - (let' [[var value] binding] - (_lux_case var - (#Meta _ (#TagS "" "let")) - (`' (;let' (~ value) (~ body'))) - - _ - (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (let' [[var value] binding] + (_lux_case var + (#Meta _ (#TagS "" "let")) + (`' (;let' (~ value) (~ body'))) + + _ + (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] (return (list (`' (_lux_case (~ monad) @@ -2483,10 +2462,10 @@ (: (-> AST (Lux AST)) (lambda [token] (case token - (#Meta _ (#SymbolS "" sub-name)) + [_ (#SymbolS "" sub-name)] (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts)))) + (\ [_ (#FormS (list& [_ (#SymbolS "" sub-name)] parts))]) (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ @@ -2500,10 +2479,10 @@ (: (-> AST (Lux (List Import))) (lambda [token] (case token - (#Meta _ (#SymbolS "" m-name)) + [_ (#SymbolS "" m-name)] (wrap (list [m-name #None #All #None])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) + (\ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2848,7 +2827,7 @@ (case tokens (\ (list struct body)) (case struct - (#Meta _ (#SymbolS name)) + [_ (#SymbolS name)] (do Lux/Monad [struct-type (find-var-type name) output (resolve-type-tags struct-type)] @@ -2910,7 +2889,7 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) record)) + (\ (list [_ (#TagS slot')] record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -2952,11 +2931,11 @@ (defmacro #export (open tokens) (case tokens - (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) + (\ (list& [_ (#SymbolS struct-name)] tokens')) (do Lux/Monad [@module get-module-name #let [prefix (case tokens' - (\ (list (#Meta _ (#TextS prefix)))) + (\ (list [_ (#TextS prefix)])) prefix _ @@ -2999,10 +2978,10 @@ (: (-> AST AST (Lux AST)) (lambda [so-far part] (case part - (#Meta _ (#SymbolS slot)) + [_ (#SymbolS slot)] (return (` (get@ (~ (tag$ slot)) (~ so-far)))) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args)))) + (\ [_ (#FormS (list& [_ (#SymbolS slot)] args))]) (return (` ((get@ (~ (tag$ slot)) (~ so-far)) (~@ args)))) @@ -3016,7 +2995,7 @@ (defmacro #export (set@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) value record)) + (\ (list [_ (#TagS slot')] value record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3051,7 +3030,7 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) fun record)) + (\ (list [_ (#TagS slot')] fun record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3086,9 +3065,9 @@ (defmacro #export (\template tokens) (case tokens - (\ (list (#Meta _ (#TupleS data)) - (#Meta _ (#TupleS bindings)) - (#Meta _ (#TupleS templates)))) + (\ (list [_ (#TupleS data)] + [_ (#TupleS bindings)] + [_ (#TupleS templates)])) (case (: (Maybe (List AST)) (do Maybe/Monad [bindings' (map% Maybe/Monad get-name bindings) @@ -3171,7 +3150,7 @@ (defmacro #export (loop tokens) (case tokens - (\ (list (#Meta _ (#TupleS bindings)) body)) + (\ (list [_ (#TupleS bindings)] body)) (let [pairs (as-pairs bindings) vars (map first pairs) inits (map second pairs)] diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8c88328f5..41a59fc00 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |case]] + (lux [base :as & :refer [|let |do return fail return* fail* |case $$]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -23,24 +23,24 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) - (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) - (&/$Cons ?catch-body - (&/$Nil))))))) - (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) - (&/$Cons ?finally-body - (&/$Nil))))) - (return (&/T catch+ (&/V &/$Some ?finally-body))) + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] + (&/$Cons [_ (&/$TextS ?ex-class)] + (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] + (&/$Cons ?catch-body + (&/$Nil))))))] + (return (&/P (&/|++ catch+ (&/|list ($$ &/P ?ex-class ?ex-arg ?catch-body))) finally+)) + + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] + (&/$Cons ?finally-body + (&/$Nil))))] + (return (&/P catch+ (&/Some$ ?finally-body))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private parse-tag [ast] (|case ast - (&/$Meta _ (&/$TagS "" name)) + [_ (&/$TagS "" name)] (return name) _ @@ -49,44 +49,44 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) - (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) - (&/$Cons (&/$Meta _ (&/$IntS ?length)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] + (&/$Cons [_ (&/$SymbolS _ ?class)] + (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) - (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) - (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?fields)] + (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS ?supers)] ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] + (&/$Cons [_ (&/$SymbolS "" ?args)] (&/$Cons ?body (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -97,86 +97,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -185,106 +185,106 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] + (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/P (&/|list) &/None$) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) @@ -295,53 +295,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -351,63 +351,63 @@ (|case token ;; Host special forms ;; Characters - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -418,60 +418,60 @@ (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] + (&/$Cons [_ (&/$SymbolS "" ?self)] + (&/$Cons [_ (&/$SymbolS "" ?arg)] (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) - (&/$Cons (&/$Meta _ (&/$TupleS tags)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] + (&/$Cons [_ (&/$TupleS tags)] + (&/$Cons [_ (&/$SymbolS "" type-name)] (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) - (&/$Cons (&/$Meta _ (&/$TextS ?path)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] + (&/$Cons [_ (&/$TextS ?path)] (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] + (&/$Cons [_ (&/$SymbolS "" ?ident)] (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) - (&/$Cons (&/$Meta _ (&/$TextS ?alias)) - (&/$Cons (&/$Meta _ (&/$TextS ?module)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] + (&/$Cons [_ (&/$TextS ?alias)] + (&/$Cons [_ (&/$TextS ?module)] (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) @@ -483,23 +483,23 @@ ;; Standard special forms (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) @@ -528,20 +528,21 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - (&/$Meta meta ?token) + [meta ?token] (fn [state] - (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - (catch Error e - (prn e) - (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) + (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + ;; (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + ;; (catch Error e + ;; (prn e) + ;; (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) (&/$Right state* output) (return* state* output) (&/$Left "") - (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (fail* (add-loc (&/$get-cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) (&/$Left msg) - (fail* (add-loc (&/get$ &/$cursor state) msg)) + (fail* (add-loc (&/$get-cursor state) msg)) )) )) @@ -553,42 +554,44 @@ [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/T ?output-term ?output-type*))) - (return (&/T ?output-term ?output-type))) + (return (&/P ?output-term ?output-type*))) + (return (&/P ?output-term ?output-type))) [_ _] - (return (&/T ?output-term ?output-type))) + (return (&/P ?output-term ?output-type))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] + ;; (prn 'analyse-ast (&/adt->text token)) ;; (prn 'analyse-ast (&/show-ast token)) - (&/with-cursor (aget token 1 0) - (&/with-expected-type exo-type - (|case token - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - - (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) - (fn [state] - (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - _ - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - _ - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) + (|let [[cursor _] token] + (&/with-cursor cursor + (&/with-expected-type exo-type + (|case token + [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + + [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/P module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + + [meta (&/$FormS (&/$Cons ?fn ?args))] + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index fe1e0d55b..622f0b853 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -13,120 +13,120 @@ [type :as &type]))) ;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) +(deftags + ["bool" + "int" + "real" + "char" + "text" + "unit" + "sum" + "prod" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + ]) ;; [Exports] (defn expr-type [syntax+] @@ -147,4 +147,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/T module* ?name))))) + (return (&/P module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 483002adc..aab25d741 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -9,7 +9,7 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |do return fail |let |case]] + (lux [base :as & :refer [deftags |do return fail |let |case $$]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -18,31 +18,31 @@ [record :as &&record]))) ;; [Tags] -(deftags "" - "DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "TupleTotal" - "VariantTotal" +(deftags + ["DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "ProdTotal" + "SumTotal"] ) -(deftags "" - "StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "TupleTestAC" - "VariantTestAC" +(deftags + ["StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "ProdTestAC" + "SumTestAC"] ) ;; [Utils] (def ^:private unit - (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) + (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS (&/|list)))) (defn ^:private resolve-type [type] (|case type @@ -64,74 +64,66 @@ _ (&type/actual-type type))) -(defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - ;; (prn 'adjust-type* (&type/show-type type)) - (|case type - (&/$AllT _aenv _aname _aarg _abody) - (&type/with-var - (fn [$var] - (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - - (&/$TupleT ?members) - (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&type/Tuple$ (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - (&/$VariantT ?members) - (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V &/$VariantT (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - (&/$AppT ?tfun ?targ) - (|do [=type (&type/apply-type ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$VarT ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##9##")))] - (adjust-type* up type*)) - - (&/$NamedT ?name ?type) - (adjust-type* up ?type) - - _ - (assert false (prn 'adjust-type* (&type/show-type type))) - )) +(let [cleaner (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/S &/$BoundT _aarg))] + (&type/clean* _avar _abody))))] + (defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + ;; (prn 'adjust-type* (&type/show-type type)) + (|case type + (&/$AllT _aenv _aname _aarg _abody) + (&type/with-var + (fn [$var] + (|do [=type (&type/apply-type type $var)] + (adjust-type* (&/Cons$ ($$ &/P _aenv _aname _aarg $var) up) =type)))) + + (&/$SumT ?left ?right) + (|do [=left (&/fold% cleaner ?left up) + =right (&/fold% cleaner ?right up)] + (return (&type/Sum$ =left =right))) + + (&/$ProdT ?left ?right) + (|do [=left (&/fold% cleaner ?left up) + =right (&/fold% cleaner ?right up)] + (return (&type/Prod$ =left =right))) + + (&/$AppT ?tfun ?targ) + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + _ + (assert false (prn 'adjust-type* (&type/show-type type))) + ))) (defn adjust-type [type] "(-> Type (Lux Type))" (adjust-type* (&/|list) type)) +(defn ^:private resolve-tag [tag type] + (|do [[=module =name] (&&/resolved-ident tag) + type* (adjust-type type) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/variant-case idx type*)] + (return ($$ &/P idx (&/|length group) case-type)))) + (defn ^:private analyse-pattern [value-type pattern kont] - (|let [(&/$Meta _ pattern*) pattern] + (|let [[_ pattern*] pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/T (&/V $StoreTestAC idx) =kont))) + (return (&/P (&/S $StoreTestAC idx) =kont))) (&/$SymbolS ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) @@ -139,194 +131,152 @@ (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/T (&/V $BoolTestAC ?value) =kont))) + (return (&/P (&/S $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/T (&/V $IntTestAC ?value) =kont))) + (return (&/P (&/S $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/T (&/V $RealTestAC ?value) =kont))) + (return (&/P (&/S $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/T (&/V $CharTestAC ?value) =kont))) + (return (&/P (&/S $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/T (&/V $TextTestAC ?value) =kont))) + (return (&/P (&/S $TextTestAC ?value) =kont))) - (&/$TupleS ?members) + (&/$TupleS (&/$Cons ?_left ?tail)) (|do [value-type* (adjust-type value-type)] - (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (|case value-type* - (&/$TupleT ?member-types) - (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont))))) - - _ - (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - - (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs) - ;; :let [_ (prn 'PRE (&type/show-type value-type))] - value-type* (adjust-type value-type) - ;; :let [_ (prn 'POST (&type/show-type value-type*))] - ;; value-type* (resolve-type value-type) - ] (|case value-type* - (&/$TupleT ?member-types) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont)))) + (&/$ProdT ?left ?right) + (|do [[=left [=right =kont]] (analyse-pattern ?left ?_left + (|do [[=right =kont] (|case ?tail + (&/$Cons ?_right (&/$Nil)) + (analyse-pattern ?right ?_right kont) + + (&/$Nil) + (fail "[Pattern-matching Error] Pattern-matching mismatch. Tuple has wrong size.") + + _ + (analyse-pattern ?right (&/S &/$TupleS ?tail) kont))] + (return (&/P =right =kont))))] + (return (&/P (&/S $ProdTestAC =left =right) =kont))) _ - (fail "[Pattern-matching Error] Record requires record-type."))) + (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*))))) + + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs)] + (analyse-pattern value-type (&/S &/$TupleS ?members) kont)) (&/$TagS ?ident) - (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] - [=module =name] (&&/resolved-ident ?ident) - ;; :let [_ (println "#01")] - value-type* (adjust-type value-type) - ;; :let [_ (println "#02")] - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - ;; :let [_ (println "#03")] - case-type (&type/variant-case idx value-type*) - ;; :let [_ (println "#04")] - [=test =kont] (analyse-pattern case-type unit kont) - ;; :let [_ (println "#05")] - ] - (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + (|do [[idx group-count case-type] (resolve-tag ?ident value-type) + [=test =kont] (analyse-pattern case-type unit kont)] + (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) - (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] - [=module =name] (&&/resolved-ident ?ident) - ;; :let [_ (println "#11")] - value-type* (adjust-type value-type) - ;; :let [_ (println "#12" (&type/show-type value-type*))] - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - ;; :let [_ (println "#13")] - case-type (&type/variant-case idx value-type*) - ;; :let [_ (println "#14" (&type/show-type case-type))] + (|do [[idx group-count case-type] (resolve-tag ?ident value-type) [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) + (analyse-pattern case-type (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS ?values)) kont)) ;; :let [_ (println "#15")] ] - (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/|cons pattern+body patterns)))) + (return (&/Cons$ pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return (&/V $DefaultTotal true)) + (return (&/S $DefaultTotal true)) [[?tag [total? ?values]] ($StoreTestAC ?idx)] - (return (&/V ?tag (&/T true ?values))) + (return (&/S ?tag (&/P true ?values))) [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) + (return (&/S $BoolTotal (&/P total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $BoolTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|list ?value)))) + (return (&/S $IntTotal (&/P total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $IntTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|list ?value)))) + (return (&/S $RealTotal (&/P total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $RealTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|list ?value)))) + (return (&/S $CharTotal (&/P total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $CharTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/|list ?value)))) + (return (&/S $TextTotal (&/P total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) - - [($DefaultTotal total?) ($TupleTestAC ?tests)] - (|do [structs (&/map% (fn [t] - (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) - ?tests)] - (return (&/V $TupleTotal (&/T total? structs)))) - - [($TupleTotal total? ?values) ($TupleTestAC ?tests)] - (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map2% (fn [v t] - (merge-total v (&/T t ?body))) - ?values ?tests)] - (return (&/V $TupleTotal (&/T total? structs)))) - (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - - [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (&/V $DefaultTotal total?) - (&/T ?test ?body)) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) + (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) + + [($DefaultTotal total?) ($ProdTestAC ?left ?right)] + (|do [:let [_default (&/S $DefaultTotal total?)] + =left (merge-total _default (&/P ?left ?body)) + =right (merge-total _default (&/P ?right ?body))] + (return (&/S $ProdTotal ($$ &/P total? =left =right)))) + + [($ProdTotal total? ?_left ?_right) ($ProdTestAC ?left ?right)] + (|do [=left (merge-total ?_left (&/P ?left ?body)) + =right (merge-total ?_right (&/P ?right ?body))] + (return (&/S $ProdTotal ($$ &/P total? =left =right)))) + + [($DefaultTotal total?) ($SumTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (&/S $DefaultTotal total?) + (&/P ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/S $DefaultTotal total?))) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T total? structs)))) + (return (&/S $SumTotal (&/P total? structs)))) - [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + [($SumTotal total? ?branches) ($SumTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) (&/$Some sub) sub (&/$None) - (&/V $DefaultTotal total?)) - (&/T ?test ?body)) + (&/S $DefaultTotal total?)) + (&/P ?test ?body)) structs (|case (&/|list-put ?tag sub-struct ?branches) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T total? structs)))) + (return (&/S $SumTotal (&/P total? structs)))) )))) (defn ^:private check-totality [value-type struct] @@ -351,33 +301,36 @@ ($TextTotal ?total _) (return ?total) - ($TupleTotal ?total ?structs) + ($ProdTotal ?total ?_left ?_right) (if ?total (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$TupleT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (&/$ProdT ?left ?right) + (|do [=left (check-totality ?left ?_left) + =right (check-totality ?right ?_right)] + (return (and =left =right))) _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ($VariantTotal ?total ?structs) + ($SumTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$VariantT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - ;; (prn '$VariantTotal - ;; (&/adt->text sub-struct) - ;; (&type/show-type ?member)) - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (|case [value-type* ?structs] + [(&/$SumT ?left ?right) (&/$Cons ?_left ?tail)] + (|do [=left (check-totality ?left ?_left) + =right (|case ?tail + (&/$Cons ?_right (&/$Nil)) + (check-totality ?right ?_right) + + (&/$Nil) + (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.") + + _ + (check-totality ?right ($SumTotal ?total ?tail)))] + (return (and =left =right))) _ (fail "[Pattern-maching Error] Variant is not total.")))) @@ -394,7 +347,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) + struct (&/fold% merge-total (&/S $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 4e9dcd79f..5686700e3 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,31 +15,31 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) + (return* state (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) - =return (body (&/update$ &/$envs - (fn [stack] - (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] - (&/|cons (&/update$ &/$locals #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) - (&/|head stack)) - (&/|tail stack)))) - state))] + (let [old-mappings (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-mappings)) + =return (body (&/$update-envs + (fn [stack] + (let [bound-unit (&/S &&/$var (&/S &/$Local (->> (&/|head stack) (&/$get-locals) (&/$get-counter))))] + (&/Cons$ (&/$update-locals #(->> % + (&/$update-counter inc) + (&/$update-mappings (fn [m] (&/|put name (&/P bound-unit type) m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] (|case =return (&/$Right ?state ?value) - (return* (&/update$ &/$envs (fn [stack*] - (&/|cons (&/update$ &/$locals #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) + (return* (&/$update-envs (fn [stack*] + (&/Cons$ (&/$update-locals #(->> % + (&/$update-counter dec) + (&/$set-mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) ?value) _ @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) + (return* state (->> state (&/$get-envs) &/|head (&/$get-closure) (&/$get-mappings))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 64f297994..69aa95f12 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case]] + (lux [base :as & :refer [|let |do return fail |case $$]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -20,7 +20,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - (&/$Meta _ (&/$TextS ?text)) + [_ (&/$TextS ?text)] (return ?text) _ @@ -32,7 +32,7 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (return (&/P ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -47,20 +47,20 @@ "(-> Type Type)" (|case type (&/$DataT class) - (&/V &/$DataT (&type/as-obj class)) + (&type/Data$ (&type/as-obj class)) _ type)) ;; [Resources] (do-template [ ] - (let [input-type (&/V &/$DataT ) - output-type (&/V &/$DataT )] + (let [input-type (&type/Data$ ) + output-type (&type/Data$ )] (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) + (return (&/|list (&/P (&/S (&/P =x =y)) output-type)))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -108,7 +108,7 @@ =type (&host/lookup-static-field class-loader ?class ?field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-getstatic (&/P ?class ?field)) output-type))))) (defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] (|do [class-loader &/loader @@ -116,7 +116,7 @@ =object (&&/analyse-1 analyse ?object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-getfield ($$ &/P ?class ?field =object)) output-type))))) (defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] (|do [class-loader &/loader @@ -124,7 +124,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-putstatic ($$ &/P ?class ?field =value)) output-type))))) (defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] (|do [class-loader &/loader @@ -133,7 +133,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-putfield ($$ &/P ?class ?field =object =value)) output-type))))) (defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] (|do [class-loader &/loader @@ -143,31 +143,31 @@ ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) + (&&/analyse-1 analyse (&type/Data$ _class) _arg)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-invokestatic ($$ &/P ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-instanceof (&/P ?class =object)) output-type))))) (do-template [ ] (defn [analyse exo-type ?class ?method ?classes ?object ?args] (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/P (&/S ($$ &/P ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface @@ -179,73 +179,73 @@ =return (if (= "" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-invokespecial ($$ &/P ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V &/$DataT "null")] + (|do [:let [output-type (&type/Data$ "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&/V &/$DataT ?class)] + :let [output-type (&type/Data$ ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-new ($$ &/P ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) - (&/V &/$Nil nil))))))) + (return (&/|list (&/P (&/S &&/$jvm-new-array (&/P ?class ?length)) (&/S "array" (&/P (&type/Data$ ?class) + (&/S &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) + (return (&/|list (&/P (&/S &&/$jvm-aastore ($$ &/P =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) + (return (&/|list (&/P (&/S &&/$jvm-aaload (&/P =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - (&/$Meta _ (&/$TextS "public")) + [_ (&/$TextS "public")] (return (assoc so-far :visibility "public")) - (&/$Meta _ (&/$TextS "private")) + [_ (&/$TextS "private")] (return (assoc so-far :visibility "private")) - (&/$Meta _ (&/$TextS "protected")) + [_ (&/$TextS "protected")] (return (assoc so-far :visibility "protected")) - (&/$Meta _ (&/$TextS "static")) + [_ (&/$TextS "static")] (return (assoc so-far :static? true)) - (&/$Meta _ (&/$TextS "final")) + [_ (&/$TextS "final")] (return (assoc so-far :final? true)) - (&/$Meta _ (&/$TextS "abstract")) + [_ (&/$TextS "abstract")] (return (assoc so-far :abstract? true)) - (&/$Meta _ (&/$TextS "synchronized")) + [_ (&/$TextS "synchronized")] (return (assoc so-far :concurrency "synchronized")) - (&/$Meta _ (&/$TextS "volatile")) + [_ (&/$TextS "volatile")] (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) - (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) - (&/$Nil)))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Nil)))))] (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -289,18 +289,18 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) - (&/$Cons ?method-body - (&/$Nil))))))))] + [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?method-inputs)] + (&/$Cons [_ (&/$TextS ?method-output)] + (&/$Cons [_ (&/$TupleS ?method-modifiers)] + (&/$Cons ?method-body + (&/$Nil)))))))]] (|do [=method-inputs (&/map% (fn [minput] (|case minput - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) - (&/$Nil))))) - (return (&/T ?input-name ?input-type)) + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] + (&/$Cons [_ (&/$TextS ?input-type)] + (&/$Nil))))] + (return (&/P ?input-name ?input-type)) _ (fail "[Analyser Error] Wrong syntax for method input."))) @@ -309,14 +309,14 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&/V &/$DataT (as-otype itype)) + (&&env/with-local iname (&type/Data$ (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/|cons (&/T ";this" ?super-class) + (&/Cons$ (&/P "this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers @@ -327,18 +327,18 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/S &&/$jvm-class ($$ &/P ?name ?super-class =interfaces =fields =methods)))] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) - (&/$Nil))))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?inputs)] + (&/$Cons [_ (&/$TextS ?output)] + (&/$Cons [_ (&/$TupleS ?modifiers)] + (&/$Nil))))))] (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -349,29 +349,29 @@ _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) - _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] + _ (compile-token (&/S &&/$jvm-interface ($$ &/P ?name =supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] - (return (&/T ?ex-class idx =catch-body)))) + (return ($$ &/P ?ex-class idx =catch-body)))) ?catches) - =finally (|case [?finally] - (&/$None) (return (&/V &/$None nil)) + =finally (|case ?finally + (&/$None) (return &/None$) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V &/$Some =finally))))] - (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) + (return (&/Some$ =finally))))] + (return (&/|list (&/P (&/S &&/$jvm-try ($$ &/P =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) + _ (&type/check (&type/Data$ "java.lang.Throwable") _type)] + (return (&/|list (&/P (&/S &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] (defn [analyse exo-type ?monitor] @@ -379,18 +379,18 @@ _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =monitor) output-type))))) + (return (&/|list (&/P (&/S =monitor) output-type))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [ ] - (let [output-type (&/V &/$DataT )] + (let [output-type (&type/Data$ )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ ) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =value) output-type)))))) + (return (&/|list (&/P (&/S =value) output-type)))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -413,11 +413,11 @@ ) (do-template [ ] - (let [output-type (&/V &/$DataT )] + (let [output-type (&type/Data$ )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ ) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =value) output-type)))))) + (return (&/|list (&/P (&/S =value) output-type)))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V &&/$jvm-program =body))] + (&&env/with-local ?args (&type/App$ &type/List &type/Text) + (&&/analyse-1 analyse (&type/App$ &type/IO &type/Unit) ?body))) + _ (compile-token (&/S &&/$jvm-program =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index aeb5a4814..696c816e9 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -9,7 +9,7 @@ (ns lux.analyser.lambda (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case]] + (lux [base :as & :refer [|let |do return fail |case $$]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -22,15 +22,19 @@ (&env/with-local arg arg-type (|do [=return body =captured &env/captured-vars] - (return (&/T scope-name =captured =return)))))))) + (return ($$ &/P scope-name =captured =return)))))))) (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/T (&/V &&/$captured (&/T scope - (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) - register)) + register* (&/P (&/S &&/$captured ($$ &/P scope + (->> frame (&/$get-closure) (&/$get-counter)) + register)) register-type)] - (&/T register* (&/update$ &/$closure #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) - frame)))) + (do (prn 'close-over 'updating-closure + [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] + [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) + (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) + ($$ &/P register* (&/$update-closure #(->> % + (&/$update-counter inc) + (&/$update-mappings (fn [mps] (&/|put name register* mps)))) + frame))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index d241201f4..f7ed07ee4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case $$]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -27,52 +27,64 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (return (&/P ?item =type)))))) (defn ^:private with-cursor [cursor form] (|case form - (&/$Meta _ syntax) - (&/V &/$Meta (&/T cursor syntax)))) + [_ syntax] + (&/P cursor syntax))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$TupleT ?members) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) - - (&/$AllT _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) - - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) - -(defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [output (|case ?values - (&/$Nil) - (analyse-tuple analyse exo-type (&/|list)) - - (&/$Cons ?value (&/$Nil)) - (analyse exo-type ?value) + ;; (prn 'analyse-tuple/_0 (&type/show-type exo-type) (->> ?elems (&/|map &/show-ast) (&/->seq))) + (|case ?elems + (&/$Nil) + (|do [_ (&type/check exo-type &type/Unit)] + (return (&/|list (&/P (&/S &&/$unit nil) + exo-type)))) + + (&/$Cons single (&/$Nil)) + (fail (str "Tuples can't have only 1 element: " (&/show-ast single))) + + (&/$Cons head tail) + (|do [exo-type* (&type/actual-type exo-type) + ;; :let [_ (prn 'analyse-tuple/_0.25_0 (&/show-ast head) (&/adt->text exo-type*)) + ;; _ (prn 'analyse-tuple/_0.25_1 (&/show-ast head) (&type/show-type exo-type*))] + ] + (|case exo-type* + (&/$ProdT ?left ?right) + (|do [;; :let [_ (prn 'analyse-tuple/_0.5 (&/show-ast head) (&type/show-type ?left))] + =left (&&/analyse-1 analyse ?left head) + ;; :let [_ (prn 'analyse-tuple/_1 =left (&type/show-type ?left))] + =right (|case tail + (&/$Nil) + (fail "Tuples has wrong size.") + + (&/$Cons single (&/$Nil)) + (&&/analyse-1 analyse ?right single) + + _ + (&/ensure-1 (analyse-tuple analyse ?right tail))) + ;; :let [_ (prn 'analyse-tuple/_2 =right (&type/show-type ?right))] + ] + (return (&/|list (&/P (&/S &&/$prod (&/P =left =right)) + exo-type)))) - _ - (analyse-tuple analyse exo-type ?values) - )] - (|case output - (&/$Cons x (&/$Nil)) - (return x) + (&/$AllT _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - _ - (fail "[Analyser Error] Can't expand to other than 1 element.")))) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))) + )) (defn analyse-variant [analyse exo-type idx ?values] + ;; (prn 'analyse-variant/_0 + ;; (&type/show-type exo-type) + ;; idx + ;; (->> ?values (&/|map &/show-ast) (&/->seq))) (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -83,82 +95,41 @@ _ (&type/actual-type exo-type))] (|case exo-type* - (&/$VariantT ?cases) - (|case (&/|at idx ?cases) - (&/$Some vtype) - (|do [=value (analyse-variant-body analyse vtype ?values)] - (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) - exo-type)))) - - (&/$None) - (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) - (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** idx ?values)))) - - _ - (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) -;; (defn analyse-variant [analyse exo-type ident ?values] -;; (|do [exo-type* (|case exo-type -;; (&/$VarT ?id) -;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] -;; (&type/actual-type exo-type*)) -;; (|do [_ (&type/set-var ?id &type/Type)] -;; (&type/actual-type &type/Type)))) - -;; _ -;; (&type/actual-type exo-type))] -;; (|case exo-type* -;; (&/$VariantT ?cases) -;; (|do [?tag (&&/resolved-ident ident)] -;; (if-let [vtype (&/|get ?tag ?cases)] -;; (|do [=value (analyse-variant-body analyse vtype ?values)] -;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) -;; exo-type)))) -;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - -;; (&/$AllT _) -;; (&type/with-var -;; (fn [$var] -;; (|do [exo-type** (&type/apply-type exo-type* $var)] -;; (analyse-variant analyse exo-type** ident ?values)))) - -;; _ -;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) -(defn analyse-record [analyse exo-type ?elems] - (|do [exo-type* (|case exo-type - (&/$VarT ?id) - (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - - (&/$AllT _) - (|do [$var &type/existential - =type (&type/apply-type exo-type $var)] - (&type/actual-type =type)) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [=type (&type/apply-type exo-type $var)] - ;; (&type/actual-type =type)))) + ?variant + (|do [;; :let [_ (prn 'analyse-variant/_1 + ;; (&type/show-type ?variant) + ;; idx + ;; (->> ?values (&/|map &/show-ast) (&/->seq)))] + vtype (&type/variant-case idx ?variant) + ;; :let [_ (prn 'analyse-variant/_2 + ;; idx + ;; (&type/show-type vtype))] + =value (&/ensure-1 (|case ?values + (&/$Nil) + (analyse-tuple analyse vtype (&/|list)) + + (&/$Cons ?value (&/$Nil)) + (analyse vtype ?value) + + _ + (analyse-tuple analyse vtype ?values))) + ;; :let [_ (prn 'analyse-variant/_3 + ;; idx + ;; =value)] + ] + (return (&/|list (&/P (&/S &&/$sum (&/P idx =value)) + exo-type)))) + ))) - _ - (&type/actual-type exo-type)) - types (|case exo-type* - (&/$TupleT ?table) - (return ?table) - - _ - (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) - _ (&/assert! (= (&/|length types) (&/|length ?elems)) - (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) - members (&&record/order-record ?elems) - =members (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - types members)] - (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) +(defn analyse-record [analyse exo-type ?elems] + (|do [members (&&record/order-record ?elems)] + (analyse-tuple analyse exo-type members))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -177,14 +148,17 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/get$ &/$envs state) - no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) - (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) + (|let [stack (&/$get-envs state) + no-binding? #(do ;; (prn 'analyse-local/_ (->> % &/adt->text)) + ;; (prn 'analyse-local/_1 (->> % (&/$get-locals) &/adt->text)) + ;; (prn 'analyse-local/_2 (->> % (&/$get-closure) &/adt->text)) + (and (->> % (&/$get-locals) (&/$get-mappings) (&/|contains? name) not) + (->> % (&/$get-closure) (&/$get-mappings) (&/|contains? name) not))) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -193,8 +167,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/$get-locals) (&/$get-mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/$get-locals) (&/$get-mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -213,32 +187,31 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) endo-type)))) state) - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) (fail* "_{_ analyse-symbol _}_"))) (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) - (&/|map #(&/get$ &/$name %) outer) + (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/$get-name %2) %1) + (&/|map #(&/$get-name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) - (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) + (&/P register* (&/Cons$ frame* new-inner)))) + (&/P (or (->> top-outer (&/$get-locals) (&/$get-mappings) (&/|get name)) + (->> top-outer (&/$get-closure) (&/$get-mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/set$ &/$envs (&/|++ inner* outer) state)))) + (&/$set-envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -253,7 +226,7 @@ (|case ?args (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/T fun-type (&/|list)))) + (return (&/P fun-type (&/|list)))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -271,15 +244,15 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/S &/$BoundT _aarg))] (&type/clean $var =output-t)))] - (return (&/T type** =args))) + (return (&/P type** =args))) )))) (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/T =output-t (&/|cons =arg =args)))) + (return (&/P =output-t (&/Cons$ =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -313,12 +286,12 @@ _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) + (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) + (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) =output-t))))) ))) @@ -329,7 +302,7 @@ =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) + (return (&/|list (&/P (&/S &&/$case (&/P =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -348,7 +321,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) + (return (&/P (&/S &&/$lambda ($$ &/P =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -370,22 +343,22 @@ ] (|case dtype (&/$BoundT ?vname) - (return (&/T _expr exo-type)) + (return (&/P _expr exo-type)) (&/$ExT _) - (return (&/T _expr exo-type)) + (return (&/P _expr exo-type)) (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] - ;; (return (&/T _expr exo-type)) + ;; (return (&/P _expr exo-type)) (if ?? (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) - (return (&/T _expr exo-type))) + (return (&/P _expr exo-type))) ) _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) - (return (&/T _expr exo-type)))))))) + (return (&/P _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] @@ -418,7 +391,7 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + (|do [_ (compile-token (&/S &&/$def (&/P ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) @@ -428,16 +401,16 @@ (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] module-name &/get-module-name ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) + _ (compile-token (&/S &&/$declare-macro (&/P module-name ?name))) ;; :let [_ (prn 'analyse-declare-macro ?name "2")] ] (return (&/|list)))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) @@ -469,7 +442,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) + (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -477,5 +450,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (analyse-1+ analyse ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) + (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index d23953f5e..909e7e2c4 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -12,69 +12,70 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] + (lux [base :as & :refer [defrtags |let |do return return* fail fail* |case $$]] [type :as &type] [host :as &host]))) ;; [Utils] -(deftags "" - "module-aliases" - "defs" - "imports" - "tags" - "types") +(defrtags + ["module-aliases" + "defs" + "imports" + "tags" + "types"]) (def ^:private +init+ - (&/T ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - (&/|list) - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) - )) + ($$ &/P + ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + (&/|list) + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + )) ;; [Exports] (defn add-import [module] "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/update$ &/$modules - (fn [ms] - (&/|update current-module - (fn [m] (&/update$ $imports (partial &/|cons module) m)) - ms)) - state) + (return* (&/$update-modules + (fn [ms] + (&/|update current-module + (fn [m] ($update-imports (partial &/Cons$ module) m)) + ms)) + state) nil)))) (defn set-imports [imports] "(-> (List Text) (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/update$ &/$modules - (fn [ms] - (&/|update current-module - (fn [m] (&/set$ $imports imports m)) - ms)) - state) + (return* (&/$update-modules + (fn [ms] + (&/|update current-module + (fn [m] ($set-imports imports m)) + ms)) + state) nil)))) (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] - (|case (&/get$ &/$envs state) + (|case (&/$get-envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T false def-data) %) - m)) - ms)))) + (&/$update-modules + (fn [ms] + (&/|update module + (fn [m] + ($update-defs + #(&/|put name (&/P false def-data) %) + m)) + ms)))) nil) _ @@ -83,8 +84,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (if-let [$module (->> state (&/$get-modules) (&/|get module))] + (if-let [$def (->> $module ($get-defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -104,31 +105,31 @@ (defn type-def [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (if-let [$module (->> state (&/$get-modules) (&/|get module))] + (if-let [$def (->> $module ($get-defs) (&/|get name))] (|case $def [_ (&/$TypeD _type)] (return* state _type) _ - (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) - (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/P module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/P module name))))) (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/get$ &/$envs state) + (|case (&/$get-envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update a-module - (fn [m] - (&/update$ $defs - #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) - m)) - ms)))) + (&/$update-modules + (fn [ms] + (&/|update a-module + (fn [m] + ($update-defs + #(&/|put a-name (&/P false (&/S &/$AliasD (&/P r-module r-name))) %) + m)) + ms)))) nil) _ @@ -137,26 +138,30 @@ (defn exists? [name] "(-> Text (Lux Bool))" (fn [state] + ;; (prn 'exists?/_0 &/$modules name) + ;; (prn 'exists?/_2 (&/adt->text state)) + ;; (prn 'exists?/_3 (&/adt->text (->> state (&/$get-modules)))) + ;; (prn 'exists?/_4 (&/adt->text (->> state (&/$get-modules) (&/|contains? name)))) (return* state - (->> state (&/get$ &/$modules) (&/|contains? name))))) + (->> state (&/$get-modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - #(&/update$ $module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) + (&/$update-modules + (fn [ms] + (&/|update module + #($update-module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) nil))) (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] + (if-let [real-name (->> state (&/$get-modules) (&/|get current-module) ($get-module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -164,9 +169,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$module (->> state (&/$get-modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (if-let [$def (->> $module ($get-defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -177,7 +182,7 @@ state)) _ - (return* state (&/T (&/T module name) $$def))) + (return* state (&/P (&/P module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) @@ -198,7 +203,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] + (if-let [$module (->> state (&/$get-modules) (&/|get module) ($get-defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -208,15 +213,15 @@ (.getField &/datum-field) (.get nil))]] (fn [state*] - (return* (&/update$ &/$modules - (fn [$modules] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) - m)) - $modules)) - state*) + (return* (&/$update-modules + (fn [$modules] + (&/|update module + (fn [m] + ($update-defs + #(&/|put name (&/P exported? (&/S &/$MacroD macro)) %) + m)) + $modules)) + state*) nil))) state) @@ -230,21 +235,21 @@ (defn export [module name] (fn [state] - (|case (&/get$ &/$envs state) + (|case (&/$get-envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] + (if-let [$def (->> state (&/$get-modules) (&/|get module) ($get-defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/update$ &/$modules (fn [ms] - (&/|update module (fn [m] - (&/update$ $defs - #(&/|put name (&/T true ?data) %) - m)) - ms)))) + (&/$update-modules (fn [ms] + (&/|update module (fn [m] + ($update-defs + #(&/|put name (&/P true ?data) %) + m)) + ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) @@ -260,61 +265,61 @@ (do ;; (prn 'defs k ?exported?) (|case ?def (&/$AliasD ?r-module ?r-name) - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + ($$ &/P ?exported? k (str "A" ?r-module ";" ?r-name)) (&/$MacroD _) - (&/T ?exported? k "M") + ($$ &/P ?exported? k "M") (&/$TypeD _) - (&/T ?exported? k "T") + ($$ &/P ?exported? k "T") _ - (&/T ?exported? k "V"))))) - (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) + ($$ &/P ?exported? k "V"))))) + (->> state (&/$get-modules) (&/|get module) ($get-defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) + (return* state (->> state (&/$get-modules) (&/|get module) ($get-imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) + (return* (&/$update-modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/update$ &/$modules #(&/|put name +init+ %)) - (&/set$ &/$envs (&/|list (&/env name)))) + (&/$update-modules #(&/|put name +init+ %)) + (&/$set-envs (&/|list (&/env name)))) nil))) -(do-template [ ] +(do-template [ ] (defn [module] (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ =module)) + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (return* state ( =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) - tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + tags-by-module $get-tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $get-types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" ) (defn ensure-undeclared-tags [module tags] (|do [tags-table (tags-by-module module) _ (&/map% (fn [tag] (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/P module tag)))) (return nil))) tags)] (return nil))) (defn ensure-undeclared-type [module name] (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/P module name))))] (return nil))) (defn declare-tags [module tag-names type] @@ -327,37 +332,37 @@ (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) _ (ensure-undeclared-type _module _name)] (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] - (return* (&/update$ &/$modules - (fn [=modules] - (&/|update module - #(->> % - (&/set$ $tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name (&/T idx tags type) table))) - (&/get$ $tags %) - (&/enumerate tag-names))) - (&/update$ $types (partial &/|put _name (&/T tags type)))) - =modules)) - state) + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/P module tag-name)) tag-names)] + (return* (&/$update-modules + (fn [=modules] + (&/|update module + #(->> % + ($set-tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name ($$ &/P idx tags type) table))) + ($get-tags %) + (&/enumerate tag-names))) + ($update-types (partial &/|put _name (&/P tags type)))) + =modules)) + state) nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) (defn tag-index [module tag-name] "(-> Text Text (Lux Int))" (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] (return* state (aget idx+tags 0)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) (fail* (str "[Module Error] Unknown module: " module))))) (defn tag-group [module tag-name] "(-> Text Text (Lux (List Ident)))" (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] (return* state (aget idx+tags 1)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 2b4b7e095..96c988544 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -13,122 +13,6 @@ (lux.analyser [base :as &&] [module :as &&module]))) -;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) - ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" @@ -136,7 +20,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) + (&/$Cons [[_ (&/$TagS tag1)] _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -144,9 +28,9 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [(&/$Meta _ (&/$TagS k)) v] + [[_ (&/$TagS k)] v] (|do [=k (&&/resolved-ident k)] - (return (&/T (&/ident->text =k) v))) + (return (&/P (&/ident->text =k) v))) _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 6247524af..2f0925586 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -11,99 +11,157 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) -;; [Tags] -(defmacro deftags [prefix & names] +;; [ADTs] +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + +(defmacro deftags [names] + (assert (vector? names)) `(do ~@(for [[name idx] (map vector names (range (count names)))] `(def ~(symbol (str "$" name)) ~idx)))) +(defn ^:private unfold-accesses + ([elems] + (unfold-accesses 1 (count elems) elems)) + ([begin end elems] + (if (= begin end) + (list elems) + (cons (take begin elems) + (unfold-accesses (inc begin) end elems))))) + +(defmacro defrtags [tags] + (let [num-tags (count tags) + normals (butlast tags) + special (last tags) + tags+locs (cons [special (repeat (dec num-tags) 1)] + (map #(vector %1 (concat (repeat %2 1) [0])) + normals + (range num-tags)))] + `(do ~@(for [[tag loc] tags+locs + :let [getter (symbol (str "$get-" tag)) + setter (symbol (str "$set-" tag)) + updater (symbol (str "$update-" tag)) + record (gensym "record") + value (gensym "value")]] + `(do (defn ~getter [~record] + ;; (if (= '~'$get-source '~getter) + ;; (prn '~getter '~loc ~record (aget ~record ~@loc)) + ;; (prn '~getter '~loc ~record (adt->text (aget ~record ~@loc)))) + (aget ~record ~@loc)) + (defn ~setter [~value ~record] + ;; (if (= '~'$set-source '~setter) + ;; (prn '~setter '_1 '~loc ~record) + ;; (prn '~setter '_2 '~loc ~record (adt->text ~value))) + ;; (doto record# + ;; (aset ~@loc value#)) + ;; (doto record# + ;; (aset 1 (doto (aget record# 1) + ;; (aset 1 ...)))) + ~(reduce (fn [inner indices] + `(doto (aclone ~(if (= 1 (count indices)) + record + `(aget ~record ~@(butlast indices)))) + (aset ~(last indices) ~inner))) + value + (reverse (unfold-accesses loc))) + ) + (defn ~updater [f# ~record] + ;; (prn '~updater '~loc ~record) + ;; (doto record# + ;; (aset ~@loc (f# (aget record# ~@loc)))) + (~setter (f# (~getter ~record)) ~record))))) + )) + ;; List -(deftags "" - "Nil" - "Cons") +(deftags + ["Nil" + "Cons"]) ;; Maybe -(deftags "" - "None" - "Some") - -;; Meta -(deftags "" - "Meta") +(deftags + ["None" + "Some"]) ;; Either -(deftags "" - "Left" - "Right") +(deftags + ["Left" + "Right"]) ;; AST -(deftags "" - "BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS") +(deftags + ["BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS"]) ;; Type -(deftags "" - "DataT" - "VariantT" - "TupleT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "AllT" - "AppT" - "NamedT") +(deftags + ["VoidT" + "UnitT" + "SumT" + "ProdT" + "DataT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT" + "NamedT"]) ;; Vars -(deftags "lux;" - "Local" - "Global") +(deftags + ["Local" + "Global"]) ;; Definitions -(deftags "lux;" - "ValueD" - "TypeD" - "MacroD" - "AliasD") +(deftags + ["ValueD" + "TypeD" + "MacroD" + "AliasD"]) ;; Binding -(deftags "" - "counter" - "mappings") +(defrtags + ["counter" + "mappings"]) ;; Env -(deftags "" - "name" - "inner-closures" - "locals" - "closure") +(defrtags + ["name" + "inner-closures" + "locals" + "closure"]) ;; Host -(deftags "" - "writer" - "loader" - "classes") +(defrtags + ["writer" + "loader" + "classes"]) ;; Compiler -(deftags "" - "source" - "cursor" - "modules" - "envs" - "type-vars" - "expected" - "seed" - "eval?" - "host") +(defrtags + ["source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host"]) ;; [Exports] +;; Class fields (def datum-field "_datum") (def meta-field "_meta") (def name-field "_name") @@ -117,55 +175,59 @@ (def +name-separator+ ";") -(defn T [& elems] - (to-array elems)) - -(defn V [^Long tag value] - (to-array [tag value])) +(def prelude-name "lux") -;; Constructors -(def None$ (V $None nil)) -(defn Some$ [x] (V $Some x)) +(defmacro $$ [op & args] + (assert (> (count args) 1) + (prn-str '$$ op args)) + (let [[last & others] (reverse args)] + (reduce (fn [right left] `(~op ~left ~right)) + last + others))) -(def Nil$ (V $Nil nil)) -(defn Cons$ [h t] (V $Cons (T h t))) +(defn S [^Long tag value] + (to-array [tag value])) -(defn get$ [slot ^objects record] - (aget record slot)) +(defn P [left right] + (to-array [left right])) -(defn set$ [slot value ^objects record] - (let [record* (aclone record) - size (alength record)] - (aset record* slot value) - record*)) +;; Constructors +(def None$ (S $None nil)) +(defn Some$ [x] (S $Some x)) -(defmacro update$ [slot f record] - `(let [record# ~record] - (set$ ~slot (~f (get$ ~slot record#)) - record#))) +(def Nil$ (S $Nil nil)) +(defn Cons$ [h t] (S $Cons (P h t))) (defn fail* [message] - (V $Left message)) + (S $Left message)) (defn return* [state value] - (V $Right (T state value))) + (S $Right (P state value))) + +(defn ^:private transform-tuple-pattern [pattern] + (case (count pattern) + 0 '_ + 1 (assert false "Can't have singleton tuples.") + 2 pattern + ;; else + (let [[last & others] (reverse pattern)] + (reduce (fn [r l] [l r]) last others)))) (defn transform-pattern [pattern] - (cond (vector? pattern) (mapv transform-pattern pattern) + (cond (vector? pattern) (transform-tuple-pattern (mapv transform-pattern pattern)) (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] (vec (cons (eval (first pattern)) (list (case (count parts) - 0 '_ 1 (first parts) ;; else - `[~@parts]))))) + (transform-tuple-pattern parts)))))) :else pattern )) (defmacro |case [value & branches] (assert (= 0 (mod (count branches) 2))) (let [value* (if (vector? value) - [`(T ~@value)] + [`($$ P ~@value)] [value])] `(matchv ::M/objects ~value* ~@(mapcat (fn [[pattern body]] @@ -183,8 +245,8 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(V $Cons (T ~head ~tail))) - `(V $Nil nil) + `(Cons$ ~head ~tail)) + `Nil$ (reverse elems))) (defmacro |table [& elems] @@ -204,17 +266,18 @@ (|get slot table*)))) (defn |put [slot value table] + ;; (prn '|put slot (adt->text value) (adt->text table)) (|case table ($Nil) - (V $Cons (T (T slot value) (V $Nil nil))) + (Cons$ (P slot value) Nil$) ($Cons [k v] table*) (if (.equals ^Object k slot) - (V $Cons (T (T slot value) table*)) - (V $Cons (T (T k v) (|put slot value table*)))) + (Cons$ (P slot value) table*) + (Cons$ (P k v) (|put slot value table*))) ;; _ - ;; (assert false (prn-str '|put (aget table 0))) + ;; (assert false (prn-str '|put slot (adt->text value) (adt->text table))) )) (defn |remove [slot table] @@ -225,7 +288,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (V $Cons (T (T k v) (|remove slot table*)))))) + (Cons$ (P k v) (|remove slot table*))))) (defn |update [k f table] (|case table @@ -234,8 +297,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (V $Cons (T (T k* (f v)) table*)) - (V $Cons (T (T k* v) (|update k f table*)))))) + (Cons$ (P k* (f v)) table*) + (Cons$ (P k* v) (|update k f table*))))) (defn |head [xs] (|case xs @@ -256,11 +319,11 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (V $Left message))) + (S $Left message))) (defn return [value] (fn [state] - (V $Right (T state value)))) + (S $Right (P state value)))) (defn bind [m-value step] (fn [state] @@ -288,22 +351,13 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn |cons [head tail] - (V $Cons (T head tail))) - (defn |++ [xs ys] (|case xs ($Nil) ys ($Cons x xs*) - (V $Cons (T x (|++ xs* ys))))) - -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) + (Cons$ x (|++ xs* ys)))) (defn |map [f xs] (|case xs @@ -311,7 +365,7 @@ xs ($Cons x xs*) - (V $Cons (T (f x) (|map f xs*))) + (Cons$ (f x) (|map f xs*)) _ (assert false (prn-str '|map f (adt->text xs))) @@ -332,7 +386,7 @@ ($Cons x xs*) (if (p x) - (V $Cons (T x (|filter p xs*))) + (Cons$ x (|filter p xs*)) (|filter p xs*)))) (defn flat-map [f xs] @@ -346,13 +400,13 @@ (defn |split-with [p xs] (|case xs ($Nil) - (T xs xs) + (P xs xs) ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (T (|cons x pre) post)) - (T (V $Nil nil) xs)))) + (P (Cons$ x pre) post)) + (P Nil$ xs)))) (defn |contains? [k table] (|case table @@ -361,7 +415,10 @@ ($Cons [k* _] table*) (or (.equals ^Object k k*) - (|contains? k table*)))) + (|contains? k table*)) + + _ + (assert false (prn-str '|contains? k (adt->text table))))) (defn fold [f init xs] (|case xs @@ -386,15 +443,15 @@ (|list init) ($Cons x xs*) - (|cons init (folds f (f init x) xs*)))) + (Cons$ init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] (if (< from to) - (V $Cons (T from (|range* (inc from) to))) - (V $Nil nil)))] + (Cons$ from (|range* (inc from) to)) + Nil$))] (defn |range [n] (|range* 0 n))) @@ -409,10 +466,10 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (V $Cons (T (T x y) (zip2 xs* ys*))) + (Cons$ (P x y) (zip2 xs* ys*)) [_ _] - (V $Nil nil))) + Nil$)) (defn |keys [plist] (|case plist @@ -420,7 +477,7 @@ (|list) ($Cons [k v] plist*) - (|cons k (|keys plist*)))) + (Cons$ k (|keys plist*)))) (defn |vals [plist] (|case plist @@ -428,7 +485,7 @@ (|list) ($Cons [k v] plist*) - (|cons v (|vals plist*)))) + (Cons$ v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -439,7 +496,7 @@ xs ($Cons x xs*) - (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) + (Cons$ x (Cons$ sep (|interpose sep xs*))))) (do-template [ ] (defn [f xs] @@ -452,23 +509,23 @@ ys ( f xs*)] (return ( y ys))))) - map% |cons + map% Cons$ flat-map% |++) (defn list-join [xss] - (fold |++ (V $Nil nil) xss)) + (fold |++ Nil$ xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (V $Cons (T (T x y) (|as-pairs xs*))) + (Cons$ (P x y) (|as-pairs xs*)) _ - (V $Nil nil))) + Nil$)) (defn |reverse [xs] (fold (fn [tail head] - (|cons head tail)) + (Cons$ head tail)) (|list) xs)) @@ -504,7 +561,7 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (|cons head tail))) + (return (Cons$ head tail))) (return (|list))))) (defn exhaust% [step] @@ -551,28 +608,28 @@ (def loader (fn [state] - (return* state (->> state (get$ $host) (get$ $loader))))) + (return* state (->> state $get-host ($get-loader))))) (def classes (fn [state] - (return* state (->> state (get$ $host) (get$ $classes))))) + (return* state (->> state $get-host ($get-classes))))) (def +init-bindings+ - (T ;; "lux;counter" + (P ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - (T ;; "lux;name" - name - ;; "lux;inner-closures" - 0 - ;; "lux;locals" - +init-bindings+ - ;; "lux;closure" - +init-bindings+ - )) + ($$ P ;; "lux;name" + name + ;; "lux;inner-closures" + 0 + ;; "lux;locals" + +init-bindings+ + ;; "lux;closure" + +init-bindings+ + )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String (class (byte-array [])) @@ -594,41 +651,41 @@ (defn host [_] (let [store (atom {})] - (T ;; "lux;writer" - (V $None nil) - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store))) + ($$ P ;; "lux;writer" + None$ + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store))) (defn init-state [_] - (T ;; "lux;source" - (V $None nil) - ;; "lux;cursor" - (T "" -1 -1) - ;; "lux;modules" - (|table) - ;; "lux;envs" - (|list) - ;; "lux;types" - +init-bindings+ - ;; "lux;expected" - (V $VariantT (|list)) - ;; "lux;seed" - 0 - ;; "lux;eval?" - false - ;; "lux;host" - (host nil) - )) + ($$ P ;; "lux;source" + None$ + ;; "lux;cursor" + ($$ P "" -1 -1) + ;; "lux;modules" + (|table) + ;; "lux;envs" + (|list) + ;; "lux;types" + +init-bindings+ + ;; "lux;expected" + (S $VoidT nil) + ;; "lux;seed" + 0 + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) + )) (defn save-module [body] (fn [state] (|case (body state) ($Right state* output) (return* (->> state* - (set$ $envs (get$ $envs state)) - (set$ $source (get$ $source state))) + ($set-envs ($get-envs state)) + ($set-source ($get-source state))) output) ($Left msg) @@ -636,20 +693,20 @@ (defn with-eval [body] (fn [state] - (|case (body (set$ $eval? true state)) + (|case (body ($set-eval? true state)) ($Right state* output) - (return* (set$ $eval? (get$ $eval? state) state*) output) + (return* ($set-eval? ($get-eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state (get$ $eval? state)))) + (return* state ($get-eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state (get$ $host) (get$ $writer))] + (let [writer* (->> state ($get-host) ($get-writer))] (|case writer* ($Some datum) (return* state datum) @@ -659,15 +716,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head (get$ $envs state))] + (try (let [top (|head ($get-envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed (get$ $seed state)] - (return* (set$ $seed (inc seed) state) seed)))) + (let [seed ($get-seed state)] + (return* ($set-seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -680,26 +737,26 @@ (defn ->list [seq] (if (empty? seq) (|list) - (|cons (first seq) (->list (rest seq))))) + (Cons$ (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (|cons x (|repeat (dec n) x)) + (Cons$ x (|repeat (dec n) x)) (|list))) (def get-module-name (fn [state] - (|case (|reverse (get$ $envs state)) + (|case (|reverse ($get-envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state (get$ $name ?global))))) + (return* state ($get-name ?global))))) (defn find-module [name] "(-> Text (Lux (Module Compiler)))" (fn [state] - (if-let [module (|get name (get$ $modules state))] + (if-let [module (|get name ($get-modules state))] (return* state module) (fail* (str "Unknown module: " name))))) @@ -710,10 +767,10 @@ (defn with-scope [name body] (fn [state] - (let [output (body (update$ $envs #(|cons (env name) %) state))] + (let [output (body ($update-envs #(Cons$ (env name) %) state))] (|case output ($Right state* datum) - (return* (update$ $envs |tail state*) datum) + (return* ($update-envs |tail state*) datum) _ output)))) @@ -723,23 +780,24 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $inner-closures) str)))] + (return (->> top ($get-inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) - (|tail %)) - state)))))) + (run-state body* ($update-envs #(Cons$ ($update-inner-closures inc (|head %)) + (|tail %)) + state)))))) (def get-scope-name (fn [state] - (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) + (return* state (->> state ($get-envs) (|map #($get-name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + (prn 'with-writer writer body) + (let [output (body ($update-host #($set-writer (Some$ writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) + (return* ($update-host #($set-writer (->> state ($get-host) ($get-writer)) %) ?state) ?value) _ @@ -748,10 +806,11 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - (let [output (body (set$ $expected type state))] + ;; (prn 'with-expected-type type state) + (let [output (body ($set-expected type state))] (|case output ($Right ?state ?value) - (return* (set$ $expected (get$ $expected state) ?state) + (return* ($set-expected ($get-expected state) ?state) ?value) _ @@ -759,14 +818,20 @@ (defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" + ;; (prn 'with-cursor/_0 (adt->text cursor)) (if (= "" (aget cursor 0)) body (fn [state] - (let [output (body (set$ $cursor cursor state))] + (let [;; _ (prn 'with-cursor/_1 cursor) + state* ($set-cursor cursor state) + ;; _ (prn 'with-cursor/_2 state*) + output (body state*)] (|case output ($Right ?state ?value) - (return* (set$ $cursor (get$ $cursor state) ?state) - ?value) + (let [?state* ($set-cursor ($get-cursor state) ?state)] + ;; (prn 'with-cursor/_3 ?state*) + (return* ?state* + ?value)) _ output))))) @@ -774,40 +839,40 @@ (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast - ($Meta _ ($BoolS ?value)) + [_ ($BoolS ?value)] (pr-str ?value) - ($Meta _ ($IntS ?value)) + [_ ($IntS ?value)] (pr-str ?value) - ($Meta _ ($RealS ?value)) + [_ ($RealS ?value)] (pr-str ?value) - ($Meta _ ($CharS ?value)) + [_ ($CharS ?value)] (pr-str ?value) - ($Meta _ ($TextS ?value)) + [_ ($TextS ?value)] (str "\"" ?value "\"") - ($Meta _ ($TagS ?module ?tag)) + [_ ($TagS ?module ?tag)] (str "#" ?module ";" ?tag) - ($Meta _ ($SymbolS ?module ?ident)) + [_ ($SymbolS ?module ?ident)] (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - ($Meta _ ($TupleS ?elems)) + [_ ($TupleS ?elems)] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - ($Meta _ ($RecordS ?elems)) + [_ ($RecordS ?elems)] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - ($Meta _ ($FormS ?elems)) + [_ ($FormS ?elems)] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") _ @@ -835,10 +900,10 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (|cons z zs))) + (return (Cons$ z zs))) [($Nil) ($Nil)] - (return (V $Nil nil)) + (return Nil$) [_ _] (fail "Lists don't match in size."))) @@ -846,10 +911,10 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (|cons (f x y) (map2 f xs* ys*)) + (Cons$ (f x y) (map2 f xs* ys*)) [_ _] - (V $Nil nil))) + Nil$)) (defn fold2 [f init xs ys] (|case [xs ys] @@ -867,8 +932,8 @@ "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) - (V $Cons (T (T idx x) - (enumerate* (inc idx) xs*))) + (Cons$ (P idx x) + (enumerate* (inc idx) xs*)) ($Nil) xs @@ -881,7 +946,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys (get$ $modules state))))) + (return* state (|keys ($get-modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -895,23 +960,23 @@ (|case xs ($Cons x xs*) (cond (< idx 0) - (V $None nil) + None$ (= idx 0) - (V $Some x) + (Some$ x) :else ;; > 1 (|at (dec idx) xs*)) ($Nil) - (V $None nil) + None$ )) (defn normalize [ident] "(-> Ident (Lux Ident))" (|case ident ["" name] (|do [module get-module-name] - (return (T module name))) + (return (P module name))) _ (return ident))) (defn ident= [x y] @@ -923,12 +988,24 @@ (defn |list-put [idx val xs] (|case xs ($Nil) - (V $None nil) + None$ ($Cons x xs*) (if (= idx 0) - (V $Some (V $Cons (T val xs*))) + (Some$ (Cons$ val xs*)) (|case (|list-put (dec idx) val xs*) - ($None) (V $None nil) - ($Some xs**) (V $Some (V $Cons (T x xs**)))) + ($None) None$ + ($Some xs**) (Some$ (Cons$ x xs**))) ))) + +(defn ensure-1 [m-value] + (|do [output m-value] + (|case output + ($Cons x ($Nil)) + (return x) + + _ + (fail "[Error] Can't expand to other than 1 element.")))) + +(defn cursor$ [file-name line-num column-num] + ($$ P file-name line-num column-num)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 79d2c84f8..4315ea75d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -39,8 +39,12 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] + ;; (prn 'compile-expression (&/adt->text syntax)) (|let [[?form ?type] syntax] (|case ?form + (&a/$unit) + (&&lux/compile-unit compile-expression ?type) + (&a/$bool ?value) (&&lux/compile-bool compile-expression ?type ?value) @@ -56,8 +60,11 @@ (&a/$text ?value) (&&lux/compile-text compile-expression ?type ?value) - (&a/$tuple ?elems) - (&&lux/compile-tuple compile-expression ?type ?elems) + (&a/$prod left right) + (&&lux/compile-prod compile-expression ?type left right) + + (&a/$sum tag value) + (&&lux/compile-sum compile-expression ?type tag value) (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -71,9 +78,6 @@ (&a/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) - (&a/$variant ?tag ?members) - (&&lux/compile-variant compile-expression ?type ?tag ?members) - (&a/$case ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) @@ -424,7 +428,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from file-name file-content) state)) + (&/$set-source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports @@ -471,7 +475,7 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) + (|case ((&/map% compile-module (&/|list &/prelude-name program-module)) (&/init-state nil)) (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 1e5f3a024..72d569ed1 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -76,26 +76,32 @@ _ (load-class! loader real-name)]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [^MethodVisitor writer] (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature )))) - ;; (doto writer - ;; ;; X - ;; (.visitTypeInsn Opcodes/NEW ) ;; XW - ;; (.visitInsn ) ;; WXW - ;; (.visitInsn ) ;; WWXW - ;; (.visitInsn Opcodes/POP) ;; WWX - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "" ) ;; W - ;; ) - ) + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature ))))) - wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 - wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 - wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 - wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 - wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 - wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 - wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 - wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 + wrap-boolean "java/lang/Boolean" "(Z)" + wrap-byte "java/lang/Byte" "(B)" + wrap-short "java/lang/Short" "(S)" + wrap-int "java/lang/Integer" "(I)" + wrap-long "java/lang/Long" "(J)" + wrap-float "java/lang/Float" "(F)" + wrap-double "java/lang/Double" "(D)" + wrap-char "java/lang/Character" "(C)" + ) + +(do-template [ ] + (defn [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" )))) + + unwrap-boolean "java/lang/Boolean" "Z" "booleanValue" + unwrap-byte "java/lang/Byte" "B" "byteValue" + unwrap-short "java/lang/Short" "S" "shortValue" + unwrap-int "java/lang/Integer" "I" "intValue" + unwrap-long "java/lang/Long" "J" "longValue" + unwrap-float "java/lang/Float" "F" "floatValue" + unwrap-double "java/lang/Double" "D" "doubleValue" + unwrap-char "java/lang/Character" "C" "charValue" ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index dc224f52e..48b35c83a 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) + (let [needed-modules (->> state (&/$get-modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] @@ -120,7 +120,7 @@ ;; (prn '_group _group) (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] ;; (prn '[_type _tags] [_type _tags]) - (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + (&/P _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) @@ -132,10 +132,10 @@ (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) + (&a-module/define module _name (&/S &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] + (|do [_ (&a-module/define module _name (&/S &/$ValueD (&/P &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index dd3258059..b30fcb4f8 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -11,7 +11,7 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] + (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -84,63 +84,62 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$TupleTestAC ?members) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (-> (doto (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)) - (.visitInsn Opcodes/AALOAD) - (compile-match test $next $sub-else) - (.visitLabel $sub-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $next)) - (->> (|let [[idx test] idx+member - $next (new Label) - $sub-else (new Label)]) - (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$ProdTestAC left right) + (let [$post-left (new Label) + $post-right (new Label)] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (compile-match left $post-left $else) + (.visitLabel $post-left) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (compile-match right $post-right $else) + (.visitLabel $post-right) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target))) - (&a-case/$VariantTestAC ?tag ?count ?test) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitLdcInsn ?tag) - (&&/wrap-long) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (-> (doto (compile-match ?test $value-then $value-else) - (.visitLabel $value-then) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $value-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else)) - (->> (let [$value-then (new Label) - $value-else (new Label)])))) + (&a-case/$SumTestAC ?tag ?count ?test) + (let [$value-then (new Label) + $sum-else (new Label)] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (&&/unwrap-int) + (.visitLdcInsn (int ?tag)) + (.visitJumpInsn Opcodes/IF_ICMPNE $sum-else) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (compile-match ?test $value-then $sum-else) + (.visitLabel $value-then) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $sum-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else))) ))) (defn ^:private separate-bodies [patterns] (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body] - (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) - (&/T 0 (&/|table) (&/|table)) + ($$ &/P (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) + ($$ &/P 0 (&/|table) (&/|table)) patterns)] - (&/T mappings (&/|reverse patterns*)))) + (&/P mappings (&/|reverse patterns*)))) (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] - (&/T (&/T ?branch label) - (&/T label ?body)))) + (&/P (&/P ?branch label) + (&/P label ?body)))) mappings) mappings* (&/|map &/|first entries)] (doto writer diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 26ef73cb7..ead44085a 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - (&/$TupleT (&/$Nil)) + (&/$UnitT) (.visitInsn *writer* Opcodes/ACONST_NULL) (&/$DataT "boolean") @@ -421,14 +421,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -455,12 +455,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 83e294c1a..79383acc0 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -28,27 +28,43 @@ ClassWriter MethodVisitor))) +;; [Utils] +(defn ^:private array-of [^MethodVisitor *writer* type-name size] + (do (doto *writer* + (.visitLdcInsn (int size)) + (.visitTypeInsn Opcodes/ANEWARRAY type-name)) + (return nil))) + +(defn ^:private store-at [^MethodVisitor *writer* compile idx value] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + _ (compile value) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + ;; [Exports] +(defn compile-unit [compile *type*] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + (return nil))) + (defn compile-bool [compile *type* ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (try (doto *writer* - (.visitTypeInsn Opcodes/NEW ) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL "" )) - (catch Exception e - (assert false (prn-str ' (alength value) (aget value 0) (aget value 1)))))]] + :let [_ (doto *writer* + (.visitLdcInsn value) + ())]] (return nil))) - compile-int "java/lang/Long" "(J)V" long - compile-real "java/lang/Double" "(D)V" double - compile-char "java/lang/Character" "(C)V" char + compile-int &&/wrap-long + compile-real &&/wrap-double + compile-char &&/wrap-char ) (defn compile-text [compile *type* ?value] @@ -56,37 +72,28 @@ :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-tuple [compile *type* ?elems] +(defn compile-prod [compile *type* left right] + ;; (prn 'compile-prod (&type/show-type *type*) + ;; (&/adt->text left) + ;; (&/adt->text right)) (|do [^MethodVisitor *writer* &/get-writer - :let [num-elems (&/|length ?elems) - _ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx elem] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret))) - (&/|range num-elems) ?elems)] + _ (array-of *writer* "java/lang/Object" 2) + _ (store-at *writer* compile 0 left) + ;; :let [_ (prn 'compile-prod (&type/show-type *type*) left right)] + _ (store-at *writer* compile 1 right)] (return nil))) -(defn compile-variant [compile *type* ?tag ?value] +(defn compile-sum [compile *type* ?tag ?value] ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer + _ (array-of *writer* "java/lang/Object" 2) :let [_ (doto *writer* - (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) - (.visitLdcInsn ?tag) - (&&/wrap-long) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)))] - _ (compile ?value) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (.visitLdcInsn (int ?tag)) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE))] + _ (store-at *writer* compile 1 ?value)] (return nil))) (defn compile-local [compile *type* ?idx] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index db73e8bb4..50d8b0011 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -23,6 +23,6 @@ (return (&/|map (fn [pair] (|case pair [name [tags _]] - (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) - (&/get$ &module/$types module))) + (&/P name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&module/$get-types module))) )) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 7e2bc6961..cfaa9668b 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -9,83 +9,86 @@ (ns lux.compiler.type (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] + (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] [type :as &type]) [lux.analyser.base :as &a])) ;; [Utils] -(defn ^:private variant$ [tag body] - "(-> Text Analysis Analysis)" - (&/T (&/V &a/$variant (&/T tag body)) +(def ^:private unit$ + "Analysis" + (&/P (&/S &a/$unit nil) + &type/$Void)) + +(defn ^:private sum$ [tag body] + "(-> Int Analysis Analysis)" + (&/P (&/S &a/$sum (&/P tag body)) &type/$Void)) -(defn ^:private tuple$ [members] - "(-> (List Analysis) Analysis)" - (&/T (&/V &a/$tuple members) +(defn ^:private prod$ [left right] + "(-> Analysis Analysis Analysis)" + (&/P (&/S &a/$prod (&/P left right)) &type/$Void)) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/T (&/V &a/$text text) + (&/P (&/S &a/$text text) &type/$Void)) (def ^:private $Nil "Analysis" - (variant$ &/$Nil (tuple$ (&/|list)))) + (sum$ &/$Nil unit$)) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (variant$ &/$Cons (tuple$ (&/|list head tail)))) + (sum$ &/$Cons (prod$ head tail))) ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" (|case type (&/$DataT ?class) - (variant$ &/$DataT (text$ ?class)) + (sum$ &/$DataT (text$ ?class)) - (&/$TupleT ?members) - (variant$ &/$TupleT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) + (&/$ProdT left right) + (sum$ &/$ProdT + (prod$ (->analysis left) + (->analysis right))) - (&/$VariantT ?members) - (variant$ &/$VariantT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) + (&/$SumT left right) + (sum$ &/$SumT + (prod$ (->analysis left) + (->analysis right))) (&/$LambdaT ?input ?output) - (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + (sum$ &/$LambdaT (prod$ (->analysis ?input) (->analysis ?output))) (&/$AllT ?env ?name ?arg ?body) - (variant$ &/$AllT - (tuple$ (&/|list (|case ?env - (&/$None) - (variant$ &/$None (tuple$ (&/|list))) + (sum$ &/$AllT + ($$ prod$ + (|case ?env + (&/$None) + (sum$ &/$None unit$) - (&/$Some ??env) - (variant$ &/$Some - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) - $Nil - (&/|reverse ??env)))) - (text$ ?name) - (text$ ?arg) - (->analysis ?body)))) + (&/$Some ??env) + (sum$ &/$Some + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (prod$ (text$ hlabel) + (->analysis htype)) + tail))) + $Nil + (&/|reverse ??env)))) + (text$ ?name) + (text$ ?arg) + (->analysis ?body))) (&/$BoundT ?name) - (variant$ &/$BoundT (text$ ?name)) + (sum$ &/$BoundT (text$ ?name)) (&/$AppT ?fun ?arg) - (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (sum$ &/$AppT (prod$ (->analysis ?fun) (->analysis ?arg))) (&/$NamedT [?module ?name] ?type) - (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) - (->analysis ?type)))) + (sum$ &/$NamedT (prod$ (prod$ (text$ ?module) (text$ ?name)) + (->analysis ?type))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index dfd4df23d..d77e9b31c 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,8 +29,8 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) + (return (&/S &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base))) ))) (defn ^:private method->type [^Method method] @@ -76,7 +76,7 @@ (&/$LambdaT _ _) (->type-signature function-class) - (&/$TupleT (&/$Nil)) + (&/$VoidT) "V" (&/$NamedT ?name ?type) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index e848cc3fd..91693cc77 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -13,22 +13,22 @@ [lux.analyser.module :as &module])) ;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] ) ;; [Utils] @@ -58,19 +58,19 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) + (return (&/P meta (&/S $White_Space white-space))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/P meta (&/S $Comment comment))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") ;; :let [_ (prn 'immediate comment)] _ (&reader/read-text ")#")] - (return (&/T meta comment))) + (return (&/P meta comment))) (|do [;; :let [_ (prn 'pre/_0)] [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") ;; :let [_ (prn 'pre pre)] @@ -79,10 +79,10 @@ [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] ] - (return (&/T meta (str pre "#(" inner ")#" post)))))) + (return (&/P meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/P meta (&/S $Comment comment))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -91,7 +91,7 @@ (do-template [ ] (def (|do [[meta token] (&reader/read-regex )] - (return (&/V &/$Meta (&/T meta (&/V token)))))) + (return (&/P meta (&/S token))))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" @@ -105,13 +105,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) + (return (&/P meta (&/S $Char token))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) + (return (&/P meta (&/S $Text token))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -119,35 +119,35 @@ [_ local-token] (&reader/read-regex +ident-re+) ? (&module/exists? token)] (if ? - (return (&/T meta (&/T token local-token))) + (return (&/P meta (&/P token local-token))) (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] + (&module/dealias token))] (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/T meta (&/T unaliased local-token))))))) - (return (&/T meta (&/T "" token))) + (return (&/P meta (&/P unaliased local-token))))))) + (return (&/P meta (&/P "" token))) ))) (|do [[meta _] (&reader/read-text ";;") [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/T meta (&/T module-name token)))) + (return (&/P meta (&/P module-name token)))) (|do [[meta _] (&reader/read-text ";") [_ token] (&reader/read-regex +ident-re+)] - (return (&/T meta (&/T "lux" token)))) + (return (&/P meta (&/P &/prelude-name token)))) ))) (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) + (return (&/P meta (&/S $Symbol ident))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) + (return (&/P meta (&/S $Tag ident))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/V &/$Meta (&/T meta (&/V nil)))))) + (return (&/P meta (&/S nil))))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/parser.clj b/src/lux/parser.clj index eaa22db20..c40221d63 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -14,22 +14,22 @@ [lexer :as &lexer]))) ;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] ) ;; [Utils] @@ -38,8 +38,8 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - (&/$Meta meta [ _]) - (return (&/V (&/fold &/|++ (&/|list) elems))) + [meta [ _]] + (return (&/S (&/fold &/|++ (&/|list) elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) @@ -53,9 +53,9 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - (&/$Meta meta ($Close_Brace _)) + [meta ($Close_Brace _)] (if (even? (&/|length elems)) - (return (&/V &/$RecordS (&/|as-pairs elems))) + (return (&/S &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -64,7 +64,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [(&/$Meta meta token*) token]] + :let [[meta token*] token]] (|case token* ($White_Space _) (return (&/|list)) @@ -73,37 +73,37 @@ (return (&/|list)) ($Bool ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) + (return (&/|list (&/P meta (&/S &/$BoolS (Boolean/parseBoolean ?value))))) ($Int ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) + (return (&/|list (&/P meta (&/S &/$IntS (Long/parseLong ?value))))) ($Real ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) + (return (&/|list (&/P meta (&/S &/$RealS (Double/parseDouble ?value))))) ($Char ^String ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) + (return (&/|list (&/P meta (&/S &/$CharS (.charAt ?value 0))))) ($Text ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) + (return (&/|list (&/P meta (&/S &/$TextS ?value)))) ($Symbol ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) + (return (&/|list (&/P meta (&/S &/$SymbolS ?ident)))) ($Tag ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) + (return (&/|list (&/P meta (&/S &/$TagS ?ident)))) ($Open_Paren _) (|do [syntax (parse-form parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) ($Open_Bracket _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) ($Open_Brace _) (|do [syntax (parse-record parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index e3f95b5f9..24a0bf94d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,18 +10,18 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case $$]])) ;; [Tags] -(deftags "" - "No" - "Done" - "Yes") +(deftags + ["No" + "Done" + "Yes"]) ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/get$ &/$source state) + (|case (&/$get-source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/set$ &/$source more state) + (return* (&/$set-source more state) output) ($Yes output line*) - (return* (&/set$ &/$source (&/|cons line* more) state) + (return* (&/$set-source (&/Cons$ line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/get$ &/$source state)) + (|case (body (&/$get-source state)) (&/$Right reader* match) - (return* (&/set$ &/$source reader* state) + (return* (&/$set-source reader* state) match) (&/$Left msg) @@ -85,10 +85,10 @@ match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) match)) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) match)) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) match) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -98,10 +98,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2))) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2)) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -110,7 +110,7 @@ reader* reader] (|case reader* (&/$Nil) - (&/V &/$Left "[Reader Error] EOF") + (&/S &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] reader**) @@ -120,10 +120,10 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) + (&/S &/$Right (&/P (&/Cons$ (&/P (&/cursor$ file-name line-num column-num*) line) reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) - (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + (&/P (&/cursor$ file-name line-num column-num) (str prefix match)))))) + (&/S &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line @@ -133,10 +133,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) text)) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Text failed: " text)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) text)) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) text) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] @@ -144,7 +144,7 @@ file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/T (&/T file-name (inc line-num) 0) + (&/P (&/cursor$ file-name (inc line-num) 0) line))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] diff --git a/src/lux/type.clj b/src/lux/type.clj index 9f3adb036..4193d8df4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -10,7 +10,7 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case $$]])) (declare show-type) @@ -26,302 +26,300 @@ _ false)) -(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) -(def ^:private no-env (&/V &/$None nil)) +(def ^:private empty-env (&/Some$ &/Nil$)) +(def ^:private no-env &/None$) +(def Ident$ &/P) (defn Data$ [name] - (&/V &/$DataT name)) + (&/S &/$DataT name)) (defn Bound$ [name] - (&/V &/$BoundT name)) + (&/S &/$BoundT name)) (defn Var$ [id] - (&/V &/$VarT id)) + (&/S &/$VarT id)) (defn Lambda$ [in out] - (&/V &/$LambdaT (&/T in out))) + (&/S &/$LambdaT (&/P in out))) (defn App$ [fun arg] - (&/V &/$AppT (&/T fun arg))) -(defn Tuple$ [members] + (&/S &/$AppT (&/P fun arg))) +(defn Prod$ [left right] ;; (assert (|list? members)) - (&/V &/$TupleT members)) -(defn Variant$ [members] + (&/S &/$ProdT (&/P left right))) +(defn Sum$ [left right] ;; (assert (|list? members)) - (&/V &/$VariantT members)) + (&/S &/$SumT (&/P left right))) (defn All$ [env name arg body] - (&/V &/$AllT (&/T env name arg body))) + (&/S &/$AllT ($$ &/P env name arg body))) (defn Named$ [name type] - (&/V &/$NamedT (&/T name type))) + (&/S &/$NamedT (&/P name type))) - -(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) -(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) -(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) -(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) -(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) -(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) -(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) -(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) +(def Bool (Named$ (Ident$ &/prelude-name "Bool") (Data$ "java.lang.Boolean"))) +(def Int (Named$ (Ident$ &/prelude-name "Int") (Data$ "java.lang.Long"))) +(def Real (Named$ (Ident$ &/prelude-name "Real") (Data$ "java.lang.Double"))) +(def Char (Named$ (Ident$ &/prelude-name "Char") (Data$ "java.lang.Character"))) +(def Text (Named$ (Ident$ &/prelude-name "Text") (Data$ "java.lang.String"))) +(def Unit (Named$ (Ident$ &/prelude-name "Unit") (&/S &/$UnitT nil))) +(def $Void (Named$ (Ident$ &/prelude-name "Void") (&/S &/$VoidT nil))) +(def Ident (Named$ (Ident$ &/prelude-name "Ident") (Prod$ Text Text))) (def IO - (Named$ (&/T "lux/data" "IO") + (Named$ (Ident$ "lux/data" "IO") (All$ empty-env "IO" "a" (Lambda$ Unit (Bound$ "a"))))) (def List - (Named$ (&/T "lux" "List") + (Named$ (Ident$ &/prelude-name "List") (All$ empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - ))))) + (Sum$ + ;; lux;Nil + Unit + ;; lux;Cons + (Prod$ (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a"))) + )))) (def Maybe - (Named$ (&/T "lux" "Maybe") + (Named$ (Ident$ &/prelude-name "Maybe") (All$ empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - ))))) + (Sum$ + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + )))) (def Type - (Named$ (&/T "lux" "Type") + (Named$ (Ident$ &/prelude-name "Type") (let [Type (App$ (Bound$ "Type") (Bound$ "_")) TypeList (App$ List Type) - TypeEnv (App$ List (Tuple$ (&/|list Text Type))) - TypePair (Tuple$ (&/|list Type Type))] + TypeEnv (App$ List (Prod$ Text Type)) + TypePair (Prod$ Type Type)] (App$ (All$ empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; VariantT - TypeList - ;; TupleT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) - ;; AppT - TypePair - ;; NamedT - (Tuple$ (&/|list Ident Type)) - ))) + ($$ Sum$ + ;; VoidT + Unit + ;; UnitT + Unit + ;; SumT + TypePair + ;; ProdT + TypePair + ;; DataT + Text + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + ($$ Prod$ (App$ Maybe TypeEnv) Text Text Type) + ;; AppT + TypePair + ;; NamedT + (Prod$ Ident Type) + )) $Void)))) (def Bindings - (Named$ (&/T "lux" "Bindings") + (Named$ (Ident$ &/prelude-name "Bindings") (All$ empty-env "lux;Bindings" "k" (All$ no-env "" "v" - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v")))))))))) + (Prod$ + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Prod$ (Bound$ "k") + (Bound$ "v")))))))) (def Env - (Named$ (&/T "lux" "Env") + (Named$ (Ident$ &/prelude-name "Env") (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" (All$ no-env "" "v" - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - ))))))) + ($$ Prod$ + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + )))))) (def Cursor - (Named$ (&/T "lux" "Cursor") - (Tuple$ (&/|list Text Int Int)))) + (Named$ (Ident$ &/prelude-name "Cursor") + ($$ Prod$ Text Int Int))) (def Meta - (Named$ (&/T "lux" "Meta") + (Named$ (Ident$ &/prelude-name "Meta") (All$ empty-env "lux;Meta" "m" (All$ no-env "" "v" - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ "m") - (Bound$ "v"))))))))) + (Prod$ (Bound$ "m") + (Bound$ "v")))))) (def AST* - (Named$ (&/T "lux" "AST'") + (Named$ (Ident$ &/prelude-name "AST'") (let [AST* (App$ (Bound$ "w") (App$ (Bound$ "lux;AST'") (Bound$ "w"))) AST*List (App$ List AST*)] (All$ empty-env "lux;AST'" "w" - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - ))))) + ($$ Sum$ + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Prod$ AST* AST*)) + ))))) (def AST - (Named$ (&/T "lux" "AST") + (Named$ (Ident$ &/prelude-name "AST") (let [w (App$ Meta Cursor)] (App$ w (App$ AST* w))))) (def ^:private ASTList (App$ List AST)) (def Either - (Named$ (&/T "lux" "Either") + (Named$ (Ident$ &/prelude-name "Either") (All$ empty-env "lux;Either" "l" (All$ no-env "" "r" - (Variant$ (&/|list - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r"))))))) + (Sum$ + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r")))))) (def StateE (All$ empty-env "lux;StateE" "s" (All$ no-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ "s") - (Bound$ "a")))))))) + (Prod$ (Bound$ "s") + (Bound$ "a"))))))) (def Source - (Named$ (&/T "lux" "Source") + (Named$ (Ident$ &/prelude-name "Source") (App$ List (App$ (App$ Meta Cursor) Text)))) (def Host - (Named$ (&/T "lux" "Host") - (Tuple$ - (&/|list - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") - ;; "lux;loader" - (Data$ "java.lang.ClassLoader") - ;; "lux;classes" - (Data$ "clojure.lang.Atom"))))) + (Named$ (Ident$ &/prelude-name "Host") + ($$ Prod$ + ;; "lux;writer" + (Data$ "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (Data$ "java.lang.ClassLoader") + ;; "lux;classes" + (Data$ "clojure.lang.Atom")))) (def DefData* (All$ empty-env "lux;DefData'" "" - (Variant$ (&/|list - ;; "lux;ValueD" - (Tuple$ (&/|list Type Unit)) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ "") - ;; "lux;AliasD" - Ident - )))) + ($$ Sum$ + ;; "lux;ValueD" + (Prod$ Type Unit) + ;; "lux;TypeD" + Type + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + ))) (def LuxVar - (Named$ (&/T "lux" "LuxVar") - (Variant$ (&/|list - ;; "lux;Local" - Int - ;; "lux;Global" - Ident)))) + (Named$ (Ident$ &/prelude-name "LuxVar") + (Sum$ + ;; "lux;Local" + Int + ;; "lux;Global" + Ident))) (def $Module (All$ empty-env "lux;$Module" "Compiler" - (Tuple$ - (&/|list - ;; "lux;module-aliases" - (App$ List (Tuple$ (&/|list Text Text))) - ;; "lux;defs" - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Int - (App$ List Ident) - Type))))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list (App$ List Ident) - Type))))) - )))) + ($$ Prod$ + ;; "lux;module-aliases" + (App$ List (Prod$ Text Text)) + ;; "lux;defs" + (App$ List + (Prod$ Text + (Prod$ Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (, Int (List Ident) Type))) + (App$ List + (Prod$ Text + ($$ Prod$ Int + (App$ List Ident) + Type))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Prod$ Text + (Prod$ (App$ List Ident) + Type))) + ))) (def $Compiler - (Named$ (&/T "lux" "Compiler") + (Named$ (Ident$ &/prelude-name "Compiler") (App$ (All$ empty-env "lux;Compiler" "" - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) + ($$ Prod$ + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Prod$ Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Prod$ LuxVar Type))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + )) $Void))) (def Macro - (Named$ (&/T "lux" "Macro") + (Named$ (Ident$ &/prelude-name "Macro") (Lambda$ ASTList (App$ (App$ StateE $Compiler) ASTList)))) (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [type (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -332,7 +330,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [type* (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -343,32 +341,37 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [tvar (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) - ts)) - state) + (return* (&/$update-type-vars (fn [ts] (&/$update-mappings #(&/|put id (&/Some$ type) %) + ts)) + state) nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/$get-type-vars) (&/$get-mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] - (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) - state) + (let [id (->> state &/$get-type-vars &/$get-counter)] + (return* (&/$update-type-vars #(do ;; (prn 'create-var/_0 (&/adt->text %)) + ;; (prn 'create-var/_1 (&/adt->text (->> % (&/$update-counter inc)))) + ;; (prn 'create-var/_2 (&/adt->text (->> % + ;; (&/$update-counter inc) + ;; (&/$update-mappings (fn [ms] (&/|put id &/None$ ms)))))) + (->> % + (&/$update-counter inc) + (&/$update-mappings (fn [ms] (&/|put id &/None$ ms))))) + state) id)))) (def existential (|do [seed &/gen-id] - (return (&/V &/$ExT seed)))) + (return (&/S &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -390,19 +393,19 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/T ?id (&/V &/$None nil))) + (return (&/P ?id &/None$)) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/T ?id (&/V &/$Some ?type**))))) + (return (&/P ?id (&/Some$ ?type**))))) )))) - (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] + (->> state (&/$get-type-vars) (&/$get-mappings)))] (fn [state] - (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings (&/|remove id mappings*))) - state) + (return* (&/$update-type-vars #(->> % + (&/$update-counter dec) + (&/$set-mappings (&/|remove id mappings*))) + state) nil))) state)))) @@ -435,13 +438,15 @@ =param (clean* ?tid ?param)] (return (App$ =lambda =param))) - (&/$TupleT ?members) - (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (Tuple$ =members))) - - (&/$VariantT ?members) - (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (Variant$ =members))) + (&/$SumT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (Sum$ =left =right))) + + (&/$ProdT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (Prod$ =left =right))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -451,9 +456,9 @@ (&/$Some ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) + (return (&/P k =v)))) ?env*)] - (return (&/V &/$Some clean-env)))) + (return (&/Some$ clean-env)))) body* (clean* ?tid ?body)] (return (All$ =env ?name ?arg body*))) @@ -473,37 +478,36 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/T ??out (&/|cons ?in ?args))) + (&/P ??out (&/Cons$ ?in ?args))) _ - (&/T type (&/|list)))) + (&/P type (&/|list)))) (defn ^:private unravel-app [fun-type] (|case fun-type (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] - (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) + (&/P ?fun-type (&/|++ ?args (&/|list ?right)))) _ - (&/T fun-type (&/|list)))) + (&/P fun-type (&/|list)))) (defn show-type [^objects type] (|case type + (&/$VoidT) + "(|)" + + (&/$UnitT) + "(,)" + (&/$DataT name) (str "(^ " name ")") - (&/$TupleT elems) - (if (&/|empty? elems) - "(,)" - (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - (&/$VariantT cases) - (if (&/|empty? cases) - "(|)" - (str "(| " (->> cases - (&/|map show-type) - (&/|interpose " ") - (&/fold str "")) ")")) + (&/$ProdT left right) + (str "(, " (show-type left) " " (show-type right) ")") + + (&/$SumT left right) + (str "(| " (show-type left) " " (show-type right) ")") (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] @@ -547,15 +551,13 @@ [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [(&/$TupleT xelems) (&/$TupleT yelems)] - (&/fold2 (fn [old x y] (and old (type= x y))) - true - xelems yelems) + [(&/$ProdT xleft xright) (&/$ProdT yleft yright)] + (and (type= xleft yleft) + (type= xright yright)) - [(&/$VariantT xcases) (&/$VariantT ycases)] - (&/fold2 (fn [old x y] (and old (type= x y))) - true - xcases ycases) + [(&/$SumT xleft xright) (&/$SumT yleft yright)] + (and (type= xleft yleft) + (type= xright yright)) [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) @@ -607,17 +609,17 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - (&/V &/$None nil) + &/None$ (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/V &/$Some v*) + (&/Some$ v*) (fp-get k fixpoints*)) ))) (defn ^:private fp-put [k v fixpoints] - (&/|cons (&/T k v) fixpoints)) + (&/Cons$ (&/P k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) @@ -626,11 +628,11 @@ (defn beta-reduce [env type] (|case type - (&/$VariantT ?members) - (Variant$ (&/|map (partial beta-reduce env) ?members)) + (&/$SumT ?left ?right) + (Sum$ (beta-reduce env ?left) (beta-reduce env ?right)) - (&/$TupleT ?members) - (Tuple$ (&/|map (partial beta-reduce env) ?members)) + (&/$ProdT ?left ?right) + (Prod$ (beta-reduce env ?left) (beta-reduce env ?right)) (&/$AppT ?type-fn ?type-arg) (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -638,7 +640,7 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) + (All$ (&/Some$ env) ?local-name ?local-arg ?local-def) (&/$Some _) type) @@ -697,30 +699,32 @@ (def ^:private init-fixpoints (&/|list)) (defn ^:private check* [class-loader fixpoints expected actual] + ;; (prn 'check*/_0 (&/adt->text expected) (&/adt->text actual)) + ;; (prn 'check*/_1 (show-type expected) (show-type actual)) (if (clojure.lang.Util/identical expected actual) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (|case [expected actual] [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (|do [ebound (fn [state] (|case ((deref ?eid) state) (&/$Right state* ebound) - (return* state* (&/V &/$Some ebound)) + (return* state* (&/Some$ ebound)) (&/$Left _) - (return* state (&/V &/$None nil)))) + (return* state &/None$))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) - (return* state* (&/V &/$Some abound)) + (return* state* (&/Some$ abound)) (&/$Left _) - (return* state (&/V &/$None nil))))] + (return* state &/None$)))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] - (return (&/T fixpoints nil))) + (return (&/P fixpoints nil))) [(&/$Some etype) (&/$None _)] (check* class-loader fixpoints etype actual) @@ -735,7 +739,7 @@ (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) - (return* state* (&/T fixpoints nil)) + (return* state* (&/P fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -746,7 +750,7 @@ (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) - (return* state* (&/T fixpoints nil)) + (return* state* (&/P fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -757,9 +761,9 @@ (fn [state] (|case ((|do [F1 (deref ?eid)] (fn [state] - (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state)] + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state) (&/$Right state* output) (return* state* output) @@ -780,11 +784,11 @@ (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] - ;; (return (&/T fixpoints nil))) + ;; (return (&/P fixpoints nil))) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] @@ -799,14 +803,14 @@ e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state))) ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) + ;; (return (&/P fixpoints** nil))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] @@ -821,17 +825,17 @@ e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state))) ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) + ;; (return (&/P fixpoints** nil))) [(&/$AppT F A) _] - (let [fp-pair (&/T expected actual) + (let [fp-pair (&/P expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] @@ -844,7 +848,7 @@ (|case (fp-get fp-pair fixpoints) (&/$Some ?) (if ? - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (check-error expected actual))) (&/$None) @@ -870,39 +874,33 @@ [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/T fixpoints nil))) + (return (&/P fixpoints nil))) [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [(&/$TupleT e!members) (&/$TupleT a!members)] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] - (return fp*))) - fixpoints - e!members a!members)] - (return (&/T fixpoints* nil))) + [(&/$ProdT e!left e!right) (&/$ProdT a!left a!right)] + (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) + [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] + (return (&/P fixpoints** nil))) - [(&/$VariantT e!cases) (&/$VariantT a!cases)] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] - (return fp*))) - fixpoints - e!cases a!cases)] - (return (&/T fixpoints* nil))) + [(&/$SumT e!left e!right) (&/$SumT a!left a!right)] + (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) + [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] + (return (&/P fixpoints** nil))) [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (check-error expected actual))) [(&/$NamedT ?ename ?etype) _] @@ -958,20 +956,31 @@ )) (defn variant-case [tag type] + ;; (prn 'variant-case tag (show-type type)) (|case type (&/$NamedT ?name ?type) (variant-case tag ?type) - (&/$VariantT ?cases) - (|case (&/|at tag ?cases) - (&/$Some case-type) - (return case-type) + (&/$SumT ?left ?right) + (case tag + 0 + (return ?left) - (&/$None) - (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) + 1 + (|case ?right + (&/$SumT ?left* _) + (return ?left*) + + _ + (return ?right)) + + ;; else + (variant-case (dec tag) ?right)) _ - (fail (str "[Type Error] Type is not a variant: " (show-type type))))) + (fail (str "[Type Error] Type is not a variant: " (show-type type))) + ;; (assert false (str "[Type Error] Type is not a variant: " (show-type type))) + )) (defn type-name [type] "(-> Type (Lux Ident))" -- cgit v1.2.3 From 82b019a5b5f547f3b321642ce687d8aec59e802e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 17:41:45 -0400 Subject: - Restructuring how sums & products work [part 2] --- source/lux.lux | 154 +++++++++++++++++++++++--------------------- src/lux/analyser/case.clj | 28 ++++++-- src/lux/analyser/lambda.clj | 8 +-- src/lux/analyser/module.clj | 31 ++++----- src/lux/base.clj | 4 +- src/lux/compiler/base.clj | 1 + src/lux/compiler/case.clj | 25 ++++--- src/lux/compiler/lux.clj | 4 +- src/lux/type.clj | 14 +++- 9 files changed, 158 insertions(+), 111 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 7c5fd5c8d..bdb845f1b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -63,7 +63,7 @@ ## (1 a))) (_lux_def Maybe (11 ["lux" "Maybe"] - (9 (1 (0)) "lux;Maybe" "a" + (9 (1 #Nil) "lux;Maybe" "a" (2 ## "lux;None" Unit ## "lux;Some" @@ -92,7 +92,7 @@ Type (_lux_case (10 List (3 Text Type)) TypeEnv - (10 (9 (1 (0)) "Type" "_" + (10 (9 (#Some #Nil) "Type" "_" (2 ## lux;VoidT Unit (2 ## lux;UnitT @@ -493,7 +493,7 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)) + (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS "" "")) (#Cons arg @@ -508,7 +508,7 @@ #Nil)))))) #Nil)) - (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))) + (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS self)) (#Cons arg @@ -531,9 +531,9 @@ (_lux_: Macro (lambda'' [tokens] (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [_ (#TagS ["" "export"])] + (#Cons [_ (#FormS (#Cons name args))] + (#Cons type (#Cons body #Nil)))) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -547,7 +547,7 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [_ (#TagS "" "export")] (#Cons name (#Cons type (#Cons body #Nil)))) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -558,8 +558,8 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) - (#Cons [type (#Cons [body #Nil])])]) + (#Cons [_ (#FormS (#Cons name args))] + (#Cons type (#Cons body #Nil))) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -572,7 +572,7 @@ #Nil])])]))) #Nil])) - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Cons name (#Cons type (#Cons body #Nil))) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -590,7 +590,7 @@ (def'' (defmacro tokens) Macro (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) @@ -600,7 +600,7 @@ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(tag$ ["" "export"]) (#Cons [(form$ (#Cons [name args])) @@ -640,12 +640,12 @@ (defmacro (All' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [[_ (#TupleS #Nil)] (#Cons [body #Nil])]) (return (#Cons [body #Nil])) - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [[_ (#TupleS (#Cons [[_ (#SymbolS ["" arg-name])] other-args]))] (#Cons [body #Nil])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) @@ -664,7 +664,7 @@ (defmacro (B' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + (#Cons [[_ (#SymbolS ["" bound-name])] #Nil]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) (#Cons [(_meta (#TextS bound-name)) @@ -732,15 +732,15 @@ (fail "Wrong syntax for list&"))) (defmacro (lambda' tokens) - (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) + (let'' [name tokens'] (_lux_: (#ProdT Ident ($' List AST)) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + (#Cons [[_ (#SymbolS name)] tokens']) [name tokens'] _ [["" ""] tokens])) (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) (_lux_case args #Nil (fail "lambda' requires a non-empty arguments tuple.") @@ -762,8 +762,8 @@ (defmacro (def''' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -775,7 +775,7 @@ body)))))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) @@ -783,7 +783,7 @@ body)))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -805,7 +805,7 @@ (def''' (as-pairs xs) (All' [a] - (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) + (->' ($' List (B' a)) ($' List (#ProdT (B' a) (B' a))))) (_lux_case xs (#Cons [x (#Cons [y xs'])]) (#Cons [[x y] (as-pairs xs')]) @@ -815,8 +815,8 @@ (defmacro (let' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) + (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) + (return (list (foldL (_lux_: (->' AST (#ProdT AST AST) AST) (lambda' [body binding] (_lux_case binding @@ -853,7 +853,7 @@ (def''' (spliced? token) (->' AST Bool) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] true _ @@ -861,9 +861,8 @@ (def''' (wrap-meta content) (->' AST AST) - (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content))))))) + (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) + content)))) (def''' (untemplate-list tokens) (->' ($' List AST) AST) @@ -902,7 +901,7 @@ true (let' [elems' (map (lambda' [elem] (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] spliced _ @@ -923,23 +922,23 @@ (def''' (untemplate replace? subst token) (->' Bool Text AST AST) - (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) - [_ (#Meta [_ (#BoolS value)])] + (_lux_case (_lux_: (#ProdT Bool AST) [replace? token]) + [_ [_ (#BoolS value)]] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - [_ (#Meta [_ (#IntS value)])] + [_ [_ (#IntS value)]] (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - [_ (#Meta [_ (#RealS value)])] + [_ [_ (#RealS value)]] (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - [_ (#Meta [_ (#CharS value)])] + [_ [_ (#CharS value)]] (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - [_ (#Meta [_ (#TextS value)])] + [_ [_ (#TextS value)]] (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - [_ (#Meta [_ (#TagS [module name])])] + [_ [_ (#TagS [module name])]] (let' [module' (_lux_case module "" subst @@ -948,7 +947,7 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ (#Meta [_ (#SymbolS [module name])])] + [_ [_ (#SymbolS [module name])]] (let' [module' (_lux_case module "" subst @@ -957,19 +956,19 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ (#Meta [_ (#TupleS elems)])] + [_ [_ (#TupleS elems)]] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] unquoted - [_ (#Meta [meta (#FormS elems)])] - (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - (#Meta [meta form'])) + [_ [meta (#FormS elems)]] + (let' [[_ form'] (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + [meta form']) - [_ (#Meta [_ (#RecordS fields)])] + [_ [_ (#RecordS fields)]] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) + (untemplate-list (map (_lux_: (->' (#ProdT AST AST) AST) (lambda' [kv] (let' [[k v] kv] (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) @@ -995,16 +994,17 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (lambda' [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [acc app] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (list:++ parts (list acc))) - (#Meta [_ (#FormS parts)]) - (form$ (list:++ parts (list acc))) + [_ (#FormS parts)] + (form$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) + _ + (`' ((~ app) (~ acc)))))) init apps))) @@ -1026,7 +1026,7 @@ (def''' #export Lux Type (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) + (->' Compiler ($' Either Text (#ProdT Compiler (B' a)))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1037,10 +1037,10 @@ Type (#NamedT ["lux" "Monad"] (All' [m] - (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) - (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))))))) + (#ProdT (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b)))))))) (_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad @@ -1074,7 +1074,7 @@ (defmacro #export (^ tokens) (_lux_case tokens - (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil) + (#Cons [_ (#SymbolS "" class-name)] #Nil) (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ @@ -1083,7 +1083,8 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons output inputs) - (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [o i] (`' (#;LambdaT (~ i) (~ o))))) output inputs))) @@ -1091,16 +1092,25 @@ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) + (_lux_case (reverse tokens) + (#Cons last prevs) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [r l] (`' (#;ProdT (~ l) (~ r))))) + last + prevs))) + + _ + (fail "Wrong syntax for ,")) + ) (defmacro (do tokens) (_lux_case tokens - (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) + (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var - (#Meta _ (#TagS "" "let")) + [_ (#TagS "" "let")] (`' (;let' (~ value) (~ body'))) _ @@ -1146,7 +1156,7 @@ (def''' (get-ident x) (-> AST ($' Maybe Ident)) (_lux_case x - (#Meta [_ (#SymbolS sname)]) + [_ (#SymbolS sname)] (#Some sname) _ @@ -1155,7 +1165,7 @@ (def''' (get-name x) (-> AST ($' Maybe Text)) (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) + [_ (#SymbolS ["" sname])] (#Some sname) _ @@ -1164,7 +1174,7 @@ (def''' (tuple->list tuple) (-> AST ($' Maybe ($' List AST))) (_lux_case tuple - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (#Some members) _ @@ -1203,7 +1213,7 @@ (def''' (apply-template env template) (-> RepEnv AST AST) (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) + [_ (#SymbolS ["" sname])] (_lux_case (get-rep sname env) (#Some subst) subst @@ -1211,13 +1221,13 @@ _ template) - (#Meta [_ (#TupleS elems)]) + [_ (#TupleS elems)] (tuple$ (map (apply-template env) elems)) - (#Meta [_ (#FormS elems)]) + [_ (#FormS elems)] (form$ (map (apply-template env) elems)) - (#Meta [_ (#RecordS members)]) + [_ (#RecordS members)] (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] @@ -1239,7 +1249,7 @@ (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index aab25d741..212f02665 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -25,6 +25,7 @@ "RealTotal" "CharTotal" "TextTotal" + "UnitTotal" "ProdTotal" "SumTotal"] ) @@ -36,6 +37,7 @@ "RealTestAC" "CharTestAC" "TextTestAC" + "UnitTestAC" "ProdTestAC" "SumTestAC"] ) @@ -113,11 +115,14 @@ type* (adjust-type type) idx (&module/tag-index =module =name) group (&module/tag-group =module =name) + ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))] case-type (&type/variant-case idx type*)] (return ($$ &/P idx (&/|length group) case-type)))) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[_ pattern*] pattern] + (|let [[_ pattern*] pattern + ;; :let [_ (prn 'analyse-pattern (&/adt->text pattern*) (&type/show-type value-type))] + ] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type @@ -153,6 +158,11 @@ =kont kont] (return (&/P (&/S $TextTestAC ?value) =kont))) + (&/$TupleS (&/$Nil)) + (|do [_ (&type/check value-type &type/Unit) + =kont kont] + (return (&/P (&/S $UnitTestAC nil) =kont))) + (&/$TupleS (&/$Cons ?_left ?tail)) (|do [value-type* (adjust-type value-type)] (|case value-type* @@ -168,7 +178,7 @@ _ (analyse-pattern ?right (&/S &/$TupleS ?tail) kont))] (return (&/P =right =kont))))] - (return (&/P (&/S $ProdTestAC =left =right) =kont))) + (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont))) _ (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*))))) @@ -182,8 +192,7 @@ [=test =kont] (analyse-pattern case-type unit kont)] (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) - (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] - ?values)) + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) (|do [[idx group-count case-type] (resolve-tag ?ident value-type) [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) @@ -240,6 +249,12 @@ [($TextTotal total? ?values) ($TextTestAC ?value)] (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) + [($DefaultTotal total?) ($UnitTestAC)] + (return (&/S $UnitTotal nil)) + + [($UnitTotal) ($UnitTestAC)] + (return (&/S $UnitTotal nil)) + [($DefaultTotal total?) ($ProdTestAC ?left ?right)] (|do [:let [_default (&/S $DefaultTotal total?)] =left (merge-total _default (&/P ?left ?body)) @@ -301,6 +316,9 @@ ($TextTotal ?total _) (return ?total) + ($UnitTotal) + (return true) + ($ProdTotal ?total ?_left ?_right) (if ?total (return true) @@ -329,7 +347,7 @@ (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.") _ - (check-totality ?right ($SumTotal ?total ?tail)))] + (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))] (return (and =left =right))) _ diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 696c816e9..b30953f67 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -30,10 +30,10 @@ (->> frame (&/$get-closure) (&/$get-counter)) register)) register-type)] - (do (prn 'close-over 'updating-closure - [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] - [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) - (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) + (do ;; (prn 'close-over 'updating-closure + ;; [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] + ;; [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) + ;; (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) ($$ &/P register* (&/$update-closure #(->> % (&/$update-counter inc) (&/$update-mappings (fn [mps] (&/|put name register* mps)))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 909e7e2c4..bc9647f9f 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -349,20 +349,17 @@ nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(defn tag-index [module tag-name] - "(-> Text Text (Lux Int))" - (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] - (return* state (aget idx+tags 0)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - -(defn tag-group [module tag-name] - "(-> Text Text (Lux (List Ident)))" - (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] - (return* state (aget idx+tags 1)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) +(do-template [ ] + (defn [module tag-name] + + (fn [state] + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] + (|let [[idx tags type] idx+tags] + (return* state )) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + + tag-index idx "(-> Text Text (Lux Int))" + tag-group tags "(-> Text Text (Lux (List Ident)))" + ) diff --git a/src/lux/base.clj b/src/lux/base.clj index 2f0925586..d261145ae 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -21,7 +21,7 @@ (defmacro deftags [names] (assert (vector? names)) `(do ~@(for [[name idx] (map vector names (range (count names)))] - `(def ~(symbol (str "$" name)) ~idx)))) + `(def ~(symbol (str "$" name)) (int ~idx))))) (defn ^:private unfold-accesses ([elems] @@ -793,7 +793,7 @@ (defn with-writer [writer body] (fn [state] - (prn 'with-writer writer body) + ;; (prn 'with-writer writer body) (let [output (body ($update-host #($set-writer (Some$ writer) %) state))] (|case output ($Right ?state ?value) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 72d569ed1..e327d1de4 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -94,6 +94,7 @@ (do-template [ ] (defn [^MethodVisitor writer] (doto writer + (.visitTypeInsn Opcodes/CHECKCAST ) (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" )))) unwrap-boolean "java/lang/Boolean" "Z" "booleanValue" diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index b30fcb4f8..0a928a056 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -84,27 +84,36 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$UnitTestAC) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$ProdTestAC left right) (let [$post-left (new Label) - $post-right (new Label)] + $post-right (new Label) + $pre-else (new Label)] (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitInsn Opcodes/AALOAD) - (compile-match left $post-left $else) + (compile-match left $post-left $pre-else) (.visitLabel $post-left) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)) (.visitInsn Opcodes/AALOAD) - (compile-match right $post-right $else) + (compile-match right $post-right $pre-else) (.visitLabel $post-right) (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target))) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $pre-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else))) (&a-case/$SumTestAC ?tag ?count ?test) (let [$value-then (new Label) - $sum-else (new Label)] + $pre-else (new Label)] (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) @@ -112,15 +121,15 @@ (.visitInsn Opcodes/AALOAD) (&&/unwrap-int) (.visitLdcInsn (int ?tag)) - (.visitJumpInsn Opcodes/IF_ICMPNE $sum-else) + (.visitJumpInsn Opcodes/IF_ICMPNE $else) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)) (.visitInsn Opcodes/AALOAD) - (compile-match ?test $value-then $sum-else) + (compile-match ?test $value-then $pre-else) (.visitLabel $value-then) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $sum-else) + (.visitLabel $pre-else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $else))) ))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 79383acc0..10ee40839 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -138,7 +138,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$TypeD) ;; VVIT - (&&/wrap-long) + (&&/wrap-int) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -165,7 +165,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$ValueD) ;; VVIT - (&&/wrap-long) + (&&/wrap-int) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI diff --git a/src/lux/type.clj b/src/lux/type.clj index 4193d8df4..91bc6e480 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -548,6 +548,12 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] + [(&/$UnitT) (&/$UnitT)] + true + + [(&/$VoidT) (&/$VoidT)] + true + [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) @@ -704,6 +710,9 @@ (if (clojure.lang.Util/identical expected actual) (return (&/P fixpoints nil)) (|case [expected actual] + [(&/$UnitT) (&/$UnitT)] + (return (&/P fixpoints nil)) + [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/P fixpoints nil)) @@ -840,7 +849,7 @@ (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] (|let [[e a] pair] - (str (show-type e) ":+:" + (str (show-type e) " :+: " (show-type a))))) (&/|interpose "\n\n") (&/fold str ""))) @@ -909,6 +918,9 @@ [_ (&/$NamedT ?aname ?atype)] (check* class-loader fixpoints expected ?atype) + [_ (&/$VoidT)] + (return (&/P fixpoints nil)) + [_ _] (fail (check-error expected actual)) ))) -- cgit v1.2.3 From 37a9044d8ec523a282c0470d65380ce5cff27084 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 20:27:51 -0400 Subject: - Restructuring how sums & products work [part 3] --- source/lux.lux | 252 +++++++++++++++++++++++-------------------- source/lux/control/monad.lux | 6 +- source/lux/data/id.lux | 13 ++- source/lux/data/list.lux | 51 +++++---- source/lux/meta/ast.lux | 2 +- source/lux/meta/macro.lux | 16 +-- source/lux/meta/syntax.lux | 18 ++-- src/lux/analyser/case.clj | 11 +- src/lux/analyser/lux.clj | 22 ++-- src/lux/type.clj | 4 +- 10 files changed, 205 insertions(+), 190 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index bdb845f1b..97030a7ef 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1100,7 +1100,7 @@ prevs))) _ - (fail "Wrong syntax for ,")) + (fail ", must have at least 2 members.")) ) (defmacro (do tokens) @@ -1334,7 +1334,7 @@ (def''' (replace-syntax reps syntax) (-> RepEnv AST AST) (_lux_case syntax - (#Meta [_ (#SymbolS ["" name])]) + [_ (#SymbolS ["" name])] (_lux_case (get-rep name reps) (#Some replacement) replacement @@ -1342,18 +1342,18 @@ #None syntax) - (#Meta [_ (#FormS parts)]) - (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) + [_ (#FormS parts)] + [_ (#FormS (map (replace-syntax reps) parts))] - (#Meta [_ (#TupleS members)]) - (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - - (#Meta [_ (#RecordS slots)]) - (#Meta [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) - (lambda' [slot] - (let' [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) + [_ (#TupleS members)] + [_ (#TupleS (map (replace-syntax reps) members))] + + [_ (#RecordS slots)] + [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) + (lambda' [slot] + (let' [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))] _ syntax) @@ -1362,13 +1362,13 @@ (defmacro #export (All tokens) (let' [[self-ident tokens'] (_lux_: (, Text ASTList) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + (#Cons [[_ (#SymbolS ["" self-ident])] tokens']) [self-ident tokens'] _ ["" tokens]))] (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) (_lux_case (map% Maybe/Monad get-name args) (#Some idents) (_lux_case idents @@ -1379,8 +1379,9 @@ (let' [replacements (map (_lux_: (-> Text (, Text AST)) (lambda' [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) (list& self-ident idents)) - body' (foldL (lambda' [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) + body' (foldL (_lux_: (-> AST Text AST) + (lambda' [body' arg'] + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')])))) (replace-syntax replacements body) (reverse targs))] ## (#;Some #;Nil) @@ -1502,7 +1503,7 @@ (def''' (macro-expand token) (-> AST ($' Lux ($' List AST))) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1522,7 +1523,7 @@ (def''' (macro-expand-all syntax) (-> AST ($' Lux ($' List AST))) (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1538,13 +1539,13 @@ [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (wrap (list (form$ (list:join parts'))))))) - (#Meta [_ (#FormS (#Cons [harg targs]))]) + [_ (#FormS (#Cons [harg targs]))] (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (map% Lux/Monad macro-expand-all targs)] (wrap (list (form$ (list:++ harg+ (list:join targs+)))))) - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (do Lux/Monad [members' (map% Lux/Monad macro-expand-all members)] (wrap (list (tuple$ (list:join members'))))) @@ -1555,14 +1556,15 @@ (def''' (walk-type type) (-> AST AST) (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - (form$ (#Cons [(tag$ tag) (map walk-type parts)])) + [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))] + (form$ (#Cons (tag$ tag) (map walk-type parts))) - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (tuple$ (map walk-type members)) - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + [_ (#FormS (#Cons [type-fn args]))] + (foldL (_lux_: (-> AST AST AST) + (lambda' [type-fn arg] (`' (#;AppT (~ type-fn) (~ arg))))) (walk-type type-fn) (map walk-type args)) @@ -1617,40 +1619,50 @@ (def''' (unfold-type-def type) (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) (_lux_case type - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "|")) cases))) + [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))] (do Lux/Monad [members (map% Lux/Monad (: (-> AST ($' Lux (, Text AST))) (lambda' [case] (_lux_case case - (#Meta _ (#TagS "" member-name)) + [_ (#TagS "" member-name)] (return [member-name (`' Unit)]) - (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "" member-name)) (#Cons member-type #Nil)))) + [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")))) - cases)] - (return [(`' (#;VariantT (~ (untemplate-list (map second members))))) + cases) + variant-type (: (Lux AST) + (_lux_case (reverse members) + (#Cons last prevs) + (return (foldL (_lux_: (->' AST AST AST) + (lambda' [r l] (`' (#;SumT (~ l) (~ r))))) + (second last) + (map second prevs))) + + _ + (fail "| must have at least 2 members.")))] + (return [variant-type (#Some (|> members (map first) (map (: (-> Text AST) (lambda' [name] (tag$ ["" name]))))))])) - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "&")) pairs))) + [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))] (do Lux/Monad [members (map% Lux/Monad (: (-> (, AST AST) ($' Lux (, Text AST))) (lambda' [pair] (_lux_case pair - [(#Meta _ (#TagS "" member-name)) member-type] + [[_ (#TagS "" member-name)] member-type] (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")))) (as-pairs pairs))] - (return [(`' (#TupleT (~ (untemplate-list (map second members))))) + (return [(`' (, (~@ (map second members)))) (#Some (|> members (map first) (map (: (-> Text AST) @@ -1662,24 +1674,24 @@ (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) [rec? tokens'] (: (, Bool (List AST)) (_lux_case tokens' - (#Cons (#Meta _ (#TagS "" "rec")) tokens') + (#Cons [_ (#TagS "" "rec")] tokens') [true tokens'] _ [false tokens'])) parts (: (Maybe (, Text (List AST) AST)) (_lux_case tokens' - (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) + (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) (#Some name #Nil type) - (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil)) + (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil)) (#Some name args type) _ @@ -1735,7 +1747,8 @@ (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] - (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + (return (list (foldL (: (-> AST AST AST) + (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) value actions)))) @@ -1745,20 +1758,20 @@ (defmacro (def' tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (_lux_case tokens' - (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) + (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) (#Some name args (#Some type) body) (#Cons name (#Cons type (#Cons body #Nil))) (#Some name #Nil (#Some type) body) - (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil)) + (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) (#Some name args #None body) (#Cons name (#Cons body #Nil)) @@ -1804,7 +1817,7 @@ (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] (do Lux/Monad [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] @@ -1863,7 +1876,7 @@ (def' (symbol? ast) (-> AST Bool) (case ast - (#Meta _ (#SymbolS _)) + [_ (#SymbolS _)] true _ @@ -1871,7 +1884,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list (#Meta _ (#TupleS bindings)) body)) + (\ (list [_ (#TupleS bindings)] body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> AST (, AST AST) AST) @@ -1891,7 +1904,7 @@ (def' (ast:show ast) (-> AST Text) (case ast - (#Meta _ ast) + [_ ast] (case ast (\or (#BoolS val) (#IntS val) (#RealS val)) (->text val) @@ -1927,10 +1940,10 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens - (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) + (\ (list [_ (#TupleS (#Cons head tail))] body)) (#Some ["" ""] head tail body) - (\ (list (#Meta _ (#SymbolS [_ name])) (#Meta _ (#TupleS (#Cons head tail))) body)) + (\ (list [_ (#SymbolS [_ name])] [_ (#TupleS (#Cons head tail))] body)) (#Some ["" name] head tail body) _ @@ -1956,20 +1969,20 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' - (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) + (\ (list [_ (#FormS (#Cons name args))] type body)) (#Some name args (#Some type) body) (\ (list name type body)) (#Some name #Nil (#Some type) body) - (\ (list (#Meta _ (#FormS (#Cons name args))) body)) + (\ (list [_ (#FormS (#Cons name args))] body)) (#Some name args #None body) (\ (list name body)) @@ -2017,17 +2030,17 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& (#Meta _ (#TagS "" "export")) tokens')) + (\ (list& [_ (#TagS "" "export")] tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& (#Meta _ (#FormS (list& (#Meta _ (#SymbolS name)) args))) sigs)) + (\ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) (#Some name args sigs) - (\ (list& (#Meta _ (#SymbolS name)) sigs)) + (\ (list& [_ (#SymbolS name)] sigs)) (#Some name #Nil sigs) _ @@ -2041,7 +2054,7 @@ (: (-> AST (Lux (, Text AST))) (lambda [token] (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS ["" name])))))) + (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) (wrap (: (, Text AST) [name type])) _ @@ -2050,8 +2063,7 @@ #let [[_module _name] name+ def-name (symbol$ name) tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) - types (map second members) - sig-type (: AST (` (#;TupleT (~ (untemplate-list types))))) + sig-type (: AST (` (, (~@ (map second members))))) sig-decl (: AST (` (_lux_declare-tags [(~@ tags)] (~ def-name)))) sig+ (: AST (case args @@ -2129,24 +2141,20 @@ (def (type:show type) (-> Type Text) (case type - (#DataT name) - ($ text:++ "(^ " name ")") - - (#TupleT members) - (case members - #;Nil - "(,)" + #VoidT + "(|)" - _ - ($ text:++ "(, " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) + #UnitT + "(,)" + + (#SumT left right) + ($ text:++ "(| " (type:show left) " " (type:show right) ")") - (#VariantT members) - (case members - #;Nil - "(|)" + (#ProdT left right) + ($ text:++ "(, " (type:show left) " " (type:show right) ")") - _ - ($ text:++ "(| " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) + (#DataT name) + ($ text:++ "(^ " name ")") (#LambdaT input output) ($ text:++ "(-> " (type:show input) " " (type:show output) ")") @@ -2173,11 +2181,11 @@ (def (beta-reduce env type) (-> (List (, Text Type)) Type Type) (case type - (#VariantT ?cases) - (#VariantT (map (beta-reduce env) ?cases)) + (#SumT left right) + (#SumT (beta-reduce env left) (beta-reduce env right)) - (#TupleT ?members) - (#TupleT (map (beta-reduce env) ?members)) + (#ProdT left right) + (#ProdT (beta-reduce env left) (beta-reduce env right)) (#AppT ?type-fn ?type-arg) (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -2233,9 +2241,16 @@ (def (resolve-struct-type type) (-> Type (Maybe (List Type))) (case type - (#TupleT slots) - (#Some slots) - + (#ProdT left right) + (case right + (#ProdT _) + (do Maybe/Monad + [rights (resolve-struct-type right)] + (wrap (list& left rights))) + + _ + (#Some (list left right))) + (#AppT fun arg) (do Maybe/Monad [output (apply-type fun arg)] @@ -2327,7 +2342,7 @@ (: (-> AST (Lux (, AST AST))) (lambda [token] (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS tag-name)) value)))) + (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS tag-name)] value))]) (wrap (: (, AST AST) [(tag$ tag-name) value])) _ @@ -2338,14 +2353,14 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& (#Meta _ (#TagS "" "export")) tokens')) + (\ (list& [_ (#TagS "" "export")] tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' - (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) + (\ (list& [_ (#FormS (list& name args))] type defs)) (#Some name args type defs) (\ (list& name type defs)) @@ -2378,7 +2393,8 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (list (foldL (lambda [post pre] (`
)) + (return (list (foldL (: (-> AST AST AST) + (lambda [post pre] (` ))) last init))) @@ -2406,7 +2422,7 @@ (: (-> AST (Lux Text)) (lambda [def] (case def - (#Meta _ (#SymbolS "" name)) + [_ (#SymbolS "" name)] (return name) _ @@ -2416,7 +2432,7 @@ (def (parse-alias tokens) (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) + (\ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) _ @@ -2425,17 +2441,17 @@ (def (parse-referrals tokens) (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) + (\ (list& [_ (#TagS "" "refer")] referral tokens')) (case referral - (#Meta _ (#TagS "" "all")) + [_ (#TagS "" "all")] (return (: (, Referrals (List AST)) [#All tokens'])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) + (\ [_ (#FormS (list& [_ (#TagS "" "only")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) - (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) + (\ [_ (#FormS (list& [_ (#TagS "" "exclude")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) @@ -2449,7 +2465,7 @@ (def (extract-symbol syntax) (-> AST (Lux Ident)) (case syntax - (#Meta _ (#SymbolS ident)) + [_ (#SymbolS ident)] (return ident) _ @@ -2458,7 +2474,7 @@ (def (parse-openings tokens) (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) + (\ (list& [_ (#TagS "" "open")] [_ (#FormS (list& [_ (#TextS prefix)] structs))] tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) @@ -2684,10 +2700,10 @@ (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] (wrap ($ list:++ - (list (` (_lux_import (~ (text$ m-name))))) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) + (: (List AST) (list (` (_lux_import (~ (text$ m-name)))))) + (: (List AST) (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) (map (: (-> Text AST) (lambda [def] (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) @@ -2698,9 +2714,10 @@ _ (wrap (: (List AST) - (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) + (list:++ (map (: (-> Text AST) + (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))) unknowns) - (list (` (import (~@ tokens)))))))))) + (: (List AST) (list (` (import (~@ tokens))))))))))) (def (try-both f x1 x2) (All [a b] @@ -2863,12 +2880,6 @@ _ (fail "Wrong syntax for using"))) -(def (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [y x] - (f x y))) - (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") @@ -2989,11 +3000,11 @@ (lambda [so-far part] (case part [_ (#SymbolS slot)] - (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + (return (: AST (` (get@ (~ (tag$ slot)) (~ so-far))))) (\ [_ (#FormS (list& [_ (#SymbolS slot)] args))]) - (return (` ((get@ (~ (tag$ slot)) (~ so-far)) - (~@ args)))) + (return (: AST (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args))))) _ (fail "Wrong syntax for ::")))) @@ -3121,26 +3132,29 @@ (def (type->syntax type) (-> Type AST) (case type + (\template [] + [ + (` )]) + [[#VoidT] [#UnitT]] + + (\template [] + [( left right) + (` ( (~ (type->syntax left)) (~ (type->syntax right))))]) + [[#SumT] [#ProdT]] + (#DataT name) (` (#;DataT (~ (text$ name)))) - - (#;VariantT cases) - (` (#;VariantT (~ (untemplate-list (map type->syntax cases))))) - (#TupleT parts) - (` (#;TupleT (~ (untemplate-list (map type->syntax parts))))) - (#LambdaT in out) (` (#;LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) (#BoundT name) (` (#;BoundT (~ (text$ name)))) - - (#VarT id) - (` (#;VarT (~ (int$ id)))) - (#ExT id) - (` (#;ExT (~ (int$ id)))) + (\template [] + [( id) + (` ( (~ (int$ id))))]) + [[#VarT] [#ExT]] (#AllT env name arg type) (let [env' (: AST @@ -3190,4 +3204,6 @@ (fail "Wrong syntax for loop"))) (defmacro #export (export tokens) - (return (map (lambda [token] (` (_lux_export (~ token)))) tokens))) + (return (map (: (-> AST AST) + (lambda [token] (` (_lux_export (~ token))))) + tokens))) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index c87c4fdc3..8a7974e8b 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -53,15 +53,15 @@ ## [Syntax] (defmacro #export (do tokens state) (case tokens - ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) + ## (\ (list monad [_ (#;TupleS bindings)] body)) + (#;Cons [monad (#;Cons [[_ (#;TupleS bindings)] (#;Cons [body #;Nil])])]) (let [g!map (symbol$ ["" " map "]) g!join (symbol$ ["" " join "]) body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var - (#;Meta [_ (#;TagS ["" "let"])]) + [_ (#;TagS ["" "let"])] (` (;let (~ value) (~ body'))) _ diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 3ad6b056b..d8bb30a3d 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -13,20 +13,19 @@ ## [Types] (deftype #export (Id a) - (| (#Id a))) + a) ## [Structures] (defstruct #export Id/Functor (Functor Id) (def (F;map f fa) - (let [(#Id a) fa] - (#Id (f a))))) + (f fa))) (defstruct #export Id/Monad (Monad Id) (def M;_functor Id/Functor) - (def (M;wrap a) (#Id a)) - (def (M;join mma) (let [(#Id ma) mma] ma))) + (def M;wrap id) + (def M;join id)) (defstruct #export Id/CoMonad (CoMonad Id) (def CM;_functor Id/Functor) - (def (CM;unwrap wa) (let [(#Id a) wa] a)) - (def (CM;split wa) (#Id wa))) + (def CM;unwrap id) + (def CM;split id)) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 5a8357251..97333f570 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -23,13 +23,13 @@ ## (#Cons (, a (List a))))) (deftype #export (PList k v) - (| (#PList (, (E;Eq k) (List (, k v)))))) + (, (E;Eq k) (List (, k v)))) ## [Constructors] (def #export (plist eq) (All [k v] (-> (E;Eq k) (PList k v))) - (#PList [eq #;Nil])) + [eq #;Nil]) ## [Functions] (def #export (foldL f init xs) @@ -252,8 +252,7 @@ ## true ## [(#;Cons [x xs']) (#;Cons [y ys'])] -## (and (:: eq (E;= x y)) -## (E;= xs' ys')) +## (and (:: eq (E;= x y)) (= xs' ys')) ## ))) (defstruct #export List/Monoid (All [a] @@ -281,7 +280,7 @@ (foldL ++ unit mma)))) (defstruct #export PList/Dict (Dict PList) - (def (D;get k (#PList [eq kvs])) + (def (D;get k [eq kvs]) (loop [kvs kvs] (case kvs #;Nil @@ -292,27 +291,27 @@ (#;Some v') (recur kvs'))))) - (def (D;put k v (#PList [eq kvs])) - (#PList [eq (loop [kvs kvs] - (case kvs - #;Nil - (#;Cons [k v] kvs) - - (#;Cons [k' v'] kvs') - (if (:: eq (E;= k k')) - (#;Cons [k v] kvs') - (#;Cons [k' v'] (recur kvs')))))])) - - (def (D;remove k (#PList [eq kvs])) - (#PList [eq (loop [kvs kvs] - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (recur kvs')]))))]))) + (def (D;put k v [eq kvs]) + [eq (loop [kvs kvs] + (case kvs + #;Nil + (#;Cons [k v] kvs) + + (#;Cons [k' v'] kvs') + (if (:: eq (E;= k k')) + (#;Cons [k v] kvs') + (#;Cons [k' v'] (recur kvs')))))]) + + (def (D;remove k [eq kvs]) + [eq (loop [kvs kvs] + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (recur kvs')]))))])) (defstruct #export List/Stack (S;Stack List) (def S;empty (list)) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index f01f08af1..3d2f30db2 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -31,7 +31,7 @@ (do-template [ ] [(def #export ( x) (-> AST) - (#;Meta _cursor ( x)))] + [_cursor ( x)])] [bool$ Bool #;BoolS] [int$ Int #;IntS] diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux index 15f3582fa..e6963b3d6 100644 --- a/source/lux/meta/macro.lux +++ b/source/lux/meta/macro.lux @@ -12,18 +12,18 @@ (def #export (defmacro tokens state) Macro (case tokens - (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) - (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) + (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) ((~ name) (~@ args)) + (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) (~ body))) - (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) #;Nil])])]) - (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) (~ (#;Meta ["" -1 -1] (#;TagS ["" "export"]))) ((~ name) (~@ args)) - (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) + (#;Cons [[_ (#;TagS ["" "export"])] (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) (~ [["" -1 -1] (#;TagS ["" "export"])]) ((~ name) (~@ args)) + (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) (~ body))) - (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) #;Nil])])]) _ diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index b9834f972..db6a5774a 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -73,7 +73,7 @@ [(def #export ( tokens) (Parser ) (case tokens - (#;Cons [(#;Meta [_ ( x)]) tokens']) + (#;Cons [[_ ( x)] tokens']) (#;Some [tokens' x]) _ @@ -92,7 +92,7 @@ [(def #export ( tokens) (Parser Text) (case tokens - (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) + (#;Cons [[_ ( ["" x])] tokens']) (#;Some [tokens' x]) _ @@ -113,7 +113,7 @@ [(def #export ( v tokens) (-> (Parser (,))) (case tokens - (#;Cons [(#;Meta [_ ( x)]) tokens']) + (#;Cons [[_ ( x)] tokens']) (if ( v x) (#;Some [tokens' []]) #;None) @@ -135,7 +135,7 @@ (All [a] (-> (Parser a) (Parser a))) (case tokens - (#;Cons [(#;Meta [_ ( form)]) tokens']) + (#;Cons [[_ ( form)] tokens']) (case (p form) (#;Some [#;Nil x]) (#;Some [tokens' x]) _ #;None) @@ -215,24 +215,24 @@ (defmacro #export (defsyntax tokens) (let [[exported? tokens] (: (, Bool (List AST)) (case tokens - (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) + (\ (list& [_ (#;TagS ["" "export"])] tokens')) [true tokens'] _ [false tokens]))] (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + (\ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))] body)) (do Lux/Monad [names+parsers (M;map% Lux/Monad (: (-> AST (Lux (, AST AST))) (lambda [arg] (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) + (\ [_ (#;TupleS (list [_ (#;SymbolS var-name)] + parser))]) (wrap [(symbol$ var-name) parser]) - (\ (#;Meta [_ (#;SymbolS var-name)])) + (\ [_ (#;SymbolS var-name)]) (wrap [(symbol$ var-name) (` id^)]) _ diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 212f02665..6bb767d3e 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -120,8 +120,8 @@ (return ($$ &/P idx (&/|length group) case-type)))) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[_ pattern*] pattern - ;; :let [_ (prn 'analyse-pattern (&/adt->text pattern*) (&type/show-type value-type))] + (|let [[meta pattern*] pattern + ;; _ (prn 'analyse-pattern (&/show-ast pattern) (&type/show-type value-type)) ] (|case pattern* (&/$SymbolS "" name) @@ -130,9 +130,6 @@ idx &env/next-local-idx] (return (&/P (&/S $StoreTestAC idx) =kont))) - (&/$SymbolS ident) - (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] @@ -176,7 +173,7 @@ (fail "[Pattern-matching Error] Pattern-matching mismatch. Tuple has wrong size.") _ - (analyse-pattern ?right (&/S &/$TupleS ?tail) kont))] + (analyse-pattern ?right (&/P meta (&/S &/$TupleS ?tail)) kont))] (return (&/P =right =kont))))] (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont))) @@ -185,7 +182,7 @@ (&/$RecordS pairs) (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/S &/$TupleS ?members) kont)) + (analyse-pattern value-type (&/P meta (&/S &/$TupleS ?members)) kont)) (&/$TagS ?ident) (|do [[idx group-count case-type] (resolve-tag ?ident value-type) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index f7ed07ee4..20e435eb3 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -209,7 +209,11 @@ (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] + ;; :let [_ (prn 'analyse-local/_0 name) + ;; _ (prn 'analyse-local/_1 name (&type/show-type exo-type) (&type/show-type btype))] + _ (&type/check exo-type btype) + ;; :let [_ (prn 'analyse-local/_2 name 'CHECKED)] + ] (return (&/|list =local))) (&/$set-envs (&/|++ inner* outer) state)))) )))) @@ -273,14 +277,14 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= "defsig" (aget real-name 1)) - ;; ;; (= "type" (aget real-name 1)) - ;; ;; (= &&/$struct r-name) - ;; ) - ;; (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (prn (&/ident->text real-name))))] + :let [_ (when (or (= "using" (aget real-name 1)) + ;; (= "type" (aget real-name 1)) + ;; (= &&/$struct r-name) + ) + (->> (&/|map &/show-ast macro-expansion) + (&/|interpose "\n") + (&/fold str "") + (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 91bc6e480..37f3a99d4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -685,7 +685,7 @@ (apply-type ?type param) _ - (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) + (fail (str "[Type Error] Not a type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] (case class @@ -947,7 +947,7 @@ (apply-lambda ?type param) _ - (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) + (fail (str "[Type Error] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] -- cgit v1.2.3 From f403ee7a9662f81c91aa124f0573c5957a88ebe5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 06:37:46 -0400 Subject: Due to several performance issues and my inability to optimize them away due to too many corner cases, I decided the abandon the path towards a more mathematical implementation of tuples & variants. --- source/lux.lux | 885 +++++++++++++++++++++---------------------- source/lux/control/monad.lux | 6 +- source/lux/data/id.lux | 13 +- source/lux/data/list.lux | 51 +-- source/lux/meta/ast.lux | 2 +- source/lux/meta/macro.lux | 16 +- source/lux/meta/syntax.lux | 18 +- src/lux/analyser.clj | 401 ++++++++++---------- src/lux/analyser/base.clj | 230 +++++------ src/lux/analyser/case.clj | 380 ++++++++++--------- src/lux/analyser/env.clj | 38 +- src/lux/analyser/host.clj | 158 ++++---- src/lux/analyser/lambda.clj | 22 +- src/lux/analyser/lux.clj | 277 +++++++------- src/lux/analyser/module.clj | 266 +++++++------ src/lux/analyser/record.clj | 122 +++++- src/lux/base.clj | 529 +++++++++++--------------- src/lux/compiler.clj | 18 +- src/lux/compiler/base.clj | 45 +-- src/lux/compiler/cache.clj | 8 +- src/lux/compiler/case.clj | 92 ++--- src/lux/compiler/host.clj | 26 +- src/lux/compiler/lux.clj | 79 ++-- src/lux/compiler/module.clj | 4 +- src/lux/compiler/type.clj | 89 +++-- src/lux/host.clj | 6 +- src/lux/lexer.clj | 66 ++-- src/lux/parser.clj | 62 +-- src/lux/reader.clj | 54 +-- src/lux/type.clj | 645 +++++++++++++++---------------- 30 files changed, 2320 insertions(+), 2288 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 97030a7ef..4120b262c 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -11,50 +11,51 @@ ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) ## Basic types -(_lux_def Bool (11 ["lux" "Bool"] - (4 "java.lang.Boolean"))) +(_lux_def Bool (9 ["lux" "Bool"] + (0 "java.lang.Boolean"))) (_lux_export Bool) -(_lux_def Int (11 ["lux" "Int"] - (4 "java.lang.Long"))) +(_lux_def Int (9 ["lux" "Int"] + (0 "java.lang.Long"))) (_lux_export Int) -(_lux_def Real (11 ["lux" "Real"] - (4 "java.lang.Double"))) +(_lux_def Real (9 ["lux" "Real"] + (0 "java.lang.Double"))) (_lux_export Real) -(_lux_def Char (11 ["lux" "Char"] - (4 "java.lang.Character"))) +(_lux_def Char (9 ["lux" "Char"] + (0 "java.lang.Character"))) (_lux_export Char) -(_lux_def Text (11 ["lux" "Text"] - (4 "java.lang.String"))) +(_lux_def Text (9 ["lux" "Text"] + (0 "java.lang.String"))) (_lux_export Text) -(_lux_def Void (11 ["lux" "Void"] - (0 []))) -(_lux_export Void) - -(_lux_def Unit (11 ["lux" "Unit"] - (1 []))) +(_lux_def Unit (9 ["lux" "Unit"] + (2 (0)))) (_lux_export Unit) -(_lux_def Ident (11 ["lux" "Ident"] - (3 Text Text))) +(_lux_def Void (9 ["lux" "Void"] + (1 (0)))) +(_lux_export Void) + +(_lux_def Ident (9 ["lux" "Ident"] + (2 (1 Text (1 Text (0)))))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons a (List a)))) (_lux_def List - (11 ["lux" "List"] - (9 (1 (0)) "lux;List" "a" - (2 ## "lux;Nil" - Unit - ## "lux;Cons" - (3 (6 "a") - (10 (6 "lux;List") (6 "a"))) - )))) + (9 ["lux" "List"] + (7 (1 (0)) "lux;List" "a" + (1 (1 ## "lux;Nil" + (2 (0)) + (1 ## "lux;Cons" + (2 (1 (4 "a") + (1 (8 (4 "lux;List") (4 "a")) + (0)))) + (0))))))) (_lux_export List) (_lux_declare-tags [#Nil #Cons] List) @@ -62,78 +63,76 @@ ## (| #None ## (1 a))) (_lux_def Maybe - (11 ["lux" "Maybe"] - (9 (1 #Nil) "lux;Maybe" "a" - (2 ## "lux;None" - Unit - ## "lux;Some" - (6 "a") - )))) + (9 ["lux" "Maybe"] + (7 (1 (0)) "lux;Maybe" "a" + (1 (1 ## "lux;None" + (2 (0)) + (1 ## "lux;Some" + (4 "a") + (0))))))) (_lux_export Maybe) (_lux_declare-tags [#None #Some] Maybe) ## (deftype #rec Type -## (| #VoidT -## #UnitT -## (#SumT Type Type) -## (#ProdT Type Type) -## (#DataT Text) +## (| (#DataT Text) +## (#VariantT (List Type)) +## (#TupleT (List Type)) ## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) -## (#ExT Int) ## (#AllT (Maybe (List (, Text Type))) Text Text Type) ## (#AppT Type Type) ## (#NamedT Ident Type) -## )) +## )) (_lux_def Type - (11 ["lux" "Type"] - (_lux_case (10 (6 "Type") (6 "_")) - Type - (_lux_case (10 List (3 Text Type)) - TypeEnv - (10 (9 (#Some #Nil) "Type" "_" - (2 ## lux;VoidT - Unit - (2 ## lux;UnitT - Unit - (2 ## lux;SumT - (3 Type Type) - (2 ## lux;ProdT - (3 Type Type) - (2 ## "lux;DataT" - Text - (2 ## "lux;LambdaT" - (3 Type Type) - (2 ## "lux;BoundT" - Text - (2 ## "lux;VarT" - Int - (2 ## "lux;ExT" + (9 ["lux" "Type"] + (_lux_case (8 (4 "Type") (4 "_")) + Type + (_lux_case (8 List (2 (1 Text (1 Type (0))))) + TypeEnv + (_lux_case (8 List Type) + TypeList + (8 (7 (1 (0)) "Type" "_" + (1 (1 ## "lux;DataT" + Text + (1 ## "lux;VariantT" + TypeList + (1 ## "lux;TupleT" + TypeList + (1 ## "lux;LambdaT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;BoundT" + Text + (1 ## "lux;VarT" Int - (2 ## "lux;AllT" - (3 (10 Maybe TypeEnv) (3 Text (3 Text Type))) - (2 ## "lux;AppT" - (3 Type Type) - ## "lux;NamedT" - (3 Ident Type))))))))))))) - Void))))) + (1 ## "lux;ExT" + Int + (1 ## "lux;AllT" + (2 (1 (8 Maybe TypeEnv) (1 Text (1 Text (1 Type (0)))))) + (1 ## "lux;AppT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;NamedT" + (2 (1 Ident (1 Type (0)))) + (0))))))))))))) + Void)))))) (_lux_export Type) -(_lux_declare-tags [#VoidT #UnitT #SumT #ProdT #DataT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings (#NamedT ["lux" "Bindings"] - (#AllT (#Some #Nil) "lux;Bindings" "k" - (#AllT #None "" "v" - (#ProdT ## lux;counter - Int - ## lux;mappings - (#AppT List - (#ProdT (#BoundT "k") - (#BoundT "v")))))))) + (#AllT [(#Some #Nil) "lux;Bindings" "k" + (#AllT [#None "" "v" + (#TupleT (#Cons ## "lux;counter" + Int + (#Cons ## "lux;mappings" + (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))]) + #Nil)))])]))) (_lux_export Bindings) (_lux_declare-tags [#counter #mappings] Bindings) @@ -146,16 +145,17 @@ (#NamedT ["lux" "Env"] (#AllT (#Some #Nil) "lux;Env" "k" (#AllT #None "" "v" - (#ProdT ## "lux;name" - Text - (#ProdT ## "lux;inner-closures" - Int - (#ProdT ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v")) - ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v"))))))))) + (#TupleT (#Cons ## "lux;name" + Text + (#Cons ## "lux;inner-closures" + Int + (#Cons ## "lux;locals" + (#AppT (#AppT Bindings (#BoundT "k")) + (#BoundT "v")) + (#Cons ## "lux;closure" + (#AppT (#AppT Bindings (#BoundT "k")) + (#BoundT "v")) + #Nil))))))))) (_lux_export Env) (_lux_declare-tags [#name #inner-closures #locals #closure] Env) @@ -163,7 +163,7 @@ ## (, Text Int Int)) (_lux_def Cursor (#NamedT ["lux" "Cursor"] - (#ProdT Text (#ProdT Int Int)))) + (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) (_lux_export Cursor) ## (deftype (Meta m v) @@ -172,9 +172,13 @@ (#NamedT ["lux" "Meta"] (#AllT (#Some #Nil) "lux;Meta" "m" (#AllT #None "" "v" - (#ProdT (#BoundT "m") - (#BoundT "v")))))) + (#VariantT (#Cons ## "lux;Meta" + (#TupleT (#Cons (#BoundT "m") + (#Cons (#BoundT "v") + #Nil))) + #Nil)))))) (_lux_export Meta) +(_lux_declare-tags [#Meta] Meta) ## (deftype (AST' w) ## (| (#BoolS Bool) @@ -196,28 +200,29 @@ (_lux_case (#AppT [List AST]) ASTList (#AllT (#Some #Nil) "lux;AST'" "w" - (#SumT ## "lux;BoolS" - Bool - (#SumT ## "lux;IntS" - Int - (#SumT ## "lux;RealS" - Real - (#SumT ## "lux;CharS" - Char - (#SumT ## "lux;TextS" - Text - (#SumT ## "lux;SymbolS" - Ident - (#SumT ## "lux;TagS" - Ident - (#SumT ## "lux;FormS" - ASTList - (#SumT ## "lux;TupleS" - ASTList - ## "lux;RecordS" - (#AppT List (#ProdT AST AST)) - )))))))) - )))))) + (#VariantT (#Cons ## "lux;BoolS" + Bool + (#Cons ## "lux;IntS" + Int + (#Cons ## "lux;RealS" + Real + (#Cons ## "lux;CharS" + Char + (#Cons ## "lux;TextS" + Text + (#Cons ## "lux;SymbolS" + Ident + (#Cons ## "lux;TagS" + Ident + (#Cons ## "lux;FormS" + ASTList + (#Cons ## "lux;TupleS" + ASTList + (#Cons ## "lux;RecordS" + (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) + #Nil) + ))))))))) + )))))) (_lux_export AST') (_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') @@ -239,30 +244,32 @@ (#NamedT ["lux" "Either"] (#AllT (#Some #Nil) "lux;Either" "l" (#AllT #None "" "r" - (#SumT ## "lux;Left" - (#BoundT "l") - ## "lux;Right" - (#BoundT "r")))))) + (#VariantT (#Cons ## "lux;Left" + (#BoundT "l") + (#Cons ## "lux;Right" + (#BoundT "r") + #Nil))))))) (_lux_export Either) (_lux_declare-tags [#Left #Right] Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT (#Some #Nil) "lux;StateE" "s" - (#AllT #None "" "a" - (#LambdaT (#BoundT "s") - (#AppT (#AppT [Either Text]) - (#ProdT (#BoundT "s") - (#BoundT "a"))))))) + (#AllT [(#Some #Nil) "lux;StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) ## (deftype Source ## (List (Meta Cursor Text))) (_lux_def Source (#NamedT ["lux" "Source"] - (#AppT List - (#AppT (#AppT Meta Cursor) - Text)))) + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])]))) (_lux_export Source) ## (deftype Host @@ -271,12 +278,13 @@ ## #classes (^ clojure.lang.Atom))) (_lux_def Host (#NamedT ["lux" "Host"] - (#ProdT ## "lux;writer" - (#DataT "org.objectweb.asm.ClassWriter") - (#ProdT ## "lux;loader" - (#DataT "java.lang.ClassLoader") - ## "lux;classes" - (#DataT "clojure.lang.Atom"))))) + (#TupleT (#Cons [## "lux;writer" + (#DataT "org.objectweb.asm.ClassWriter") + (#Cons [## "lux;loader" + (#DataT "java.lang.ClassLoader") + (#Cons [## "lux;classes" + (#DataT "clojure.lang.Atom") + #Nil])])])))) (_lux_declare-tags [#writer #loader #classes] Host) ## (deftype (DefData' m) @@ -287,15 +295,17 @@ (_lux_def DefData' (#NamedT ["lux" "DefData'"] (#AllT [(#Some #Nil) "lux;DefData'" "" - (#SumT ## "lux;ValueD" - (#ProdT Type - Unit) - (#SumT ## "lux;TypeD" - Type - (#SumT ## "lux;MacroD" - (#BoundT "") - ## "lux;AliasD" - Ident)))]))) + (#VariantT (#Cons [## "lux;ValueD" + (#TupleT (#Cons [Type + (#Cons [Unit + #Nil])])) + (#Cons [## "lux;TypeD" + Type + (#Cons [## "lux;MacroD" + (#BoundT "") + (#Cons [## "lux;AliasD" + Ident + #Nil])])])]))]))) (_lux_export DefData') (_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData') @@ -304,10 +314,11 @@ ## (#Global Ident))) (_lux_def LuxVar (#NamedT ["lux" "LuxVar"] - (#SumT ## "lux;Local" - Int - ## "lux;Global" - Ident))) + (#VariantT (#Cons [## "lux;Local" + Int + (#Cons [## "lux;Global" + Ident + #Nil])])))) (_lux_export LuxVar) (_lux_declare-tags [#Local #Global] LuxVar) @@ -320,28 +331,34 @@ ## )) (_lux_def Module (#NamedT ["lux" "Module"] - (#AllT (#Some #Nil) "lux;Module" "Compiler" - (#ProdT ## "lux;module-aliases" - (#AppT List (#ProdT Text Text)) - (#ProdT ## "lux;defs" - (#AppT List (#ProdT Text - (#ProdT Bool - (#AppT DefData' (#LambdaT ASTList - (#AppT (#AppT StateE (#BoundT "Compiler")) - ASTList)))))) - (#ProdT ## "lux;imports" - (#AppT List Text) - (#ProdT ## "lux;tags" - (#AppT List - (#ProdT Text - (#ProdT Int - (#ProdT (#AppT List Ident) - Type)))) - ## "lux;types" - (#AppT List - (#ProdT Text - (#ProdT (#AppT List Ident) - Type)))))))))) + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#TupleT (#Cons [## "lux;module-aliases" + (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) + (#Cons [## "lux;defs" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + ASTList])])]) + #Nil])])) + #Nil])]))]) + (#Cons [## "lux;imports" + (#AppT [List Text]) + (#Cons [## "lux;tags" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Int + (#Cons (#AppT [List Ident]) + (#Cons Type + #Nil)))) + #Nil)))]) + (#Cons [## "lux;types" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons (#AppT [List Ident]) + (#Cons Type + #Nil))) + #Nil)))]) + #Nil])])])])]))]))) (_lux_export Module) (_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) @@ -358,28 +375,30 @@ ## )) (_lux_def Compiler (#NamedT ["lux" "Compiler"] - (#AppT (#AllT (#Some #Nil) "lux;Compiler" "" - (#ProdT ## "lux;source" - Source - (#ProdT ## "lux;cursor" - Cursor - (#ProdT ## "lux;modules" - (#AppT List (#ProdT Text - (#AppT Module (#AppT (#BoundT "lux;Compiler") (#BoundT ""))))) - (#ProdT ## "lux;envs" - (#AppT List (#AppT (#AppT [Env Text]) - (#ProdT LuxVar Type))) - (#ProdT ## "lux;type-vars" - (#AppT (#AppT Bindings Int) Type) - (#ProdT ## "lux;expected" - Type - (#ProdT ## "lux;seed" - Int - (#ProdT ## "lux;eval?" - Bool - ## "lux;host" - Host))))))))) - Void))) + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#TupleT (#Cons [## "lux;source" + Source + (#Cons [## "lux;cursor" + Cursor + (#Cons [## "lux;modules" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))]) + (#Cons [## "lux;envs" + (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) + (#Cons [## "lux;type-vars" + (#AppT [(#AppT [Bindings Int]) Type]) + (#Cons [## "lux;expected" + Type + (#Cons [## "lux;seed" + Int + (#Cons [## "lux;eval?" + Bool + (#Cons [## "lux;host" + Host + #Nil])])])])])])])])]))]) + Void]))) (_lux_export Compiler) (_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) @@ -407,7 +426,7 @@ (#AppT Meta Cursor)) AST) (_lux_lambda _ data - [_cursor data]))) + (#Meta _cursor data)))) ## (def (return x) ## (All [a] @@ -419,8 +438,9 @@ (#LambdaT (#BoundT "a") (#LambdaT Compiler (#AppT (#AppT Either Text) - (#ProdT Compiler - (#BoundT "a")))))) + (#TupleT (#Cons Compiler + (#Cons (#BoundT "a") + #Nil))))))) (_lux_lambda _ val (_lux_lambda _ state (#Right state val))))) @@ -435,8 +455,9 @@ (#LambdaT Text (#LambdaT Compiler (#AppT (#AppT Either Text) - (#ProdT Compiler - (#BoundT "a")))))) + (#TupleT (#Cons Compiler + (#Cons (#BoundT "a") + #Nil))))))) (_lux_lambda _ msg (_lux_lambda _ state (#Left msg))))) @@ -472,7 +493,7 @@ (_meta (#TupleS tokens))))) (_lux_def record$ - (_lux_: (#LambdaT (#AppT List (#ProdT AST AST)) AST) + (_lux_: (#LambdaT (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) AST) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) @@ -493,7 +514,7 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) + (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS "" "")) (#Cons arg @@ -508,7 +529,7 @@ #Nil)))))) #Nil)) - (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) + (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS self)) (#Cons arg @@ -531,9 +552,9 @@ (_lux_: Macro (lambda'' [tokens] (_lux_case tokens - (#Cons [_ (#TagS ["" "export"])] - (#Cons [_ (#FormS (#Cons name args))] - (#Cons type (#Cons body #Nil)))) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -547,7 +568,7 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [_ (#TagS "" "export")] (#Cons name (#Cons type (#Cons body #Nil)))) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -558,8 +579,8 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [_ (#FormS (#Cons name args))] - (#Cons type (#Cons body #Nil))) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -572,7 +593,7 @@ #Nil])])]))) #Nil])) - (#Cons name (#Cons type (#Cons body #Nil))) + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -590,7 +611,7 @@ (def'' (defmacro tokens) Macro (_lux_case tokens - (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) @@ -600,7 +621,7 @@ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(tag$ ["" "export"]) (#Cons [(form$ (#Cons [name args])) @@ -640,12 +661,12 @@ (defmacro (All' tokens) (_lux_case tokens - (#Cons [[_ (#TupleS #Nil)] + (#Cons [(#Meta [_ (#TupleS #Nil)]) (#Cons [body #Nil])]) (return (#Cons [body #Nil])) - (#Cons [[_ (#TupleS (#Cons [[_ (#SymbolS ["" arg-name])] other-args]))] + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) (#Cons [body #Nil])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) @@ -664,7 +685,7 @@ (defmacro (B' tokens) (_lux_case tokens - (#Cons [[_ (#SymbolS ["" bound-name])] + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) #Nil]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) (#Cons [(_meta (#TextS bound-name)) @@ -732,15 +753,15 @@ (fail "Wrong syntax for list&"))) (defmacro (lambda' tokens) - (let'' [name tokens'] (_lux_: (#ProdT Ident ($' List AST)) + (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) (_lux_case tokens - (#Cons [[_ (#SymbolS name)] tokens']) + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) [name tokens'] _ [["" ""] tokens])) (_lux_case tokens' - (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) (_lux_case args #Nil (fail "lambda' requires a non-empty arguments tuple.") @@ -762,8 +783,8 @@ (defmacro (def''' tokens) (_lux_case tokens - (#Cons [[_ (#TagS ["" "export"])] - (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -775,7 +796,7 @@ body)))))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) @@ -783,7 +804,7 @@ body)))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [[_ (#FormS (#Cons [name args]))] + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -805,7 +826,7 @@ (def''' (as-pairs xs) (All' [a] - (->' ($' List (B' a)) ($' List (#ProdT (B' a) (B' a))))) + (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (_lux_case xs (#Cons [x (#Cons [y xs'])]) (#Cons [[x y] (as-pairs xs')]) @@ -815,8 +836,8 @@ (defmacro (let' tokens) (_lux_case tokens - (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' AST (#ProdT AST AST) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) AST) (lambda' [body binding] (_lux_case binding @@ -853,7 +874,7 @@ (def''' (spliced? token) (->' AST Bool) (_lux_case token - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) true _ @@ -861,8 +882,9 @@ (def''' (wrap-meta content) (->' AST AST) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content)))) + (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) + (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) + content))))))) (def''' (untemplate-list tokens) (->' ($' List AST) AST) @@ -901,7 +923,7 @@ true (let' [elems' (map (lambda' [elem] (_lux_case elem - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) spliced _ @@ -922,23 +944,23 @@ (def''' (untemplate replace? subst token) (->' Bool Text AST AST) - (_lux_case (_lux_: (#ProdT Bool AST) [replace? token]) - [_ [_ (#BoolS value)]] + (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) + [_ (#Meta [_ (#BoolS value)])] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - [_ [_ (#IntS value)]] + [_ (#Meta [_ (#IntS value)])] (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - [_ [_ (#RealS value)]] + [_ (#Meta [_ (#RealS value)])] (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - [_ [_ (#CharS value)]] + [_ (#Meta [_ (#CharS value)])] (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - [_ [_ (#TextS value)]] + [_ (#Meta [_ (#TextS value)])] (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - [_ [_ (#TagS [module name])]] + [_ (#Meta [_ (#TagS [module name])])] (let' [module' (_lux_case module "" subst @@ -947,7 +969,7 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ [_ (#SymbolS [module name])]] + [_ (#Meta [_ (#SymbolS [module name])])] (let' [module' (_lux_case module "" subst @@ -956,19 +978,19 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ [_ (#TupleS elems)]] + [_ (#Meta [_ (#TupleS elems)])] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] + [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] unquoted - [_ [meta (#FormS elems)]] - (let' [[_ form'] (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - [meta form']) + [_ (#Meta [meta (#FormS elems)])] + (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + (#Meta [meta form'])) - [_ [_ (#RecordS fields)]] + [_ (#Meta [_ (#RecordS fields)])] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#ProdT AST AST) AST) + (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) (lambda' [kv] (let' [[k v] kv] (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) @@ -994,17 +1016,16 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (_lux_: (->' AST AST AST) - (lambda' [acc app] - (_lux_case app - [_ (#TupleS parts)] - (tuple$ (list:++ parts (list acc))) + (return (list (foldL (lambda' [acc app] + (_lux_case app + (#Meta [_ (#TupleS parts)]) + (tuple$ (list:++ parts (list acc))) - [_ (#FormS parts)] - (form$ (list:++ parts (list acc))) + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc)))))) + _ + (`' ((~ app) (~ acc))))) init apps))) @@ -1026,7 +1047,7 @@ (def''' #export Lux Type (All' [a] - (->' Compiler ($' Either Text (#ProdT Compiler (B' a)))))) + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1037,44 +1058,44 @@ Type (#NamedT ["lux" "Monad"] (All' [m] - (#ProdT (All' [a] (->' (B' a) ($' (B' m) (B' a)))) - (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b)))))))) + (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b))))))))) (_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad ($' Monad Maybe) {#return (lambda' return [x] - (#Some x)) + (#Some x)) #bind (lambda' [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) + (_lux_case ma + #None #None + (#Some a) (f a)))}) (def''' Lux/Monad ($' Monad Lux) {#return (lambda' [x] - (lambda' [state] - (#Right state x))) + (lambda' [state] + (#Right state x))) #bind (lambda' [f ma] - (lambda' [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) + (lambda' [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right state' a) - (f a state'))))}) + (#Right state' a) + (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens - (#Cons [_ (#SymbolS "" class-name)] #Nil) + (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil) (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ @@ -1083,8 +1104,7 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons output inputs) - (return (list (foldL (_lux_: (->' AST AST AST) - (lambda' [o i] (`' (#;LambdaT (~ i) (~ o))))) + (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))) output inputs))) @@ -1092,32 +1112,23 @@ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (_lux_case (reverse tokens) - (#Cons last prevs) - (return (list (foldL (_lux_: (->' AST AST AST) - (lambda' [r l] (`' (#;ProdT (~ l) (~ r))))) - last - prevs))) - - _ - (fail ", must have at least 2 members.")) - ) + (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) (defmacro (do tokens) (_lux_case tokens - (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) + (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] - (let' [[var value] binding] - (_lux_case var - [_ (#TagS "" "let")] - (`' (;let' (~ value) (~ body'))) - - _ - (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (let' [[var value] binding] + (_lux_case var + (#Meta _ (#TagS "" "let")) + (`' (;let' (~ value) (~ body'))) + + _ + (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] (return (list (`' (_lux_case (~ monad) @@ -1156,7 +1167,7 @@ (def''' (get-ident x) (-> AST ($' Maybe Ident)) (_lux_case x - [_ (#SymbolS sname)] + (#Meta [_ (#SymbolS sname)]) (#Some sname) _ @@ -1165,7 +1176,7 @@ (def''' (get-name x) (-> AST ($' Maybe Text)) (_lux_case x - [_ (#SymbolS ["" sname])] + (#Meta [_ (#SymbolS ["" sname])]) (#Some sname) _ @@ -1174,7 +1185,7 @@ (def''' (tuple->list tuple) (-> AST ($' Maybe ($' List AST))) (_lux_case tuple - [_ (#TupleS members)] + (#Meta [_ (#TupleS members)]) (#Some members) _ @@ -1213,7 +1224,7 @@ (def''' (apply-template env template) (-> RepEnv AST AST) (_lux_case template - [_ (#SymbolS ["" sname])] + (#Meta [_ (#SymbolS ["" sname])]) (_lux_case (get-rep sname env) (#Some subst) subst @@ -1221,13 +1232,13 @@ _ template) - [_ (#TupleS elems)] + (#Meta [_ (#TupleS elems)]) (tuple$ (map (apply-template env) elems)) - [_ (#FormS elems)] + (#Meta [_ (#FormS elems)]) (form$ (map (apply-template env) elems)) - [_ (#RecordS members)] + (#Meta [_ (#RecordS members)]) (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] @@ -1249,7 +1260,7 @@ (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) @@ -1334,7 +1345,7 @@ (def''' (replace-syntax reps syntax) (-> RepEnv AST AST) (_lux_case syntax - [_ (#SymbolS ["" name])] + (#Meta [_ (#SymbolS ["" name])]) (_lux_case (get-rep name reps) (#Some replacement) replacement @@ -1342,18 +1353,18 @@ #None syntax) - [_ (#FormS parts)] - [_ (#FormS (map (replace-syntax reps) parts))] + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - [_ (#TupleS members)] - [_ (#TupleS (map (replace-syntax reps) members))] + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - [_ (#RecordS slots)] - [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) - (lambda' [slot] - (let' [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))] + (#Meta [_ (#RecordS slots)]) + (#Meta [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) + (lambda' [slot] + (let' [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) _ syntax) @@ -1362,13 +1373,13 @@ (defmacro #export (All tokens) (let' [[self-ident tokens'] (_lux_: (, Text ASTList) (_lux_case tokens - (#Cons [[_ (#SymbolS ["" self-ident])] tokens']) + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) [self-ident tokens'] _ ["" tokens]))] (_lux_case tokens' - (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) (_lux_case (map% Maybe/Monad get-name args) (#Some idents) (_lux_case idents @@ -1379,9 +1390,8 @@ (let' [replacements (map (_lux_: (-> Text (, Text AST)) (lambda' [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) (list& self-ident idents)) - body' (foldL (_lux_: (-> AST Text AST) - (lambda' [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')])))) + body' (foldL (lambda' [body' arg'] + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) (replace-syntax replacements body) (reverse targs))] ## (#;Some #;Nil) @@ -1503,7 +1513,7 @@ (def''' (macro-expand token) (-> AST ($' Lux ($' List AST))) (_lux_case token - [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1523,7 +1533,7 @@ (def''' (macro-expand-all syntax) (-> AST ($' Lux ($' List AST))) (_lux_case syntax - [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1539,13 +1549,13 @@ [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (wrap (list (form$ (list:join parts'))))))) - [_ (#FormS (#Cons [harg targs]))] + (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (map% Lux/Monad macro-expand-all targs)] (wrap (list (form$ (list:++ harg+ (list:join targs+)))))) - [_ (#TupleS members)] + (#Meta [_ (#TupleS members)]) (do Lux/Monad [members' (map% Lux/Monad macro-expand-all members)] (wrap (list (tuple$ (list:join members'))))) @@ -1556,15 +1566,14 @@ (def''' (walk-type type) (-> AST AST) (_lux_case type - [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))] - (form$ (#Cons (tag$ tag) (map walk-type parts))) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - [_ (#TupleS members)] + (#Meta [_ (#TupleS members)]) (tuple$ (map walk-type members)) - [_ (#FormS (#Cons [type-fn args]))] - (foldL (_lux_: (-> AST AST AST) - (lambda' [type-fn arg] (`' (#;AppT (~ type-fn) (~ arg))))) + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (foldL (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) (walk-type type-fn) (map walk-type args)) @@ -1619,50 +1628,40 @@ (def''' (unfold-type-def type) (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) (_lux_case type - [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))] + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "|")) cases))) (do Lux/Monad [members (map% Lux/Monad (: (-> AST ($' Lux (, Text AST))) (lambda' [case] (_lux_case case - [_ (#TagS "" member-name)] + (#Meta _ (#TagS "" member-name)) (return [member-name (`' Unit)]) - [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] + (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "" member-name)) (#Cons member-type #Nil)))) (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")))) - cases) - variant-type (: (Lux AST) - (_lux_case (reverse members) - (#Cons last prevs) - (return (foldL (_lux_: (->' AST AST AST) - (lambda' [r l] (`' (#;SumT (~ l) (~ r))))) - (second last) - (map second prevs))) - - _ - (fail "| must have at least 2 members.")))] - (return [variant-type + cases)] + (return [(`' (#;VariantT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) (lambda' [name] (tag$ ["" name]))))))])) - [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))] + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "&")) pairs))) (do Lux/Monad [members (map% Lux/Monad (: (-> (, AST AST) ($' Lux (, Text AST))) (lambda' [pair] (_lux_case pair - [[_ (#TagS "" member-name)] member-type] + [(#Meta _ (#TagS "" member-name)) member-type] (return [member-name member-type]) _ (fail "Wrong syntax for variant case.")))) (as-pairs pairs))] - (return [(`' (, (~@ (map second members)))) + (return [(`' (#TupleT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) @@ -1674,24 +1673,24 @@ (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) [rec? tokens'] (: (, Bool (List AST)) (_lux_case tokens' - (#Cons [_ (#TagS "" "rec")] tokens') + (#Cons (#Meta _ (#TagS "" "rec")) tokens') [true tokens'] _ [false tokens'])) parts (: (Maybe (, Text (List AST) AST)) (_lux_case tokens' - (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) + (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) (#Some name #Nil type) - (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil)) + (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil)) (#Some name args type) _ @@ -1747,8 +1746,7 @@ (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] - (return (list (foldL (: (-> AST AST AST) - (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) + (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) value actions)))) @@ -1758,20 +1756,20 @@ (defmacro (def' tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (_lux_case tokens' - (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) (#Some name args (#Some type) body) (#Cons name (#Cons type (#Cons body #Nil))) (#Some name #Nil (#Some type) body) - (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil)) (#Some name args #None body) (#Cons name (#Cons body #Nil)) @@ -1817,7 +1815,7 @@ (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern - [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) (do Lux/Monad [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] @@ -1876,7 +1874,7 @@ (def' (symbol? ast) (-> AST Bool) (case ast - [_ (#SymbolS _)] + (#Meta _ (#SymbolS _)) true _ @@ -1884,7 +1882,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list [_ (#TupleS bindings)] body)) + (\ (list (#Meta _ (#TupleS bindings)) body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> AST (, AST AST) AST) @@ -1904,7 +1902,7 @@ (def' (ast:show ast) (-> AST Text) (case ast - [_ ast] + (#Meta _ ast) (case ast (\or (#BoolS val) (#IntS val) (#RealS val)) (->text val) @@ -1940,10 +1938,10 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens - (\ (list [_ (#TupleS (#Cons head tail))] body)) + (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) (#Some ["" ""] head tail body) - (\ (list [_ (#SymbolS [_ name])] [_ (#TupleS (#Cons head tail))] body)) + (\ (list (#Meta _ (#SymbolS [_ name])) (#Meta _ (#TupleS (#Cons head tail))) body)) (#Some ["" name] head tail body) _ @@ -1969,20 +1967,20 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (#Cons [_ (#TagS "" "export")] tokens') + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' - (\ (list [_ (#FormS (#Cons name args))] type body)) + (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) (#Some name args (#Some type) body) (\ (list name type body)) (#Some name #Nil (#Some type) body) - (\ (list [_ (#FormS (#Cons name args))] body)) + (\ (list (#Meta _ (#FormS (#Cons name args))) body)) (#Some name args #None body) (\ (list name body)) @@ -2030,17 +2028,17 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#TagS "" "export")] tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) + (\ (list& (#Meta _ (#FormS (list& (#Meta _ (#SymbolS name)) args))) sigs)) (#Some name args sigs) - (\ (list& [_ (#SymbolS name)] sigs)) + (\ (list& (#Meta _ (#SymbolS name)) sigs)) (#Some name #Nil sigs) _ @@ -2054,7 +2052,7 @@ (: (-> AST (Lux (, Text AST))) (lambda [token] (case token - (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS ["" name])))))) (wrap (: (, Text AST) [name type])) _ @@ -2063,7 +2061,8 @@ #let [[_module _name] name+ def-name (symbol$ name) tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) - sig-type (: AST (` (, (~@ (map second members))))) + types (map second members) + sig-type (: AST (` (#;TupleT (~ (untemplate-list types))))) sig-decl (: AST (` (_lux_declare-tags [(~@ tags)] (~ def-name)))) sig+ (: AST (case args @@ -2141,20 +2140,24 @@ (def (type:show type) (-> Type Text) (case type - #VoidT - "(|)" + (#DataT name) + ($ text:++ "(^ " name ")") - #UnitT - "(,)" - - (#SumT left right) - ($ text:++ "(| " (type:show left) " " (type:show right) ")") + (#TupleT members) + (case members + #;Nil + "(,)" - (#ProdT left right) - ($ text:++ "(, " (type:show left) " " (type:show right) ")") + _ + ($ text:++ "(, " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) - (#DataT name) - ($ text:++ "(^ " name ")") + (#VariantT members) + (case members + #;Nil + "(|)" + + _ + ($ text:++ "(| " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) (#LambdaT input output) ($ text:++ "(-> " (type:show input) " " (type:show output) ")") @@ -2181,11 +2184,11 @@ (def (beta-reduce env type) (-> (List (, Text Type)) Type Type) (case type - (#SumT left right) - (#SumT (beta-reduce env left) (beta-reduce env right)) + (#VariantT ?cases) + (#VariantT (map (beta-reduce env) ?cases)) - (#ProdT left right) - (#ProdT (beta-reduce env left) (beta-reduce env right)) + (#TupleT ?members) + (#TupleT (map (beta-reduce env) ?members)) (#AppT ?type-fn ?type-arg) (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -2241,16 +2244,9 @@ (def (resolve-struct-type type) (-> Type (Maybe (List Type))) (case type - (#ProdT left right) - (case right - (#ProdT _) - (do Maybe/Monad - [rights (resolve-struct-type right)] - (wrap (list& left rights))) - - _ - (#Some (list left right))) - + (#TupleT slots) + (#Some slots) + (#AppT fun arg) (do Maybe/Monad [output (apply-type fun arg)] @@ -2342,7 +2338,7 @@ (: (-> AST (Lux (, AST AST))) (lambda [token] (case token - (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS tag-name)] value))]) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS tag-name)) value)))) (wrap (: (, AST AST) [(tag$ tag-name) value])) _ @@ -2353,14 +2349,14 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#TagS "" "export")] tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' - (\ (list& [_ (#FormS (list& name args))] type defs)) + (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) (#Some name args type defs) (\ (list& name type defs)) @@ -2393,8 +2389,7 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (list (foldL (: (-> AST AST AST) - (lambda [post pre] (` ))) + (return (list (foldL (lambda [post pre] (` )) last init))) @@ -2422,7 +2417,7 @@ (: (-> AST (Lux Text)) (lambda [def] (case def - [_ (#SymbolS "" name)] + (#Meta _ (#SymbolS "" name)) (return name) _ @@ -2432,7 +2427,7 @@ (def (parse-alias tokens) (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) + (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) _ @@ -2441,17 +2436,17 @@ (def (parse-referrals tokens) (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "refer")] referral tokens')) + (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) (case referral - [_ (#TagS "" "all")] + (#Meta _ (#TagS "" "all")) (return (: (, Referrals (List AST)) [#All tokens'])) - (\ [_ (#FormS (list& [_ (#TagS "" "only")] defs))]) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) - (\ [_ (#FormS (list& [_ (#TagS "" "exclude")] defs))]) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) @@ -2465,7 +2460,7 @@ (def (extract-symbol syntax) (-> AST (Lux Ident)) (case syntax - [_ (#SymbolS ident)] + (#Meta _ (#SymbolS ident)) (return ident) _ @@ -2474,7 +2469,7 @@ (def (parse-openings tokens) (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "open")] [_ (#FormS (list& [_ (#TextS prefix)] structs))] tokens')) + (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) @@ -2488,10 +2483,10 @@ (: (-> AST (Lux AST)) (lambda [token] (case token - [_ (#SymbolS "" sub-name)] + (#Meta _ (#SymbolS "" sub-name)) (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ [_ (#FormS (list& [_ (#SymbolS "" sub-name)] parts))]) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts)))) (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ @@ -2505,10 +2500,10 @@ (: (-> AST (Lux (List Import))) (lambda [token] (case token - [_ (#SymbolS "" m-name)] + (#Meta _ (#SymbolS "" m-name)) (wrap (list [m-name #None #All #None])) - (\ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2700,10 +2695,10 @@ (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] (wrap ($ list:++ - (: (List AST) (list (` (_lux_import (~ (text$ m-name)))))) - (: (List AST) (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) + (list (` (_lux_import (~ (text$ m-name))))) + (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) (map (: (-> Text AST) (lambda [def] (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) @@ -2714,10 +2709,9 @@ _ (wrap (: (List AST) - (list:++ (map (: (-> Text AST) - (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))) + (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) unknowns) - (: (List AST) (list (` (import (~@ tokens))))))))))) + (list (` (import (~@ tokens)))))))))) (def (try-both f x1 x2) (All [a b] @@ -2854,7 +2848,7 @@ (case tokens (\ (list struct body)) (case struct - [_ (#SymbolS name)] + (#Meta _ (#SymbolS name)) (do Lux/Monad [struct-type (find-var-type name) output (resolve-type-tags struct-type)] @@ -2880,6 +2874,12 @@ _ (fail "Wrong syntax for using"))) +(def (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [y x] + (f x y))) + (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") @@ -2910,7 +2910,7 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list [_ (#TagS slot')] record)) + (\ (list (#Meta _ (#TagS slot')) record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -2952,11 +2952,11 @@ (defmacro #export (open tokens) (case tokens - (\ (list& [_ (#SymbolS struct-name)] tokens')) + (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) (do Lux/Monad [@module get-module-name #let [prefix (case tokens' - (\ (list [_ (#TextS prefix)])) + (\ (list (#Meta _ (#TextS prefix)))) prefix _ @@ -2999,12 +2999,12 @@ (: (-> AST AST (Lux AST)) (lambda [so-far part] (case part - [_ (#SymbolS slot)] - (return (: AST (` (get@ (~ (tag$ slot)) (~ so-far))))) + (#Meta _ (#SymbolS slot)) + (return (` (get@ (~ (tag$ slot)) (~ so-far)))) - (\ [_ (#FormS (list& [_ (#SymbolS slot)] args))]) - (return (: AST (` ((get@ (~ (tag$ slot)) (~ so-far)) - (~@ args))))) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args)))) + (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args)))) _ (fail "Wrong syntax for ::")))) @@ -3016,7 +3016,7 @@ (defmacro #export (set@ tokens) (case tokens - (\ (list [_ (#TagS slot')] value record)) + (\ (list (#Meta _ (#TagS slot')) value record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3051,7 +3051,7 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list [_ (#TagS slot')] fun record)) + (\ (list (#Meta _ (#TagS slot')) fun record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3086,9 +3086,9 @@ (defmacro #export (\template tokens) (case tokens - (\ (list [_ (#TupleS data)] - [_ (#TupleS bindings)] - [_ (#TupleS templates)])) + (\ (list (#Meta _ (#TupleS data)) + (#Meta _ (#TupleS bindings)) + (#Meta _ (#TupleS templates)))) (case (: (Maybe (List AST)) (do Maybe/Monad [bindings' (map% Maybe/Monad get-name bindings) @@ -3132,29 +3132,26 @@ (def (type->syntax type) (-> Type AST) (case type - (\template [] - [ - (` )]) - [[#VoidT] [#UnitT]] - - (\template [] - [( left right) - (` ( (~ (type->syntax left)) (~ (type->syntax right))))]) - [[#SumT] [#ProdT]] - (#DataT name) (` (#;DataT (~ (text$ name)))) + + (#;VariantT cases) + (` (#;VariantT (~ (untemplate-list (map type->syntax cases))))) + (#TupleT parts) + (` (#;TupleT (~ (untemplate-list (map type->syntax parts))))) + (#LambdaT in out) (` (#;LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) (#BoundT name) (` (#;BoundT (~ (text$ name)))) + + (#VarT id) + (` (#;VarT (~ (int$ id)))) - (\template [] - [( id) - (` ( (~ (int$ id))))]) - [[#VarT] [#ExT]] + (#ExT id) + (` (#;ExT (~ (int$ id)))) (#AllT env name arg type) (let [env' (: AST @@ -3174,7 +3171,7 @@ (defmacro #export (loop tokens) (case tokens - (\ (list [_ (#TupleS bindings)] body)) + (\ (list (#Meta _ (#TupleS bindings)) body)) (let [pairs (as-pairs bindings) vars (map first pairs) inits (map second pairs)] @@ -3204,6 +3201,4 @@ (fail "Wrong syntax for loop"))) (defmacro #export (export tokens) - (return (map (: (-> AST AST) - (lambda [token] (` (_lux_export (~ token))))) - tokens))) + (return (map (lambda [token] (` (_lux_export (~ token)))) tokens))) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 8a7974e8b..c87c4fdc3 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -53,15 +53,15 @@ ## [Syntax] (defmacro #export (do tokens state) (case tokens - ## (\ (list monad [_ (#;TupleS bindings)] body)) - (#;Cons [monad (#;Cons [[_ (#;TupleS bindings)] (#;Cons [body #;Nil])])]) + ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) (let [g!map (symbol$ ["" " map "]) g!join (symbol$ ["" " join "]) body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var - [_ (#;TagS ["" "let"])] + (#;Meta [_ (#;TagS ["" "let"])]) (` (;let (~ value) (~ body'))) _ diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index d8bb30a3d..3ad6b056b 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -13,19 +13,20 @@ ## [Types] (deftype #export (Id a) - a) + (| (#Id a))) ## [Structures] (defstruct #export Id/Functor (Functor Id) (def (F;map f fa) - (f fa))) + (let [(#Id a) fa] + (#Id (f a))))) (defstruct #export Id/Monad (Monad Id) (def M;_functor Id/Functor) - (def M;wrap id) - (def M;join id)) + (def (M;wrap a) (#Id a)) + (def (M;join mma) (let [(#Id ma) mma] ma))) (defstruct #export Id/CoMonad (CoMonad Id) (def CM;_functor Id/Functor) - (def CM;unwrap id) - (def CM;split id)) + (def (CM;unwrap wa) (let [(#Id a) wa] a)) + (def (CM;split wa) (#Id wa))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 97333f570..5a8357251 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -23,13 +23,13 @@ ## (#Cons (, a (List a))))) (deftype #export (PList k v) - (, (E;Eq k) (List (, k v)))) + (| (#PList (, (E;Eq k) (List (, k v)))))) ## [Constructors] (def #export (plist eq) (All [k v] (-> (E;Eq k) (PList k v))) - [eq #;Nil]) + (#PList [eq #;Nil])) ## [Functions] (def #export (foldL f init xs) @@ -252,7 +252,8 @@ ## true ## [(#;Cons [x xs']) (#;Cons [y ys'])] -## (and (:: eq (E;= x y)) (= xs' ys')) +## (and (:: eq (E;= x y)) +## (E;= xs' ys')) ## ))) (defstruct #export List/Monoid (All [a] @@ -280,7 +281,7 @@ (foldL ++ unit mma)))) (defstruct #export PList/Dict (Dict PList) - (def (D;get k [eq kvs]) + (def (D;get k (#PList [eq kvs])) (loop [kvs kvs] (case kvs #;Nil @@ -291,27 +292,27 @@ (#;Some v') (recur kvs'))))) - (def (D;put k v [eq kvs]) - [eq (loop [kvs kvs] - (case kvs - #;Nil - (#;Cons [k v] kvs) - - (#;Cons [k' v'] kvs') - (if (:: eq (E;= k k')) - (#;Cons [k v] kvs') - (#;Cons [k' v'] (recur kvs')))))]) - - (def (D;remove k [eq kvs]) - [eq (loop [kvs kvs] - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (recur kvs')]))))])) + (def (D;put k v (#PList [eq kvs])) + (#PList [eq (loop [kvs kvs] + (case kvs + #;Nil + (#;Cons [k v] kvs) + + (#;Cons [k' v'] kvs') + (if (:: eq (E;= k k')) + (#;Cons [k v] kvs') + (#;Cons [k' v'] (recur kvs')))))])) + + (def (D;remove k (#PList [eq kvs])) + (#PList [eq (loop [kvs kvs] + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (recur kvs')]))))]))) (defstruct #export List/Stack (S;Stack List) (def S;empty (list)) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index 3d2f30db2..f01f08af1 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -31,7 +31,7 @@ (do-template [ ] [(def #export ( x) (-> AST) - [_cursor ( x)])] + (#;Meta _cursor ( x)))] [bool$ Bool #;BoolS] [int$ Int #;IntS] diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux index e6963b3d6..15f3582fa 100644 --- a/source/lux/meta/macro.lux +++ b/source/lux/meta/macro.lux @@ -12,18 +12,18 @@ (def #export (defmacro tokens state) Macro (case tokens - (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) ((~ name) (~@ args)) - (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) + (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) + (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) (~ body))) - (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) + (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) #;Nil])])]) - (#;Cons [[_ (#;TagS ["" "export"])] (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) (~ [["" -1 -1] (#;TagS ["" "export"])]) ((~ name) (~@ args)) - (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) + (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) (~ (#;Meta ["" -1 -1] (#;TagS ["" "export"]))) ((~ name) (~@ args)) + (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) (~ body))) - (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) + (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) #;Nil])])]) _ diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index db6a5774a..b9834f972 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -73,7 +73,7 @@ [(def #export ( tokens) (Parser ) (case tokens - (#;Cons [[_ ( x)] tokens']) + (#;Cons [(#;Meta [_ ( x)]) tokens']) (#;Some [tokens' x]) _ @@ -92,7 +92,7 @@ [(def #export ( tokens) (Parser Text) (case tokens - (#;Cons [[_ ( ["" x])] tokens']) + (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) (#;Some [tokens' x]) _ @@ -113,7 +113,7 @@ [(def #export ( v tokens) (-> (Parser (,))) (case tokens - (#;Cons [[_ ( x)] tokens']) + (#;Cons [(#;Meta [_ ( x)]) tokens']) (if ( v x) (#;Some [tokens' []]) #;None) @@ -135,7 +135,7 @@ (All [a] (-> (Parser a) (Parser a))) (case tokens - (#;Cons [[_ ( form)] tokens']) + (#;Cons [(#;Meta [_ ( form)]) tokens']) (case (p form) (#;Some [#;Nil x]) (#;Some [tokens' x]) _ #;None) @@ -215,24 +215,24 @@ (defmacro #export (defsyntax tokens) (let [[exported? tokens] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#;TagS ["" "export"])] tokens')) + (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) [true tokens'] _ [false tokens]))] (case tokens - (\ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))] + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) body)) (do Lux/Monad [names+parsers (M;map% Lux/Monad (: (-> AST (Lux (, AST AST))) (lambda [arg] (case arg - (\ [_ (#;TupleS (list [_ (#;SymbolS var-name)] - parser))]) + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) (wrap [(symbol$ var-name) parser]) - (\ [_ (#;SymbolS var-name)]) + (\ (#;Meta [_ (#;SymbolS var-name)])) (wrap [(symbol$ var-name) (` id^)]) _ diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 41a59fc00..8c88328f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |case $$]] + (lux [base :as & :refer [|let |do return fail return* fail* |case]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -23,24 +23,24 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] - (&/$Cons [_ (&/$TextS ?ex-class)] - (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] - (&/$Cons ?catch-body - (&/$Nil))))))] - (return (&/P (&/|++ catch+ (&/|list ($$ &/P ?ex-class ?ex-arg ?catch-body))) finally+)) - - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] - (&/$Cons ?finally-body - (&/$Nil))))] - (return (&/P catch+ (&/Some$ ?finally-body))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) + (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) + (&/$Cons ?catch-body + (&/$Nil))))))) + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) + + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) + (&/$Cons ?finally-body + (&/$Nil))))) + (return (&/T catch+ (&/V &/$Some ?finally-body))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private parse-tag [ast] (|case ast - [_ (&/$TagS "" name)] + (&/$Meta _ (&/$TagS "" name)) (return name) _ @@ -49,44 +49,44 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] - (&/$Cons [_ (&/$SymbolS _ ?class)] - (&/$Cons [_ (&/$IntS ?length)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) + (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) + (&/$Cons (&/$Meta _ (&/$IntS ?length)) (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TextS ?super-class)] - (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons [_ (&/$TupleS ?fields)] - (&/$Cons [_ (&/$TupleS ?methods)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) + (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) + (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TupleS ?supers)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] - (&/$Cons [_ (&/$SymbolS "" ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) (&/$Cons ?body (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -97,86 +97,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -185,106 +185,106 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TupleS ?classes)] - (&/$Cons [_ (&/$TupleS ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] - (&/$Cons [_ (&/$TupleS ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/P (&/|list) &/None$) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) @@ -295,53 +295,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -351,63 +351,63 @@ (|case token ;; Host special forms ;; Characters - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -418,60 +418,60 @@ (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] - (&/$Cons [_ (&/$SymbolS "" ?self)] - (&/$Cons [_ (&/$SymbolS "" ?arg)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] - (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] - (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] - (&/$Cons [_ (&/$TupleS tags)] - (&/$Cons [_ (&/$SymbolS "" type-name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) + (&/$Cons (&/$Meta _ (&/$TupleS tags)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] - (&/$Cons [_ (&/$TextS ?path)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) + (&/$Cons (&/$Meta _ (&/$TextS ?path)) (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] - (&/$Cons [_ (&/$SymbolS "" ?ident)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] - (&/$Cons [_ (&/$TextS ?alias)] - (&/$Cons [_ (&/$TextS ?module)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) + (&/$Cons (&/$Meta _ (&/$TextS ?alias)) + (&/$Cons (&/$Meta _ (&/$TextS ?module)) (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) @@ -483,23 +483,23 @@ ;; Standard special forms (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/P (&/S &&/$bool ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/P (&/S &&/$int ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/P (&/S &&/$real ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/P (&/S &&/$char ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/P (&/S &&/$text ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) @@ -528,21 +528,20 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - [meta ?token] + (&/$Meta meta ?token) (fn [state] - (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ;; (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ;; (catch Error e - ;; (prn e) - ;; (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) + (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (catch Error e + (prn e) + (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) (&/$Right state* output) (return* state* output) (&/$Left "") - (fail* (add-loc (&/$get-cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) (&/$Left msg) - (fail* (add-loc (&/$get-cursor state) msg)) + (fail* (add-loc (&/get$ &/$cursor state) msg)) )) )) @@ -554,44 +553,42 @@ [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/P ?output-term ?output-type*))) - (return (&/P ?output-term ?output-type))) + (return (&/T ?output-term ?output-type*))) + (return (&/T ?output-term ?output-type))) [_ _] - (return (&/P ?output-term ?output-type))) + (return (&/T ?output-term ?output-type))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] - ;; (prn 'analyse-ast (&/adt->text token)) ;; (prn 'analyse-ast (&/show-ast token)) - (|let [[cursor _] token] - (&/with-cursor cursor - (&/with-expected-type exo-type - (|case token - [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - - [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/P module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - - [meta (&/$FormS (&/$Cons ?fn ?args))] - (fn [state] - (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - _ - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - _ - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) + (&/with-cursor (aget token 1 0) + (&/with-expected-type exo-type + (|case token + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + + (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 622f0b853..fe1e0d55b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -13,120 +13,120 @@ [type :as &type]))) ;; [Tags] -(deftags - ["bool" - "int" - "real" - "char" - "text" - "unit" - "sum" - "prod" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - ]) +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) ;; [Exports] (defn expr-type [syntax+] @@ -147,4 +147,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/P module* ?name))))) + (return (&/T module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6bb767d3e..483002adc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -9,7 +9,7 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |do return fail |let |case $$]] + (lux [base :as & :refer [deftags |do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -18,33 +18,31 @@ [record :as &&record]))) ;; [Tags] -(deftags - ["DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "UnitTotal" - "ProdTotal" - "SumTotal"] +(deftags "" + "DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "VariantTotal" ) -(deftags - ["StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "UnitTestAC" - "ProdTestAC" - "SumTestAC"] +(deftags "" + "StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "VariantTestAC" ) ;; [Utils] (def ^:private unit - (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS (&/|list)))) + (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) (defn ^:private resolve-type [type] (|case type @@ -66,229 +64,269 @@ _ (&type/actual-type type))) -(let [cleaner (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/S &/$BoundT _aarg))] - (&type/clean* _avar _abody))))] - (defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - ;; (prn 'adjust-type* (&type/show-type type)) - (|case type - (&/$AllT _aenv _aname _aarg _abody) - (&type/with-var - (fn [$var] - (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/Cons$ ($$ &/P _aenv _aname _aarg $var) up) =type)))) - - (&/$SumT ?left ?right) - (|do [=left (&/fold% cleaner ?left up) - =right (&/fold% cleaner ?right up)] - (return (&type/Sum$ =left =right))) - - (&/$ProdT ?left ?right) - (|do [=left (&/fold% cleaner ?left up) - =right (&/fold% cleaner ?right up)] - (return (&type/Prod$ =left =right))) - - (&/$AppT ?tfun ?targ) - (|do [=type (&type/apply-type ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$VarT ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##9##")))] - (adjust-type* up type*)) - - (&/$NamedT ?name ?type) - (adjust-type* up ?type) - - _ - (assert false (prn 'adjust-type* (&type/show-type type))) - ))) +(defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + ;; (prn 'adjust-type* (&type/show-type type)) + (|case type + (&/$AllT _aenv _aname _aarg _abody) + (&type/with-var + (fn [$var] + (|do [=type (&type/apply-type type $var)] + (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) + + (&/$TupleT ?members) + (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&type/Tuple$ (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$VariantT ?members) + (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$AppT ?tfun ?targ) + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + _ + (assert false (prn 'adjust-type* (&type/show-type type))) + )) (defn adjust-type [type] "(-> Type (Lux Type))" (adjust-type* (&/|list) type)) -(defn ^:private resolve-tag [tag type] - (|do [[=module =name] (&&/resolved-ident tag) - type* (adjust-type type) - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))] - case-type (&type/variant-case idx type*)] - (return ($$ &/P idx (&/|length group) case-type)))) - (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[meta pattern*] pattern - ;; _ (prn 'analyse-pattern (&/show-ast pattern) (&type/show-type value-type)) - ] + (|let [(&/$Meta _ pattern*) pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/P (&/S $StoreTestAC idx) =kont))) + (return (&/T (&/V $StoreTestAC idx) =kont))) + + (&/$SymbolS ident) + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/P (&/S $BoolTestAC ?value) =kont))) + (return (&/T (&/V $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/P (&/S $IntTestAC ?value) =kont))) + (return (&/T (&/V $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/P (&/S $RealTestAC ?value) =kont))) + (return (&/T (&/V $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/P (&/S $CharTestAC ?value) =kont))) + (return (&/T (&/V $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/P (&/S $TextTestAC ?value) =kont))) + (return (&/T (&/V $TextTestAC ?value) =kont))) - (&/$TupleS (&/$Nil)) - (|do [_ (&type/check value-type &type/Unit) - =kont kont] - (return (&/P (&/S $UnitTestAC nil) =kont))) - - (&/$TupleS (&/$Cons ?_left ?tail)) + (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] + (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) + (|case value-type* + (&/$TupleT ?member-types) + (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont))))) + + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) + + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs) + ;; :let [_ (prn 'PRE (&type/show-type value-type))] + value-type* (adjust-type value-type) + ;; :let [_ (prn 'POST (&type/show-type value-type*))] + ;; value-type* (resolve-type value-type) + ] (|case value-type* - (&/$ProdT ?left ?right) - (|do [[=left [=right =kont]] (analyse-pattern ?left ?_left - (|do [[=right =kont] (|case ?tail - (&/$Cons ?_right (&/$Nil)) - (analyse-pattern ?right ?_right kont) - - (&/$Nil) - (fail "[Pattern-matching Error] Pattern-matching mismatch. Tuple has wrong size.") - - _ - (analyse-pattern ?right (&/P meta (&/S &/$TupleS ?tail)) kont))] - (return (&/P =right =kont))))] - (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont))) + (&/$TupleT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) _ - (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*))))) - - (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/P meta (&/S &/$TupleS ?members)) kont)) + (fail "[Pattern-matching Error] Record requires record-type."))) (&/$TagS ?ident) - (|do [[idx group-count case-type] (resolve-tag ?ident value-type) - [=test =kont] (analyse-pattern case-type unit kont)] - (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) - - (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [[idx group-count case-type] (resolve-tag ?ident value-type) + (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#01")] + value-type* (adjust-type value-type) + ;; :let [_ (println "#02")] + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + ;; :let [_ (println "#03")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#04")] + [=test =kont] (analyse-pattern case-type unit kont) + ;; :let [_ (println "#05")] + ] + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + + (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) + ?values)) + (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#11")] + value-type* (adjust-type value-type) + ;; :let [_ (println "#12" (&type/show-type value-type*))] + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + ;; :let [_ (println "#13")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#14" (&type/show-type case-type))] [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS ?values)) kont)) + (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) ;; :let [_ (println "#15")] ] - (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/Cons$ pattern+body patterns)))) + (return (&/|cons pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return (&/S $DefaultTotal true)) + (return (&/V $DefaultTotal true)) [[?tag [total? ?values]] ($StoreTestAC ?idx)] - (return (&/S ?tag (&/P true ?values))) + (return (&/V ?tag (&/T true ?values))) [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/S $BoolTotal (&/P total? (&/|list ?value)))) + (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/S $BoolTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/S $IntTotal (&/P total? (&/|list ?value)))) + (return (&/V $IntTotal (&/T total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/S $IntTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/S $RealTotal (&/P total? (&/|list ?value)))) + (return (&/V $RealTotal (&/T total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/S $RealTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/S $CharTotal (&/P total? (&/|list ?value)))) + (return (&/V $CharTotal (&/T total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/S $CharTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/S $TextTotal (&/P total? (&/|list ?value)))) + (return (&/V $TextTotal (&/T total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) - - [($DefaultTotal total?) ($UnitTestAC)] - (return (&/S $UnitTotal nil)) - - [($UnitTotal) ($UnitTestAC)] - (return (&/S $UnitTotal nil)) - - [($DefaultTotal total?) ($ProdTestAC ?left ?right)] - (|do [:let [_default (&/S $DefaultTotal total?)] - =left (merge-total _default (&/P ?left ?body)) - =right (merge-total _default (&/P ?right ?body))] - (return (&/S $ProdTotal ($$ &/P total? =left =right)))) - - [($ProdTotal total? ?_left ?_right) ($ProdTestAC ?left ?right)] - (|do [=left (merge-total ?_left (&/P ?left ?body)) - =right (merge-total ?_right (&/P ?right ?body))] - (return (&/S $ProdTotal ($$ &/P total? =left =right)))) - - [($DefaultTotal total?) ($SumTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (&/S $DefaultTotal total?) - (&/P ?test ?body)) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/S $DefaultTotal total?))) + (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) + + [($DefaultTotal total?) ($TupleTestAC ?tests)] + (|do [structs (&/map% (fn [t] + (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) + ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T t ?body))) + ?values ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) + + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (&/V $DefaultTotal total?) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/S $SumTotal (&/P total? structs)))) + (return (&/V $VariantTotal (&/T total? structs)))) - [($SumTotal total? ?branches) ($SumTestAC ?tag ?count ?test)] + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) (&/$Some sub) sub (&/$None) - (&/S $DefaultTotal total?)) - (&/P ?test ?body)) + (&/V $DefaultTotal total?)) + (&/T ?test ?body)) structs (|case (&/|list-put ?tag sub-struct ?branches) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/S $SumTotal (&/P total? structs)))) + (return (&/V $VariantTotal (&/T total? structs)))) )))) (defn ^:private check-totality [value-type struct] @@ -313,39 +351,33 @@ ($TextTotal ?total _) (return ?total) - ($UnitTotal) - (return true) - - ($ProdTotal ?total ?_left ?_right) + ($TupleTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$ProdT ?left ?right) - (|do [=left (check-totality ?left ?_left) - =right (check-totality ?right ?_right)] - (return (and =left =right))) + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ($SumTotal ?total ?structs) + ($VariantTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (|case [value-type* ?structs] - [(&/$SumT ?left ?right) (&/$Cons ?_left ?tail)] - (|do [=left (check-totality ?left ?_left) - =right (|case ?tail - (&/$Cons ?_right (&/$Nil)) - (check-totality ?right ?_right) - - (&/$Nil) - (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.") - - _ - (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))] - (return (and =left =right))) + (|case value-type* + (&/$VariantT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + ;; (prn '$VariantTotal + ;; (&/adt->text sub-struct) + ;; (&type/show-type ?member)) + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Variant is not total.")))) @@ -362,7 +394,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/S $DefaultTotal false) patterns) + struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 5686700e3..4e9dcd79f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,31 +15,31 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-counter))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-mappings)) - =return (body (&/$update-envs - (fn [stack] - (let [bound-unit (&/S &&/$var (&/S &/$Local (->> (&/|head stack) (&/$get-locals) (&/$get-counter))))] - (&/Cons$ (&/$update-locals #(->> % - (&/$update-counter inc) - (&/$update-mappings (fn [m] (&/|put name (&/P bound-unit type) m)))) - (&/|head stack)) - (&/|tail stack)))) - state))] + (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$envs + (fn [stack] + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] (|case =return (&/$Right ?state ?value) - (return* (&/$update-envs (fn [stack*] - (&/Cons$ (&/$update-locals #(->> % - (&/$update-counter dec) - (&/$set-mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) + (return* (&/update$ &/$envs (fn [stack*] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) ?value) _ @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/$get-envs) &/|head (&/$get-closure) (&/$get-mappings))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 69aa95f12..64f297994 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case $$]] + (lux [base :as & :refer [|let |do return fail |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -20,7 +20,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - [_ (&/$TextS ?text)] + (&/$Meta _ (&/$TextS ?text)) (return ?text) _ @@ -32,7 +32,7 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/P ?item =type)))))) + (return (&/T ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -47,20 +47,20 @@ "(-> Type Type)" (|case type (&/$DataT class) - (&type/Data$ (&type/as-obj class)) + (&/V &/$DataT (&type/as-obj class)) _ type)) ;; [Resources] (do-template [ ] - (let [input-type (&type/Data$ ) - output-type (&type/Data$ )] + (let [input-type (&/V &/$DataT ) + output-type (&/V &/$DataT )] (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S (&/P =x =y)) output-type)))))) + (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -108,7 +108,7 @@ =type (&host/lookup-static-field class-loader ?class ?field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-getstatic (&/P ?class ?field)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) (defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] (|do [class-loader &/loader @@ -116,7 +116,7 @@ =object (&&/analyse-1 analyse ?object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-getfield ($$ &/P ?class ?field =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) (defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] (|do [class-loader &/loader @@ -124,7 +124,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-putstatic ($$ &/P ?class ?field =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) (defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] (|do [class-loader &/loader @@ -133,7 +133,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-putfield ($$ &/P ?class ?field =object =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) (defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] (|do [class-loader &/loader @@ -143,31 +143,31 @@ ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&type/Data$ _class) _arg)) + (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-invokestatic ($$ &/P ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-instanceof (&/P ?class =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) (do-template [ ] (defn [analyse exo-type ?class ?method ?classes ?object ?args] (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S ($$ &/P ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface @@ -179,73 +179,73 @@ =return (if (= "" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) + (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-invokespecial ($$ &/P ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-null? =object) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null")] + (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-null nil) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&type/Data$ ?class)] + :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-new ($$ &/P ?class =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/P (&/S &&/$jvm-new-array (&/P ?class ?length)) (&/S "array" (&/P (&type/Data$ ?class) - (&/S &/$Nil nil))))))) + (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) + (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] - (return (&/|list (&/P (&/S &&/$jvm-aastore ($$ &/P =array ?idx =elem)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] - (return (&/|list (&/P (&/S &&/$jvm-aaload (&/P =array ?idx)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - [_ (&/$TextS "public")] + (&/$Meta _ (&/$TextS "public")) (return (assoc so-far :visibility "public")) - [_ (&/$TextS "private")] + (&/$Meta _ (&/$TextS "private")) (return (assoc so-far :visibility "private")) - [_ (&/$TextS "protected")] + (&/$Meta _ (&/$TextS "protected")) (return (assoc so-far :visibility "protected")) - [_ (&/$TextS "static")] + (&/$Meta _ (&/$TextS "static")) (return (assoc so-far :static? true)) - [_ (&/$TextS "final")] + (&/$Meta _ (&/$TextS "final")) (return (assoc so-far :final? true)) - [_ (&/$TextS "abstract")] + (&/$Meta _ (&/$TextS "abstract")) (return (assoc so-far :abstract? true)) - [_ (&/$TextS "synchronized")] + (&/$Meta _ (&/$TextS "synchronized")) (return (assoc so-far :concurrency "synchronized")) - [_ (&/$TextS "volatile")] + (&/$Meta _ (&/$TextS "volatile")) (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Nil)))))] + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) + (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) + (&/$Nil)))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -289,18 +289,18 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?method-inputs)] - (&/$Cons [_ (&/$TextS ?method-output)] - (&/$Cons [_ (&/$TupleS ?method-modifiers)] - (&/$Cons ?method-body - (&/$Nil)))))))]] + [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) + (&/$Cons ?method-body + (&/$Nil))))))))] (|do [=method-inputs (&/map% (fn [minput] (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] - (&/$Cons [_ (&/$TextS ?input-type)] - (&/$Nil))))] - (return (&/P ?input-name ?input-type)) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) + (&/$Nil))))) + (return (&/T ?input-name ?input-type)) _ (fail "[Analyser Error] Wrong syntax for method input."))) @@ -309,14 +309,14 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype)) + (&&env/with-local iname (&/V &/$DataT (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/Cons$ (&/P "this" ?super-class) + (&/|cons (&/T ";this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers @@ -327,18 +327,18 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/S &&/$jvm-class ($$ &/P ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?inputs)] - (&/$Cons [_ (&/$TextS ?output)] - (&/$Cons [_ (&/$TupleS ?modifiers)] - (&/$Nil))))))] + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) + (&/$Nil))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -349,29 +349,29 @@ _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) - _ (compile-token (&/S &&/$jvm-interface ($$ &/P ?name =supers =methods)))] + _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] - (return ($$ &/P ?ex-class idx =catch-body)))) + (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (|case ?finally - (&/$None) (return &/None$) + =finally (|case [?finally] + (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/Some$ =finally))))] - (return (&/|list (&/P (&/S &&/$jvm-try ($$ &/P =body =catches =finally)) exo-type))))) + (return (&/V &/$Some =finally))))] + (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable") _type)] - (return (&/|list (&/P (&/S &&/$jvm-throw =ex) &type/$Void))))) + _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] (defn [analyse exo-type ?monitor] @@ -379,18 +379,18 @@ _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S =monitor) output-type))))) + (return (&/|list (&/T (&/V =monitor) output-type))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [ ] - (let [output-type (&type/Data$ )] + (let [output-type (&/V &/$DataT )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ ) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S =value) output-type)))))) + (return (&/|list (&/T (&/V =value) output-type)))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -413,11 +413,11 @@ ) (do-template [ ] - (let [output-type (&type/Data$ )] + (let [output-type (&/V &/$DataT )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ ) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S =value) output-type)))))) + (return (&/|list (&/T (&/V =value) output-type)))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&type/App$ &type/List &type/Text) - (&&/analyse-1 analyse (&type/App$ &type/IO &type/Unit) ?body))) - _ (compile-token (&/S &&/$jvm-program =body))] + (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V &&/$jvm-program =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index b30953f67..aeb5a4814 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -9,7 +9,7 @@ (ns lux.analyser.lambda (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case $$]] + (lux [base :as & :refer [|let |do return fail |case]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -22,19 +22,15 @@ (&env/with-local arg arg-type (|do [=return body =captured &env/captured-vars] - (return ($$ &/P scope-name =captured =return)))))))) + (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/P (&/S &&/$captured ($$ &/P scope - (->> frame (&/$get-closure) (&/$get-counter)) - register)) + register* (&/T (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register)) register-type)] - (do ;; (prn 'close-over 'updating-closure - ;; [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] - ;; [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) - ;; (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) - ($$ &/P register* (&/$update-closure #(->> % - (&/$update-counter inc) - (&/$update-mappings (fn [mps] (&/|put name register* mps)))) - frame))))) + (&/T register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) + frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 20e435eb3..d241201f4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list |case $$]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -27,64 +27,52 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/P ?item =type)))))) + (return (&/T ?item =type)))))) (defn ^:private with-cursor [cursor form] (|case form - [_ syntax] - (&/P cursor syntax))) + (&/$Meta _ syntax) + (&/V &/$Meta (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - ;; (prn 'analyse-tuple/_0 (&type/show-type exo-type) (->> ?elems (&/|map &/show-ast) (&/->seq))) - (|case ?elems - (&/$Nil) - (|do [_ (&type/check exo-type &type/Unit)] - (return (&/|list (&/P (&/S &&/$unit nil) - exo-type)))) - - (&/$Cons single (&/$Nil)) - (fail (str "Tuples can't have only 1 element: " (&/show-ast single))) - - (&/$Cons head tail) - (|do [exo-type* (&type/actual-type exo-type) - ;; :let [_ (prn 'analyse-tuple/_0.25_0 (&/show-ast head) (&/adt->text exo-type*)) - ;; _ (prn 'analyse-tuple/_0.25_1 (&/show-ast head) (&type/show-type exo-type*))] - ] - (|case exo-type* - (&/$ProdT ?left ?right) - (|do [;; :let [_ (prn 'analyse-tuple/_0.5 (&/show-ast head) (&type/show-type ?left))] - =left (&&/analyse-1 analyse ?left head) - ;; :let [_ (prn 'analyse-tuple/_1 =left (&type/show-type ?left))] - =right (|case tail - (&/$Nil) - (fail "Tuples has wrong size.") - - (&/$Cons single (&/$Nil)) - (&&/analyse-1 analyse ?right single) - - _ - (&/ensure-1 (analyse-tuple analyse ?right tail))) - ;; :let [_ (prn 'analyse-tuple/_2 =right (&type/show-type ?right))] - ] - (return (&/|list (&/P (&/S &&/$prod (&/P =left =right)) - exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) - (&/$AllT _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) + (&/$AllT _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))) - )) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) + +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (|case ?values + (&/$Nil) + (analyse-tuple analyse exo-type (&/|list)) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse exo-type ?values) + )] + (|case output + (&/$Cons x (&/$Nil)) + (return x) + + _ + (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn analyse-variant [analyse exo-type idx ?values] - ;; (prn 'analyse-variant/_0 - ;; (&type/show-type exo-type) - ;; idx - ;; (->> ?values (&/|map &/show-ast) (&/->seq))) (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -95,41 +83,82 @@ _ (&type/actual-type exo-type))] (|case exo-type* + (&/$VariantT ?cases) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (analyse-variant-body analyse vtype ?values)] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** idx ?values)))) - - ?variant - (|do [;; :let [_ (prn 'analyse-variant/_1 - ;; (&type/show-type ?variant) - ;; idx - ;; (->> ?values (&/|map &/show-ast) (&/->seq)))] - vtype (&type/variant-case idx ?variant) - ;; :let [_ (prn 'analyse-variant/_2 - ;; idx - ;; (&type/show-type vtype))] - =value (&/ensure-1 (|case ?values - (&/$Nil) - (analyse-tuple analyse vtype (&/|list)) - - (&/$Cons ?value (&/$Nil)) - (analyse vtype ?value) - - _ - (analyse-tuple analyse vtype ?values))) - ;; :let [_ (prn 'analyse-variant/_3 - ;; idx - ;; =value)] - ] - (return (&/|list (&/P (&/S &&/$sum (&/P idx =value)) - exo-type)))) - ))) + + _ + (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) +;; (defn analyse-variant [analyse exo-type ident ?values] +;; (|do [exo-type* (|case exo-type +;; (&/$VarT ?id) +;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] +;; (&type/actual-type exo-type*)) +;; (|do [_ (&type/set-var ?id &type/Type)] +;; (&type/actual-type &type/Type)))) + +;; _ +;; (&type/actual-type exo-type))] +;; (|case exo-type* +;; (&/$VariantT ?cases) +;; (|do [?tag (&&/resolved-ident ident)] +;; (if-let [vtype (&/|get ?tag ?cases)] +;; (|do [=value (analyse-variant-body analyse vtype ?values)] +;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) +;; exo-type)))) +;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + +;; (&/$AllT _) +;; (&type/with-var +;; (fn [$var] +;; (|do [exo-type** (&type/apply-type exo-type* $var)] +;; (analyse-variant analyse exo-type** ident ?values)))) + +;; _ +;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - (|do [members (&&record/order-record ?elems)] - (analyse-tuple analyse exo-type members))) + (|do [exo-type* (|case exo-type + (&/$VarT ?id) + (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + + (&/$AllT _) + (|do [$var &type/existential + =type (&type/apply-type exo-type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type exo-type $var)] + ;; (&type/actual-type =type)))) + + _ + (&type/actual-type exo-type)) + types (|case exo-type* + (&/$TupleT ?table) + (return ?table) + + _ + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) + _ (&/assert! (= (&/|length types) (&/|length ?elems)) + (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) + members (&&record/order-record ?elems) + =members (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + types members)] + (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -148,17 +177,14 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/$get-envs state) - no-binding? #(do ;; (prn 'analyse-local/_ (->> % &/adt->text)) - ;; (prn 'analyse-local/_1 (->> % (&/$get-locals) &/adt->text)) - ;; (prn 'analyse-local/_2 (->> % (&/$get-closure) &/adt->text)) - (and (->> % (&/$get-locals) (&/$get-mappings) (&/|contains? name) not) - (->> % (&/$get-closure) (&/$get-mappings) (&/|contains? name) not))) + (|let [stack (&/get$ &/$envs state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -167,8 +193,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/$get-locals) (&/$get-mappings) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/$get-locals) (&/$get-mappings) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -187,35 +213,32 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type)))) state) - _ - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/$get-name %2) %1) - (&/|map #(&/$get-name %) outer) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/P register* (&/Cons$ frame* new-inner)))) - (&/P (or (->> top-outer (&/$get-locals) (&/$get-mappings) (&/|get name)) - (->> top-outer (&/$get-closure) (&/$get-mappings) (&/|get name))) + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) - ;; :let [_ (prn 'analyse-local/_0 name) - ;; _ (prn 'analyse-local/_1 name (&type/show-type exo-type) (&type/show-type btype))] - _ (&type/check exo-type btype) - ;; :let [_ (prn 'analyse-local/_2 name 'CHECKED)] - ] + _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/$set-envs (&/|++ inner* outer) state)))) + (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -230,7 +253,7 @@ (|case ?args (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/P fun-type (&/|list)))) + (return (&/T fun-type (&/|list)))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -248,15 +271,15 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/S &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] (&type/clean $var =output-t)))] - (return (&/P type** =args))) + (return (&/T type** =args))) )))) (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/P =output-t (&/Cons$ =arg =args)))) + (return (&/T =output-t (&/|cons =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -277,25 +300,25 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - :let [_ (when (or (= "using" (aget real-name 1)) - ;; (= "type" (aget real-name 1)) - ;; (= &&/$struct r-name) - ) - (->> (&/|map &/show-ast macro-expansion) - (&/|interpose "\n") - (&/fold str "") - (prn (&/ident->text real-name))))] + ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; ;; (= "type" (aget real-name 1)) + ;; ;; (= &&/$struct r-name) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t))))) ))) @@ -306,7 +329,7 @@ =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/P (&/S &&/$case (&/P =value =match)) + (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -325,7 +348,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/P (&/S &&/$lambda ($$ &/P =scope =captured =body)) exo-type*))) + (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -347,22 +370,22 @@ ] (|case dtype (&/$BoundT ?vname) - (return (&/P _expr exo-type)) + (return (&/T _expr exo-type)) (&/$ExT _) - (return (&/P _expr exo-type)) + (return (&/T _expr exo-type)) (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] - ;; (return (&/P _expr exo-type)) + ;; (return (&/T _expr exo-type)) (if ?? (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) - (return (&/P _expr exo-type))) + (return (&/T _expr exo-type))) ) _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) - (return (&/P _expr exo-type)))))))) + (return (&/T _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] @@ -395,7 +418,7 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/S &&/$def (&/P ?name =value))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) @@ -405,16 +428,16 @@ (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] module-name &/get-module-name ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/S &&/$declare-macro (&/P module-name ?name))) + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) ;; :let [_ (prn 'analyse-declare-macro ?name "2")] ] (return (&/|list)))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) @@ -446,7 +469,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -454,5 +477,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (analyse-1+ analyse ?value)] - (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index bc9647f9f..d23953f5e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -12,70 +12,69 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [defrtags |let |do return return* fail fail* |case $$]] + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] [host :as &host]))) ;; [Utils] -(defrtags - ["module-aliases" - "defs" - "imports" - "tags" - "types"]) +(deftags "" + "module-aliases" + "defs" + "imports" + "tags" + "types") (def ^:private +init+ - ($$ &/P - ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - (&/|list) - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) - )) + (&/T ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + (&/|list) + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + )) ;; [Exports] (defn add-import [module] "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/$update-modules - (fn [ms] - (&/|update current-module - (fn [m] ($update-imports (partial &/Cons$ module) m)) - ms)) - state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $imports (partial &/|cons module) m)) + ms)) + state) nil)))) (defn set-imports [imports] "(-> (List Text) (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/$update-modules - (fn [ms] - (&/|update current-module - (fn [m] ($set-imports imports m)) - ms)) - state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) nil)))) (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update module - (fn [m] - ($update-defs - #(&/|put name (&/P false def-data) %) - m)) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T false def-data) %) + m)) + ms)))) nil) _ @@ -84,8 +83,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module))] - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -105,31 +104,31 @@ (defn type-def [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module))] - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _type)] (return* state _type) _ - (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/P module name))))) - (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/P module name))))) + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update a-module - (fn [m] - ($update-defs - #(&/|put a-name (&/P false (&/S &/$AliasD (&/P r-module r-name))) %) - m)) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update a-module + (fn [m] + (&/update$ $defs + #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) + m)) + ms)))) nil) _ @@ -138,30 +137,26 @@ (defn exists? [name] "(-> Text (Lux Bool))" (fn [state] - ;; (prn 'exists?/_0 &/$modules name) - ;; (prn 'exists?/_2 (&/adt->text state)) - ;; (prn 'exists?/_3 (&/adt->text (->> state (&/$get-modules)))) - ;; (prn 'exists?/_4 (&/adt->text (->> state (&/$get-modules) (&/|contains? name)))) (return* state - (->> state (&/$get-modules) (&/|contains? name))))) + (->> state (&/get$ &/$modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update module - #($update-module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) nil))) (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/$get-modules) (&/|get current-module) ($get-module-aliases) (&/|get name))] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -169,9 +164,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/$get-modules) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -182,7 +177,7 @@ state)) _ - (return* state (&/P (&/P module name) $$def))) + (return* state (&/T (&/T module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) @@ -203,7 +198,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module) ($get-defs))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -213,15 +208,15 @@ (.getField &/datum-field) (.get nil))]] (fn [state*] - (return* (&/$update-modules - (fn [$modules] - (&/|update module - (fn [m] - ($update-defs - #(&/|put name (&/P exported? (&/S &/$MacroD macro)) %) - m)) - $modules)) - state*) + (return* (&/update$ &/$modules + (fn [$modules] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) + m)) + $modules)) + state*) nil))) state) @@ -235,21 +230,21 @@ (defn export [module name] (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/$get-modules) (&/|get module) ($get-defs) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/$update-modules (fn [ms] - (&/|update module (fn [m] - ($update-defs - #(&/|put name (&/P true ?data) %) - m)) - ms)))) + (&/update$ &/$modules (fn [ms] + (&/|update module (fn [m] + (&/update$ $defs + #(&/|put name (&/T true ?data) %) + m)) + ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) @@ -265,61 +260,61 @@ (do ;; (prn 'defs k ?exported?) (|case ?def (&/$AliasD ?r-module ?r-name) - ($$ &/P ?exported? k (str "A" ?r-module ";" ?r-name)) + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) (&/$MacroD _) - ($$ &/P ?exported? k "M") + (&/T ?exported? k "M") (&/$TypeD _) - ($$ &/P ?exported? k "T") + (&/T ?exported? k "T") _ - ($$ &/P ?exported? k "V"))))) - (->> state (&/$get-modules) (&/|get module) ($get-defs))))))) + (&/T ?exported? k "V"))))) + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/$get-modules) (&/|get module) ($get-imports)))))) + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/$update-modules #(&/|put name +init+ %) state) nil))) + (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/$update-modules #(&/|put name +init+ %)) - (&/$set-envs (&/|list (&/env name)))) + (&/update$ &/$modules #(&/|put name +init+ %)) + (&/set$ &/$envs (&/|list (&/env name)))) nil))) -(do-template [ ] +(do-template [ ] (defn [module] (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (return* state ( =module)) + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) - tags-by-module $get-tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $get-types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" ) (defn ensure-undeclared-tags [module tags] (|do [tags-table (tags-by-module module) _ (&/map% (fn [tag] (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/P module tag)))) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) (return nil))) tags)] (return nil))) (defn ensure-undeclared-type [module name] (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/P module name))))] + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] (return nil))) (defn declare-tags [module tag-names type] @@ -332,34 +327,37 @@ (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) _ (ensure-undeclared-type _module _name)] (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/P module tag-name)) tag-names)] - (return* (&/$update-modules - (fn [=modules] - (&/|update module - #(->> % - ($set-tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name ($$ &/P idx tags type) table))) - ($get-tags %) - (&/enumerate tag-names))) - ($update-types (partial &/|put _name (&/P tags type)))) - =modules)) - state) + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags type) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T tags type)))) + =modules)) + state) nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(do-template [ ] - (defn [module tag-name] - - (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] - (|let [[idx tags type] idx+tags] - (return* state )) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - - tag-index idx "(-> Text Text (Lux Int))" - tag-group tags "(-> Text Text (Lux (List Ident)))" - ) +(defn tag-index [module tag-name] + "(-> Text Text (Lux Int))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 0)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + +(defn tag-group [module tag-name] + "(-> Text Text (Lux (List Ident)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 1)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 96c988544..2b4b7e095 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -13,6 +13,122 @@ (lux.analyser [base :as &&] [module :as &&module]))) +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" @@ -20,7 +136,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [[_ (&/$TagS tag1)] _] _) + (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -28,9 +144,9 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [[_ (&/$TagS k)] v] + [(&/$Meta _ (&/$TagS k)) v] (|do [=k (&&/resolved-ident k)] - (return (&/P (&/ident->text =k) v))) + (return (&/T (&/ident->text =k) v))) _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) diff --git a/src/lux/base.clj b/src/lux/base.clj index d261145ae..6247524af 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -11,157 +11,99 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) -;; [ADTs] -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) - -(defmacro deftags [names] - (assert (vector? names)) +;; [Tags] +(defmacro deftags [prefix & names] `(do ~@(for [[name idx] (map vector names (range (count names)))] - `(def ~(symbol (str "$" name)) (int ~idx))))) - -(defn ^:private unfold-accesses - ([elems] - (unfold-accesses 1 (count elems) elems)) - ([begin end elems] - (if (= begin end) - (list elems) - (cons (take begin elems) - (unfold-accesses (inc begin) end elems))))) - -(defmacro defrtags [tags] - (let [num-tags (count tags) - normals (butlast tags) - special (last tags) - tags+locs (cons [special (repeat (dec num-tags) 1)] - (map #(vector %1 (concat (repeat %2 1) [0])) - normals - (range num-tags)))] - `(do ~@(for [[tag loc] tags+locs - :let [getter (symbol (str "$get-" tag)) - setter (symbol (str "$set-" tag)) - updater (symbol (str "$update-" tag)) - record (gensym "record") - value (gensym "value")]] - `(do (defn ~getter [~record] - ;; (if (= '~'$get-source '~getter) - ;; (prn '~getter '~loc ~record (aget ~record ~@loc)) - ;; (prn '~getter '~loc ~record (adt->text (aget ~record ~@loc)))) - (aget ~record ~@loc)) - (defn ~setter [~value ~record] - ;; (if (= '~'$set-source '~setter) - ;; (prn '~setter '_1 '~loc ~record) - ;; (prn '~setter '_2 '~loc ~record (adt->text ~value))) - ;; (doto record# - ;; (aset ~@loc value#)) - ;; (doto record# - ;; (aset 1 (doto (aget record# 1) - ;; (aset 1 ...)))) - ~(reduce (fn [inner indices] - `(doto (aclone ~(if (= 1 (count indices)) - record - `(aget ~record ~@(butlast indices)))) - (aset ~(last indices) ~inner))) - value - (reverse (unfold-accesses loc))) - ) - (defn ~updater [f# ~record] - ;; (prn '~updater '~loc ~record) - ;; (doto record# - ;; (aset ~@loc (f# (aget record# ~@loc)))) - (~setter (f# (~getter ~record)) ~record))))) - )) + `(def ~(symbol (str "$" name)) ~idx)))) ;; List -(deftags - ["Nil" - "Cons"]) +(deftags "" + "Nil" + "Cons") ;; Maybe -(deftags - ["None" - "Some"]) +(deftags "" + "None" + "Some") + +;; Meta +(deftags "" + "Meta") ;; Either -(deftags - ["Left" - "Right"]) +(deftags "" + "Left" + "Right") ;; AST -(deftags - ["BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS"]) +(deftags "" + "BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS") ;; Type -(deftags - ["VoidT" - "UnitT" - "SumT" - "ProdT" - "DataT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "AllT" - "AppT" - "NamedT"]) +(deftags "" + "DataT" + "VariantT" + "TupleT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT" + "NamedT") ;; Vars -(deftags - ["Local" - "Global"]) +(deftags "lux;" + "Local" + "Global") ;; Definitions -(deftags - ["ValueD" - "TypeD" - "MacroD" - "AliasD"]) +(deftags "lux;" + "ValueD" + "TypeD" + "MacroD" + "AliasD") ;; Binding -(defrtags - ["counter" - "mappings"]) +(deftags "" + "counter" + "mappings") ;; Env -(defrtags - ["name" - "inner-closures" - "locals" - "closure"]) +(deftags "" + "name" + "inner-closures" + "locals" + "closure") ;; Host -(defrtags - ["writer" - "loader" - "classes"]) +(deftags "" + "writer" + "loader" + "classes") ;; Compiler -(defrtags - ["source" - "cursor" - "modules" - "envs" - "type-vars" - "expected" - "seed" - "eval?" - "host"]) +(deftags "" + "source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host") ;; [Exports] -;; Class fields (def datum-field "_datum") (def meta-field "_meta") (def name-field "_name") @@ -175,59 +117,55 @@ (def +name-separator+ ";") -(def prelude-name "lux") - -(defmacro $$ [op & args] - (assert (> (count args) 1) - (prn-str '$$ op args)) - (let [[last & others] (reverse args)] - (reduce (fn [right left] `(~op ~left ~right)) - last - others))) +(defn T [& elems] + (to-array elems)) -(defn S [^Long tag value] +(defn V [^Long tag value] (to-array [tag value])) -(defn P [left right] - (to-array [left right])) - ;; Constructors -(def None$ (S $None nil)) -(defn Some$ [x] (S $Some x)) +(def None$ (V $None nil)) +(defn Some$ [x] (V $Some x)) + +(def Nil$ (V $Nil nil)) +(defn Cons$ [h t] (V $Cons (T h t))) -(def Nil$ (S $Nil nil)) -(defn Cons$ [h t] (S $Cons (P h t))) +(defn get$ [slot ^objects record] + (aget record slot)) + +(defn set$ [slot value ^objects record] + (let [record* (aclone record) + size (alength record)] + (aset record* slot value) + record*)) + +(defmacro update$ [slot f record] + `(let [record# ~record] + (set$ ~slot (~f (get$ ~slot record#)) + record#))) (defn fail* [message] - (S $Left message)) + (V $Left message)) (defn return* [state value] - (S $Right (P state value))) - -(defn ^:private transform-tuple-pattern [pattern] - (case (count pattern) - 0 '_ - 1 (assert false "Can't have singleton tuples.") - 2 pattern - ;; else - (let [[last & others] (reverse pattern)] - (reduce (fn [r l] [l r]) last others)))) + (V $Right (T state value))) (defn transform-pattern [pattern] - (cond (vector? pattern) (transform-tuple-pattern (mapv transform-pattern pattern)) + (cond (vector? pattern) (mapv transform-pattern pattern) (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] (vec (cons (eval (first pattern)) (list (case (count parts) + 0 '_ 1 (first parts) ;; else - (transform-tuple-pattern parts)))))) + `[~@parts]))))) :else pattern )) (defmacro |case [value & branches] (assert (= 0 (mod (count branches) 2))) (let [value* (if (vector? value) - [`($$ P ~@value)] + [`(T ~@value)] [value])] `(matchv ::M/objects ~value* ~@(mapcat (fn [[pattern body]] @@ -245,8 +183,8 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(Cons$ ~head ~tail)) - `Nil$ + `(V $Cons (T ~head ~tail))) + `(V $Nil nil) (reverse elems))) (defmacro |table [& elems] @@ -266,18 +204,17 @@ (|get slot table*)))) (defn |put [slot value table] - ;; (prn '|put slot (adt->text value) (adt->text table)) (|case table ($Nil) - (Cons$ (P slot value) Nil$) + (V $Cons (T (T slot value) (V $Nil nil))) ($Cons [k v] table*) (if (.equals ^Object k slot) - (Cons$ (P slot value) table*) - (Cons$ (P k v) (|put slot value table*))) + (V $Cons (T (T slot value) table*)) + (V $Cons (T (T k v) (|put slot value table*)))) ;; _ - ;; (assert false (prn-str '|put slot (adt->text value) (adt->text table))) + ;; (assert false (prn-str '|put (aget table 0))) )) (defn |remove [slot table] @@ -288,7 +225,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (Cons$ (P k v) (|remove slot table*))))) + (V $Cons (T (T k v) (|remove slot table*)))))) (defn |update [k f table] (|case table @@ -297,8 +234,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (Cons$ (P k* (f v)) table*) - (Cons$ (P k* v) (|update k f table*))))) + (V $Cons (T (T k* (f v)) table*)) + (V $Cons (T (T k* v) (|update k f table*)))))) (defn |head [xs] (|case xs @@ -319,11 +256,11 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (S $Left message))) + (V $Left message))) (defn return [value] (fn [state] - (S $Right (P state value)))) + (V $Right (T state value)))) (defn bind [m-value step] (fn [state] @@ -351,13 +288,22 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] +(defn |cons [head tail] + (V $Cons (T head tail))) + (defn |++ [xs ys] (|case xs ($Nil) ys ($Cons x xs*) - (Cons$ x (|++ xs* ys)))) + (V $Cons (T x (|++ xs* ys))))) + +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) (defn |map [f xs] (|case xs @@ -365,7 +311,7 @@ xs ($Cons x xs*) - (Cons$ (f x) (|map f xs*)) + (V $Cons (T (f x) (|map f xs*))) _ (assert false (prn-str '|map f (adt->text xs))) @@ -386,7 +332,7 @@ ($Cons x xs*) (if (p x) - (Cons$ x (|filter p xs*)) + (V $Cons (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] @@ -400,13 +346,13 @@ (defn |split-with [p xs] (|case xs ($Nil) - (P xs xs) + (T xs xs) ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (P (Cons$ x pre) post)) - (P Nil$ xs)))) + (T (|cons x pre) post)) + (T (V $Nil nil) xs)))) (defn |contains? [k table] (|case table @@ -415,10 +361,7 @@ ($Cons [k* _] table*) (or (.equals ^Object k k*) - (|contains? k table*)) - - _ - (assert false (prn-str '|contains? k (adt->text table))))) + (|contains? k table*)))) (defn fold [f init xs] (|case xs @@ -443,15 +386,15 @@ (|list init) ($Cons x xs*) - (Cons$ init (folds f (f init x) xs*)))) + (|cons init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] (if (< from to) - (Cons$ from (|range* (inc from) to)) - Nil$))] + (V $Cons (T from (|range* (inc from) to))) + (V $Nil nil)))] (defn |range [n] (|range* 0 n))) @@ -466,10 +409,10 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (Cons$ (P x y) (zip2 xs* ys*)) + (V $Cons (T (T x y) (zip2 xs* ys*))) [_ _] - Nil$)) + (V $Nil nil))) (defn |keys [plist] (|case plist @@ -477,7 +420,7 @@ (|list) ($Cons [k v] plist*) - (Cons$ k (|keys plist*)))) + (|cons k (|keys plist*)))) (defn |vals [plist] (|case plist @@ -485,7 +428,7 @@ (|list) ($Cons [k v] plist*) - (Cons$ v (|vals plist*)))) + (|cons v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -496,7 +439,7 @@ xs ($Cons x xs*) - (Cons$ x (Cons$ sep (|interpose sep xs*))))) + (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) (do-template [ ] (defn [f xs] @@ -509,23 +452,23 @@ ys ( f xs*)] (return ( y ys))))) - map% Cons$ + map% |cons flat-map% |++) (defn list-join [xss] - (fold |++ Nil$ xss)) + (fold |++ (V $Nil nil) xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (Cons$ (P x y) (|as-pairs xs*)) + (V $Cons (T (T x y) (|as-pairs xs*))) _ - Nil$)) + (V $Nil nil))) (defn |reverse [xs] (fold (fn [tail head] - (Cons$ head tail)) + (|cons head tail)) (|list) xs)) @@ -561,7 +504,7 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (Cons$ head tail))) + (return (|cons head tail))) (return (|list))))) (defn exhaust% [step] @@ -608,28 +551,28 @@ (def loader (fn [state] - (return* state (->> state $get-host ($get-loader))))) + (return* state (->> state (get$ $host) (get$ $loader))))) (def classes (fn [state] - (return* state (->> state $get-host ($get-classes))))) + (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ - (P ;; "lux;counter" + (T ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - ($$ P ;; "lux;name" - name - ;; "lux;inner-closures" - 0 - ;; "lux;locals" - +init-bindings+ - ;; "lux;closure" - +init-bindings+ - )) + (T ;; "lux;name" + name + ;; "lux;inner-closures" + 0 + ;; "lux;locals" + +init-bindings+ + ;; "lux;closure" + +init-bindings+ + )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String (class (byte-array [])) @@ -651,41 +594,41 @@ (defn host [_] (let [store (atom {})] - ($$ P ;; "lux;writer" - None$ - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store))) + (T ;; "lux;writer" + (V $None nil) + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store))) (defn init-state [_] - ($$ P ;; "lux;source" - None$ - ;; "lux;cursor" - ($$ P "" -1 -1) - ;; "lux;modules" - (|table) - ;; "lux;envs" - (|list) - ;; "lux;types" - +init-bindings+ - ;; "lux;expected" - (S $VoidT nil) - ;; "lux;seed" - 0 - ;; "lux;eval?" - false - ;; "lux;host" - (host nil) - )) + (T ;; "lux;source" + (V $None nil) + ;; "lux;cursor" + (T "" -1 -1) + ;; "lux;modules" + (|table) + ;; "lux;envs" + (|list) + ;; "lux;types" + +init-bindings+ + ;; "lux;expected" + (V $VariantT (|list)) + ;; "lux;seed" + 0 + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) + )) (defn save-module [body] (fn [state] (|case (body state) ($Right state* output) (return* (->> state* - ($set-envs ($get-envs state)) - ($set-source ($get-source state))) + (set$ $envs (get$ $envs state)) + (set$ $source (get$ $source state))) output) ($Left msg) @@ -693,20 +636,20 @@ (defn with-eval [body] (fn [state] - (|case (body ($set-eval? true state)) + (|case (body (set$ $eval? true state)) ($Right state* output) - (return* ($set-eval? ($get-eval? state) state*) output) + (return* (set$ $eval? (get$ $eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state ($get-eval? state)))) + (return* state (get$ $eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state ($get-host) ($get-writer))] + (let [writer* (->> state (get$ $host) (get$ $writer))] (|case writer* ($Some datum) (return* state datum) @@ -716,15 +659,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head ($get-envs state))] + (try (let [top (|head (get$ $envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed ($get-seed state)] - (return* ($set-seed (inc seed) state) seed)))) + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -737,26 +680,26 @@ (defn ->list [seq] (if (empty? seq) (|list) - (Cons$ (first seq) (->list (rest seq))))) + (|cons (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (Cons$ x (|repeat (dec n) x)) + (|cons x (|repeat (dec n) x)) (|list))) (def get-module-name (fn [state] - (|case (|reverse ($get-envs state)) + (|case (|reverse (get$ $envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state ($get-name ?global))))) + (return* state (get$ $name ?global))))) (defn find-module [name] "(-> Text (Lux (Module Compiler)))" (fn [state] - (if-let [module (|get name ($get-modules state))] + (if-let [module (|get name (get$ $modules state))] (return* state module) (fail* (str "Unknown module: " name))))) @@ -767,10 +710,10 @@ (defn with-scope [name body] (fn [state] - (let [output (body ($update-envs #(Cons$ (env name) %) state))] + (let [output (body (update$ $envs #(|cons (env name) %) state))] (|case output ($Right state* datum) - (return* ($update-envs |tail state*) datum) + (return* (update$ $envs |tail state*) datum) _ output)))) @@ -780,24 +723,23 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top ($get-inner-closures) str)))] + (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* ($update-envs #(Cons$ ($update-inner-closures inc (|head %)) - (|tail %)) - state)))))) + (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) + (|tail %)) + state)))))) (def get-scope-name (fn [state] - (return* state (->> state ($get-envs) (|map #($get-name %)) |reverse)))) + (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - ;; (prn 'with-writer writer body) - (let [output (body ($update-host #($set-writer (Some$ writer) %) state))] + (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* ($update-host #($set-writer (->> state ($get-host) ($get-writer)) %) ?state) + (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) ?value) _ @@ -806,11 +748,10 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - ;; (prn 'with-expected-type type state) - (let [output (body ($set-expected type state))] + (let [output (body (set$ $expected type state))] (|case output ($Right ?state ?value) - (return* ($set-expected ($get-expected state) ?state) + (return* (set$ $expected (get$ $expected state) ?state) ?value) _ @@ -818,20 +759,14 @@ (defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" - ;; (prn 'with-cursor/_0 (adt->text cursor)) (if (= "" (aget cursor 0)) body (fn [state] - (let [;; _ (prn 'with-cursor/_1 cursor) - state* ($set-cursor cursor state) - ;; _ (prn 'with-cursor/_2 state*) - output (body state*)] + (let [output (body (set$ $cursor cursor state))] (|case output ($Right ?state ?value) - (let [?state* ($set-cursor ($get-cursor state) ?state)] - ;; (prn 'with-cursor/_3 ?state*) - (return* ?state* - ?value)) + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) _ output))))) @@ -839,40 +774,40 @@ (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast - [_ ($BoolS ?value)] + ($Meta _ ($BoolS ?value)) (pr-str ?value) - [_ ($IntS ?value)] + ($Meta _ ($IntS ?value)) (pr-str ?value) - [_ ($RealS ?value)] + ($Meta _ ($RealS ?value)) (pr-str ?value) - [_ ($CharS ?value)] + ($Meta _ ($CharS ?value)) (pr-str ?value) - [_ ($TextS ?value)] + ($Meta _ ($TextS ?value)) (str "\"" ?value "\"") - [_ ($TagS ?module ?tag)] + ($Meta _ ($TagS ?module ?tag)) (str "#" ?module ";" ?tag) - [_ ($SymbolS ?module ?ident)] + ($Meta _ ($SymbolS ?module ?ident)) (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - [_ ($TupleS ?elems)] + ($Meta _ ($TupleS ?elems)) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [_ ($RecordS ?elems)] + ($Meta _ ($RecordS ?elems)) (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [_ ($FormS ?elems)] + ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") _ @@ -900,10 +835,10 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (Cons$ z zs))) + (return (|cons z zs))) [($Nil) ($Nil)] - (return Nil$) + (return (V $Nil nil)) [_ _] (fail "Lists don't match in size."))) @@ -911,10 +846,10 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (Cons$ (f x y) (map2 f xs* ys*)) + (|cons (f x y) (map2 f xs* ys*)) [_ _] - Nil$)) + (V $Nil nil))) (defn fold2 [f init xs ys] (|case [xs ys] @@ -932,8 +867,8 @@ "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) - (Cons$ (P idx x) - (enumerate* (inc idx) xs*)) + (V $Cons (T (T idx x) + (enumerate* (inc idx) xs*))) ($Nil) xs @@ -946,7 +881,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys ($get-modules state))))) + (return* state (|keys (get$ $modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -960,23 +895,23 @@ (|case xs ($Cons x xs*) (cond (< idx 0) - None$ + (V $None nil) (= idx 0) - (Some$ x) + (V $Some x) :else ;; > 1 (|at (dec idx) xs*)) ($Nil) - None$ + (V $None nil) )) (defn normalize [ident] "(-> Ident (Lux Ident))" (|case ident ["" name] (|do [module get-module-name] - (return (P module name))) + (return (T module name))) _ (return ident))) (defn ident= [x y] @@ -988,24 +923,12 @@ (defn |list-put [idx val xs] (|case xs ($Nil) - None$ + (V $None nil) ($Cons x xs*) (if (= idx 0) - (Some$ (Cons$ val xs*)) + (V $Some (V $Cons (T val xs*))) (|case (|list-put (dec idx) val xs*) - ($None) None$ - ($Some xs**) (Some$ (Cons$ x xs**))) + ($None) (V $None nil) + ($Some xs**) (V $Some (V $Cons (T x xs**)))) ))) - -(defn ensure-1 [m-value] - (|do [output m-value] - (|case output - ($Cons x ($Nil)) - (return x) - - _ - (fail "[Error] Can't expand to other than 1 element.")))) - -(defn cursor$ [file-name line-num column-num] - ($$ P file-name line-num column-num)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 4315ea75d..79d2c84f8 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -39,12 +39,8 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - ;; (prn 'compile-expression (&/adt->text syntax)) (|let [[?form ?type] syntax] (|case ?form - (&a/$unit) - (&&lux/compile-unit compile-expression ?type) - (&a/$bool ?value) (&&lux/compile-bool compile-expression ?type ?value) @@ -60,11 +56,8 @@ (&a/$text ?value) (&&lux/compile-text compile-expression ?type ?value) - (&a/$prod left right) - (&&lux/compile-prod compile-expression ?type left right) - - (&a/$sum tag value) - (&&lux/compile-sum compile-expression ?type tag value) + (&a/$tuple ?elems) + (&&lux/compile-tuple compile-expression ?type ?elems) (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -78,6 +71,9 @@ (&a/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) + (&a/$variant ?tag ?members) + (&&lux/compile-variant compile-expression ?type ?tag ?members) + (&a/$case ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) @@ -428,7 +424,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/$set-source (&reader/from file-name file-content) state)) + (&/set$ &/$source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports @@ -475,7 +471,7 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (|case ((&/map% compile-module (&/|list &/prelude-name program-module)) (&/init-state nil)) + (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index e327d1de4..1e5f3a024 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -76,33 +76,26 @@ _ (load-class! loader real-name)]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [^MethodVisitor writer] (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature ))))) + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature )))) + ;; (doto writer + ;; ;; X + ;; (.visitTypeInsn Opcodes/NEW ) ;; XW + ;; (.visitInsn ) ;; WXW + ;; (.visitInsn ) ;; WWXW + ;; (.visitInsn Opcodes/POP) ;; WWX + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "" ) ;; W + ;; ) + ) - wrap-boolean "java/lang/Boolean" "(Z)" - wrap-byte "java/lang/Byte" "(B)" - wrap-short "java/lang/Short" "(S)" - wrap-int "java/lang/Integer" "(I)" - wrap-long "java/lang/Long" "(J)" - wrap-float "java/lang/Float" "(F)" - wrap-double "java/lang/Double" "(D)" - wrap-char "java/lang/Character" "(C)" - ) - -(do-template [ ] - (defn [^MethodVisitor writer] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST ) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" )))) - - unwrap-boolean "java/lang/Boolean" "Z" "booleanValue" - unwrap-byte "java/lang/Byte" "B" "byteValue" - unwrap-short "java/lang/Short" "S" "shortValue" - unwrap-int "java/lang/Integer" "I" "intValue" - unwrap-long "java/lang/Long" "J" "longValue" - unwrap-float "java/lang/Float" "F" "floatValue" - unwrap-double "java/lang/Double" "D" "doubleValue" - unwrap-char "java/lang/Character" "C" "charValue" + wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 + wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 + wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 + wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 + wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 + wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 + wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 + wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 48b35c83a..dc224f52e 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/$get-modules) &/|keys &/->seq set) + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] @@ -120,7 +120,7 @@ ;; (prn '_group _group) (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] ;; (prn '[_type _tags] [_type _tags]) - (&/P _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) @@ -132,10 +132,10 @@ (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/S &/$TypeD def-value) &type/Type)) + (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/S &/$ValueD (&/P &type/Macro def-value)) &type/Macro)] + (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 0a928a056..dd3258059 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -11,7 +11,7 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -84,71 +84,63 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$UnitTestAC) + (&a-case/$TupleTestAC ?members) (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (-> (doto (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)) + (.visitInsn Opcodes/AALOAD) + (compile-match test $next $sub-else) + (.visitLabel $sub-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $next)) + (->> (|let [[idx test] idx+member + $next (new Label) + $sub-else (new Label)]) + (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$ProdTestAC left right) - (let [$post-left (new Label) - $post-right (new Label) - $pre-else (new Label)] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (compile-match left $post-left $pre-else) - (.visitLabel $post-left) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (compile-match right $post-right $pre-else) - (.visitLabel $post-right) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $pre-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else))) - - (&a-case/$SumTestAC ?tag ?count ?test) - (let [$value-then (new Label) - $pre-else (new Label)] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (&&/unwrap-int) - (.visitLdcInsn (int ?tag)) - (.visitJumpInsn Opcodes/IF_ICMPNE $else) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (compile-match ?test $value-then $pre-else) - (.visitLabel $value-then) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $pre-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else))) + (&a-case/$VariantTestAC ?tag ?count ?test) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitLdcInsn ?tag) + (&&/wrap-long) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (-> (doto (compile-match ?test $value-then $value-else) + (.visitLabel $value-then) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $value-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else)) + (->> (let [$value-then (new Label) + $value-else (new Label)])))) ))) (defn ^:private separate-bodies [patterns] (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body] - ($$ &/P (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) - ($$ &/P 0 (&/|table) (&/|table)) + (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) + (&/T 0 (&/|table) (&/|table)) patterns)] - (&/P mappings (&/|reverse patterns*)))) + (&/T mappings (&/|reverse patterns*)))) (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] - (&/P (&/P ?branch label) - (&/P label ?body)))) + (&/T (&/T ?branch label) + (&/T label ?body)))) mappings) mappings* (&/|map &/|first entries)] (doto writer diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index ead44085a..26ef73cb7 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - (&/$UnitT) + (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) (&/$DataT "boolean") @@ -421,14 +421,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -455,12 +455,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 10ee40839..83e294c1a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -28,43 +28,27 @@ ClassWriter MethodVisitor))) -;; [Utils] -(defn ^:private array-of [^MethodVisitor *writer* type-name size] - (do (doto *writer* - (.visitLdcInsn (int size)) - (.visitTypeInsn Opcodes/ANEWARRAY type-name)) - (return nil))) - -(defn ^:private store-at [^MethodVisitor *writer* compile idx value] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - _ (compile value) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - ;; [Exports] -(defn compile-unit [compile *type*] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] - (return nil))) - (defn compile-bool [compile *type* ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn value) - ())]] + :let [_ (try (doto *writer* + (.visitTypeInsn Opcodes/NEW ) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL "" )) + (catch Exception e + (assert false (prn-str ' (alength value) (aget value 0) (aget value 1)))))]] (return nil))) - compile-int &&/wrap-long - compile-real &&/wrap-double - compile-char &&/wrap-char + compile-int "java/lang/Long" "(J)V" long + compile-real "java/lang/Double" "(D)V" double + compile-char "java/lang/Character" "(C)V" char ) (defn compile-text [compile *type* ?value] @@ -72,28 +56,37 @@ :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-prod [compile *type* left right] - ;; (prn 'compile-prod (&type/show-type *type*) - ;; (&/adt->text left) - ;; (&/adt->text right)) +(defn compile-tuple [compile *type* ?elems] (|do [^MethodVisitor *writer* &/get-writer - _ (array-of *writer* "java/lang/Object" 2) - _ (store-at *writer* compile 0 left) - ;; :let [_ (prn 'compile-prod (&type/show-type *type*) left right)] - _ (store-at *writer* compile 1 right)] + :let [num-elems (&/|length ?elems) + _ (doto *writer* + (.visitLdcInsn (int num-elems)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx elem] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret))) + (&/|range num-elems) ?elems)] (return nil))) -(defn compile-sum [compile *type* ?tag ?value] +(defn compile-variant [compile *type* ?tag ?value] ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer - _ (array-of *writer* "java/lang/Object" 2) :let [_ (doto *writer* + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) - (.visitLdcInsn (int ?tag)) - (&&/wrap-int) - (.visitInsn Opcodes/AASTORE))] - _ (store-at *writer* compile 1 ?value)] + (.visitLdcInsn ?tag) + (&&/wrap-long) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)))] + _ (compile ?value) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) (defn compile-local [compile *type* ?idx] @@ -138,7 +131,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$TypeD) ;; VVIT - (&&/wrap-int) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -165,7 +158,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$ValueD) ;; VVIT - (&&/wrap-int) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index 50d8b0011..db73e8bb4 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -23,6 +23,6 @@ (return (&/|map (fn [pair] (|case pair [name [tags _]] - (&/P name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) - (&module/$get-types module))) + (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&/get$ &module/$types module))) )) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index cfaa9668b..7e2bc6961 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -9,86 +9,83 @@ (ns lux.compiler.type (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]) [lux.analyser.base :as &a])) ;; [Utils] -(def ^:private unit$ - "Analysis" - (&/P (&/S &a/$unit nil) - &type/$Void)) - -(defn ^:private sum$ [tag body] - "(-> Int Analysis Analysis)" - (&/P (&/S &a/$sum (&/P tag body)) +(defn ^:private variant$ [tag body] + "(-> Text Analysis Analysis)" + (&/T (&/V &a/$variant (&/T tag body)) &type/$Void)) -(defn ^:private prod$ [left right] - "(-> Analysis Analysis Analysis)" - (&/P (&/S &a/$prod (&/P left right)) +(defn ^:private tuple$ [members] + "(-> (List Analysis) Analysis)" + (&/T (&/V &a/$tuple members) &type/$Void)) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/P (&/S &a/$text text) + (&/T (&/V &a/$text text) &type/$Void)) (def ^:private $Nil "Analysis" - (sum$ &/$Nil unit$)) + (variant$ &/$Nil (tuple$ (&/|list)))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (sum$ &/$Cons (prod$ head tail))) + (variant$ &/$Cons (tuple$ (&/|list head tail)))) ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" (|case type (&/$DataT ?class) - (sum$ &/$DataT (text$ ?class)) + (variant$ &/$DataT (text$ ?class)) - (&/$ProdT left right) - (sum$ &/$ProdT - (prod$ (->analysis left) - (->analysis right))) + (&/$TupleT ?members) + (variant$ &/$TupleT + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) - (&/$SumT left right) - (sum$ &/$SumT - (prod$ (->analysis left) - (->analysis right))) + (&/$VariantT ?members) + (variant$ &/$VariantT + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) (&/$LambdaT ?input ?output) - (sum$ &/$LambdaT (prod$ (->analysis ?input) (->analysis ?output))) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) (&/$AllT ?env ?name ?arg ?body) - (sum$ &/$AllT - ($$ prod$ - (|case ?env - (&/$None) - (sum$ &/$None unit$) + (variant$ &/$AllT + (tuple$ (&/|list (|case ?env + (&/$None) + (variant$ &/$None (tuple$ (&/|list))) - (&/$Some ??env) - (sum$ &/$Some - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (prod$ (text$ hlabel) - (->analysis htype)) - tail))) - $Nil - (&/|reverse ??env)))) - (text$ ?name) - (text$ ?arg) - (->analysis ?body))) + (&/$Some ??env) + (variant$ &/$Some + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ??env)))) + (text$ ?name) + (text$ ?arg) + (->analysis ?body)))) (&/$BoundT ?name) - (sum$ &/$BoundT (text$ ?name)) + (variant$ &/$BoundT (text$ ?name)) (&/$AppT ?fun ?arg) - (sum$ &/$AppT (prod$ (->analysis ?fun) (->analysis ?arg))) + (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) (&/$NamedT [?module ?name] ?type) - (sum$ &/$NamedT (prod$ (prod$ (text$ ?module) (text$ ?name)) - (->analysis ?type))) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) + (->analysis ?type)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index d77e9b31c..dfd4df23d 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,8 +29,8 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/S &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) + (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base))) ))) (defn ^:private method->type [^Method method] @@ -76,7 +76,7 @@ (&/$LambdaT _ _) (->type-signature function-class) - (&/$VoidT) + (&/$TupleT (&/$Nil)) "V" (&/$NamedT ?name ?type) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 91693cc77..e848cc3fd 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -13,22 +13,22 @@ [lux.analyser.module :as &module])) ;; [Tags] -(deftags - ["White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace"] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" ) ;; [Utils] @@ -58,19 +58,19 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/P meta (&/S $White_Space white-space))))) + (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/P meta (&/S $Comment comment))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") ;; :let [_ (prn 'immediate comment)] _ (&reader/read-text ")#")] - (return (&/P meta comment))) + (return (&/T meta comment))) (|do [;; :let [_ (prn 'pre/_0)] [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") ;; :let [_ (prn 'pre pre)] @@ -79,10 +79,10 @@ [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] ] - (return (&/P meta (str pre "#(" inner ")#" post)))))) + (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/P meta (&/S $Comment comment))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -91,7 +91,7 @@ (do-template [ ] (def (|do [[meta token] (&reader/read-regex )] - (return (&/P meta (&/S token))))) + (return (&/V &/$Meta (&/T meta (&/V token)))))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" @@ -105,13 +105,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/P meta (&/S $Char token))))) + (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/P meta (&/S $Text token))))) + (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -119,35 +119,35 @@ [_ local-token] (&reader/read-regex +ident-re+) ? (&module/exists? token)] (if ? - (return (&/P meta (&/P token local-token))) + (return (&/T meta (&/T token local-token))) (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] + (&module/dealias token))] (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/P meta (&/P unaliased local-token))))))) - (return (&/P meta (&/P "" token))) + (return (&/T meta (&/T unaliased local-token))))))) + (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/P meta (&/P module-name token)))) + (return (&/T meta (&/T module-name token)))) (|do [[meta _] (&reader/read-text ";") [_ token] (&reader/read-regex +ident-re+)] - (return (&/P meta (&/P &/prelude-name token)))) + (return (&/T meta (&/T "lux" token)))) ))) (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/P meta (&/S $Symbol ident))))) + (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/P meta (&/S $Tag ident))))) + (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/P meta (&/S nil))))) + (return (&/V &/$Meta (&/T meta (&/V nil)))))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/parser.clj b/src/lux/parser.clj index c40221d63..eaa22db20 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -14,22 +14,22 @@ [lexer :as &lexer]))) ;; [Tags] -(deftags - ["White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace"] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" ) ;; [Utils] @@ -38,8 +38,8 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - [meta [ _]] - (return (&/S (&/fold &/|++ (&/|list) elems))) + (&/$Meta meta [ _]) + (return (&/V (&/fold &/|++ (&/|list) elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) @@ -53,9 +53,9 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - [meta ($Close_Brace _)] + (&/$Meta meta ($Close_Brace _)) (if (even? (&/|length elems)) - (return (&/S &/$RecordS (&/|as-pairs elems))) + (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -64,7 +64,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [[meta token*] token]] + :let [(&/$Meta meta token*) token]] (|case token* ($White_Space _) (return (&/|list)) @@ -73,37 +73,37 @@ (return (&/|list)) ($Bool ?value) - (return (&/|list (&/P meta (&/S &/$BoolS (Boolean/parseBoolean ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) ($Int ?value) - (return (&/|list (&/P meta (&/S &/$IntS (Long/parseLong ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) ($Real ?value) - (return (&/|list (&/P meta (&/S &/$RealS (Double/parseDouble ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) ($Char ^String ?value) - (return (&/|list (&/P meta (&/S &/$CharS (.charAt ?value 0))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) ($Text ?value) - (return (&/|list (&/P meta (&/S &/$TextS ?value)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) ($Symbol ?ident) - (return (&/|list (&/P meta (&/S &/$SymbolS ?ident)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) ($Tag ?ident) - (return (&/|list (&/P meta (&/S &/$TagS ?ident)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) ($Open_Paren _) (|do [syntax (parse-form parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ($Open_Bracket _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ($Open_Brace _) (|do [syntax (parse-record parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 24a0bf94d..e3f95b5f9 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,18 +10,18 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [deftags |do return* return fail fail* |let |case $$]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) ;; [Tags] -(deftags - ["No" - "Done" - "Yes"]) +(deftags "" + "No" + "Done" + "Yes") ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/$get-source state) + (|case (&/get$ &/$source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/$set-source more state) + (return* (&/set$ &/$source more state) output) ($Yes output line*) - (return* (&/$set-source (&/Cons$ line* more) state) + (return* (&/set$ &/$source (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/$get-source state)) + (|case (body (&/get$ &/$source state)) (&/$Right reader* match) - (return* (&/$set-source reader* state) + (return* (&/set$ &/$source reader* state) match) (&/$Left msg) @@ -85,10 +85,10 @@ match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) match)) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) match) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) match)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -98,10 +98,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2))) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2)) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -110,7 +110,7 @@ reader* reader] (|case reader* (&/$Nil) - (&/S &/$Left "[Reader Error] EOF") + (&/V &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] reader**) @@ -120,10 +120,10 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/S &/$Right (&/P (&/Cons$ (&/P (&/cursor$ file-name line-num column-num*) line) + (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) reader**) - (&/P (&/cursor$ file-name line-num column-num) (str prefix match)))))) - (&/S &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) + (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line @@ -133,10 +133,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) text)) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) text) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Text failed: " text)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) text)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] @@ -144,7 +144,7 @@ file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/P (&/cursor$ file-name (inc line-num) 0) + (&/T (&/T file-name (inc line-num) 0) line))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] diff --git a/src/lux/type.clj b/src/lux/type.clj index 37f3a99d4..9f3adb036 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -10,7 +10,7 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case $$]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) (declare show-type) @@ -26,300 +26,302 @@ _ false)) -(def ^:private empty-env (&/Some$ &/Nil$)) -(def ^:private no-env &/None$) -(def Ident$ &/P) +(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) +(def ^:private no-env (&/V &/$None nil)) (defn Data$ [name] - (&/S &/$DataT name)) + (&/V &/$DataT name)) (defn Bound$ [name] - (&/S &/$BoundT name)) + (&/V &/$BoundT name)) (defn Var$ [id] - (&/S &/$VarT id)) + (&/V &/$VarT id)) (defn Lambda$ [in out] - (&/S &/$LambdaT (&/P in out))) + (&/V &/$LambdaT (&/T in out))) (defn App$ [fun arg] - (&/S &/$AppT (&/P fun arg))) -(defn Prod$ [left right] + (&/V &/$AppT (&/T fun arg))) +(defn Tuple$ [members] ;; (assert (|list? members)) - (&/S &/$ProdT (&/P left right))) -(defn Sum$ [left right] + (&/V &/$TupleT members)) +(defn Variant$ [members] ;; (assert (|list? members)) - (&/S &/$SumT (&/P left right))) + (&/V &/$VariantT members)) (defn All$ [env name arg body] - (&/S &/$AllT ($$ &/P env name arg body))) + (&/V &/$AllT (&/T env name arg body))) (defn Named$ [name type] - (&/S &/$NamedT (&/P name type))) + (&/V &/$NamedT (&/T name type))) -(def Bool (Named$ (Ident$ &/prelude-name "Bool") (Data$ "java.lang.Boolean"))) -(def Int (Named$ (Ident$ &/prelude-name "Int") (Data$ "java.lang.Long"))) -(def Real (Named$ (Ident$ &/prelude-name "Real") (Data$ "java.lang.Double"))) -(def Char (Named$ (Ident$ &/prelude-name "Char") (Data$ "java.lang.Character"))) -(def Text (Named$ (Ident$ &/prelude-name "Text") (Data$ "java.lang.String"))) -(def Unit (Named$ (Ident$ &/prelude-name "Unit") (&/S &/$UnitT nil))) -(def $Void (Named$ (Ident$ &/prelude-name "Void") (&/S &/$VoidT nil))) -(def Ident (Named$ (Ident$ &/prelude-name "Ident") (Prod$ Text Text))) + +(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) +(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) +(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) +(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) +(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) +(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) +(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) +(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO - (Named$ (Ident$ "lux/data" "IO") + (Named$ (&/T "lux/data" "IO") (All$ empty-env "IO" "a" (Lambda$ Unit (Bound$ "a"))))) (def List - (Named$ (Ident$ &/prelude-name "List") + (Named$ (&/T "lux" "List") (All$ empty-env "lux;List" "a" - (Sum$ - ;; lux;Nil - Unit - ;; lux;Cons - (Prod$ (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a"))) - )))) + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + ))))) (def Maybe - (Named$ (Ident$ &/prelude-name "Maybe") + (Named$ (&/T "lux" "Maybe") (All$ empty-env "lux;Maybe" "a" - (Sum$ - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - )))) + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + ))))) (def Type - (Named$ (Ident$ &/prelude-name "Type") + (Named$ (&/T "lux" "Type") (let [Type (App$ (Bound$ "Type") (Bound$ "_")) TypeList (App$ List Type) - TypeEnv (App$ List (Prod$ Text Type)) - TypePair (Prod$ Type Type)] + TypeEnv (App$ List (Tuple$ (&/|list Text Type))) + TypePair (Tuple$ (&/|list Type Type))] (App$ (All$ empty-env "Type" "_" - ($$ Sum$ - ;; VoidT - Unit - ;; UnitT - Unit - ;; SumT - TypePair - ;; ProdT - TypePair - ;; DataT - Text - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - ($$ Prod$ (App$ Maybe TypeEnv) Text Text Type) - ;; AppT - TypePair - ;; NamedT - (Prod$ Ident Type) - )) + (Variant$ (&/|list + ;; DataT + Text + ;; VariantT + TypeList + ;; TupleT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + ;; NamedT + (Tuple$ (&/|list Ident Type)) + ))) $Void)))) (def Bindings - (Named$ (Ident$ &/prelude-name "Bindings") + (Named$ (&/T "lux" "Bindings") (All$ empty-env "lux;Bindings" "k" (All$ no-env "" "v" - (Prod$ - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Prod$ (Bound$ "k") - (Bound$ "v")))))))) + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v")))))))))) (def Env - (Named$ (Ident$ &/prelude-name "Env") + (Named$ (&/T "lux" "Env") (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" (All$ no-env "" "v" - ($$ Prod$ - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - )))))) + (Tuple$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + ))))))) (def Cursor - (Named$ (Ident$ &/prelude-name "Cursor") - ($$ Prod$ Text Int Int))) + (Named$ (&/T "lux" "Cursor") + (Tuple$ (&/|list Text Int Int)))) (def Meta - (Named$ (Ident$ &/prelude-name "Meta") + (Named$ (&/T "lux" "Meta") (All$ empty-env "lux;Meta" "m" (All$ no-env "" "v" - (Prod$ (Bound$ "m") - (Bound$ "v")))))) + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ "m") + (Bound$ "v"))))))))) (def AST* - (Named$ (Ident$ &/prelude-name "AST'") + (Named$ (&/T "lux" "AST'") (let [AST* (App$ (Bound$ "w") (App$ (Bound$ "lux;AST'") (Bound$ "w"))) AST*List (App$ List AST*)] (All$ empty-env "lux;AST'" "w" - ($$ Sum$ - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Prod$ AST* AST*)) - ))))) + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + ))))) (def AST - (Named$ (Ident$ &/prelude-name "AST") + (Named$ (&/T "lux" "AST") (let [w (App$ Meta Cursor)] (App$ w (App$ AST* w))))) (def ^:private ASTList (App$ List AST)) (def Either - (Named$ (Ident$ &/prelude-name "Either") + (Named$ (&/T "lux" "Either") (All$ empty-env "lux;Either" "l" (All$ no-env "" "r" - (Sum$ - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r")))))) + (Variant$ (&/|list + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r"))))))) (def StateE (All$ empty-env "lux;StateE" "s" (All$ no-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) - (Prod$ (Bound$ "s") - (Bound$ "a"))))))) + (Tuple$ (&/|list (Bound$ "s") + (Bound$ "a")))))))) (def Source - (Named$ (Ident$ &/prelude-name "Source") + (Named$ (&/T "lux" "Source") (App$ List (App$ (App$ Meta Cursor) Text)))) (def Host - (Named$ (Ident$ &/prelude-name "Host") - ($$ Prod$ - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") - ;; "lux;loader" - (Data$ "java.lang.ClassLoader") - ;; "lux;classes" - (Data$ "clojure.lang.Atom")))) + (Named$ (&/T "lux" "Host") + (Tuple$ + (&/|list + ;; "lux;writer" + (Data$ "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (Data$ "java.lang.ClassLoader") + ;; "lux;classes" + (Data$ "clojure.lang.Atom"))))) (def DefData* (All$ empty-env "lux;DefData'" "" - ($$ Sum$ - ;; "lux;ValueD" - (Prod$ Type Unit) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ "") - ;; "lux;AliasD" - Ident - ))) + (Variant$ (&/|list + ;; "lux;ValueD" + (Tuple$ (&/|list Type Unit)) + ;; "lux;TypeD" + Type + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + )))) (def LuxVar - (Named$ (Ident$ &/prelude-name "LuxVar") - (Sum$ - ;; "lux;Local" - Int - ;; "lux;Global" - Ident))) + (Named$ (&/T "lux" "LuxVar") + (Variant$ (&/|list + ;; "lux;Local" + Int + ;; "lux;Global" + Ident)))) (def $Module (All$ empty-env "lux;$Module" "Compiler" - ($$ Prod$ - ;; "lux;module-aliases" - (App$ List (Prod$ Text Text)) - ;; "lux;defs" - (App$ List - (Prod$ Text - (Prod$ Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Prod$ Text - ($$ Prod$ Int - (App$ List Ident) - Type))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Prod$ Text - (Prod$ (App$ List Ident) - Type))) - ))) + (Tuple$ + (&/|list + ;; "lux;module-aliases" + (App$ List (Tuple$ (&/|list Text Text))) + ;; "lux;defs" + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (, Int (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Int + (App$ List Ident) + Type))))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list (App$ List Ident) + Type))))) + )))) (def $Compiler - (Named$ (Ident$ &/prelude-name "Compiler") + (Named$ (&/T "lux" "Compiler") (App$ (All$ empty-env "lux;Compiler" "" - ($$ Prod$ - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Prod$ Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Prod$ LuxVar Type))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - )) + (Tuple$ + (&/|list + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + ))) $Void))) (def Macro - (Named$ (Ident$ &/prelude-name "Macro") + (Named$ (&/T "lux" "Macro") (Lambda$ ASTList (App$ (App$ StateE $Compiler) ASTList)))) (defn bound? [id] (fn [state] - (if-let [type (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -330,7 +332,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -341,37 +343,32 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/$update-type-vars (fn [ts] (&/$update-mappings #(&/|put id (&/Some$ type) %) - ts)) - state) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) + ts)) + state) nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/$get-type-vars) (&/$get-mappings) &/|length)))))) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state &/$get-type-vars &/$get-counter)] - (return* (&/$update-type-vars #(do ;; (prn 'create-var/_0 (&/adt->text %)) - ;; (prn 'create-var/_1 (&/adt->text (->> % (&/$update-counter inc)))) - ;; (prn 'create-var/_2 (&/adt->text (->> % - ;; (&/$update-counter inc) - ;; (&/$update-mappings (fn [ms] (&/|put id &/None$ ms)))))) - (->> % - (&/$update-counter inc) - (&/$update-mappings (fn [ms] (&/|put id &/None$ ms))))) - state) + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + state) id)))) (def existential (|do [seed &/gen-id] - (return (&/S &/$ExT seed)))) + (return (&/V &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -393,19 +390,19 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/P ?id &/None$)) + (return (&/T ?id (&/V &/$None nil))) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/P ?id (&/Some$ ?type**))))) + (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/$get-type-vars) (&/$get-mappings)))] + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/$update-type-vars #(->> % - (&/$update-counter dec) - (&/$set-mappings (&/|remove id mappings*))) - state) + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) + state) nil))) state)))) @@ -438,15 +435,13 @@ =param (clean* ?tid ?param)] (return (App$ =lambda =param))) - (&/$SumT ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (Sum$ =left =right))) - - (&/$ProdT ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (Prod$ =left =right))) + (&/$TupleT ?members) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Tuple$ =members))) + + (&/$VariantT ?members) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Variant$ =members))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -456,9 +451,9 @@ (&/$Some ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] - (return (&/P k =v)))) + (return (&/T k =v)))) ?env*)] - (return (&/Some$ clean-env)))) + (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] (return (All$ =env ?name ?arg body*))) @@ -478,36 +473,37 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/P ??out (&/Cons$ ?in ?args))) + (&/T ??out (&/|cons ?in ?args))) _ - (&/P type (&/|list)))) + (&/T type (&/|list)))) (defn ^:private unravel-app [fun-type] (|case fun-type (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] - (&/P ?fun-type (&/|++ ?args (&/|list ?right)))) + (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) _ - (&/P fun-type (&/|list)))) + (&/T fun-type (&/|list)))) (defn show-type [^objects type] (|case type - (&/$VoidT) - "(|)" - - (&/$UnitT) - "(,)" - (&/$DataT name) (str "(^ " name ")") - (&/$ProdT left right) - (str "(, " (show-type left) " " (show-type right) ")") - - (&/$SumT left right) - (str "(| " (show-type left) " " (show-type right) ")") + (&/$TupleT elems) + (if (&/|empty? elems) + "(,)" + (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$VariantT cases) + (if (&/|empty? cases) + "(|)" + (str "(| " (->> cases + (&/|map show-type) + (&/|interpose " ") + (&/fold str "")) ")")) (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] @@ -548,22 +544,18 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] - [(&/$UnitT) (&/$UnitT)] - true - - [(&/$VoidT) (&/$VoidT)] - true - [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [(&/$ProdT xleft xright) (&/$ProdT yleft yright)] - (and (type= xleft yleft) - (type= xright yright)) + [(&/$TupleT xelems) (&/$TupleT yelems)] + (&/fold2 (fn [old x y] (and old (type= x y))) + true + xelems yelems) - [(&/$SumT xleft xright) (&/$SumT yleft yright)] - (and (type= xleft yleft) - (type= xright yright)) + [(&/$VariantT xcases) (&/$VariantT ycases)] + (&/fold2 (fn [old x y] (and old (type= x y))) + true + xcases ycases) [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) @@ -615,17 +607,17 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - &/None$ + (&/V &/$None nil) (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/Some$ v*) + (&/V &/$Some v*) (fp-get k fixpoints*)) ))) (defn ^:private fp-put [k v fixpoints] - (&/Cons$ (&/P k v) fixpoints)) + (&/|cons (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) @@ -634,11 +626,11 @@ (defn beta-reduce [env type] (|case type - (&/$SumT ?left ?right) - (Sum$ (beta-reduce env ?left) (beta-reduce env ?right)) + (&/$VariantT ?members) + (Variant$ (&/|map (partial beta-reduce env) ?members)) - (&/$ProdT ?left ?right) - (Prod$ (beta-reduce env ?left) (beta-reduce env ?right)) + (&/$TupleT ?members) + (Tuple$ (&/|map (partial beta-reduce env) ?members)) (&/$AppT ?type-fn ?type-arg) (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -646,7 +638,7 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (All$ (&/Some$ env) ?local-name ?local-arg ?local-def) + (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) (&/$Some _) type) @@ -685,7 +677,7 @@ (apply-type ?type param) _ - (fail (str "[Type Error] Not a type function:\n" (show-type type-fn) "\n")))) + (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] (case class @@ -705,35 +697,30 @@ (def ^:private init-fixpoints (&/|list)) (defn ^:private check* [class-loader fixpoints expected actual] - ;; (prn 'check*/_0 (&/adt->text expected) (&/adt->text actual)) - ;; (prn 'check*/_1 (show-type expected) (show-type actual)) (if (clojure.lang.Util/identical expected actual) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (|case [expected actual] - [(&/$UnitT) (&/$UnitT)] - (return (&/P fixpoints nil)) - [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (|do [ebound (fn [state] (|case ((deref ?eid) state) (&/$Right state* ebound) - (return* state* (&/Some$ ebound)) + (return* state* (&/V &/$Some ebound)) (&/$Left _) - (return* state &/None$))) + (return* state (&/V &/$None nil)))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) - (return* state* (&/Some$ abound)) + (return* state* (&/V &/$Some abound)) (&/$Left _) - (return* state &/None$)))] + (return* state (&/V &/$None nil))))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] - (return (&/P fixpoints nil))) + (return (&/T fixpoints nil))) [(&/$Some etype) (&/$None _)] (check* class-loader fixpoints etype actual) @@ -748,7 +735,7 @@ (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) - (return* state* (&/P fixpoints nil)) + (return* state* (&/T fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -759,7 +746,7 @@ (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) - (return* state* (&/P fixpoints nil)) + (return* state* (&/T fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -770,9 +757,9 @@ (fn [state] (|case ((|do [F1 (deref ?eid)] (fn [state] - (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state) + (|case [((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state)] (&/$Right state* output) (return* state* output) @@ -793,11 +780,11 @@ (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/P fixpoints** nil))) + (return (&/T fixpoints** nil))) state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] - ;; (return (&/P fixpoints nil))) + ;; (return (&/T fixpoints nil))) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] @@ -812,14 +799,14 @@ e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/P fixpoints** nil))) + (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/P fixpoints** nil))) + ;; (return (&/T fixpoints** nil))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] @@ -834,22 +821,22 @@ e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/P fixpoints** nil))) + (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/P fixpoints** nil))) + ;; (return (&/T fixpoints** nil))) [(&/$AppT F A) _] - (let [fp-pair (&/P expected actual) + (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] (|let [[e a] pair] - (str (show-type e) " :+: " + (str (show-type e) ":+:" (show-type a))))) (&/|interpose "\n\n") (&/fold str ""))) @@ -857,7 +844,7 @@ (|case (fp-get fp-pair fixpoints) (&/$Some ?) (if ? - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (check-error expected actual))) (&/$None) @@ -883,33 +870,39 @@ [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/P fixpoints nil))) + (return (&/T fixpoints nil))) [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [(&/$ProdT e!left e!right) (&/$ProdT a!left a!right)] - (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) - [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] - (return (&/P fixpoints** nil))) + [(&/$TupleT e!members) (&/$TupleT a!members)] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) + fixpoints + e!members a!members)] + (return (&/T fixpoints* nil))) - [(&/$SumT e!left e!right) (&/$SumT a!left a!right)] - (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) - [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] - (return (&/P fixpoints** nil))) + [(&/$VariantT e!cases) (&/$VariantT a!cases)] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) + fixpoints + e!cases a!cases)] + (return (&/T fixpoints* nil))) [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (check-error expected actual))) [(&/$NamedT ?ename ?etype) _] @@ -918,9 +911,6 @@ [_ (&/$NamedT ?aname ?atype)] (check* class-loader fixpoints expected ?atype) - [_ (&/$VoidT)] - (return (&/P fixpoints nil)) - [_ _] (fail (check-error expected actual)) ))) @@ -947,7 +937,7 @@ (apply-lambda ?type param) _ - (fail (str "[Type Error] Not a function type:\n" (show-type func) "\n")) + (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] @@ -968,31 +958,20 @@ )) (defn variant-case [tag type] - ;; (prn 'variant-case tag (show-type type)) (|case type (&/$NamedT ?name ?type) (variant-case tag ?type) - (&/$SumT ?left ?right) - (case tag - 0 - (return ?left) - - 1 - (|case ?right - (&/$SumT ?left* _) - (return ?left*) - - _ - (return ?right)) + (&/$VariantT ?cases) + (|case (&/|at tag ?cases) + (&/$Some case-type) + (return case-type) - ;; else - (variant-case (dec tag) ?right)) + (&/$None) + (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) _ - (fail (str "[Type Error] Type is not a variant: " (show-type type))) - ;; (assert false (str "[Type Error] Type is not a variant: " (show-type type))) - )) + (fail (str "[Type Error] Type is not a variant: " (show-type type))))) (defn type-name [type] "(-> Type (Lux Ident))" -- cgit v1.2.3 From d916be54994c8266f005744f7c3a61a36a39e31d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 07:01:33 -0400 Subject: Changed the license from EPL to MPL. --- README.md | 2 +- epl-v10.html | 261 ---------------------------- license.txt | 374 ++++++++++++++++++++++++++++++++++++++++ source/lux.lux | 11 +- source/lux/codata/function.lux | 11 +- source/lux/codata/lazy.lux | 11 +- source/lux/codata/reader.lux | 11 +- source/lux/codata/state.lux | 11 +- source/lux/codata/stream.lux | 11 +- source/lux/control/bounded.lux | 11 +- source/lux/control/comonad.lux | 11 +- source/lux/control/dict.lux | 11 +- source/lux/control/eq.lux | 11 +- source/lux/control/functor.lux | 11 +- source/lux/control/hash.lux | 11 +- source/lux/control/monad.lux | 11 +- source/lux/control/monoid.lux | 11 +- source/lux/control/number.lux | 11 +- source/lux/control/ord.lux | 11 +- source/lux/control/show.lux | 11 +- source/lux/control/stack.lux | 11 +- source/lux/data/bool.lux | 11 +- source/lux/data/char.lux | 11 +- source/lux/data/cont.lux | 11 +- source/lux/data/either.lux | 11 +- source/lux/data/error.lux | 11 +- source/lux/data/id.lux | 11 +- source/lux/data/io.lux | 11 +- source/lux/data/list.lux | 11 +- source/lux/data/maybe.lux | 11 +- source/lux/data/number/int.lux | 11 +- source/lux/data/number/real.lux | 11 +- source/lux/data/text.lux | 11 +- source/lux/data/tuple.lux | 11 +- source/lux/data/writer.lux | 11 +- source/lux/host/jvm.lux | 11 +- source/lux/math.lux | 11 +- source/lux/meta/ast.lux | 11 +- source/lux/meta/lux.lux | 11 +- source/lux/meta/macro.lux | 11 +- source/lux/meta/syntax.lux | 11 +- source/program.lux | 11 +- src/lux.clj | 11 +- src/lux/analyser.clj | 11 +- src/lux/analyser/base.clj | 11 +- src/lux/analyser/case.clj | 11 +- src/lux/analyser/env.clj | 11 +- src/lux/analyser/host.clj | 11 +- src/lux/analyser/lambda.clj | 11 +- src/lux/analyser/lux.clj | 11 +- src/lux/analyser/module.clj | 11 +- src/lux/analyser/record.clj | 11 +- src/lux/base.clj | 11 +- src/lux/compiler.clj | 11 +- src/lux/compiler/base.clj | 11 +- src/lux/compiler/cache.clj | 11 +- src/lux/compiler/case.clj | 11 +- src/lux/compiler/host.clj | 11 +- src/lux/compiler/io.clj | 11 +- src/lux/compiler/lambda.clj | 11 +- src/lux/compiler/lux.clj | 11 +- src/lux/compiler/module.clj | 11 +- src/lux/compiler/package.clj | 11 +- src/lux/compiler/type.clj | 11 +- src/lux/host.clj | 11 +- src/lux/lexer.clj | 11 +- src/lux/optimizer.clj | 11 +- src/lux/parser.clj | 11 +- src/lux/reader.clj | 11 +- src/lux/type.clj | 11 +- 70 files changed, 643 insertions(+), 731 deletions(-) delete mode 100644 epl-v10.html create mode 100644 license.txt diff --git a/README.md b/README.md index 0c0b4e5c8..f408af009 100644 --- a/README.md +++ b/README.md @@ -36,7 +36,7 @@ Then, you can run the program like this: ### What's the license? -Eclipse Public License v1.0 +Mozilla Public License v2.0 ## What's interesting about the language? diff --git a/epl-v10.html b/epl-v10.html deleted file mode 100644 index 813c07d8c..000000000 --- a/epl-v10.html +++ /dev/null @@ -1,261 +0,0 @@ - - - - - - -Eclipse Public License - Version 1.0 - - - - - - -

Eclipse Public License - v 1.0

- -

THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE -PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR -DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS -AGREEMENT.

- -

1. DEFINITIONS

- -

"Contribution" means:

- -

a) in the case of the initial Contributor, the initial -code and documentation distributed under this Agreement, and

-

b) in the case of each subsequent Contributor:

-

i) changes to the Program, and

-

ii) additions to the Program;

-

where such changes and/or additions to the Program -originate from and are distributed by that particular Contributor. A -Contribution 'originates' from a Contributor if it was added to the -Program by such Contributor itself or anyone acting on such -Contributor's behalf. Contributions do not include additions to the -Program which: (i) are separate modules of software distributed in -conjunction with the Program under their own license agreement, and (ii) -are not derivative works of the Program.

- -

"Contributor" means any person or entity that distributes -the Program.

- -

"Licensed Patents" mean patent claims licensable by a -Contributor which are necessarily infringed by the use or sale of its -Contribution alone or when combined with the Program.

- -

"Program" means the Contributions distributed in accordance -with this Agreement.

- -

"Recipient" means anyone who receives the Program under -this Agreement, including all Contributors.

- -

2. GRANT OF RIGHTS

- -

a) Subject to the terms of this Agreement, each -Contributor hereby grants Recipient a non-exclusive, worldwide, -royalty-free copyright license to reproduce, prepare derivative works -of, publicly display, publicly perform, distribute and sublicense the -Contribution of such Contributor, if any, and such derivative works, in -source code and object code form.

- -

b) Subject to the terms of this Agreement, each -Contributor hereby grants Recipient a non-exclusive, worldwide, -royalty-free patent license under Licensed Patents to make, use, sell, -offer to sell, import and otherwise transfer the Contribution of such -Contributor, if any, in source code and object code form. This patent -license shall apply to the combination of the Contribution and the -Program if, at the time the Contribution is added by the Contributor, -such addition of the Contribution causes such combination to be covered -by the Licensed Patents. The patent license shall not apply to any other -combinations which include the Contribution. No hardware per se is -licensed hereunder.

- -

c) Recipient understands that although each Contributor -grants the licenses to its Contributions set forth herein, no assurances -are provided by any Contributor that the Program does not infringe the -patent or other intellectual property rights of any other entity. Each -Contributor disclaims any liability to Recipient for claims brought by -any other entity based on infringement of intellectual property rights -or otherwise. As a condition to exercising the rights and licenses -granted hereunder, each Recipient hereby assumes sole responsibility to -secure any other intellectual property rights needed, if any. For -example, if a third party patent license is required to allow Recipient -to distribute the Program, it is Recipient's responsibility to acquire -that license before distributing the Program.

- -

d) Each Contributor represents that to its knowledge it -has sufficient copyright rights in its Contribution, if any, to grant -the copyright license set forth in this Agreement.

- -

3. REQUIREMENTS

- -

A Contributor may choose to distribute the Program in object code -form under its own license agreement, provided that:

- -

a) it complies with the terms and conditions of this -Agreement; and

- -

b) its license agreement:

- -

i) effectively disclaims on behalf of all Contributors -all warranties and conditions, express and implied, including warranties -or conditions of title and non-infringement, and implied warranties or -conditions of merchantability and fitness for a particular purpose;

- -

ii) effectively excludes on behalf of all Contributors -all liability for damages, including direct, indirect, special, -incidental and consequential damages, such as lost profits;

- -

iii) states that any provisions which differ from this -Agreement are offered by that Contributor alone and not by any other -party; and

- -

iv) states that source code for the Program is available -from such Contributor, and informs licensees how to obtain it in a -reasonable manner on or through a medium customarily used for software -exchange.

- -

When the Program is made available in source code form:

- -

a) it must be made available under this Agreement; and

- -

b) a copy of this Agreement must be included with each -copy of the Program.

- -

Contributors may not remove or alter any copyright notices contained -within the Program.

- -

Each Contributor must identify itself as the originator of its -Contribution, if any, in a manner that reasonably allows subsequent -Recipients to identify the originator of the Contribution.

- -

4. COMMERCIAL DISTRIBUTION

- -

Commercial distributors of software may accept certain -responsibilities with respect to end users, business partners and the -like. While this license is intended to facilitate the commercial use of -the Program, the Contributor who includes the Program in a commercial -product offering should do so in a manner which does not create -potential liability for other Contributors. Therefore, if a Contributor -includes the Program in a commercial product offering, such Contributor -("Commercial Contributor") hereby agrees to defend and -indemnify every other Contributor ("Indemnified Contributor") -against any losses, damages and costs (collectively "Losses") -arising from claims, lawsuits and other legal actions brought by a third -party against the Indemnified Contributor to the extent caused by the -acts or omissions of such Commercial Contributor in connection with its -distribution of the Program in a commercial product offering. The -obligations in this section do not apply to any claims or Losses -relating to any actual or alleged intellectual property infringement. In -order to qualify, an Indemnified Contributor must: a) promptly notify -the Commercial Contributor in writing of such claim, and b) allow the -Commercial Contributor to control, and cooperate with the Commercial -Contributor in, the defense and any related settlement negotiations. The -Indemnified Contributor may participate in any such claim at its own -expense.

- -

For example, a Contributor might include the Program in a commercial -product offering, Product X. That Contributor is then a Commercial -Contributor. If that Commercial Contributor then makes performance -claims, or offers warranties related to Product X, those performance -claims and warranties are such Commercial Contributor's responsibility -alone. Under this section, the Commercial Contributor would have to -defend claims against the other Contributors related to those -performance claims and warranties, and if a court requires any other -Contributor to pay any damages as a result, the Commercial Contributor -must pay those damages.

- -

5. NO WARRANTY

- -

EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS -PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS -OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, -ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY -OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely -responsible for determining the appropriateness of using and -distributing the Program and assumes all risks associated with its -exercise of rights under this Agreement , including but not limited to -the risks and costs of program errors, compliance with applicable laws, -damage to or loss of data, programs or equipment, and unavailability or -interruption of operations.

- -

6. DISCLAIMER OF LIABILITY

- -

EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT -NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING -WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR -DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED -HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

- -

7. GENERAL

- -

If any provision of this Agreement is invalid or unenforceable under -applicable law, it shall not affect the validity or enforceability of -the remainder of the terms of this Agreement, and without further action -by the parties hereto, such provision shall be reformed to the minimum -extent necessary to make such provision valid and enforceable.

- -

If Recipient institutes patent litigation against any entity -(including a cross-claim or counterclaim in a lawsuit) alleging that the -Program itself (excluding combinations of the Program with other -software or hardware) infringes such Recipient's patent(s), then such -Recipient's rights granted under Section 2(b) shall terminate as of the -date such litigation is filed.

- -

All Recipient's rights under this Agreement shall terminate if it -fails to comply with any of the material terms or conditions of this -Agreement and does not cure such failure in a reasonable period of time -after becoming aware of such noncompliance. If all Recipient's rights -under this Agreement terminate, Recipient agrees to cease use and -distribution of the Program as soon as reasonably practicable. However, -Recipient's obligations under this Agreement and any licenses granted by -Recipient relating to the Program shall continue and survive.

- -

Everyone is permitted to copy and distribute copies of this -Agreement, but in order to avoid inconsistency the Agreement is -copyrighted and may only be modified in the following manner. The -Agreement Steward reserves the right to publish new versions (including -revisions) of this Agreement from time to time. No one other than the -Agreement Steward has the right to modify this Agreement. The Eclipse -Foundation is the initial Agreement Steward. The Eclipse Foundation may -assign the responsibility to serve as the Agreement Steward to a -suitable separate entity. Each new version of the Agreement will be -given a distinguishing version number. The Program (including -Contributions) may always be distributed subject to the version of the -Agreement under which it was received. In addition, after a new version -of the Agreement is published, Contributor may elect to distribute the -Program (including its Contributions) under the new version. Except as -expressly stated in Sections 2(a) and 2(b) above, Recipient receives no -rights or licenses to the intellectual property of any Contributor under -this Agreement, whether expressly, by implication, estoppel or -otherwise. All rights in the Program not expressly granted under this -Agreement are reserved.

- -

This Agreement is governed by the laws of the State of New York and -the intellectual property laws of the United States of America. No party -to this Agreement will bring a legal action under this Agreement more -than one year after the cause of action arose. Each party waives its -rights to a jury trial in any resulting litigation.

- - - - diff --git a/license.txt b/license.txt new file mode 100644 index 000000000..52d135112 --- /dev/null +++ b/license.txt @@ -0,0 +1,374 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. + diff --git a/source/lux.lux b/source/lux.lux index 4120b262c..7acb5222a 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. ## First things first, must define functions (_jvm_interface "Function" [] diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux index 7898e998d..ea79ff9ad 100644 --- a/source/lux/codata/function.lux +++ b/source/lux/codata/function.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (monoid #as m))) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index 893c74d9e..9c72fdb16 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (meta macro diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux index e91687c3a..56b3e0286 100644 --- a/source/lux/codata/reader.lux +++ b/source/lux/codata/reader.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import (lux #refer (#exclude Reader)) (lux/control (functor #as F #refer #all) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index bc9858a29..d85ef3dbc 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (functor #as F #refer #all) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 64491eb5c..956bc6994 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (control (functor #as F #refer #all) diff --git a/source/lux/control/bounded.lux b/source/lux/control/bounded.lux index 9d2dabde1..b4c8a3e57 100644 --- a/source/lux/control/bounded.lux +++ b/source/lux/control/bounded.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index e82d079f6..6225af338 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (../functor #as F) diff --git a/source/lux/control/dict.lux b/source/lux/control/dict.lux index 3089ec927..0b2069cf3 100644 --- a/source/lux/control/dict.lux +++ b/source/lux/control/dict.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/control/eq.lux b/source/lux/control/eq.lux index be3400208..d86df5757 100644 --- a/source/lux/control/eq.lux +++ b/source/lux/control/eq.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/control/functor.lux b/source/lux/control/functor.lux index 6a9dcfff8..99c34a45c 100644 --- a/source/lux/control/functor.lux +++ b/source/lux/control/functor.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux index bfb8e99c0..643c49e9d 100644 --- a/source/lux/control/hash.lux +++ b/source/lux/control/hash.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index c87c4fdc3..707bf7497 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (.. (functor #as F) diff --git a/source/lux/control/monoid.lux b/source/lux/control/monoid.lux index d32baabc5..447ab8225 100644 --- a/source/lux/control/monoid.lux +++ b/source/lux/control/monoid.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/control/number.lux b/source/lux/control/number.lux index 40906a8a8..b1bbec190 100644 --- a/source/lux/control/number.lux +++ b/source/lux/control/number.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (monoid #as m) diff --git a/source/lux/control/ord.lux b/source/lux/control/ord.lux index 80f2e4fb5..987356d22 100644 --- a/source/lux/control/ord.lux +++ b/source/lux/control/ord.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (../eq #as E)) diff --git a/source/lux/control/show.lux b/source/lux/control/show.lux index adb5f911e..706819ec2 100644 --- a/source/lux/control/show.lux +++ b/source/lux/control/show.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/control/stack.lux b/source/lux/control/stack.lux index 1e5d086c5..206ab5cd7 100644 --- a/source/lux/control/stack.lux +++ b/source/lux/control/stack.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index 92f5486ef..29de09328 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (control (monoid #as m) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index b97ec644d..e6e796123 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (eq #as E) diff --git a/source/lux/data/cont.lux b/source/lux/data/cont.lux index 51c6ece87..2c55eb641 100644 --- a/source/lux/data/cont.lux +++ b/source/lux/data/cont.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (functor #as F #refer #all) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux index eba6438db..a945c32b9 100644 --- a/source/lux/data/either.lux +++ b/source/lux/data/either.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/data (list #refer (#exclude partition)))) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux index cb5c309a6..9c595144b 100644 --- a/source/lux/data/error.lux +++ b/source/lux/data/error.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (functor #as F #refer #all) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 3ad6b056b..e06a24f94 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (functor #as F #refer #all) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index f03dbddc6..144410f5c 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (meta macro diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 5a8357251..a4a6a6d0e 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (control (monoid #as m #refer #all) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index 9405c3a60..bb4eee6df 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (meta macro diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index 35c8d34bf..cc327ad0c 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (number #as N) diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux index 4f9e4fa5f..27f1bf7b0 100644 --- a/source/lux/data/number/real.lux +++ b/source/lux/data/number/real.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (number #as N) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index d1c06b6a7..3801e9675 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (meta macro diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux index 5220ad4ac..f89f9b5ee 100644 --- a/source/lux/data/tuple.lux +++ b/source/lux/data/tuple.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux index f71492e35..316e1fbcc 100644 --- a/source/lux/data/writer.lux +++ b/source/lux/data/writer.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux/control (monoid #as m #refer #all) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 4f3d6df8a..9795965bd 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (control (monoid #as m) diff --git a/source/lux/math.lux b/source/lux/math.lux index a495d130c..f6fad566f 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index f01f08af1..ecf7d6e6e 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 057345622..8a0ec5f46 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (.. macro diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux index 15f3582fa..bfc274e59 100644 --- a/source/lux/meta/macro.lux +++ b/source/lux/meta/macro.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index b9834f972..c7f691389 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (.. (macro #as m #refer #all) diff --git a/source/program.lux b/source/program.lux index 02ec633fb..716e3e6c6 100644 --- a/source/program.lux +++ b/source/program.lux @@ -1,10 +1,7 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## The use and distribution terms for this software are covered by the -## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -## which can be found in the file epl-v10.html at the root of this distribution. -## By using this software in any fashion, you are agreeing to be bound by -## the terms of this license. -## You must not remove this notice, or any other, from this software. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux (lux (control monoid diff --git a/src/lux.clj b/src/lux.clj index 7e3627cd7..03d09ebba 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux (:gen-class) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8c88328f5..7e5024c40 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser (:require (clojure [template :refer [do-template]]) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index fe1e0d55b..8c52748d7 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.base (:require clojure.core.match diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 483002adc..5987cbdf7 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.case (:require clojure.core.match diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 4e9dcd79f..666807586 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.env (:require clojure.core.match diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 64f297994..8ccfc5ace 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.host (:require (clojure [template :refer [do-template]]) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index aeb5a4814..819f07583 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.lambda (:require clojure.core.match diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index d241201f4..634769839 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index d23953f5e..77630bafe 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.module (:refer-clojure :exclude [alias]) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 2b4b7e095..c6bfb0053 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.record (:require clojure.core.match diff --git a/src/lux/base.clj b/src/lux/base.clj index 6247524af..44459beb4 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.base (:require (clojure [template :refer [do-template]]) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 79d2c84f8..b8ffa825f 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler (:refer-clojure :exclude [compile]) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 1e5f3a024..b6efaada8 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.base (:require (clojure [template :refer [do-template]] diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index dc224f52e..da7ce35e9 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.cache (:refer-clojure :exclude [load]) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index dd3258059..5f9d6cd2d 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.case (:require (clojure [set :as set] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 26ef73cb7..0529ac900 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.host (:require (clojure [string :as string] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index 0e7982a7f..e72f34a7b 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.io (:require (lux [base :as & :refer [|let |do return* return fail fail*]]) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 136ec0cfc..8fefab156 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.lambda (:require (clojure [string :as string] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 83e294c1a..3aa25ac99 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.lux (:require (clojure [string :as string] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index db73e8bb4..b4b041049 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.module (:require (clojure [string :as string] diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj index 40639e85a..b1468e540 100644 --- a/src/lux/compiler/package.clj +++ b/src/lux/compiler/package.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.package (:require [clojure.core.match :as M :refer [matchv]] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 7e2bc6961..4b43673cc 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.type (:require clojure.core.match diff --git a/src/lux/host.clj b/src/lux/host.clj index dfd4df23d..3d61eec6a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.host (:require (clojure [string :as string] diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index e848cc3fd..6f5f2250d 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.lexer (:require [clojure.template :refer [do-template]] diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 65dc4eb0d..1325a2e7d 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.optimizer (:require [lux.analyser :as &analyser])) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index eaa22db20..9436eebc3 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.parser (:require [clojure.template :refer [do-template]] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index e3f95b5f9..aa845c09d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.reader (:require [clojure.string :as string] diff --git a/src/lux/type.clj b/src/lux/type.clj index 9f3adb036..f65fdbf12 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.type (:refer-clojure :exclude [deref apply merge bound?]) -- cgit v1.2.3 From a10d922283a9256f0f0015d9d00a0c549b1891cb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 17:58:32 -0400 Subject: The environments of AllT types are no longer stored inside a Maybe. --- source/lux.lux | 53 +++++++++++++++++++++-------------------------- src/lux/compiler/type.clj | 18 ++++++---------- src/lux/type.clj | 49 ++++++++++++++++--------------------------- 3 files changed, 48 insertions(+), 72 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 7acb5222a..815f95c69 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -45,7 +45,7 @@ ## (#Cons a (List a)))) (_lux_def List (9 ["lux" "List"] - (7 (1 (0)) "lux;List" "a" + (7 (0) "lux;List" "a" (1 (1 ## "lux;Nil" (2 (0)) (1 ## "lux;Cons" @@ -61,7 +61,7 @@ ## (1 a))) (_lux_def Maybe (9 ["lux" "Maybe"] - (7 (1 (0)) "lux;Maybe" "a" + (7 (0) "lux;Maybe" "a" (1 (1 ## "lux;None" (2 (0)) (1 ## "lux;Some" @@ -77,7 +77,7 @@ ## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) -## (#AllT (Maybe (List (, Text Type))) Text Text Type) +## (#AllT (List (, Text Type)) Text Text Type) ## (#AppT Type Type) ## (#NamedT Ident Type) ## )) @@ -89,7 +89,7 @@ TypeEnv (_lux_case (8 List Type) TypeList - (8 (7 (1 (0)) "Type" "_" + (8 (7 (0) "Type" "_" (1 (1 ## "lux;DataT" Text (1 ## "lux;VariantT" @@ -105,7 +105,7 @@ (1 ## "lux;ExT" Int (1 ## "lux;AllT" - (2 (1 (8 Maybe TypeEnv) (1 Text (1 Text (1 Type (0)))))) + (2 (1 TypeEnv (1 Text (1 Text (1 Type (0)))))) (1 ## "lux;AppT" (2 (1 Type (1 Type (0)))) (1 ## "lux;NamedT" @@ -120,7 +120,7 @@ ## #mappings (List (, k v)))) (_lux_def Bindings (#NamedT ["lux" "Bindings"] - (#AllT [(#Some #Nil) "lux;Bindings" "k" + (#AllT [#Nil "lux;Bindings" "k" (#AllT [#None "" "v" (#TupleT (#Cons ## "lux;counter" Int @@ -140,7 +140,7 @@ ## #closure (Bindings k v))) (_lux_def Env (#NamedT ["lux" "Env"] - (#AllT (#Some #Nil) "lux;Env" "k" + (#AllT #Nil "lux;Env" "k" (#AllT #None "" "v" (#TupleT (#Cons ## "lux;name" Text @@ -167,7 +167,7 @@ ## (| (#Meta m v))) (_lux_def Meta (#NamedT ["lux" "Meta"] - (#AllT (#Some #Nil) "lux;Meta" "m" + (#AllT #Nil "lux;Meta" "m" (#AllT #None "" "v" (#VariantT (#Cons ## "lux;Meta" (#TupleT (#Cons (#BoundT "m") @@ -196,7 +196,7 @@ AST (_lux_case (#AppT [List AST]) ASTList - (#AllT (#Some #Nil) "lux;AST'" "w" + (#AllT #Nil "lux;AST'" "w" (#VariantT (#Cons ## "lux;BoolS" Bool (#Cons ## "lux;IntS" @@ -239,7 +239,7 @@ ## (#Right r))) (_lux_def Either (#NamedT ["lux" "Either"] - (#AllT (#Some #Nil) "lux;Either" "l" + (#AllT #Nil "lux;Either" "l" (#AllT #None "" "r" (#VariantT (#Cons ## "lux;Left" (#BoundT "l") @@ -252,7 +252,7 @@ ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [(#Some #Nil) "lux;StateE" "s" + (#AllT [#Nil "lux;StateE" "s" (#AllT [#None "" "a" (#LambdaT [(#BoundT "s") (#AppT [(#AppT [Either Text]) @@ -291,7 +291,7 @@ ## (#AliasD Ident))) (_lux_def DefData' (#NamedT ["lux" "DefData'"] - (#AllT [(#Some #Nil) "lux;DefData'" "" + (#AllT [#Nil "lux;DefData'" "" (#VariantT (#Cons [## "lux;ValueD" (#TupleT (#Cons [Type (#Cons [Unit @@ -328,7 +328,7 @@ ## )) (_lux_def Module (#NamedT ["lux" "Module"] - (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#AllT [#Nil "lux;Module" "Compiler" (#TupleT (#Cons [## "lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) (#Cons [## "lux;defs" @@ -372,7 +372,7 @@ ## )) (_lux_def Compiler (#NamedT ["lux" "Compiler"] - (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#AppT [(#AllT [#Nil "lux;Compiler" "" (#TupleT (#Cons [## "lux;source" Source (#Cons [## "lux;cursor" @@ -431,7 +431,7 @@ ## (Either Text (, Compiler a)))) ## ...) (_lux_def return - (_lux_: (#AllT (#Some #Nil) "" "a" + (_lux_: (#AllT #Nil "" "a" (#LambdaT (#BoundT "a") (#LambdaT Compiler (#AppT (#AppT Either Text) @@ -448,7 +448,7 @@ ## (Either Text (, Compiler a)))) ## ...) (_lux_def fail - (_lux_: (#AllT (#Some #Nil) "" "a" + (_lux_: (#AllT #Nil "" "a" (#LambdaT Text (#LambdaT Compiler (#AppT (#AppT Either Text) @@ -2192,10 +2192,10 @@ (#AllT ?local-env ?local-name ?local-arg ?local-def) (case ?local-env - #None - (#AllT (#Some env) ?local-name ?local-arg ?local-def) + #Nil + (#AllT env ?local-name ?local-arg ?local-def) - (#Some _) + _ type) (#LambdaT ?input ?output) @@ -2220,9 +2220,7 @@ (-> Type Type (Maybe Type)) (case type-fn (#AllT env name arg body) - (#Some (beta-reduce (|> (case env - (#Some env) env - _ (list)) + (#Some (beta-reduce (|> env (put name type-fn) (put arg param)) body)) @@ -3151,13 +3149,10 @@ (` (#;ExT (~ (int$ id)))) (#AllT env name arg type) - (let [env' (: AST - (case env - #None (` #None) - (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) AST) - (lambda [[label type]] - (tuple$ (list (text$ label) (type->syntax type))))) - _env)))))))] + (let [env' (untemplate-list (map (: (-> (, Text Type) AST) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + env))] (` (#;AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) (#AppT fun arg) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 4b43673cc..54a7c5e0c 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -60,18 +60,12 @@ (&/$AllT ?env ?name ?arg ?body) (variant$ &/$AllT - (tuple$ (&/|list (|case ?env - (&/$None) - (variant$ &/$None (tuple$ (&/|list))) - - (&/$Some ??env) - (variant$ &/$Some - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) - $Nil - (&/|reverse ??env)))) + (tuple$ (&/|list (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ?env)) (text$ ?name) (text$ ?arg) (->analysis ?body)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index f65fdbf12..bcef74475 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -23,8 +23,7 @@ _ false)) -(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) -(def ^:private no-env (&/V &/$None nil)) +(def ^:private empty-env (&/V &/$Nil nil)) (defn Data$ [name] (&/V &/$DataT name)) (defn Bound$ [name] @@ -106,7 +105,7 @@ ;; ExT Int ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + (Tuple$ (&/|list TypeEnv Text Text Type)) ;; AppT TypePair ;; NamedT @@ -117,7 +116,7 @@ (def Bindings (Named$ (&/T "lux" "Bindings") (All$ empty-env "lux;Bindings" "k" - (All$ no-env "" "v" + (All$ empty-env "" "v" (Tuple$ (&/|list ;; "lux;counter" Int @@ -131,7 +130,7 @@ (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" - (All$ no-env "" "v" + (All$ empty-env "" "v" (Tuple$ (&/|list ;; "lux;name" @@ -151,7 +150,7 @@ (def Meta (Named$ (&/T "lux" "Meta") (All$ empty-env "lux;Meta" "m" - (All$ no-env "" "v" + (All$ empty-env "" "v" (Variant$ (&/|list ;; &/$Meta (Tuple$ (&/|list (Bound$ "m") @@ -197,7 +196,7 @@ (def Either (Named$ (&/T "lux" "Either") (All$ empty-env "lux;Either" "l" - (All$ no-env "" "r" + (All$ empty-env "" "r" (Variant$ (&/|list ;; &/$Left (Bound$ "l") @@ -206,7 +205,7 @@ (def StateE (All$ empty-env "lux;StateE" "s" - (All$ no-env "" "a" + (All$ empty-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) (Tuple$ (&/|list (Bound$ "s") @@ -441,16 +440,10 @@ (return (Variant$ =members))) (&/$AllT ?env ?name ?arg ?body) - (|do [=env (|case ?env - (&/$None) - (return ?env) - - (&/$Some ?env*) - (|do [clean-env (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?env*)] - (return (&/V &/$Some clean-env)))) + (|do [=env (&/map% (fn [[k v]] + (|do [=v (clean* ?tid v)] + (return (&/T k =v)))) + ?env) body* (clean* ?tid ?body)] (return (All$ =env ?name ?arg body*))) @@ -634,10 +627,10 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env - (&/$None) - (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) + (&/$Nil) + (All$ env ?local-name ?local-arg ?local-def) - (&/$Some _) + _ type) (&/$LambdaT ?input ?output) @@ -655,16 +648,10 @@ (defn apply-type [type-fn param] (|case type-fn (&/$AllT local-env local-name local-arg local-def) - (let [local-env* (|case local-env - (&/$None) - (&/|table) - - (&/$Some local-env*) - local-env*)] - (return (beta-reduce (->> local-env* - (&/|put local-name type-fn) - (&/|put local-arg param)) - local-def))) + (return (beta-reduce (->> local-env + (&/|put local-name type-fn) + (&/|put local-arg param)) + local-def)) (&/$AppT F A) (|do [type-fn* (apply-type F A)] -- cgit v1.2.3 From 8de225f98aaed212bf3b683208bff5c6ab85a835 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 22:46:12 -0400 Subject: - Changed the name of AllT (for-all type) to UnivQ (universal quantification). - UnivQ no longer stores the environment as key-val pairs with Text names, but instead stores it as type-lists with variables accessed via an index through a (updated) BoundT. - UnivQ no longer stores the name of the type-fun, not the name of the type-arg. --- source/lux.lux | 882 ++++++++++++++++++++++--------------------- source/lux/codata/stream.lux | 8 +- src/lux/analyser/case.clj | 44 ++- src/lux/analyser/env.clj | 4 +- src/lux/analyser/host.clj | 2 +- src/lux/analyser/lux.clj | 63 ++-- src/lux/analyser/module.clj | 2 +- src/lux/base.clj | 37 +- src/lux/compiler/type.clj | 19 +- src/lux/reader.clj | 4 +- src/lux/type.clj | 445 +++++++++++----------- 11 files changed, 750 insertions(+), 760 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 815f95c69..d96b18fcb 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -45,12 +45,12 @@ ## (#Cons a (List a)))) (_lux_def List (9 ["lux" "List"] - (7 (0) "lux;List" "a" + (7 (0) (1 (1 ## "lux;Nil" (2 (0)) (1 ## "lux;Cons" - (2 (1 (4 "a") - (1 (8 (4 "lux;List") (4 "a")) + (2 (1 (4 1) + (1 (8 (4 0) (4 1)) (0)))) (0))))))) (_lux_export List) @@ -61,11 +61,11 @@ ## (1 a))) (_lux_def Maybe (9 ["lux" "Maybe"] - (7 (0) "lux;Maybe" "a" + (7 (0) (1 (1 ## "lux;None" (2 (0)) (1 ## "lux;Some" - (4 "a") + (4 1) (0))))))) (_lux_export Maybe) (_lux_declare-tags [#None #Some] Maybe) @@ -75,61 +75,59 @@ ## (#VariantT (List Type)) ## (#TupleT (List Type)) ## (#LambdaT Type Type) -## (#BoundT Text) +## (#BoundT Int) ## (#VarT Int) -## (#AllT (List (, Text Type)) Text Text Type) +## (#UnivQ (List Type) Type) ## (#AppT Type Type) ## (#NamedT Ident Type) ## )) (_lux_def Type (9 ["lux" "Type"] - (_lux_case (8 (4 "Type") (4 "_")) + (_lux_case (8 (4 0) (4 1)) Type - (_lux_case (8 List (2 (1 Text (1 Type (0))))) - TypeEnv - (_lux_case (8 List Type) - TypeList - (8 (7 (0) "Type" "_" - (1 (1 ## "lux;DataT" - Text - (1 ## "lux;VariantT" - TypeList - (1 ## "lux;TupleT" - TypeList - (1 ## "lux;LambdaT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;BoundT" - Text - (1 ## "lux;VarT" - Int - (1 ## "lux;ExT" - Int - (1 ## "lux;AllT" - (2 (1 TypeEnv (1 Text (1 Text (1 Type (0)))))) - (1 ## "lux;AppT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;NamedT" - (2 (1 Ident (1 Type (0)))) - (0))))))))))))) - Void)))))) + (_lux_case (8 List Type) + TypeList + (8 (7 (0) + (1 (1 ## "lux;DataT" + Text + (1 ## "lux;VariantT" + TypeList + (1 ## "lux;TupleT" + TypeList + (1 ## "lux;LambdaT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;BoundT" + Int + (1 ## "lux;VarT" + Int + (1 ## "lux;ExT" + Int + (1 ## "lux;UnivQ" + (2 (1 TypeList (1 Type (0)))) + (1 ## "lux;AppT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;NamedT" + (2 (1 Ident (1 Type (0)))) + (0))))))))))))) + Void))))) (_lux_export Type) -(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #UnivQ #AppT #NamedT] Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (_lux_def Bindings (#NamedT ["lux" "Bindings"] - (#AllT [#Nil "lux;Bindings" "k" - (#AllT [#None "" "v" + (#UnivQ #Nil + (#UnivQ #Nil (#TupleT (#Cons ## "lux;counter" Int (#Cons ## "lux;mappings" - (#AppT [List - (#TupleT (#Cons [(#BoundT "k") - (#Cons [(#BoundT "v") - #Nil])]))]) - #Nil)))])]))) + (#AppT List + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) + #Nil)))) + #Nil))))))) (_lux_export Bindings) (_lux_declare-tags [#counter #mappings] Bindings) @@ -140,19 +138,19 @@ ## #closure (Bindings k v))) (_lux_def Env (#NamedT ["lux" "Env"] - (#AllT #Nil "lux;Env" "k" - (#AllT #None "" "v" - (#TupleT (#Cons ## "lux;name" - Text - (#Cons ## "lux;inner-closures" - Int - (#Cons ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v")) - (#Cons ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT "k")) - (#BoundT "v")) - #Nil))))))))) + (#UnivQ #Nil + (#UnivQ #Nil + (#TupleT (#Cons ## "lux;name" + Text + (#Cons ## "lux;inner-closures" + Int + (#Cons ## "lux;locals" + (#AppT (#AppT Bindings (#BoundT 3)) + (#BoundT 1)) + (#Cons ## "lux;closure" + (#AppT (#AppT Bindings (#BoundT 3)) + (#BoundT 1)) + #Nil))))))))) (_lux_export Env) (_lux_declare-tags [#name #inner-closures #locals #closure] Env) @@ -167,13 +165,13 @@ ## (| (#Meta m v))) (_lux_def Meta (#NamedT ["lux" "Meta"] - (#AllT #Nil "lux;Meta" "m" - (#AllT #None "" "v" - (#VariantT (#Cons ## "lux;Meta" - (#TupleT (#Cons (#BoundT "m") - (#Cons (#BoundT "v") - #Nil))) - #Nil)))))) + (#UnivQ #Nil + (#UnivQ #Nil + (#VariantT (#Cons ## "lux;Meta" + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) + #Nil))) + #Nil)))))) (_lux_export Meta) (_lux_declare-tags [#Meta] Meta) @@ -190,36 +188,36 @@ ## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) (_lux_def AST' (#NamedT ["lux" "AST'"] - (_lux_case (#AppT (#BoundT "w") - (#AppT (#BoundT "lux;AST'") - (#BoundT "w"))) + (_lux_case (#AppT (#BoundT 1) + (#AppT (#BoundT 0) + (#BoundT 1))) AST (_lux_case (#AppT [List AST]) ASTList - (#AllT #Nil "lux;AST'" "w" - (#VariantT (#Cons ## "lux;BoolS" - Bool - (#Cons ## "lux;IntS" - Int - (#Cons ## "lux;RealS" - Real - (#Cons ## "lux;CharS" - Char - (#Cons ## "lux;TextS" - Text - (#Cons ## "lux;SymbolS" - Ident - (#Cons ## "lux;TagS" + (#UnivQ #Nil + (#VariantT (#Cons ## "lux;BoolS" + Bool + (#Cons ## "lux;IntS" + Int + (#Cons ## "lux;RealS" + Real + (#Cons ## "lux;CharS" + Char + (#Cons ## "lux;TextS" + Text + (#Cons ## "lux;SymbolS" Ident - (#Cons ## "lux;FormS" - ASTList - (#Cons ## "lux;TupleS" + (#Cons ## "lux;TagS" + Ident + (#Cons ## "lux;FormS" ASTList - (#Cons ## "lux;RecordS" - (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) - #Nil) - ))))))))) - )))))) + (#Cons ## "lux;TupleS" + ASTList + (#Cons ## "lux;RecordS" + (#AppT List (#TupleT (#Cons AST (#Cons AST #Nil)))) + #Nil) + ))))))))) + )))))) (_lux_export AST') (_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') @@ -239,26 +237,26 @@ ## (#Right r))) (_lux_def Either (#NamedT ["lux" "Either"] - (#AllT #Nil "lux;Either" "l" - (#AllT #None "" "r" - (#VariantT (#Cons ## "lux;Left" - (#BoundT "l") - (#Cons ## "lux;Right" - (#BoundT "r") - #Nil))))))) + (#UnivQ #Nil + (#UnivQ #Nil + (#VariantT (#Cons ## "lux;Left" + (#BoundT 3) + (#Cons ## "lux;Right" + (#BoundT 1) + #Nil))))))) (_lux_export Either) (_lux_declare-tags [#Left #Right] Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (_lux_def StateE - (#AllT [#Nil "lux;StateE" "s" - (#AllT [#None "" "a" - (#LambdaT [(#BoundT "s") - (#AppT [(#AppT [Either Text]) - (#TupleT (#Cons [(#BoundT "s") - (#Cons [(#BoundT "a") - #Nil])]))])])])])) + (#UnivQ #Nil + (#UnivQ #Nil + (#LambdaT (#BoundT 3) + (#AppT (#AppT Either Text) + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) + #Nil)))))))) ## (deftype Source ## (List (Meta Cursor Text))) @@ -291,18 +289,16 @@ ## (#AliasD Ident))) (_lux_def DefData' (#NamedT ["lux" "DefData'"] - (#AllT [#Nil "lux;DefData'" "" - (#VariantT (#Cons [## "lux;ValueD" - (#TupleT (#Cons [Type - (#Cons [Unit - #Nil])])) - (#Cons [## "lux;TypeD" - Type - (#Cons [## "lux;MacroD" - (#BoundT "") - (#Cons [## "lux;AliasD" - Ident - #Nil])])])]))]))) + (#UnivQ #Nil + (#VariantT (#Cons ## "lux;ValueD" + (#TupleT (#Cons Type (#Cons Unit #Nil))) + (#Cons ## "lux;TypeD" + Type + (#Cons ## "lux;MacroD" + (#BoundT 1) + (#Cons ## "lux;AliasD" + Ident + #Nil)))))))) (_lux_export DefData') (_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData') @@ -328,34 +324,34 @@ ## )) (_lux_def Module (#NamedT ["lux" "Module"] - (#AllT [#Nil "lux;Module" "Compiler" - (#TupleT (#Cons [## "lux;module-aliases" - (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) - (#Cons [## "lux;defs" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - ASTList])])]) - #Nil])])) - #Nil])]))]) - (#Cons [## "lux;imports" - (#AppT [List Text]) - (#Cons [## "lux;tags" - (#AppT [List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons Int - (#Cons (#AppT [List Ident]) - (#Cons Type - #Nil)))) - #Nil)))]) - (#Cons [## "lux;types" - (#AppT [List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons (#AppT [List Ident]) - (#Cons Type - #Nil))) - #Nil)))]) - #Nil])])])])]))]))) + (#UnivQ #Nil + (#TupleT (#Cons ## "lux;module-aliases" + (#AppT List (#TupleT (#Cons Text (#Cons Text #Nil)))) + (#Cons ## "lux;defs" + (#AppT List (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Bool (#Cons (#AppT DefData' (#LambdaT ASTList + (#AppT (#AppT StateE (#BoundT 1)) + ASTList))) + #Nil))) + #Nil)))) + (#Cons ## "lux;imports" + (#AppT List Text) + (#Cons ## "lux;tags" + (#AppT List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Int + (#Cons (#AppT List Ident) + (#Cons Type + #Nil)))) + #Nil)))) + (#Cons ## "lux;types" + (#AppT List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons (#AppT List Ident) + (#Cons Type + #Nil))) + #Nil)))) + #Nil))))))))) (_lux_export Module) (_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) @@ -372,30 +368,30 @@ ## )) (_lux_def Compiler (#NamedT ["lux" "Compiler"] - (#AppT [(#AllT [#Nil "lux;Compiler" "" - (#TupleT (#Cons [## "lux;source" - Source - (#Cons [## "lux;cursor" - Cursor - (#Cons [## "lux;modules" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) - #Nil])]))]) - (#Cons [## "lux;envs" - (#AppT [List (#AppT [(#AppT [Env Text]) - (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) - (#Cons [## "lux;type-vars" - (#AppT [(#AppT [Bindings Int]) Type]) - (#Cons [## "lux;expected" - Type - (#Cons [## "lux;seed" - Int - (#Cons [## "lux;eval?" - Bool - (#Cons [## "lux;host" - Host - #Nil])])])])])])])])]))]) - Void]))) + (#AppT (#UnivQ #Nil + (#TupleT (#Cons ## "lux;source" + Source + (#Cons ## "lux;cursor" + Cursor + (#Cons ## "lux;modules" + (#AppT List (#TupleT (#Cons Text + (#Cons (#AppT Module (#AppT (#BoundT 0) (#BoundT 1))) + #Nil)))) + (#Cons ## "lux;envs" + (#AppT List (#AppT (#AppT Env Text) + (#TupleT (#Cons LuxVar (#Cons Type #Nil))))) + (#Cons ## "lux;type-vars" + (#AppT (#AppT Bindings Int) Type) + (#Cons ## "lux;expected" + Type + (#Cons ## "lux;seed" + Int + (#Cons ## "lux;eval?" + Bool + (#Cons ## "lux;host" + Host + #Nil))))))))))) + Void))) (_lux_export Compiler) (_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) @@ -431,13 +427,13 @@ ## (Either Text (, Compiler a)))) ## ...) (_lux_def return - (_lux_: (#AllT #Nil "" "a" - (#LambdaT (#BoundT "a") - (#LambdaT Compiler - (#AppT (#AppT Either Text) - (#TupleT (#Cons Compiler - (#Cons (#BoundT "a") - #Nil))))))) + (_lux_: (#UnivQ #Nil + (#LambdaT (#BoundT 1) + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#TupleT (#Cons Compiler + (#Cons (#BoundT 1) + #Nil))))))) (_lux_lambda _ val (_lux_lambda _ state (#Right state val))))) @@ -448,27 +444,42 @@ ## (Either Text (, Compiler a)))) ## ...) (_lux_def fail - (_lux_: (#AllT #Nil "" "a" - (#LambdaT Text - (#LambdaT Compiler - (#AppT (#AppT Either Text) - (#TupleT (#Cons Compiler - (#Cons (#BoundT "a") - #Nil))))))) + (_lux_: (#UnivQ #Nil + (#LambdaT Text + (#LambdaT Compiler + (#AppT (#AppT Either Text) + (#TupleT (#Cons Compiler + (#Cons (#BoundT 1) + #Nil))))))) (_lux_lambda _ msg (_lux_lambda _ state (#Left msg))))) -(_lux_def text$ - (_lux_: (#LambdaT Text AST) - (_lux_lambda _ text - (_meta (#TextS text))))) +(_lux_def bool$ + (_lux_: (#LambdaT Bool AST) + (_lux_lambda _ value + (_meta (#BoolS value))))) (_lux_def int$ (_lux_: (#LambdaT Int AST) (_lux_lambda _ value (_meta (#IntS value))))) +(_lux_def real$ + (_lux_: (#LambdaT Real AST) + (_lux_lambda _ value + (_meta (#RealS value))))) + +(_lux_def char$ + (_lux_: (#LambdaT Char AST) + (_lux_lambda _ value + (_meta (#CharS value))))) + +(_lux_def text$ + (_lux_: (#LambdaT Text AST) + (_lux_lambda _ text + (_meta (#TextS text))))) + (_lux_def symbol$ (_lux_: (#LambdaT Ident AST) (_lux_lambda _ ident @@ -542,7 +553,7 @@ #Nil)) _ - (fail "Wrong syntax for lambda"))))) + (fail "Wrong syntax for lambda''"))))) (_lux_declare-macro lambda'') (_lux_def def'' @@ -601,7 +612,7 @@ #Nil])) _ - (fail "Wrong syntax for def")) + (fail "Wrong syntax for def''")) ))) (_lux_declare-macro def'') @@ -638,82 +649,179 @@ (defmacro (->' tokens) (_lux_case tokens - (#Cons [input (#Cons [output #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) - #Nil])]))) - #Nil])) - - (#Cons [input (#Cons [output others])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) - (#Cons [(_meta (#TupleS (#Cons [input - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) - (#Cons [output others])]))) - #Nil])]))) - #Nil])]))) - #Nil])) + (#Cons input (#Cons output #Nil)) + (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "LambdaT"]) + (#Cons (_meta (#TupleS (#Cons input (#Cons output #Nil)))) + #Nil)))) + #Nil)) + + (#Cons input (#Cons output others)) + (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "LambdaT"]) + (#Cons (_meta (#TupleS (#Cons input + (#Cons (_meta (#FormS (#Cons (symbol$ ["lux" "->'"]) + (#Cons output others)))) + #Nil)))) + #Nil)))) + #Nil)) _ (fail "Wrong syntax for ->'"))) -(defmacro (All' tokens) +(defmacro ($' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS #Nil)]) - (#Cons [body #Nil])]) - (return (#Cons [body - #Nil])) - - (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) - (#Cons [body #Nil])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) - (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) - (#Cons [(_meta (#TextS "")) - (#Cons [(_meta (#TextS arg-name)) - (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) - (#Cons [(_meta (#TupleS other-args)) - (#Cons [body - #Nil])])]))) - #Nil])])])]))) - #Nil])]))) - #Nil])) + (#Cons x #Nil) + (return tokens) + + (#Cons x (#Cons y xs)) + (return (#Cons (_meta (#FormS (#Cons (symbol$ ["lux" "$'"]) + (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "AppT"]) + (#Cons x (#Cons y #Nil))))) + xs)))) + #Nil)) _ - (fail "Wrong syntax for All'"))) + (fail "Wrong syntax for $'"))) -(defmacro (B' tokens) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) - #Nil]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) - (#Cons [(_meta (#TextS bound-name)) - #Nil])]))) - #Nil])) +(def'' (map f xs) + (#UnivQ #Nil + (#UnivQ #Nil + (->' (->' (#BoundT 3) (#BoundT 1)) ($' List (#BoundT 3)) ($' List (#BoundT 1))))) + (_lux_case xs + #Nil + #Nil + + (#Cons x xs') + (#Cons (f x) (map f xs')))) + +(def'' RepEnv + Type + ($' List (#TupleT (#Cons Text (#Cons AST #Nil))))) + +(def'' (make-env xs ys) + (->' ($' List Text) ($' List AST) RepEnv) + (_lux_case (_lux_: (#TupleT (#Cons ($' List Text) (#Cons ($' List AST) #Nil))) + [xs ys]) + [(#Cons x xs') (#Cons y ys')] + (#Cons [x y] (make-env xs' ys')) _ - (fail "Wrong syntax for B'"))) + #Nil)) -(defmacro ($' tokens) - (_lux_case tokens - (#Cons [x #Nil]) - (return tokens) +(def'' (text:= x y) + (->' Text Text Bool) + (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] + x [y])) + +(def'' (get-rep key env) + (->' Text RepEnv ($' Maybe AST)) + (_lux_case env + #Nil + #None + + (#Cons [k v] env') + (_lux_case (text:= k key) + true + (#Some v) + + false + (get-rep key env')))) + +(def'' (replace-syntax reps syntax) + (->' RepEnv AST AST) + (_lux_case syntax + (#Meta _ (#SymbolS "" name)) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + (#Meta _ (#FormS parts)) + (#Meta _ (#FormS (map (replace-syntax reps) parts))) - (#Cons [x (#Cons [y xs])]) - (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) - (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) - (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) - #Nil])]))) - xs])]))) - #Nil])) + (#Meta _ (#TupleS members)) + (#Meta _ (#TupleS (map (replace-syntax reps) members))) + (#Meta _ (#RecordS slots)) + (#Meta _ (#RecordS (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) + (lambda'' [slot] + (_lux_case slot + [k v] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))) + _ - (fail "Wrong syntax for $'"))) + syntax) + ) + +(def'' (update-bounds ast) + (->' AST AST) + (_lux_case ast + (#Meta _ (#BoolS value)) + (bool$ value) + + (#Meta _ (#IntS value)) + (int$ value) + + (#Meta _ (#RealS value)) + (real$ value) + + (#Meta _ (#CharS value)) + (char$ value) + + (#Meta _ (#TextS value)) + (text$ value) + + (#Meta _ (#SymbolS value)) + (symbol$ value) + + (#Meta _ (#TagS value)) + (tag$ value) + + (#Meta _ (#TupleS members)) + (tuple$ (map update-bounds members)) + + (#Meta _ (#RecordS pairs)) + (record$ (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) + (lambda'' [pair] + (let'' [name val] pair + [name (update-bounds val)]))) + pairs)) + + (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "lux" "BoundT")) (#Cons (#Meta _ (#IntS idx)) #Nil)))) + (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ (_jvm_ladd 2 idx)) #Nil))) + + (#Meta _ (#FormS members)) + (form$ (map update-bounds members))) + ) + +(defmacro (All' tokens) + (_lux_case tokens + (#Cons (#Meta _ (#TupleS (#Cons (#Meta _ (#SymbolS "" arg-name)) other-args))) + (#Cons body #Nil)) + (let'' bound-var (_meta (#FormS (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ 1) #Nil)))) + (let'' body' (replace-syntax (#Cons [arg-name bound-var] #Nil) + (update-bounds body)) + (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "UnivQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (_lux_case other-args + #Nil + body' + + _ + (_meta (#FormS (#Cons (symbol$ ["lux" "All'"]) + (#Cons (_meta (#TupleS other-args)) + (#Cons body' + #Nil)))))) + #Nil))))) + #Nil)))) + + _ + (fail "Wrong syntax for All'"))) (def'' (foldL f init xs) - (All' [a b] - (->' (->' (B' a) (B' b) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) + (All' [a b] (->' (->' a b a) a ($' List b) a)) (_lux_case xs #Nil init @@ -722,8 +830,7 @@ (foldL f (f init x) xs'))) (def'' (reverse list) - (All' [a] - (->' ($' List (B' a)) ($' List (B' a)))) + (All' [a] (->' ($' List a) ($' List a))) (foldL (lambda'' [tail head] (#Cons head tail)) #Nil list)) @@ -822,8 +929,7 @@ )) (def''' (as-pairs xs) - (All' [a] - (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) + (All' [a] (->' ($' List a) ($' List (#TupleT (list a a))))) (_lux_case xs (#Cons [x (#Cons [y xs'])]) (#Cons [[x y] (as-pairs xs')]) @@ -846,24 +952,14 @@ _ (fail "Wrong syntax for let'"))) -(def''' (map f xs) - (All' [a b] - (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) - (_lux_case xs - #Nil - #Nil - - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) - (def''' (any? p xs) (All' [a] - (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) + (->' (->' a Bool) ($' List a) Bool)) (_lux_case xs #Nil false - (#Cons [x xs']) + (#Cons x xs') (_lux_case (p x) true true false (any? p xs')))) @@ -894,17 +990,17 @@ (_meta (#TupleS (list token (untemplate-list tokens'))))))))) (def''' #export (list:++ xs ys) - (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) + (All' [a] (->' ($' List a) ($' List a) ($' List a))) (_lux_case xs - (#Cons [x xs']) - (#Cons [x (list:++ xs' ys)]) + (#Cons x xs') + (#Cons x (list:++ xs' ys)) #Nil ys)) (defmacro #export ($ tokens) (_lux_case tokens - (#Cons [op (#Cons [init args])]) + (#Cons op (#Cons init args)) (return (list (foldL (lambda' [a1 a2] (form$ (list op a1 a2))) init args))) @@ -1044,7 +1140,7 @@ (def''' #export Lux Type (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) + (->' Compiler ($' Either Text (#TupleT (list Compiler a)))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1055,40 +1151,40 @@ Type (#NamedT ["lux" "Monad"] (All' [m] - (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) - (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b))))))))) + (#TupleT (list (All' [a] (->' a ($' m a))) + (All' [a b] (->' (->' a ($' m b)) + ($' m a) + ($' m b)))))))) (_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad ($' Monad Maybe) {#return (lambda' return [x] - (#Some x)) + (#Some x)) #bind (lambda' [f ma] - (_lux_case ma - #None #None - (#Some a) (f a)))}) + (_lux_case ma + #None #None + (#Some a) (f a)))}) (def''' Lux/Monad ($' Monad Lux) {#return (lambda' [x] - (lambda' [state] - (#Right state x))) + (lambda' [state] + (#Right state x))) #bind (lambda' [f ma] - (lambda' [state] - (_lux_case (ma state) - (#Left msg) - (#Left msg) + (lambda' [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) - (#Right state' a) - (f a state'))))}) + (#Right state' a) + (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens @@ -1116,16 +1212,16 @@ (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] - (let' [[var value] binding] - (_lux_case var - (#Meta _ (#TagS "" "let")) - (`' (;let' (~ value) (~ body'))) - - _ - (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (let' [[var value] binding] + (_lux_case var + (#Meta _ (#TagS "" "let")) + (`' (;let' (~ value) (~ body'))) + + _ + (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) body (reverse (as-pairs bindings)))] (return (list (`' (_lux_case (~ monad) @@ -1139,10 +1235,10 @@ ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) (All' [m a b] - (-> ($' Monad (B' m)) - (-> (B' a) ($' (B' m) (B' b))) - ($' List (B' a)) - ($' (B' m) ($' List (B' b))))) + (-> ($' Monad m) + (-> a ($' m b)) + ($' List a) + ($' m ($' List b)))) (let' [{#;return wrap #;bind _} m] (_lux_case xs #Nil @@ -1157,14 +1253,14 @@ (def''' (. f g) (All' [a b c] - (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) + (-> (-> b c) (-> a b) (-> a c))) (lambda' [x] (f (g x)))) (def''' (get-ident x) (-> AST ($' Maybe Ident)) (_lux_case x - (#Meta [_ (#SymbolS sname)]) + (#Meta _ (#SymbolS sname)) (#Some sname) _ @@ -1173,7 +1269,7 @@ (def''' (get-name x) (-> AST ($' Maybe Text)) (_lux_case x - (#Meta [_ (#SymbolS ["" sname])]) + (#Meta _ (#SymbolS "" sname)) (#Some sname) _ @@ -1182,46 +1278,16 @@ (def''' (tuple->list tuple) (-> AST ($' Maybe ($' List AST))) (_lux_case tuple - (#Meta [_ (#TupleS members)]) + (#Meta _ (#TupleS members)) (#Some members) _ #None)) -(def''' RepEnv - Type - ($' List (, Text AST))) - -(def''' (make-env xs ys) - (-> ($' List Text) ($' List AST) RepEnv) - (_lux_case (_lux_: (, ($' List Text) ($' List AST)) - [xs ys]) - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (make-env xs' ys')]) - - _ - #Nil)) - -(def''' (text:= x y) - (-> Text Text Bool) - (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] - x [y])) - -(def''' (get-rep key env) - (-> Text RepEnv ($' Maybe AST)) - (_lux_case env - #Nil - #None - - (#Cons [[k v] env']) - (if (text:= k key) - (#Some v) - (get-rep key env')))) - (def''' (apply-template env template) (-> RepEnv AST AST) (_lux_case template - (#Meta [_ (#SymbolS ["" sname])]) + (#Meta _ (#SymbolS "" sname)) (_lux_case (get-rep sname env) (#Some subst) subst @@ -1229,13 +1295,13 @@ _ template) - (#Meta [_ (#TupleS elems)]) + (#Meta _ (#TupleS elems)) (tuple$ (map (apply-template env) elems)) - (#Meta [_ (#FormS elems)]) + (#Meta _ (#FormS elems)) (form$ (map (apply-template env) elems)) - (#Meta [_ (#RecordS members)]) + (#Meta _ (#RecordS members)) (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] @@ -1247,7 +1313,7 @@ (def''' (join-map f xs) (All' [a b] - (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) + (-> (-> a ($' List b)) ($' List a) ($' List b))) (_lux_case xs #Nil #Nil @@ -1339,63 +1405,33 @@ (let' [[module name] ident] ($ text:++ module ";" name))) -(def''' (replace-syntax reps syntax) - (-> RepEnv AST AST) - (_lux_case syntax - (#Meta [_ (#SymbolS ["" name])]) - (_lux_case (get-rep name reps) - (#Some replacement) - replacement - - #None - syntax) - - (#Meta [_ (#FormS parts)]) - (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) - - (#Meta [_ (#TupleS members)]) - (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) - - (#Meta [_ (#RecordS slots)]) - (#Meta [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) - (lambda' [slot] - (let' [[k v] slot] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))]) - - _ - syntax) - ) +(def''' (make-bound idx) + (-> Int AST) + (`' (#;BoundT (~ (int$ idx))))) (defmacro #export (All tokens) - (let' [[self-ident tokens'] (_lux_: (, Text ASTList) - (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) - [self-ident tokens'] - - _ - ["" tokens]))] - (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-name args) - (#Some idents) - (_lux_case idents - #Nil - (return (list body)) - - (#Cons [harg targs]) - (let' [replacements (map (_lux_: (-> Text (, Text AST)) - (lambda' [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) - (list& self-ident idents)) - body' (foldL (lambda' [body' arg'] - (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) - (replace-syntax replacements body) - (reverse targs))] - ## (#;Some #;Nil) - (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) + (let' [[self-name tokens] (_lux_: (, Text ASTList) + (_lux_case tokens + (#Cons (#Meta _ (#SymbolS "" self-name)) tokens) + [self-name tokens] + + _ + ["" tokens]))] + (_lux_case tokens + (#Cons (#Meta _ (#TupleS (#Cons harg targs))) (#Cons body #Nil)) + (_lux_case (map% Maybe/Monad get-name (#Cons harg targs)) + (#Some names) + (let' [body' (foldL (lambda' [body' name'] + (`' (#;UnivQ #;Nil (~ (|> body' + (update-bounds) + (replace-syntax (list [name' (make-bound 1)]))))))) + (replace-syntax (list [self-name (make-bound -2)]) + body) + names)] + (return (list body'))) #None - (fail "'All' arguments must be symbols.")) + (fail "\"All\" arguments must be symbols.")) _ (fail "Wrong syntax for All")) @@ -2162,8 +2198,8 @@ (#VarT id) ($ text:++ "⌈" (->text id) "⌋") - (#BoundT name) - name + (#BoundT idx) + (->text idx) (#ExT ?id) ($ text:++ "⟨" (->text ?id) "⟩") @@ -2171,15 +2207,28 @@ (#AppT ?lambda ?param) ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - (#AllT ?env ?name ?arg ?body) - ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") + (#UnivQ ?env ?body) + ($ text:++ "(All " (type:show ?body) ")") (#NamedT name type) (ident->text name) )) +(def (@ idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons x xs') + (if (i= idx 0) + (#Some x) + (@ (i- idx 1) xs') + ))) + (def (beta-reduce env type) - (-> (List (, Text Type)) Type Type) + (-> (List Type) Type Type) (case type (#VariantT ?cases) (#VariantT (map (beta-reduce env) ?cases)) @@ -2190,10 +2239,10 @@ (#AppT ?type-fn ?type-arg) (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - (#AllT ?local-env ?local-name ?local-arg ?local-def) + (#UnivQ ?local-env ?local-def) (case ?local-env #Nil - (#AllT env ?local-name ?local-arg ?local-def) + (#UnivQ env ?local-def) _ type) @@ -2201,8 +2250,8 @@ (#LambdaT ?input ?output) (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) - (#BoundT ?name) - (case (get ?name env) + (#BoundT idx) + (case (@ idx env) (#Some bound) bound @@ -2219,11 +2268,8 @@ (def (apply-type type-fn param) (-> Type Type (Maybe Type)) (case type-fn - (#AllT env name arg body) - (#Some (beta-reduce (|> env - (put name type-fn) - (put arg param)) - body)) + (#UnivQ env body) + (#Some (beta-reduce (list& type-fn param env) body)) (#AppT F A) (do Maybe/Monad @@ -2247,7 +2293,7 @@ [output (apply-type fun arg)] (resolve-struct-type output)) - (#AllT _ _ _ body) + (#UnivQ _ body) (resolve-struct-type body) (#NamedT name type) @@ -2294,7 +2340,7 @@ (#AppT fun arg) (resolve-type-tags fun) - (#AllT env name arg body) + (#UnivQ env body) (resolve-type-tags body) (#NamedT [module name] _) @@ -2556,19 +2602,6 @@ (#Left ($ text:++ "Unknown module: " module))) )) -(def (@ idx xs) - (All [a] - (-> Int (List a) (Maybe a))) - (case xs - #Nil - #None - - (#Cons x xs') - (if (i= idx 0) - (#Some x) - (@ (i- idx 1) xs') - ))) - (def (split-with' p ys xs) (All [a] (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) @@ -3139,8 +3172,8 @@ (#LambdaT in out) (` (#;LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) - (#BoundT name) - (` (#;BoundT (~ (text$ name)))) + (#BoundT idx) + (` (#;BoundT (~ (int$ idx)))) (#VarT id) (` (#;VarT (~ (int$ id)))) @@ -3148,12 +3181,9 @@ (#ExT id) (` (#;ExT (~ (int$ id)))) - (#AllT env name arg type) - (let [env' (untemplate-list (map (: (-> (, Text Type) AST) - (lambda [[label type]] - (tuple$ (list (text$ label) (type->syntax type))))) - env))] - (` (#;AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) + (#UnivQ env type) + (let [env' (untemplate-list (map type->syntax env))] + (` (#;UnivQ (~ env') (~ (type->syntax type))))) (#AppT fun arg) (` (#;AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 956bc6994..b4c0e0239 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -24,8 +24,8 @@ (All [a] (-> a (List a) a (List a) (Stream a))) (case xs - #;Nil (cycle' init full init full) - (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + #;Nil (cycle' init full init full) + (#;Cons x' xs') (... [x (cycle' x' xs' init full)]))) ## [Functions] (def #export (iterate f x) @@ -42,8 +42,8 @@ (All [a] (-> (List a) (Maybe (Stream a)))) (case xs - #;Nil #;None - (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + #;Nil #;None + (#;Cons x xs') (#;Some (cycle' x xs' x xs')))) (do-template [ ] [(def #export ( s) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 5987cbdf7..829b5b6d8 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -48,7 +48,7 @@ (fail "##9##")))] (resolve-type type*)) - (&/$AllT _aenv _aname _aarg _abody) + (&/$UnivQ _) ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] @@ -61,42 +61,46 @@ _ (&type/actual-type type))) +(defn update-up-frame [frame] + (|let [[_env _idx _var] frame] + (&/T _env (+ 2 _idx) _var))) + (defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" ;; (prn 'adjust-type* (&type/show-type type)) (|case type - (&/$AllT _aenv _aname _aarg _abody) + (&/$UnivQ _aenv _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) + (adjust-type* (&/Cons$ (&/T _aenv 1 $var) (&/|map update-up-frame up)) =type)))) (&/$TupleT ?members) (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] (&type/clean* _avar _abody)))) type up)] (return (&type/Tuple$ (&/|map (fn [v] (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + (|let [[_aenv _aidx _avar] ena] + (&/V &/$UnivQ (&/T _aenv _abody)))) v up)) ?members*)))) (&/$VariantT ?members) (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] (&type/clean* _avar _abody)))) type up)] (return (&/V &/$VariantT (&/|map (fn [v] (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + (|let [[_aenv _aidx _avar] ena] + (&/V &/$UnivQ (&/T _aenv _abody)))) v up)) ?members*)))) @@ -169,7 +173,7 @@ (|do [[=tests =kont] (&/fold (fn [kont* vm] (|let [[v m] vm] (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) + (return (&/T (&/Cons$ =test =tests) =kont))))) (|do [=kont kont] (return (&/T (&/|list) =kont))) (&/|reverse (&/zip2 ?member-types ?members)))] @@ -192,7 +196,7 @@ (|do [[=tests =kont] (&/fold (fn [kont* vm] (|let [[v m] vm] (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) + (return (&/T (&/Cons$ =test =tests) =kont))))) (|do [=kont kont] (return (&/T (&/|list) =kont))) (&/|reverse (&/zip2 ?member-types ?members)))] @@ -242,7 +246,7 @@ (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/|cons pattern+body patterns)))) + (return (&/Cons$ pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] @@ -258,31 +262,31 @@ (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $BoolTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] (return (&/V $IntTotal (&/T total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $IntTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] (return (&/V $RealTotal (&/T total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $RealTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] (return (&/V $CharTotal (&/T total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $CharTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] (return (&/V $TextTotal (&/T total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $TextTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($TupleTestAC ?tests)] (|do [structs (&/map% (fn [t] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 666807586..66478eecc 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -22,7 +22,7 @@ =return (body (&/update$ &/$envs (fn [stack] (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] - (&/|cons (&/update$ &/$locals #(->> % + (&/Cons$ (&/update$ &/$locals #(->> % (&/update$ &/$counter inc) (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) (&/|head stack)) @@ -31,7 +31,7 @@ (|case =return (&/$Right ?state ?value) (return* (&/update$ &/$envs (fn [stack*] - (&/|cons (&/update$ &/$locals #(->> % + (&/Cons$ (&/update$ &/$locals #(->> % (&/update$ &/$counter dec) (&/set$ &/$mappings old-mappings)) (&/|head stack*)) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 8ccfc5ace..098dc89df 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -313,7 +313,7 @@ (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/|cons (&/T ";this" ?super-class) + (&/Cons$ (&/T ";this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 634769839..c3f7622b8 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -42,7 +42,7 @@ (return (&/|list (&/T (&/V &&/$tuple =elems) exo-type)))) - (&/$AllT _) + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -90,7 +90,7 @@ (&/$None) (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) - (&/$AllT _) + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -98,41 +98,20 @@ _ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) -;; (defn analyse-variant [analyse exo-type ident ?values] -;; (|do [exo-type* (|case exo-type -;; (&/$VarT ?id) -;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] -;; (&type/actual-type exo-type*)) -;; (|do [_ (&type/set-var ?id &type/Type)] -;; (&type/actual-type &type/Type)))) - -;; _ -;; (&type/actual-type exo-type))] -;; (|case exo-type* -;; (&/$VariantT ?cases) -;; (|do [?tag (&&/resolved-ident ident)] -;; (if-let [vtype (&/|get ?tag ?cases)] -;; (|do [=value (analyse-variant-body analyse vtype ?values)] -;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) -;; exo-type)))) -;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - -;; (&/$AllT _) -;; (&type/with-var -;; (fn [$var] -;; (|do [exo-type** (&type/apply-type exo-type* $var)] -;; (analyse-variant analyse exo-type** ident ?values)))) - -;; _ -;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] + ;; (when @&type/!flag + ;; (prn 'analyse-record (&type/show-type exo-type) + ;; (&/->seq (&/|map (fn [pair] + ;; (|let [[k v] pair] + ;; (str (&/show-ast k) " " (&/show-ast v)))) + ;; ?elems)))) (|do [exo-type* (|case exo-type (&/$VarT ?id) (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) - (&/$AllT _) + (&/$UnivQ _) (|do [$var &type/existential =type (&type/apply-type exo-type $var)] (&type/actual-type =type)) @@ -148,7 +127,7 @@ (return ?table) _ - (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*) "\n" (&type/show-type exo-type)))) _ (&/assert! (= (&/|length types) (&/|length ?elems)) (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) members (&&record/order-record ?elems) @@ -221,13 +200,13 @@ (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1) (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/T register* (&/|cons frame* new-inner)))) + (&/T register* (&/Cons$ frame* new-inner)))) (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) @@ -255,7 +234,7 @@ (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* - (&/$AllT _aenv _aname _aarg _abody) + (&/$UnivQ _) ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -268,7 +247,7 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT 1))] (&type/clean $var =output-t)))] (return (&/T type** =args))) )))) @@ -276,7 +255,7 @@ (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/T =output-t (&/|cons =arg =args)))) + (return (&/T =output-t (&/Cons$ =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -332,7 +311,7 @@ (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type - (&/$AllT _) + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -353,7 +332,7 @@ (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type - (&/$AllT _env _self _arg _body) + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type* (&type/apply-type exo-type $var) @@ -376,12 +355,12 @@ (|do [?? (&type/bound? ?_id)] ;; (return (&/T _expr exo-type)) (if ?? - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))) (return (&/T _expr exo-type))) ) _ - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) _ @@ -395,8 +374,8 @@ (defn analyse-def [analyse compile-token ?name ?value] ;; (prn 'analyse-def/BEGIN ?name) - ;; (when (= "PList/Dict" ?name) - ;; (prn 'DEF ?name (&/show-ast ?value))) + ;; (when (= "monoid$" ?name) + ;; (reset! &type/!flag true)) (|do [module-name &/get-module-name ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))] ? (&&module/defined? module-name ?name)] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 77630bafe..6eca13b44 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -41,7 +41,7 @@ (return* (&/update$ &/$modules (fn [ms] (&/|update current-module - (fn [m] (&/update$ $imports (partial &/|cons module) m)) + (fn [m] (&/update$ $imports (partial &/Cons$ module) m)) ms)) state) nil)))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 44459beb4..5444c6c81 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -54,7 +54,7 @@ "BoundT" "VarT" "ExT" - "AllT" + "UnivQ" "AppT" "NamedT") @@ -285,9 +285,6 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn |cons [head tail] - (V $Cons (T head tail))) - (defn |++ [xs ys] (|case xs ($Nil) @@ -348,7 +345,7 @@ ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (T (|cons x pre) post)) + (T (Cons$ x pre) post)) (T (V $Nil nil) xs)))) (defn |contains? [k table] @@ -383,7 +380,7 @@ (|list init) ($Cons x xs*) - (|cons init (folds f (f init x) xs*)))) + (Cons$ init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) @@ -417,7 +414,7 @@ (|list) ($Cons [k v] plist*) - (|cons k (|keys plist*)))) + (Cons$ k (|keys plist*)))) (defn |vals [plist] (|case plist @@ -425,7 +422,7 @@ (|list) ($Cons [k v] plist*) - (|cons v (|vals plist*)))) + (Cons$ v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -449,7 +446,7 @@ ys ( f xs*)] (return ( y ys))))) - map% |cons + map% Cons$ flat-map% |++) (defn list-join [xss] @@ -465,7 +462,7 @@ (defn |reverse [xs] (fold (fn [tail head] - (|cons head tail)) + (Cons$ head tail)) (|list) xs)) @@ -501,7 +498,7 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (|cons head tail))) + (return (Cons$ head tail))) (return (|list))))) (defn exhaust% [step] @@ -677,11 +674,11 @@ (defn ->list [seq] (if (empty? seq) (|list) - (|cons (first seq) (->list (rest seq))))) + (Cons$ (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (|cons x (|repeat (dec n) x)) + (Cons$ x (|repeat (dec n) x)) (|list))) (def get-module-name @@ -707,7 +704,7 @@ (defn with-scope [name body] (fn [state] - (let [output (body (update$ $envs #(|cons (env name) %) state))] + (let [output (body (update$ $envs #(Cons$ (env name) %) state))] (|case output ($Right state* datum) (return* (update$ $envs |tail state*) datum) @@ -723,7 +720,7 @@ (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) + (run-state body* (update$ $envs #(Cons$ (update$ $inner-closures inc (|head %)) (|tail %)) state)))))) @@ -789,10 +786,10 @@ ($Meta _ ($TagS ?module ?tag)) (str "#" ?module ";" ?tag) - ($Meta _ ($SymbolS ?module ?ident)) + ($Meta _ ($SymbolS ?module ?name)) (if (.equals "" ?module) - ?ident - (str ?module ";" ?ident)) + ?name + (str ?module ";" ?name)) ($Meta _ ($TupleS ?elems)) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") @@ -832,7 +829,7 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (|cons z zs))) + (return (Cons$ z zs))) [($Nil) ($Nil)] (return (V $Nil nil)) @@ -843,7 +840,7 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (|cons (f x y) (map2 f xs* ys*)) + (Cons$ (f x y) (map2 f xs* ys*)) [_ _] (V $Nil nil))) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 54a7c5e0c..0d0300844 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -21,6 +21,11 @@ (&/T (&/V &a/$tuple members) &type/$Void)) +(defn ^:private int$ [value] + "(-> Int Analysis)" + (&/T (&/V &a/$int value) + &type/$Void)) + (defn ^:private text$ [text] "(-> Text Analysis)" (&/T (&/V &a/$text text) @@ -58,20 +63,16 @@ (&/$LambdaT ?input ?output) (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - (&/$AllT ?env ?name ?arg ?body) - (variant$ &/$AllT + (&/$UnivQ ?env ?body) + (variant$ &/$UnivQ (tuple$ (&/|list (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) + (Cons$ (->analysis head) tail)) $Nil (&/|reverse ?env)) - (text$ ?name) - (text$ ?arg) (->analysis ?body)))) - (&/$BoundT ?name) - (variant$ &/$BoundT (text$ ?name)) + (&/$BoundT ?idx) + (variant$ &/$BoundT (int$ ?idx)) (&/$AppT ?fun ?arg) (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index aa845c09d..0fcb5097b 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -33,7 +33,7 @@ output) ($Yes output line*) - (return* (&/set$ &/$source (&/|cons line* more) state) + (return* (&/set$ &/$source (&/Cons$ line* more) state) output)) ))) @@ -117,7 +117,7 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) + (&/V &/$Right (&/T (&/Cons$ (&/T (&/T file-name line-num column-num*) line) reader**) (&/T (&/T file-name line-num column-num) (str prefix match)))))) (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index bcef74475..2b06553c3 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -40,8 +40,8 @@ (defn Variant$ [members] ;; (assert (|list? members)) (&/V &/$VariantT members)) -(defn All$ [env name arg body] - (&/V &/$AllT (&/T env name arg body))) +(defn Univ$ [env body] + (&/V &/$UnivQ (&/T env body))) (defn Named$ [name type] (&/V &/$NamedT (&/T name type))) @@ -57,91 +57,90 @@ (def IO (Named$ (&/T "lux/data" "IO") - (All$ empty-env "IO" "a" - (Lambda$ Unit (Bound$ "a"))))) + (Univ$ empty-env + (Lambda$ Unit (Bound$ 1))))) (def List (Named$ (&/T "lux" "List") - (All$ empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - ))))) + (Univ$ empty-env + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ 1) + (App$ (Bound$ 0) + (Bound$ 1)))) + ))))) (def Maybe (Named$ (&/T "lux" "Maybe") - (All$ empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - ))))) + (Univ$ empty-env + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ 1) + ))))) (def Type (Named$ (&/T "lux" "Type") - (let [Type (App$ (Bound$ "Type") (Bound$ "_")) + (let [Type (App$ (Bound$ 0) (Bound$ 1)) TypeList (App$ List Type) - TypeEnv (App$ List (Tuple$ (&/|list Text Type))) TypePair (Tuple$ (&/|list Type Type))] - (App$ (All$ empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; VariantT - TypeList - ;; TupleT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list TypeEnv Text Text Type)) - ;; AppT - TypePair - ;; NamedT - (Tuple$ (&/|list Ident Type)) - ))) + (App$ (Univ$ empty-env + (Variant$ (&/|list + ;; DataT + Text + ;; VariantT + TypeList + ;; TupleT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Int + ;; VarT + Int + ;; ExT + Int + ;; UnivQ + (Tuple$ (&/|list TypeList Type)) + ;; AppT + TypePair + ;; NamedT + (Tuple$ (&/|list Ident Type)) + ))) $Void)))) (def Bindings (Named$ (&/T "lux" "Bindings") - (All$ empty-env "lux;Bindings" "k" - (All$ empty-env "" "v" - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v")))))))))) + (Univ$ empty-env + (Univ$ empty-env + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ 3) + (Bound$ 1)))))))))) (def Env (Named$ (&/T "lux" "Env") - (let [bindings (App$ (App$ Bindings (Bound$ "k")) - (Bound$ "v"))] - (All$ empty-env "lux;Env" "k" - (All$ empty-env "" "v" - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - ))))))) + (let [bindings (App$ (App$ Bindings (Bound$ 3)) + (Bound$ 1))] + (Univ$ empty-env + (Univ$ empty-env + (Tuple$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + ))))))) (def Cursor (Named$ (&/T "lux" "Cursor") @@ -149,42 +148,42 @@ (def Meta (Named$ (&/T "lux" "Meta") - (All$ empty-env "lux;Meta" "m" - (All$ empty-env "" "v" - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ "m") - (Bound$ "v"))))))))) + (Univ$ empty-env + (Univ$ empty-env + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ 3) + (Bound$ 1))))))))) (def AST* (Named$ (&/T "lux" "AST'") - (let [AST* (App$ (Bound$ "w") - (App$ (Bound$ "lux;AST'") - (Bound$ "w"))) + (let [AST* (App$ (Bound$ 1) + (App$ (Bound$ 0) + (Bound$ 1))) AST*List (App$ List AST*)] - (All$ empty-env "lux;AST'" "w" - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - ))))) + (Univ$ empty-env + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + ))))) (def AST (Named$ (&/T "lux" "AST") @@ -195,21 +194,21 @@ (def Either (Named$ (&/T "lux" "Either") - (All$ empty-env "lux;Either" "l" - (All$ empty-env "" "r" - (Variant$ (&/|list - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r"))))))) + (Univ$ empty-env + (Univ$ empty-env + (Variant$ (&/|list + ;; &/$Left + (Bound$ 3) + ;; &/$Right + (Bound$ 1))))))) (def StateE - (All$ empty-env "lux;StateE" "s" - (All$ empty-env "" "a" - (Lambda$ (Bound$ "s") - (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ "s") - (Bound$ "a")))))))) + (Univ$ empty-env + (Univ$ empty-env + (Lambda$ (Bound$ 3) + (App$ (App$ Either Text) + (Tuple$ (&/|list (Bound$ 3) + (Bound$ 1)))))))) (def Source (Named$ (&/T "lux" "Source") @@ -229,17 +228,17 @@ (Data$ "clojure.lang.Atom"))))) (def DefData* - (All$ empty-env "lux;DefData'" "" - (Variant$ (&/|list - ;; "lux;ValueD" - (Tuple$ (&/|list Type Unit)) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ "") - ;; "lux;AliasD" - Ident - )))) + (Univ$ empty-env + (Variant$ (&/|list + ;; "lux;ValueD" + (Tuple$ (&/|list Type Unit)) + ;; "lux;TypeD" + Type + ;; "lux;MacroD" + (Bound$ 1) + ;; "lux;AliasD" + Ident + )))) (def LuxVar (Named$ (&/T "lux" "LuxVar") @@ -250,63 +249,63 @@ Ident)))) (def $Module - (All$ empty-env "lux;$Module" "Compiler" - (Tuple$ - (&/|list - ;; "lux;module-aliases" - (App$ List (Tuple$ (&/|list Text Text))) - ;; "lux;defs" - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Int - (App$ List Ident) - Type))))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list (App$ List Ident) - Type))))) - )))) + (Univ$ empty-env + (Tuple$ + (&/|list + ;; "lux;module-aliases" + (App$ List (Tuple$ (&/|list Text Text))) + ;; "lux;defs" + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ 1)) + ASTList)))))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (, Int (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Int + (App$ List Ident) + Type))))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list (App$ List Ident) + Type))))) + )))) (def $Compiler (Named$ (&/T "lux" "Compiler") - (App$ (All$ empty-env "lux;Compiler" "" - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) + (App$ (Univ$ empty-env + (Tuple$ + (&/|list + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ 0) (Bound$ 1)))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + ))) $Void))) (def Macro @@ -439,13 +438,10 @@ (|do [=members (&/map% (partial clean* ?tid) ?members)] (return (Variant$ =members))) - (&/$AllT ?env ?name ?arg ?body) - (|do [=env (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?env) + (&/$UnivQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) body* (clean* ?tid ?body)] - (return (All$ =env ?name ?arg body*))) + (return (Univ$ =env body*))) _ (return type) @@ -463,7 +459,7 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/T ??out (&/|cons ?in ?args))) + (&/T ??out (&/Cons$ ?in ?args))) _ (&/T type (&/|list)))) @@ -505,26 +501,16 @@ (&/$ExT ?id) (str "⟨" ?id "⟩") - (&/$BoundT name) - name + (&/$BoundT idx) + (str idx) (&/$AppT _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - (&/$AllT ?env ?name ?arg ?body) - (if (= "" ?name) - (let [[args body] (loop [args (list ?arg) - body* ?body] - (|case body* - (&/$AllT ?env* ?name* ?arg* ?body*) - (recur (cons ?arg* args) ?body*) - - _ - [args body*]))] - (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) - ?name) - + (&/$UnivQ ?env ?body) + (str "(All " (show-type ?body) ")") + (&/$NamedT ?name ?type) (&/ident->text ?name) @@ -554,8 +540,8 @@ [(&/$VarT xid) (&/$VarT yid)] (.equals ^Object xid yid) - [(&/$BoundT xname) (&/$BoundT yname)] - (.equals ^Object xname yname) + [(&/$BoundT xidx) (&/$BoundT yidx)] + (= xidx yidx) [(&/$ExT xid) (&/$ExT yid)] (.equals ^Object xid yid) @@ -563,24 +549,8 @@ [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [(&/$AllT xenv xname xarg xbody) (&/$AllT yenv yname yarg ybody)] - (and (.equals ^Object xname yname) - (.equals ^Object xarg yarg) - ;; (matchv ::M/objects [xenv yenv] - ;; [[&/$None _] [&/$None _]] - ;; true - - ;; [[&/$Some xenv*] [&/$Some yenv*]] - ;; (&/fold (fn [old bname] - ;; (and old - ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) - ;; (= (&/|length xenv*) (&/|length yenv*)) - ;; (&/|keys xenv*)) - - ;; [_ _] - ;; false) - (type= xbody ybody) - ) + [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] + (type= xbody ybody) [(&/$NamedT ?xname ?xtype) _] (type= ?xtype y) @@ -607,14 +577,18 @@ ))) (defn ^:private fp-put [k v fixpoints] - (&/|cons (&/T k v) fixpoints)) + (&/Cons$ (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) "\n\nActual: " (show-type actual) "\n")) +;; (def !flag (atom false)) + (defn beta-reduce [env type] + ;; (when @!flag + ;; (prn 'beta-reduce (show-type type))) (|case type (&/$VariantT ?members) (Variant$ (&/|map (partial beta-reduce env) ?members)) @@ -625,10 +599,10 @@ (&/$AppT ?type-fn ?type-arg) (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - (&/$AllT ?local-env ?local-name ?local-arg ?local-def) + (&/$UnivQ ?local-env ?local-def) (|case ?local-env (&/$Nil) - (All$ env ?local-name ?local-arg ?local-def) + (Univ$ env ?local-def) _ type) @@ -636,21 +610,26 @@ (&/$LambdaT ?input ?output) (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output)) - (&/$BoundT ?name) - (if-let [bound (&/|get ?name env)] + (&/$BoundT ?idx) + (|case (&/|at ?idx env) + (&/$Some bound) (beta-reduce env bound) - type) + + _ + (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env))))) _ type )) (defn apply-type [type-fn param] + ;; (when @!flag + ;; (prn 'apply-type (show-type type-fn) (show-type param))) (|case type-fn - (&/$AllT local-env local-name local-arg local-def) + (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env - (&/|put local-name type-fn) - (&/|put local-arg param)) + (&/Cons$ param) + (&/Cons$ type-fn)) local-def)) (&/$AppT F A) @@ -839,13 +818,13 @@ (|do [actual* (apply-type F A)] (check* class-loader fixpoints expected actual*)) - [(&/$AllT _) _] + [(&/$UnivQ _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] (check* class-loader fixpoints expected* actual)))) - [_ (&/$AllT _)] + [_ (&/$UnivQ _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] @@ -910,7 +889,7 @@ (|do [_ (check* init-fixpoints input param)] (return output)) - (&/$AllT _) + (&/$UnivQ _) (with-var (fn [$var] (|do [func* (apply-type func $var) -- cgit v1.2.3 From cc928a8675cb35dabd4a4957ab6612b70f015d58 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 18:12:27 -0400 Subject: - Removed the (unnecessary) lux/data/cont module. - Removed the (unnecessary) lux/data/error module and moved it's structures to lux/data/either. - Implemented the \slots destructurer for records. - Implemented quicksort for lists as the "sort" function in lux/data/list. - Added tags for the Cursor type. --- source/lux.lux | 45 +++++++++++++++++++++++++++++++++++++++++---- source/lux/data/cont.lux | 38 -------------------------------------- source/lux/data/either.lux | 42 +++++++++++++++++++++++++++++++----------- source/lux/data/error.lux | 31 ------------------------------- source/lux/data/list.lux | 24 +++++++++++++++++++++--- src/lux/compiler/io.clj | 2 +- 6 files changed, 94 insertions(+), 88 deletions(-) delete mode 100644 source/lux/data/cont.lux delete mode 100644 source/lux/data/error.lux diff --git a/source/lux.lux b/source/lux.lux index d96b18fcb..cf56f326a 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -160,6 +160,7 @@ (#NamedT ["lux" "Cursor"] (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) (_lux_export Cursor) +(_lux_declare-tags [#module #line #column] Cursor) ## (deftype (Meta m v) ## (| (#Meta m v))) @@ -785,8 +786,8 @@ (#Meta _ (#RecordS pairs)) (record$ (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) (lambda'' [pair] - (let'' [name val] pair - [name (update-bounds val)]))) + (let'' [name val] pair + [name (update-bounds val)]))) pairs)) (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "lux" "BoundT")) (#Cons (#Meta _ (#IntS idx)) #Nil)))) @@ -931,8 +932,8 @@ (def''' (as-pairs xs) (All' [a] (->' ($' List a) ($' List (#TupleT (list a a))))) (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) + (#Cons x (#Cons y xs')) + (#Cons [x y] (as-pairs xs')) _ #Nil)) @@ -3224,3 +3225,39 @@ (defmacro #export (export tokens) (return (map (lambda [token] (` (_lux_export (~ token)))) tokens))) + +(defmacro #export (\slots tokens) + (case tokens + (\ (list body (#Meta _ (#TupleS (list& hslot' tslots'))))) + (do Lux/Monad + [slots (: (Lux (, Ident (List Ident))) + (case (: (Maybe (, Ident (List Ident))) + (do Maybe/Monad + [hslot (get-ident hslot') + tslots (map% Maybe/Monad get-ident tslots')] + (wrap [hslot tslots]))) + (#Some slots) + (return slots) + + #None + (fail "Wrong syntax for \\slots"))) + #let [[hslot tslots] slots] + hslot (normalize hslot) + tslots (map% Lux/Monad normalize tslots) + output (resolve-tag hslot) + g!_ (gensym "_") + #let [[idx tags type] output + slot-pairings (map (: (-> Ident (, Text AST)) + (lambda [[module name]] [name (symbol$ ["" name])])) + (list& hslot tslots)) + pattern (record$ (map (: (-> Ident (, AST AST)) + (lambda [[module name]] + (let [tag (tag$ [module name])] + (case (get name slot-pairings) + (#Some binding) [tag binding] + #None [tag g!_])))) + tags))]] + (return (list pattern body))) + + _ + (fail "Wrong syntax for \\slots"))) diff --git a/source/lux/data/cont.lux b/source/lux/data/cont.lux deleted file mode 100644 index 2c55eb641..000000000 --- a/source/lux/data/cont.lux +++ /dev/null @@ -1,38 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Cont r a) - (-> (-> a r) r)) - -## [Structures] -(defstruct #export Cont/Functor (All [r] - (Functor (Cont r))) - (def (F;map f fa) - (lambda [k] - (k (fa f))))) - -(defstruct #export Cont/Monad (All [r] - (Monad (Cont r))) - (def M;_functor Cont/Functor) - - (def (M;wrap x) - (lambda [k] - (k x))) - - (def (M;join mma) - (lambda [k] - (mma (lambda [ma] (ma k)))))) - -## [Functions] -(def #export (call/cc body) - (All [r a b] - (-> (-> (-> a (Cont r b)) (Cont r a)) (Cont r a))) - (lambda [k] - (body k))) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux index a945c32b9..86d778965 100644 --- a/source/lux/data/either.lux +++ b/source/lux/data/either.lux @@ -4,7 +4,9 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux/data (list #refer (#exclude partition)))) + (lux (control (functor #as F #refer #all) + (monad #as M #refer #all)) + (data (list #refer (#exclude partition))))) ## [Types] ## (deftype (Either l r) @@ -30,14 +32,32 @@ [rights b #;Right] ) -(def #export (partition es) +(def #export (partition xs) (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) - (foldL (: (All [a b] - (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) - (lambda [tails e] - (let [[ltail rtail] tails] - (case e - (#;Left x) [(#;Cons [x ltail]) rtail] - (#;Right x) [ltail (#;Cons [x rtail])])))) - [(list) (list)] - (reverse es))) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons x xs') + (let [[lefts rights] (partition xs')] + (case x + (#;Left x') [(#;Cons x' lefts) rights] + (#;Right x') [lefts (#;Cons x' rights)])))) + +## [Structures] +(defstruct #export Error/Functor (All [a] (Functor (Either a))) + (def (F;map f ma) + (case ma + (#;Left msg) (#;Left msg) + (#;Right datum) (#;Right (f datum))))) + +(defstruct #export Error/Monad (All [a] (Monad (Either a))) + (def M;_functor Error/Functor) + + (def (M;wrap a) + (#;Right a)) + + (def (M;join mma) + (case mma + (#;Left msg) (#;Left msg) + (#;Right ma) ma))) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux deleted file mode 100644 index 9c595144b..000000000 --- a/source/lux/data/error.lux +++ /dev/null @@ -1,31 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux/control (functor #as F #refer #all) - (monad #as M #refer #all))) - -## [Types] -(deftype #export (Error a) - (| (#Fail Text) - (#Ok a))) - -## [Structures] -(defstruct #export Error/Functor (Functor Error) - (def (F;map f ma) - (case ma - (#Fail msg) (#Fail msg) - (#Ok datum) (#Ok (f datum))))) - -(defstruct #export Error/Monad (Monad Error) - (def M;_functor Error/Functor) - - (def (M;wrap a) - (#Ok a)) - - (def (M;join mma) - (case mma - (#Fail msg) (#Fail msg) - (#Ok ma) ma))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index a4a6a6d0e..1277fc6ae 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -8,6 +8,7 @@ (functor #as F #refer #all) (monad #as M #refer #all) (eq #as E) + (ord #as O) (dict #as D #refer #all) (stack #as S)) (data (number (int #open ("i" Int/Number Int/Ord))) @@ -248,9 +249,12 @@ ## [#;Nil #;Nil] ## true -## [(#;Cons [x xs']) (#;Cons [y ys'])] +## [(#;Cons x xs') (#;Cons y ys')] ## (and (:: eq (E;= x y)) ## (E;= xs' ys')) + +## [_ _] +## false ## ))) (defstruct #export List/Monoid (All [a] @@ -258,8 +262,8 @@ (def m;unit #;Nil) (def (m;++ xs ys) (case xs - #;Nil ys - (#;Cons [x xs']) (#;Cons [x (++ xs' ys)])))) + #;Nil ys + (#;Cons x xs') (#;Cons x (++ xs' ys))))) (defstruct #export List/Functor (Functor List) (def (F;map f ma) @@ -327,3 +331,17 @@ (case xs #;Nil #;None (#;Cons x xs') (#;Some x)))) + +## [Functions] +(def #export (sort ord xs) + (All [a] (-> (O;Ord a) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons x xs') + (using ord + (let [pre (filter (>= x) xs') + post (filter (< x) xs') + ++ (:: List/Monoid m;++)] + ($ ++ (sort ord pre) (list x) (sort ord post)))))) diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index e72f34a7b..93be57f17 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -12,4 +12,4 @@ (let [file (new java.io.File path)] (if (.exists file) (return (slurp file)) - (fail (str "[I/O] File doesn't exist: " path))))) + (fail (str "[I/O Error] File doesn't exist: " path))))) -- cgit v1.2.3 From 253d5a4a3f7ef5d42c467733e394a28d18a4d9b3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 19:39:10 -0400 Subject: - Added some compiler optimizations. - Removed the (unnecessary) lux/control/dict & lux/control/stack modules. - The "Meta" type is now a record instead of a variant. --- source/lux.lux | 342 +++++++++++++++++++++-------------------- source/lux/codata/stream.lux | 2 +- source/lux/control/comonad.lux | 4 +- source/lux/control/dict.lux | 18 --- source/lux/control/monad.lux | 6 +- source/lux/control/stack.lux | 20 --- source/lux/data/list.lux | 76 +-------- source/lux/data/text.lux | 2 +- source/lux/host/jvm.lux | 8 +- source/lux/meta/ast.lux | 2 +- source/lux/meta/lux.lux | 8 +- source/lux/meta/macro.lux | 16 +- source/lux/meta/syntax.lux | 18 +-- src/lux/analyser.clj | 314 ++++++++++++++++++------------------- src/lux/analyser/case.clj | 8 +- src/lux/analyser/host.clj | 56 +++---- src/lux/analyser/lux.clj | 6 - src/lux/analyser/record.clj | 4 +- src/lux/base.clj | 24 ++- src/lux/lexer.clj | 18 +-- src/lux/parser.clj | 26 ++-- src/lux/type.clj | 10 +- 22 files changed, 444 insertions(+), 544 deletions(-) delete mode 100644 source/lux/control/dict.lux delete mode 100644 source/lux/control/stack.lux diff --git a/source/lux.lux b/source/lux.lux index cf56f326a..422fb4fad 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -155,7 +155,9 @@ (_lux_declare-tags [#name #inner-closures #locals #closure] Env) ## (deftype Cursor -## (, Text Int Int)) +## (& #module Text +## #line Int +## #column Int)) (_lux_def Cursor (#NamedT ["lux" "Cursor"] (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) @@ -163,18 +165,17 @@ (_lux_declare-tags [#module #line #column] Cursor) ## (deftype (Meta m v) -## (| (#Meta m v))) +## (& #meta m +## #datum v)) (_lux_def Meta (#NamedT ["lux" "Meta"] (#UnivQ #Nil (#UnivQ #Nil - (#VariantT (#Cons ## "lux;Meta" - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) - #Nil))) - #Nil)))))) + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) + #Nil))))))) (_lux_export Meta) -(_lux_declare-tags [#Meta] Meta) +(_lux_declare-tags [#meta #datum] Meta) ## (deftype (AST' w) ## (| (#BoolS Bool) @@ -414,13 +415,13 @@ ## (def (_meta data) ## (-> (AST' (Meta Cursor)) AST) -## (#Meta [["" -1 -1] data])) +## [["" -1 -1] data]) (_lux_def _meta (_lux_: (#LambdaT (#AppT AST' (#AppT Meta Cursor)) AST) (_lux_lambda _ data - (#Meta _cursor data)))) + [_cursor data]))) ## (def (return x) ## (All [a] @@ -523,7 +524,7 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)) + (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS "" "")) (#Cons arg @@ -538,7 +539,7 @@ #Nil)))))) #Nil)) - (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))) + (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS self)) (#Cons arg @@ -561,8 +562,8 @@ (_lux_: Macro (lambda'' [tokens] (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name @@ -577,7 +578,7 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -588,7 +589,7 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name @@ -620,7 +621,7 @@ (def'' (defmacro tokens) Macro (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) @@ -630,7 +631,7 @@ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(tag$ ["" "export"]) (#Cons [(form$ (#Cons [name args])) @@ -730,7 +731,7 @@ (def'' (replace-syntax reps syntax) (->' RepEnv AST AST) (_lux_case syntax - (#Meta _ (#SymbolS "" name)) + [_ (#SymbolS "" name)] (_lux_case (get-rep name reps) (#Some replacement) replacement @@ -738,19 +739,19 @@ #None syntax) - (#Meta _ (#FormS parts)) - (#Meta _ (#FormS (map (replace-syntax reps) parts))) + [meta (#FormS parts)] + [meta (#FormS (map (replace-syntax reps) parts))] - (#Meta _ (#TupleS members)) - (#Meta _ (#TupleS (map (replace-syntax reps) members))) + [meta (#TupleS members)] + [meta (#TupleS (map (replace-syntax reps) members))] - (#Meta _ (#RecordS slots)) - (#Meta _ (#RecordS (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) - (lambda'' [slot] - (_lux_case slot - [k v] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))) + [meta (#RecordS slots)] + [meta (#RecordS (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) + (lambda'' [slot] + (_lux_case slot + [k v] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))] _ syntax) @@ -759,47 +760,47 @@ (def'' (update-bounds ast) (->' AST AST) (_lux_case ast - (#Meta _ (#BoolS value)) + [_ (#BoolS value)] (bool$ value) - (#Meta _ (#IntS value)) + [_ (#IntS value)] (int$ value) - (#Meta _ (#RealS value)) + [_ (#RealS value)] (real$ value) - (#Meta _ (#CharS value)) + [_ (#CharS value)] (char$ value) - (#Meta _ (#TextS value)) + [_ (#TextS value)] (text$ value) - (#Meta _ (#SymbolS value)) + [_ (#SymbolS value)] (symbol$ value) - (#Meta _ (#TagS value)) + [_ (#TagS value)] (tag$ value) - (#Meta _ (#TupleS members)) + [_ (#TupleS members)] (tuple$ (map update-bounds members)) - (#Meta _ (#RecordS pairs)) + [_ (#RecordS pairs)] (record$ (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) (lambda'' [pair] (let'' [name val] pair [name (update-bounds val)]))) pairs)) - (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "lux" "BoundT")) (#Cons (#Meta _ (#IntS idx)) #Nil)))) + [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#IntS idx)] #Nil)))] (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ (_jvm_ladd 2 idx)) #Nil))) - (#Meta _ (#FormS members)) + [_ (#FormS members)] (form$ (map update-bounds members))) ) (defmacro (All' tokens) (_lux_case tokens - (#Cons (#Meta _ (#TupleS (#Cons (#Meta _ (#SymbolS "" arg-name)) other-args))) + (#Cons [_ (#TupleS (#Cons [_ (#SymbolS "" arg-name)] other-args))] (#Cons body #Nil)) (let'' bound-var (_meta (#FormS (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ 1) #Nil)))) (let'' body' (replace-syntax (#Cons [arg-name bound-var] #Nil) @@ -860,13 +861,13 @@ (defmacro (lambda' tokens) (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + (#Cons [[_ (#SymbolS name)] tokens']) [name tokens'] _ [["" ""] tokens])) (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) (_lux_case args #Nil (fail "lambda' requires a non-empty arguments tuple.") @@ -888,8 +889,8 @@ (defmacro (def''' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -901,7 +902,7 @@ body)))))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) @@ -909,7 +910,7 @@ body)))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -940,7 +941,7 @@ (defmacro (let' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) AST) (lambda' [body binding] @@ -968,7 +969,7 @@ (def''' (spliced? token) (->' AST Bool) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] true _ @@ -976,9 +977,8 @@ (def''' (wrap-meta content) (->' AST AST) - (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content))))))) + (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1))) + content))) (def''' (untemplate-list tokens) (->' ($' List AST) AST) @@ -1017,7 +1017,7 @@ true (let' [elems' (map (lambda' [elem] (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] spliced _ @@ -1039,22 +1039,22 @@ (def''' (untemplate replace? subst token) (->' Bool Text AST AST) (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) - [_ (#Meta [_ (#BoolS value)])] + [_ [_ (#BoolS value)]] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - [_ (#Meta [_ (#IntS value)])] + [_ [_ (#IntS value)]] (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - [_ (#Meta [_ (#RealS value)])] + [_ [_ (#RealS value)]] (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - [_ (#Meta [_ (#CharS value)])] + [_ [_ (#CharS value)]] (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - [_ (#Meta [_ (#TextS value)])] + [_ [_ (#TextS value)]] (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - [_ (#Meta [_ (#TagS [module name])])] + [_ [_ (#TagS [module name])]] (let' [module' (_lux_case module "" subst @@ -1063,7 +1063,7 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ (#Meta [_ (#SymbolS [module name])])] + [_ [_ (#SymbolS [module name])]] (let' [module' (_lux_case module "" subst @@ -1072,17 +1072,17 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ (#Meta [_ (#TupleS elems)])] + [_ [_ (#TupleS elems)]] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] unquoted - [_ (#Meta [meta (#FormS elems)])] - (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - (#Meta [meta form'])) + [_ [meta (#FormS elems)]] + (let' [[_ form'] (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + [meta form']) - [_ (#Meta [_ (#RecordS fields)])] + [_ [_ (#RecordS fields)]] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) (lambda' [kv] @@ -1110,16 +1110,17 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (lambda' [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [acc app] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (list:++ parts (list acc))) - (#Meta [_ (#FormS parts)]) - (form$ (list:++ parts (list acc))) + [_ (#FormS parts)] + (form$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) + _ + (`' ((~ app) (~ acc)))))) init apps))) @@ -1189,7 +1190,7 @@ (defmacro #export (^ tokens) (_lux_case tokens - (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil) + (#Cons [_ (#SymbolS "" class-name)] #Nil) (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ @@ -1198,7 +1199,8 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons output inputs) - (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [o i] (`' (#;LambdaT (~ i) (~ o))))) output inputs))) @@ -1210,12 +1212,12 @@ (defmacro (do tokens) (_lux_case tokens - (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) + (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var - (#Meta _ (#TagS "" "let")) + [_ (#TagS "" "let")] (`' (;let' (~ value) (~ body'))) _ @@ -1261,7 +1263,7 @@ (def''' (get-ident x) (-> AST ($' Maybe Ident)) (_lux_case x - (#Meta _ (#SymbolS sname)) + [_ (#SymbolS sname)] (#Some sname) _ @@ -1270,7 +1272,7 @@ (def''' (get-name x) (-> AST ($' Maybe Text)) (_lux_case x - (#Meta _ (#SymbolS "" sname)) + [_ (#SymbolS "" sname)] (#Some sname) _ @@ -1279,7 +1281,7 @@ (def''' (tuple->list tuple) (-> AST ($' Maybe ($' List AST))) (_lux_case tuple - (#Meta _ (#TupleS members)) + [_ (#TupleS members)] (#Some members) _ @@ -1288,7 +1290,7 @@ (def''' (apply-template env template) (-> RepEnv AST AST) (_lux_case template - (#Meta _ (#SymbolS "" sname)) + [_ (#SymbolS "" sname)] (_lux_case (get-rep sname env) (#Some subst) subst @@ -1296,13 +1298,13 @@ _ template) - (#Meta _ (#TupleS elems)) + [_ (#TupleS elems)] (tuple$ (map (apply-template env) elems)) - (#Meta _ (#FormS elems)) + [_ (#FormS elems)] (form$ (map (apply-template env) elems)) - (#Meta _ (#RecordS members)) + [_ (#RecordS members)] (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] @@ -1324,7 +1326,7 @@ (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) @@ -1413,19 +1415,20 @@ (defmacro #export (All tokens) (let' [[self-name tokens] (_lux_: (, Text ASTList) (_lux_case tokens - (#Cons (#Meta _ (#SymbolS "" self-name)) tokens) + (#Cons [_ (#SymbolS "" self-name)] tokens) [self-name tokens] _ ["" tokens]))] (_lux_case tokens - (#Cons (#Meta _ (#TupleS (#Cons harg targs))) (#Cons body #Nil)) + (#Cons [_ (#TupleS (#Cons harg targs))] (#Cons body #Nil)) (_lux_case (map% Maybe/Monad get-name (#Cons harg targs)) (#Some names) - (let' [body' (foldL (lambda' [body' name'] - (`' (#;UnivQ #;Nil (~ (|> body' - (update-bounds) - (replace-syntax (list [name' (make-bound 1)]))))))) + (let' [body' (foldL (_lux_: (-> AST Text AST) + (lambda' [body' name'] + (`' (#;UnivQ #;Nil (~ (|> body' + (update-bounds) + (replace-syntax (list [name' (make-bound 1)])))))))) (replace-syntax (list [self-name (make-bound -2)]) body) names)] @@ -1547,7 +1550,7 @@ (def''' (macro-expand token) (-> AST ($' Lux ($' List AST))) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1567,7 +1570,7 @@ (def''' (macro-expand-all syntax) (-> AST ($' Lux ($' List AST))) (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1583,13 +1586,13 @@ [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (wrap (list (form$ (list:join parts'))))))) - (#Meta [_ (#FormS (#Cons [harg targs]))]) + [_ (#FormS (#Cons [harg targs]))] (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (map% Lux/Monad macro-expand-all targs)] (wrap (list (form$ (list:++ harg+ (list:join targs+)))))) - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (do Lux/Monad [members' (map% Lux/Monad macro-expand-all members)] (wrap (list (tuple$ (list:join members'))))) @@ -1600,14 +1603,15 @@ (def''' (walk-type type) (-> AST AST) (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))] (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (tuple$ (map walk-type members)) - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + [_ (#FormS (#Cons [type-fn args]))] + (foldL (_lux_: (-> AST AST AST) + (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) (walk-type type-fn) (map walk-type args)) @@ -1662,16 +1666,16 @@ (def''' (unfold-type-def type) (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) (_lux_case type - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "|")) cases))) + [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))] (do Lux/Monad [members (map% Lux/Monad (: (-> AST ($' Lux (, Text AST))) (lambda' [case] (_lux_case case - (#Meta _ (#TagS "" member-name)) + [_ (#TagS "" member-name)] (return [member-name (`' Unit)]) - (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "" member-name)) (#Cons member-type #Nil)))) + [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] (return [member-name member-type]) _ @@ -1683,13 +1687,13 @@ (map (: (-> Text AST) (lambda' [name] (tag$ ["" name]))))))])) - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "&")) pairs))) + [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))] (do Lux/Monad [members (map% Lux/Monad (: (-> (, AST AST) ($' Lux (, Text AST))) (lambda' [pair] (_lux_case pair - [(#Meta _ (#TagS "" member-name)) member-type] + [[_ (#TagS "" member-name)] member-type] (return [member-name member-type]) _ @@ -1707,24 +1711,24 @@ (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) [rec? tokens'] (: (, Bool (List AST)) (_lux_case tokens' - (#Cons (#Meta _ (#TagS "" "rec")) tokens') + (#Cons [_ (#TagS "" "rec")] tokens') [true tokens'] _ [false tokens'])) parts (: (Maybe (, Text (List AST) AST)) (_lux_case tokens' - (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) + (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) (#Some name #Nil type) - (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil)) + (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil)) (#Some name args type) _ @@ -1780,7 +1784,8 @@ (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] - (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + (return (list (foldL (_lux_: (-> AST AST AST) + (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) value actions)))) @@ -1790,20 +1795,20 @@ (defmacro (def' tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (_lux_case tokens' - (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) + (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) (#Some name args (#Some type) body) (#Cons name (#Cons type (#Cons body #Nil))) (#Some name #Nil (#Some type) body) - (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil)) + (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) (#Some name args #None body) (#Cons name (#Cons body #Nil)) @@ -1849,7 +1854,7 @@ (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] (do Lux/Monad [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] @@ -1908,7 +1913,7 @@ (def' (symbol? ast) (-> AST Bool) (case ast - (#Meta _ (#SymbolS _)) + [_ (#SymbolS _)] true _ @@ -1916,7 +1921,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list (#Meta _ (#TupleS bindings)) body)) + (\ (list [_ (#TupleS bindings)] body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> AST (, AST AST) AST) @@ -1936,7 +1941,7 @@ (def' (ast:show ast) (-> AST Text) (case ast - (#Meta _ ast) + [_ ast] (case ast (\or (#BoolS val) (#IntS val) (#RealS val)) (->text val) @@ -1972,10 +1977,10 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens - (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) + (\ (list [_ (#TupleS (#Cons head tail))] body)) (#Some ["" ""] head tail body) - (\ (list (#Meta _ (#SymbolS [_ name])) (#Meta _ (#TupleS (#Cons head tail))) body)) + (\ (list [_ (#SymbolS [_ name])] [_ (#TupleS (#Cons head tail))] body)) (#Some ["" name] head tail body) _ @@ -2001,20 +2006,20 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' - (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) + (\ (list [_ (#FormS (#Cons name args))] type body)) (#Some name args (#Some type) body) (\ (list name type body)) (#Some name #Nil (#Some type) body) - (\ (list (#Meta _ (#FormS (#Cons name args))) body)) + (\ (list [_ (#FormS (#Cons name args))] body)) (#Some name args #None body) (\ (list name body)) @@ -2062,17 +2067,17 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& (#Meta _ (#TagS "" "export")) tokens')) + (\ (list& [_ (#TagS "" "export")] tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& (#Meta _ (#FormS (list& (#Meta _ (#SymbolS name)) args))) sigs)) + (\ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) (#Some name args sigs) - (\ (list& (#Meta _ (#SymbolS name)) sigs)) + (\ (list& [_ (#SymbolS name)] sigs)) (#Some name #Nil sigs) _ @@ -2086,7 +2091,7 @@ (: (-> AST (Lux (, Text AST))) (lambda [token] (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS ["" name])))))) + (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) (wrap (: (, Text AST) [name type])) _ @@ -2380,7 +2385,7 @@ (: (-> AST (Lux (, AST AST))) (lambda [token] (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS tag-name)) value)))) + (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS tag-name)] value))]) (wrap (: (, AST AST) [(tag$ tag-name) value])) _ @@ -2391,14 +2396,14 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& (#Meta _ (#TagS "" "export")) tokens')) + (\ (list& [_ (#TagS "" "export")] tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' - (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) + (\ (list& [_ (#FormS (list& name args))] type defs)) (#Some name args type defs) (\ (list& name type defs)) @@ -2431,7 +2436,8 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (list (foldL (lambda [post pre] (` )) + (return (list (foldL (: (-> AST AST AST) + (lambda [post pre] (` ))) last init))) @@ -2459,7 +2465,7 @@ (: (-> AST (Lux Text)) (lambda [def] (case def - (#Meta _ (#SymbolS "" name)) + [_ (#SymbolS "" name)] (return name) _ @@ -2469,7 +2475,7 @@ (def (parse-alias tokens) (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) + (\ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) _ @@ -2478,17 +2484,17 @@ (def (parse-referrals tokens) (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) + (\ (list& [_ (#TagS "" "refer")] referral tokens')) (case referral - (#Meta _ (#TagS "" "all")) + [_ (#TagS "" "all")] (return (: (, Referrals (List AST)) [#All tokens'])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) + (\ [_ (#FormS (list& [_ (#TagS "" "only")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) - (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) + (\ [_ (#FormS (list& [_ (#TagS "" "exclude")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) @@ -2502,7 +2508,7 @@ (def (extract-symbol syntax) (-> AST (Lux Ident)) (case syntax - (#Meta _ (#SymbolS ident)) + [_ (#SymbolS ident)] (return ident) _ @@ -2511,7 +2517,7 @@ (def (parse-openings tokens) (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) + (\ (list& [_ (#TagS "" "open")] [_ (#FormS (list& [_ (#TextS prefix)] structs))] tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) @@ -2525,10 +2531,10 @@ (: (-> AST (Lux AST)) (lambda [token] (case token - (#Meta _ (#SymbolS "" sub-name)) + [_ (#SymbolS "" sub-name)] (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts)))) + (\ [_ (#FormS (list& [_ (#SymbolS "" sub-name)] parts))]) (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ @@ -2542,10 +2548,10 @@ (: (-> AST (Lux (List Import))) (lambda [token] (case token - (#Meta _ (#SymbolS "" m-name)) + [_ (#SymbolS "" m-name)] (wrap (list [m-name #None #All #None])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) + (\ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2724,10 +2730,11 @@ (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] (wrap ($ list:++ - (list (` (_lux_import (~ (text$ m-name))))) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) + (: (List AST) (list (` (_lux_import (~ (text$ m-name)))))) + (: (List AST) + (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) (map (: (-> Text AST) (lambda [def] (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) @@ -2737,10 +2744,9 @@ (wrap (list:join output'))) _ - (wrap (: (List AST) - (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) - unknowns) - (list (` (import (~@ tokens)))))))))) + (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))) + unknowns) + (: (List AST) (list (` (import (~@ tokens)))))))))) (def (try-both f x1 x2) (All [a b] @@ -2877,7 +2883,7 @@ (case tokens (\ (list struct body)) (case struct - (#Meta _ (#SymbolS name)) + [_ (#SymbolS name)] (do Lux/Monad [struct-type (find-var-type name) output (resolve-type-tags struct-type)] @@ -2939,7 +2945,7 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) record)) + (\ (list [_ (#TagS slot')] record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -2981,11 +2987,11 @@ (defmacro #export (open tokens) (case tokens - (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) + (\ (list& [_ (#SymbolS struct-name)] tokens')) (do Lux/Monad [@module get-module-name #let [prefix (case tokens' - (\ (list (#Meta _ (#TextS prefix)))) + (\ (list [_ (#TextS prefix)])) prefix _ @@ -3028,12 +3034,12 @@ (: (-> AST AST (Lux AST)) (lambda [so-far part] (case part - (#Meta _ (#SymbolS slot)) - (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + [_ (#SymbolS slot)] + (return (: AST (` (get@ (~ (tag$ slot)) (~ so-far))))) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args)))) - (return (` ((get@ (~ (tag$ slot)) (~ so-far)) - (~@ args)))) + (\ [_ (#FormS (list& [_ (#SymbolS slot)] args))]) + (return (: AST (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args))))) _ (fail "Wrong syntax for ::")))) @@ -3045,7 +3051,7 @@ (defmacro #export (set@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) value record)) + (\ (list [_ (#TagS slot')] value record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3080,7 +3086,7 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) fun record)) + (\ (list [_ (#TagS slot')] fun record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3115,9 +3121,9 @@ (defmacro #export (\template tokens) (case tokens - (\ (list (#Meta _ (#TupleS data)) - (#Meta _ (#TupleS bindings)) - (#Meta _ (#TupleS templates)))) + (\ (list [_ (#TupleS data)] + [_ (#TupleS bindings)] + [_ (#TupleS templates)])) (case (: (Maybe (List AST)) (do Maybe/Monad [bindings' (map% Maybe/Monad get-name bindings) @@ -3194,7 +3200,7 @@ (defmacro #export (loop tokens) (case tokens - (\ (list (#Meta _ (#TupleS bindings)) body)) + (\ (list [_ (#TupleS bindings)] body)) (let [pairs (as-pairs bindings) vars (map first pairs) inits (map second pairs)] @@ -3224,11 +3230,11 @@ (fail "Wrong syntax for loop"))) (defmacro #export (export tokens) - (return (map (lambda [token] (` (_lux_export (~ token)))) tokens))) + (return (map (: (-> AST AST) (lambda [token] (` (_lux_export (~ token))))) tokens))) (defmacro #export (\slots tokens) (case tokens - (\ (list body (#Meta _ (#TupleS (list& hslot' tslots'))))) + (\ (list body [_ (#TupleS (list& hslot' tslots'))])) (do Lux/Monad [slots (: (Lux (, Ident (List Ident))) (case (: (Maybe (, Ident (List Ident))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index b4c0e0239..5415213d7 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -128,5 +128,5 @@ #let [patterns+ (: (List AST) (do List/Monad [pattern (l;reverse patterns)] - (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] + (: (List AST) (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))))]] (wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index 6225af338..052b8768d 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -29,12 +29,12 @@ ## [Syntax] (defmacro #export (be tokens state) (case tokens - (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (\ (list monad [_ (#;TupleS bindings)] body)) (let [body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var - (#;Meta [_ (#;TagS ["" "let"])]) + [_ (#;TagS ["" "let"])] (` (;let (~ value) (~ body'))) _ diff --git a/source/lux/control/dict.lux b/source/lux/control/dict.lux deleted file mode 100644 index 0b2069cf3..000000000 --- a/source/lux/control/dict.lux +++ /dev/null @@ -1,18 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## Signatures -(defsig #export (Dict d) - (: (All [k v] - (-> k (d k v) (Maybe v))) - get) - (: (All [k v] - (-> k v (d k v) (d k v))) - put) - (: (All [k v] - (-> k (d k v) (d k v))) - remove)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 707bf7497..df48da863 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -50,15 +50,15 @@ ## [Syntax] (defmacro #export (do tokens state) (case tokens - ## (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) - (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) + ## (\ (list monad [_ (#;TupleS bindings)] body)) + (#;Cons [monad (#;Cons [[_ (#;TupleS bindings)] (#;Cons [body #;Nil])])]) (let [g!map (symbol$ ["" " map "]) g!join (symbol$ ["" " join "]) body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var - (#;Meta [_ (#;TagS ["" "let"])]) + [_ (#;TagS ["" "let"])] (` (;let (~ value) (~ body'))) _ diff --git a/source/lux/control/stack.lux b/source/lux/control/stack.lux deleted file mode 100644 index 206ab5cd7..000000000 --- a/source/lux/control/stack.lux +++ /dev/null @@ -1,20 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Signatures] -(defsig #export (Stack s) - (: (All [a] (s a)) - empty) - (: (All [a] (-> (s a) Bool)) - empty?) - (: (All [a] (-> a (s a) (s a))) - push) - (: (All [a] (-> (s a) (Maybe (s a)))) - pop) - (: (All [a] (-> (s a) (Maybe a))) - top) - ) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 1277fc6ae..10bbb8086 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -8,9 +8,7 @@ (functor #as F #refer #all) (monad #as M #refer #all) (eq #as E) - (ord #as O) - (dict #as D #refer #all) - (stack #as S)) + (ord #as O)) (data (number (int #open ("i" Int/Number Int/Ord))) bool) meta/macro)) @@ -20,15 +18,6 @@ ## (| #Nil ## (#Cons (, a (List a))))) -(deftype #export (PList k v) - (| (#PList (, (E;Eq k) (List (, k v)))))) - -## [Constructors] -(def #export (plist eq) - (All [k v] - (-> (E;Eq k) (PList k v))) - (#PList [eq #;Nil])) - ## [Functions] (def #export (foldL f init xs) (All [a b] @@ -225,17 +214,19 @@ ## [Syntax] (defmacro #export (list xs state) - (#;Right [state (#;Cons [(foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) - (` #;Nil) + (#;Right [state (#;Cons [(foldL (: (-> AST AST AST) + (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)])))) + (: AST (` #;Nil)) (reverse xs)) #;Nil])])) (defmacro #export (list& xs state) (case (reverse xs) (#;Cons [last init]) - (#;Right [state (list (foldL (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)]))) + (#;Right [state (list (foldL (: (-> AST AST AST) + (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)])))) last init))]) @@ -281,57 +272,6 @@ (using List/Monoid (foldL ++ unit mma)))) -(defstruct #export PList/Dict (Dict PList) - (def (D;get k (#PList [eq kvs])) - (loop [kvs kvs] - (case kvs - #;Nil - #;None - - (#;Cons [k' v'] kvs') - (if (:: eq (E;= k k')) - (#;Some v') - (recur kvs'))))) - - (def (D;put k v (#PList [eq kvs])) - (#PList [eq (loop [kvs kvs] - (case kvs - #;Nil - (#;Cons [k v] kvs) - - (#;Cons [k' v'] kvs') - (if (:: eq (E;= k k')) - (#;Cons [k v] kvs') - (#;Cons [k' v'] (recur kvs')))))])) - - (def (D;remove k (#PList [eq kvs])) - (#PList [eq (loop [kvs kvs] - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (recur kvs')]))))]))) - -(defstruct #export List/Stack (S;Stack List) - (def S;empty (list)) - (def (S;empty? xs) - (case xs - #;Nil true - _ false)) - (def (S;push x xs) - (#;Cons x xs)) - (def (S;pop xs) - (case xs - #;Nil #;None - (#;Cons x xs') (#;Some xs'))) - (def (S;top xs) - (case xs - #;Nil #;None - (#;Cons x xs') (#;Some x)))) - ## [Functions] (def #export (sort ord xs) (All [a] (-> (O;Ord a) (List a) (List a))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 3801e9675..0040a96c5 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -166,7 +166,7 @@ (defmacro #export (<> tokens state) (case tokens - (\ (list (#;Meta _ (#;TextS template)))) + (\ (list [_ (#;TextS template)])) (let [++ (symbol$ ["" ""])] (#;Right state (list (` (;let [(~ ++) (;:: Text/Monoid m;++)] (;$ (~ ++) (~@ (unravel-template template)))))))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 9795965bd..40021d8fa 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -96,7 +96,7 @@ (list) (#;Some finally) - (list (` (_jvm_finally (~ finally))))))))))))) + (: (List AST) (list (` (_jvm_finally (~ finally)))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) @@ -166,7 +166,7 @@ (defsyntax #export (.? [field local-symbol^] obj) (case obj - (#;Meta [_ (#;SymbolS obj-name)]) + [_ (#;SymbolS obj-name)] (do Lux/Monad [obj-type (find-var-type obj-name)] (case obj-type @@ -184,7 +184,7 @@ (defsyntax #export (.= [field local-symbol^] value obj) (case obj - (#;Meta [_ (#;SymbolS obj-name)]) + [_ (#;SymbolS obj-name)] (do Lux/Monad [obj-type (find-var-type obj-name)] (case obj-type @@ -203,7 +203,7 @@ (defsyntax #export (.! [call method-call^] obj) (let [[m-name ?m-classes m-args] call] (case obj - (#;Meta [_ (#;SymbolS obj-name)]) + [_ (#;SymbolS obj-name)] (do Lux/Monad [obj-type (find-var-type obj-name)] (case obj-type diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index ecf7d6e6e..a601739a1 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -28,7 +28,7 @@ (do-template [ ] [(def #export ( x) (-> AST) - (#;Meta _cursor ( x)))] + [_cursor ( x)])] [bool$ Bool #;BoolS] [int$ Int #;IntS] diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 8a0ec5f46..92c43bbee 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -119,7 +119,7 @@ (def #export (macro-expand syntax) (-> AST (Lux (List AST))) (case syntax - (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -139,7 +139,7 @@ (def #export (macro-expand-all syntax) (-> AST (Lux (List AST))) (case syntax - (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -155,13 +155,13 @@ [parts' (M;map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (wrap (list (form$ (:: List/Monad (M;join parts')))))))) - (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) + [_ (#;FormS (#;Cons [harg targs]))] (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (M;map% Lux/Monad macro-expand-all targs)] (wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) - (#;Meta [_ (#;TupleS members)]) + [_ (#;TupleS members)] (do Lux/Monad [members' (M;map% Lux/Monad macro-expand-all members)] (wrap (list (tuple$ (:: List/Monad (M;join members')))))) diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux index bfc274e59..f554f45b4 100644 --- a/source/lux/meta/macro.lux +++ b/source/lux/meta/macro.lux @@ -9,18 +9,18 @@ (def #export (defmacro tokens state) Macro (case tokens - (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) - (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) + (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) ((~ name) (~@ args)) + (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) (~ body))) - (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) #;Nil])])]) - (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "def"]))) (~ (#;Meta ["" -1 -1] (#;TagS ["" "export"]))) ((~ name) (~@ args)) - (~ (#;Meta ["" -1 -1] (#;SymbolS ["lux" "Macro"]))) + (#;Cons [[_ (#;TagS ["" "export"])] (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) (~ [["" -1 -1] (#;TagS ["" "export"])]) ((~ name) (~@ args)) + (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) (~ body))) - (#;Cons [(` ((~ (#;Meta ["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) #;Nil])])]) _ diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index c7f691389..1732350ce 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -70,7 +70,7 @@ [(def #export ( tokens) (Parser ) (case tokens - (#;Cons [(#;Meta [_ ( x)]) tokens']) + (#;Cons [[_ ( x)] tokens']) (#;Some [tokens' x]) _ @@ -89,7 +89,7 @@ [(def #export ( tokens) (Parser Text) (case tokens - (#;Cons [(#;Meta [_ ( ["" x])]) tokens']) + (#;Cons [[_ ( ["" x])] tokens']) (#;Some [tokens' x]) _ @@ -110,7 +110,7 @@ [(def #export ( v tokens) (-> (Parser (,))) (case tokens - (#;Cons [(#;Meta [_ ( x)]) tokens']) + (#;Cons [[_ ( x)] tokens']) (if ( v x) (#;Some [tokens' []]) #;None) @@ -132,7 +132,7 @@ (All [a] (-> (Parser a) (Parser a))) (case tokens - (#;Cons [(#;Meta [_ ( form)]) tokens']) + (#;Cons [[_ ( form)] tokens']) (case (p form) (#;Some [#;Nil x]) (#;Some [tokens' x]) _ #;None) @@ -212,24 +212,24 @@ (defmacro #export (defsyntax tokens) (let [[exported? tokens] (: (, Bool (List AST)) (case tokens - (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) + (\ (list& [_ (#;TagS ["" "export"])] tokens')) [true tokens'] _ [false tokens]))] (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + (\ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))] body)) (do Lux/Monad [names+parsers (M;map% Lux/Monad (: (-> AST (Lux (, AST AST))) (lambda [arg] (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) + (\ [_ (#;TupleS (list [_ (#;SymbolS var-name)] + parser))]) (wrap [(symbol$ var-name) parser]) - (\ (#;Meta [_ (#;SymbolS var-name)])) + (\ [_ (#;SymbolS var-name)]) (wrap [(symbol$ var-name) (` id^)]) _ diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 7e5024c40..3ff214ee0 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -20,16 +20,16 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) - (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) - (&/$Cons ?catch-body - (&/$Nil))))))) + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] + (&/$Cons [_ (&/$TextS ?ex-class)] + (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] + (&/$Cons ?catch-body + (&/$Nil))))))] (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) - (&/$Cons ?finally-body - (&/$Nil))))) + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] + (&/$Cons ?finally-body + (&/$Nil))))] (return (&/T catch+ (&/V &/$Some ?finally-body))) _ @@ -37,7 +37,7 @@ (defn ^:private parse-tag [ast] (|case ast - (&/$Meta _ (&/$TagS "" name)) + [_ (&/$TagS "" name)] (return name) _ @@ -46,44 +46,44 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) - (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) - (&/$Cons (&/$Meta _ (&/$IntS ?length)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] + (&/$Cons [_ (&/$SymbolS _ ?class)] + (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) - (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) - (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?fields)] + (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS ?supers)] ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] + (&/$Cons [_ (&/$SymbolS "" ?args)] (&/$Cons ?body (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -94,86 +94,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -182,106 +182,106 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] + (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body ?handlers))) (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) @@ -292,53 +292,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -348,63 +348,63 @@ (|case token ;; Host special forms ;; Characters - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -415,60 +415,60 @@ (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] + (&/$Cons [_ (&/$SymbolS "" ?self)] + (&/$Cons [_ (&/$SymbolS "" ?arg)] (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) - (&/$Cons (&/$Meta _ (&/$TupleS tags)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] + (&/$Cons [_ (&/$TupleS tags)] + (&/$Cons [_ (&/$SymbolS "" type-name)] (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) - (&/$Cons (&/$Meta _ (&/$TextS ?path)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] + (&/$Cons [_ (&/$TextS ?path)] (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] + (&/$Cons [_ (&/$SymbolS "" ?ident)] (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) - (&/$Cons (&/$Meta _ (&/$TextS ?alias)) - (&/$Cons (&/$Meta _ (&/$TextS ?module)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] + (&/$Cons [_ (&/$TextS ?alias)] + (&/$Cons [_ (&/$TextS ?module)] (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) @@ -525,7 +525,7 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - (&/$Meta meta ?token) + [meta ?token] (fn [state] (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) (catch Error e @@ -559,13 +559,13 @@ (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] ;; (prn 'analyse-ast (&/show-ast token)) - (&/with-cursor (aget token 1 0) + (&/with-cursor (aget token 0) (&/with-expected-type exo-type (|case token - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) + [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] [module tag-name] (&/normalize ?ident) ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] @@ -574,7 +574,7 @@ ] (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) + [meta (&/$FormS (&/$Cons ?fn ?args))] (fn [state] (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) (&/$Right state* =fn) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 829b5b6d8..e86d55497 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -39,7 +39,7 @@ ;; [Utils] (def ^:private unit - (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) + (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list)))) (defn ^:private resolve-type [type] (|case type @@ -126,7 +126,7 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [(&/$Meta _ pattern*) pattern] + (|let [[_ pattern*] pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type @@ -221,7 +221,7 @@ ] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) - (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] [=module =name] (&&/resolved-ident ?ident) @@ -237,7 +237,7 @@ 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) + (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont)) ;; :let [_ (println "#15")] ] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 098dc89df..796b2d147 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -17,7 +17,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - (&/$Meta _ (&/$TextS ?text)) + [_ (&/$TextS ?text)] (return ?text) _ @@ -221,28 +221,28 @@ (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - (&/$Meta _ (&/$TextS "public")) + [_ (&/$TextS "public")] (return (assoc so-far :visibility "public")) - (&/$Meta _ (&/$TextS "private")) + [_ (&/$TextS "private")] (return (assoc so-far :visibility "private")) - (&/$Meta _ (&/$TextS "protected")) + [_ (&/$TextS "protected")] (return (assoc so-far :visibility "protected")) - (&/$Meta _ (&/$TextS "static")) + [_ (&/$TextS "static")] (return (assoc so-far :static? true)) - (&/$Meta _ (&/$TextS "final")) + [_ (&/$TextS "final")] (return (assoc so-far :final? true)) - (&/$Meta _ (&/$TextS "abstract")) + [_ (&/$TextS "abstract")] (return (assoc so-far :abstract? true)) - (&/$Meta _ (&/$TextS "synchronized")) + [_ (&/$TextS "synchronized")] (return (assoc so-far :concurrency "synchronized")) - (&/$Meta _ (&/$TextS "volatile")) + [_ (&/$TextS "volatile")] (return (assoc so-far :concurrency "volatile")) _ @@ -272,10 +272,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) - (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) - (&/$Nil)))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Nil)))))] (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -286,17 +286,17 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) - (&/$Cons ?method-body - (&/$Nil))))))))] + [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?method-inputs)] + (&/$Cons [_ (&/$TextS ?method-output)] + (&/$Cons [_ (&/$TupleS ?method-modifiers)] + (&/$Cons ?method-body + (&/$Nil)))))))]] (|do [=method-inputs (&/map% (fn [minput] (|case minput - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) - (&/$Nil))))) + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] + (&/$Cons [_ (&/$TextS ?input-type)] + (&/$Nil))))] (return (&/T ?input-name ?input-type)) _ @@ -331,11 +331,11 @@ (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) - (&/$Nil))))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?inputs)] + (&/$Cons [_ (&/$TextS ?output)] + (&/$Cons [_ (&/$TupleS ?modifiers)] + (&/$Nil))))))] (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -361,7 +361,7 @@ =finally (|case [?finally] (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V &/$Some =finally))))] + (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index c3f7622b8..375c82f27 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -26,11 +26,6 @@ =type (&type/clean $var ?type)] (return (&/T ?item =type)))))) -(defn ^:private with-cursor [cursor form] - (|case form - (&/$Meta _ syntax) - (&/V &/$Meta (&/T cursor syntax)))) - ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] @@ -275,7 +270,6 @@ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] - ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (or (= "defsig" (aget real-name 1)) ;; ;; (= "type" (aget real-name 1)) ;; ;; (= &&/$struct r-name) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index c6bfb0053..8b70bbcb4 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -133,7 +133,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) + (&/$Cons [[_ (&/$TagS tag1)] _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -141,7 +141,7 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [(&/$Meta _ (&/$TagS k)) v] + [[_ (&/$TagS k)] v] (|do [=k (&&/resolved-ident k)] (return (&/T (&/ident->text =k) v))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 5444c6c81..b99437a2c 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -23,10 +23,6 @@ "None" "Some") -;; Meta -(deftags "" - "Meta") - ;; Either (deftags "" "Left" @@ -768,40 +764,40 @@ (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast - ($Meta _ ($BoolS ?value)) + [_ ($BoolS ?value)] (pr-str ?value) - ($Meta _ ($IntS ?value)) + [_ ($IntS ?value)] (pr-str ?value) - ($Meta _ ($RealS ?value)) + [_ ($RealS ?value)] (pr-str ?value) - ($Meta _ ($CharS ?value)) + [_ ($CharS ?value)] (pr-str ?value) - ($Meta _ ($TextS ?value)) + [_ ($TextS ?value)] (str "\"" ?value "\"") - ($Meta _ ($TagS ?module ?tag)) + [_ ($TagS ?module ?tag)] (str "#" ?module ";" ?tag) - ($Meta _ ($SymbolS ?module ?name)) + [_ ($SymbolS ?module ?name)] (if (.equals "" ?module) ?name (str ?module ";" ?name)) - ($Meta _ ($TupleS ?elems)) + [_ ($TupleS ?elems)] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - ($Meta _ ($RecordS ?elems)) + [_ ($RecordS ?elems)] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - ($Meta _ ($FormS ?elems)) + [_ ($FormS ?elems)] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") _ diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 6f5f2250d..4c7741769 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -55,12 +55,12 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) + (return (&/T meta (&/V $White_Space white-space))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/T meta (&/V $Comment comment))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") @@ -79,7 +79,7 @@ (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/T meta (&/V $Comment comment))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -88,7 +88,7 @@ (do-template [ ] (def (|do [[meta token] (&reader/read-regex )] - (return (&/V &/$Meta (&/T meta (&/V token)))))) + (return (&/T meta (&/V token))))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" @@ -102,13 +102,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) + (return (&/T meta (&/V $Char token))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) + (return (&/T meta (&/V $Text token))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -134,17 +134,17 @@ (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) + (return (&/T meta (&/V $Symbol ident))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) + (return (&/T meta (&/V $Tag ident))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/V &/$Meta (&/T meta (&/V nil)))))) + (return (&/T meta (&/V nil))))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 9436eebc3..2609bf9a5 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -35,7 +35,7 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - (&/$Meta meta [ _]) + [meta [ _]] (return (&/V (&/fold &/|++ (&/|list) elems))) _ @@ -50,7 +50,7 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - (&/$Meta meta ($Close_Brace _)) + [meta ($Close_Brace _)] (if (even? (&/|length elems)) (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) @@ -61,7 +61,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [(&/$Meta meta token*) token]] + :let [[meta token*] token]] (|case token* ($White_Space _) (return (&/|list)) @@ -70,37 +70,37 @@ (return (&/|list)) ($Bool ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) + (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))) ($Int ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) + (return (&/|list (&/T meta (&/V &/$IntS (Long/parseLong ?value))))) ($Real ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) + (return (&/|list (&/T meta (&/V &/$RealS (Double/parseDouble ?value))))) ($Char ^String ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) + (return (&/|list (&/T meta (&/V &/$CharS (.charAt ?value 0))))) ($Text ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) + (return (&/|list (&/T meta (&/V &/$TextS ?value)))) ($Symbol ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) + (return (&/|list (&/T meta (&/V &/$SymbolS ?ident)))) ($Tag ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) + (return (&/|list (&/T meta (&/V &/$TagS ?ident)))) ($Open_Paren _) (|do [syntax (parse-form parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/T meta syntax)))) ($Open_Bracket _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/T meta syntax)))) ($Open_Brace _) (|do [syntax (parse-record parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/T meta syntax)))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/type.clj b/src/lux/type.clj index 2b06553c3..36590ddd2 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -150,10 +150,8 @@ (Named$ (&/T "lux" "Meta") (Univ$ empty-env (Univ$ empty-env - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ 3) - (Bound$ 1))))))))) + (Tuple$ (&/|list (Bound$ 3) + (Bound$ 1))))))) (def AST* (Named$ (&/T "lux" "AST'") @@ -520,6 +518,10 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] + [(&/$NamedT [?xmodule ?xname] ?xtype) (&/$NamedT [?ymodule ?yname] ?ytype)] + (and (= ?xmodule ?ymodule) + (= ?xname ?yname)) + [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) -- cgit v1.2.3 From 196f56b83ed357169efb75b864f81f26c10641f1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 23:17:27 -0400 Subject: - Remove the (unnec) "All'" and "->'" macros. - Improved the "struct" macro so that (once again) it doesn't ask for the prefixes of the members. - Added tests for the lux.reader namespace. --- source/lux.lux | 291 ++++++++++++++++++++-------------------- source/lux/codata/function.lux | 4 +- source/lux/codata/lazy.lux | 8 +- source/lux/codata/reader.lux | 8 +- source/lux/codata/state.lux | 8 +- source/lux/codata/stream.lux | 8 +- source/lux/data/bool.lux | 8 +- source/lux/data/char.lux | 4 +- source/lux/data/either.lux | 8 +- source/lux/data/id.lux | 14 +- source/lux/data/io.lux | 8 +- source/lux/data/list.lux | 16 +-- source/lux/data/maybe.lux | 12 +- source/lux/data/number/int.lux | 40 +++--- source/lux/data/number/real.lux | 40 +++--- source/lux/data/text.lux | 18 +-- source/lux/data/writer.lux | 8 +- source/lux/meta/lux.lux | 8 +- source/lux/meta/syntax.lux | 8 +- src/lux/compiler.clj | 2 +- src/lux/reader.clj | 27 ++-- test/test/lux/reader.clj | 57 ++++++++ 22 files changed, 331 insertions(+), 274 deletions(-) create mode 100644 test/test/lux/reader.clj diff --git a/source/lux.lux b/source/lux.lux index 422fb4fad..3ba8ec897 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -539,9 +539,9 @@ #Nil)))))) #Nil)) - (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) + (#Cons [_ (#SymbolS "" self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) - (#Cons (_meta (#SymbolS self)) + (#Cons (_meta (#SymbolS "" self)) (#Cons arg (#Cons (_lux_case args' #Nil @@ -649,26 +649,6 @@ (defmacro #export (comment tokens) (return #Nil)) -(defmacro (->' tokens) - (_lux_case tokens - (#Cons input (#Cons output #Nil)) - (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "LambdaT"]) - (#Cons (_meta (#TupleS (#Cons input (#Cons output #Nil)))) - #Nil)))) - #Nil)) - - (#Cons input (#Cons output others)) - (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "LambdaT"]) - (#Cons (_meta (#TupleS (#Cons input - (#Cons (_meta (#FormS (#Cons (symbol$ ["lux" "->'"]) - (#Cons output others)))) - #Nil)))) - #Nil)))) - #Nil)) - - _ - (fail "Wrong syntax for ->'"))) - (defmacro ($' tokens) (_lux_case tokens (#Cons x #Nil) @@ -687,7 +667,9 @@ (def'' (map f xs) (#UnivQ #Nil (#UnivQ #Nil - (->' (->' (#BoundT 3) (#BoundT 1)) ($' List (#BoundT 3)) ($' List (#BoundT 1))))) + (#LambdaT (#LambdaT (#BoundT 3) (#BoundT 1)) + (#LambdaT ($' List (#BoundT 3)) + ($' List (#BoundT 1)))))) (_lux_case xs #Nil #Nil @@ -700,7 +682,7 @@ ($' List (#TupleT (#Cons Text (#Cons AST #Nil))))) (def'' (make-env xs ys) - (->' ($' List Text) ($' List AST) RepEnv) + (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv)) (_lux_case (_lux_: (#TupleT (#Cons ($' List Text) (#Cons ($' List AST) #Nil))) [xs ys]) [(#Cons x xs') (#Cons y ys')] @@ -710,12 +692,12 @@ #Nil)) (def'' (text:= x y) - (->' Text Text Bool) + (#LambdaT Text (#LambdaT Text Bool)) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y])) (def'' (get-rep key env) - (->' Text RepEnv ($' Maybe AST)) + (#LambdaT Text (#LambdaT RepEnv ($' Maybe AST))) (_lux_case env #Nil #None @@ -729,7 +711,7 @@ (get-rep key env')))) (def'' (replace-syntax reps syntax) - (->' RepEnv AST AST) + (#LambdaT RepEnv (#LambdaT AST AST)) (_lux_case syntax [_ (#SymbolS "" name)] (_lux_case (get-rep name reps) @@ -746,7 +728,7 @@ [meta (#TupleS (map (replace-syntax reps) members))] [meta (#RecordS slots)] - [meta (#RecordS (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) + [meta (#RecordS (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) (lambda'' [slot] (_lux_case slot [k v] @@ -758,7 +740,7 @@ ) (def'' (update-bounds ast) - (->' AST AST) + (#LambdaT AST AST) (_lux_case ast [_ (#BoolS value)] (bool$ value) @@ -785,7 +767,7 @@ (tuple$ (map update-bounds members)) [_ (#RecordS pairs)] - (record$ (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) + (record$ (map (_lux_: (#LambdaT (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) (lambda'' [pair] (let'' [name val] pair [name (update-bounds val)]))) @@ -798,32 +780,33 @@ (form$ (map update-bounds members))) ) -(defmacro (All' tokens) - (_lux_case tokens - (#Cons [_ (#TupleS (#Cons [_ (#SymbolS "" arg-name)] other-args))] - (#Cons body #Nil)) - (let'' bound-var (_meta (#FormS (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ 1) #Nil)))) - (let'' body' (replace-syntax (#Cons [arg-name bound-var] #Nil) - (update-bounds body)) - (return (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "UnivQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (_lux_case other-args - #Nil - body' - - _ - (_meta (#FormS (#Cons (symbol$ ["lux" "All'"]) - (#Cons (_meta (#TupleS other-args)) - (#Cons body' - #Nil)))))) - #Nil))))) - #Nil)))) +(def'' (parse-univq-args args next) + ## (All [a] (-> (List AST) (-> (List Text) (Lux a)) (Lux a))) + (#UnivQ #Nil (#LambdaT ($' List AST) + (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 1))) + (#AppT (#AppT StateE Compiler) (#BoundT 1))))) + (_lux_case args + #Nil + (next #Nil) + + (#Cons [_ (#SymbolS "" arg-name)] args') + (parse-univq-args args' (lambda'' [names] (next (#Cons arg-name names)))) _ - (fail "Wrong syntax for All'"))) + (fail "Expected symbol."))) + +(def'' (make-bound idx) + (#LambdaT Int AST) + (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ idx) #Nil)))) (def'' (foldL f init xs) - (All' [a b] (->' (->' a b a) a ($' List b) a)) + ## (All [a b] (-> (-> a b a) a (List b) a)) + (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 3) + (#LambdaT (#BoundT 1) + (#BoundT 3))) + (#LambdaT (#BoundT 3) + (#LambdaT ($' List (#BoundT 1)) + (#BoundT 3)))))) (_lux_case xs #Nil init @@ -831,27 +814,66 @@ (#Cons x xs') (foldL f (f init x) xs'))) +(defmacro #export (All tokens) + (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil))) + (_lux_case tokens + (#Cons [_ (#SymbolS "" self-name)] tokens) + [self-name tokens] + + _ + ["" tokens])) + (_lux_case tokens + (#Cons [_ (#TupleS args)] (#Cons body #Nil)) + (parse-univq-args args + (lambda'' [names] + (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) + (lambda'' [body' name'] + (form$ (#Cons (tag$ ["lux" "UnivQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) + (update-bounds body')) #Nil)))))) + (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) + body) + names) + (return (#Cons body' #Nil))))) + + _ + (fail "Wrong syntax for All")) + )) + (def'' (reverse list) - (All' [a] (->' ($' List a) ($' List a))) + (All [a] (#LambdaT ($' List a) ($' List a))) (foldL (lambda'' [tail head] (#Cons head tail)) #Nil list)) +(defmacro #export (-> tokens) + (_lux_case (reverse tokens) + (#Cons output inputs) + (return (#Cons (foldL (_lux_: (#LambdaT AST (#LambdaT AST AST)) + (lambda'' [o i] (form$ (#Cons (tag$ ["lux" "LambdaT"]) (#Cons i (#Cons o #Nil)))))) + output + inputs) + #Nil)) + + _ + (fail "Wrong syntax for ->"))) + (defmacro (list xs) - (return (#Cons [(foldL (lambda'' [tail head] - (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) - (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#TagS ["lux" "Nil"])) - (reverse xs)) - #Nil]))) + (return (#Cons (foldL (lambda'' [tail head] + (form$ (#Cons (tag$ ["lux" "Cons"]) + (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) + #Nil)))) + (tag$ ["lux" "Nil"]) + (reverse xs)) + #Nil))) (defmacro (list& xs) (_lux_case (reverse xs) - (#Cons [last init]) + (#Cons last init) (return (list (foldL (lambda'' [tail head] - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list head tail))))))) + (form$ (list (tag$ ["lux" "Cons"]) + (tuple$ (list head tail))))) last init))) @@ -859,13 +881,13 @@ (fail "Wrong syntax for list&"))) (defmacro (lambda' tokens) - (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) + (let'' [name tokens'] (_lux_: (#TupleT (list Text ($' List AST))) (_lux_case tokens - (#Cons [[_ (#SymbolS name)] tokens']) + (#Cons [[_ (#SymbolS ["" name])] tokens']) [name tokens'] _ - [["" ""] tokens])) + ["" tokens])) (_lux_case tokens' (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) (_lux_case args @@ -874,7 +896,7 @@ (#Cons [harg targs]) (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ name) + (symbol$ ["" name]) harg (foldL (lambda'' [body' arg] (form$ (list (symbol$ ["" "_lux_lambda"]) @@ -931,7 +953,7 @@ )) (def''' (as-pairs xs) - (All' [a] (->' ($' List a) ($' List (#TupleT (list a a))))) + (All [a] (-> ($' List a) ($' List (#TupleT (list a a))))) (_lux_case xs (#Cons x (#Cons y xs')) (#Cons [x y] (as-pairs xs')) @@ -942,8 +964,8 @@ (defmacro (let' tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) - AST) + (return (list (foldL (_lux_: (-> AST (#TupleT (list AST AST)) + AST) (lambda' [body binding] (_lux_case binding [label value] @@ -955,8 +977,8 @@ (fail "Wrong syntax for let'"))) (def''' (any? p xs) - (All' [a] - (->' (->' a Bool) ($' List a) Bool)) + (All [a] + (-> (-> a Bool) ($' List a) Bool)) (_lux_case xs #Nil false @@ -967,7 +989,7 @@ false (any? p xs')))) (def''' (spliced? token) - (->' AST Bool) + (-> AST Bool) (_lux_case token [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] true @@ -976,12 +998,12 @@ false)) (def''' (wrap-meta content) - (->' AST AST) + (-> AST AST) (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1))) content))) (def''' (untemplate-list tokens) - (->' ($' List AST) AST) + (-> ($' List AST) AST) (_lux_case tokens #Nil (_meta (#TagS ["lux" "Nil"])) @@ -991,7 +1013,7 @@ (_meta (#TupleS (list token (untemplate-list tokens'))))))))) (def''' #export (list:++ xs ys) - (All' [a] (->' ($' List a) ($' List a) ($' List a))) + (All [a] (-> ($' List a) ($' List a) ($' List a))) (_lux_case xs (#Cons x xs') (#Cons x (list:++ xs' ys)) @@ -1010,7 +1032,7 @@ (fail "Wrong syntax for $"))) (def''' (splice replace? untemplate tag elems) - (->' Bool (->' AST AST) AST ($' List AST) AST) + (-> Bool (-> AST AST) AST ($' List AST) AST) (_lux_case replace? true (_lux_case (any? spliced? elems) @@ -1037,7 +1059,7 @@ (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) (def''' (untemplate replace? subst token) - (->' Bool Text AST AST) + (-> Bool Text AST AST) (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) [_ [_ (#BoolS value)]] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) @@ -1084,7 +1106,7 @@ [_ [_ (#RecordS fields)]] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) + (untemplate-list (map (_lux_: (-> (#TupleT (list AST AST)) AST) (lambda' [kv] (let' [[k v] kv] (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) @@ -1110,7 +1132,7 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (_lux_: (->' AST AST AST) + (return (list (foldL (_lux_: (-> AST AST AST) (lambda' [acc app] (_lux_case app [_ (#TupleS parts)] @@ -1141,8 +1163,8 @@ ## (-> Compiler (Either Text (, Compiler a)))) (def''' #export Lux Type - (All' [a] - (->' Compiler ($' Either Text (#TupleT (list Compiler a)))))) + (All [a] + (-> Compiler ($' Either Text (#TupleT (list Compiler a)))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1152,11 +1174,11 @@ (def''' Monad Type (#NamedT ["lux" "Monad"] - (All' [m] - (#TupleT (list (All' [a] (->' a ($' m a))) - (All' [a b] (->' (->' a ($' m b)) - ($' m a) - ($' m b)))))))) + (All [m] + (#TupleT (list (All [a] (-> a ($' m a))) + (All [a b] (-> (-> a ($' m b)) + ($' m a) + ($' m b)))))))) (_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad @@ -1196,17 +1218,6 @@ _ (fail "Wrong syntax for ^"))) -(defmacro #export (-> tokens) - (_lux_case (reverse tokens) - (#Cons output inputs) - (return (list (foldL (_lux_: (->' AST AST AST) - (lambda' [o i] (`' (#;LambdaT (~ i) (~ o))))) - output - inputs))) - - _ - (fail "Wrong syntax for ->"))) - (defmacro #export (, tokens) (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) @@ -1237,11 +1248,11 @@ (def''' (map% m f xs) ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) - (All' [m a b] - (-> ($' Monad m) - (-> a ($' m b)) - ($' List a) - ($' m ($' List b)))) + (All [m a b] + (-> ($' Monad m) + (-> a ($' m b)) + ($' List a) + ($' m ($' List b)))) (let' [{#;return wrap #;bind _} m] (_lux_case xs #Nil @@ -1255,8 +1266,8 @@ ))) (def''' (. f g) - (All' [a b c] - (-> (-> b c) (-> a b) (-> a c))) + (All [a b c] + (-> (-> b c) (-> a b) (-> a c))) (lambda' [x] (f (g x)))) @@ -1315,8 +1326,8 @@ template)) (def''' (join-map f xs) - (All' [a b] - (-> (-> a ($' List b)) ($' List a) ($' List b))) + (All [a b] + (-> (-> a ($' List b)) ($' List a) ($' List b))) (_lux_case xs #Nil #Nil @@ -1408,39 +1419,6 @@ (let' [[module name] ident] ($ text:++ module ";" name))) -(def''' (make-bound idx) - (-> Int AST) - (`' (#;BoundT (~ (int$ idx))))) - -(defmacro #export (All tokens) - (let' [[self-name tokens] (_lux_: (, Text ASTList) - (_lux_case tokens - (#Cons [_ (#SymbolS "" self-name)] tokens) - [self-name tokens] - - _ - ["" tokens]))] - (_lux_case tokens - (#Cons [_ (#TupleS (#Cons harg targs))] (#Cons body #Nil)) - (_lux_case (map% Maybe/Monad get-name (#Cons harg targs)) - (#Some names) - (let' [body' (foldL (_lux_: (-> AST Text AST) - (lambda' [body' name'] - (`' (#;UnivQ #;Nil (~ (|> body' - (update-bounds) - (replace-syntax (list [name' (make-bound 1)])))))))) - (replace-syntax (list [self-name (make-bound -2)]) - body) - names)] - (return (list body'))) - - #None - (fail "\"All\" arguments must be symbols.")) - - _ - (fail "Wrong syntax for All")) - )) - (def''' (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) @@ -1980,7 +1958,7 @@ (\ (list [_ (#TupleS (#Cons head tail))] body)) (#Some ["" ""] head tail body) - (\ (list [_ (#SymbolS [_ name])] [_ (#TupleS (#Cons head tail))] body)) + (\ (list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body)) (#Some ["" name] head tail body) _ @@ -2379,17 +2357,40 @@ (defmacro #export (struct tokens) (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens)] + [tokens' (map% Lux/Monad macro-expand tokens) + struct-type expected-type + tags+type (resolve-type-tags struct-type) + tags (: (Lux (List Ident)) + (case tags+type + (#Some [tags _]) + (return tags) + + _ + (fail "No tags available for type."))) + #let [tag-mappings (: (List (, Text AST)) + (map (lambda [tag] [(second tag) (tag$ tag)]) + tags))] + _ (: (Lux Unit) + (let [msg ($ text:++ "struct/tag-mappings: " "[" (|> tag-mappings (map first) (interpose " ") (foldL text:++ "")) "]" " " (type:show struct-type)) + _ (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.Object"] + (_jvm_getstatic "java.lang.System" "out") [msg])] + (return (: Unit [])))) + ] (do Lux/Monad [members (map% Lux/Monad (: (-> AST (Lux (, AST AST))) (lambda [token] (case token - (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS tag-name)] value))]) - (wrap (: (, AST AST) [(tag$ tag-name) value])) + (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) + (case (get tag-name tag-mappings) + (#Some tag) + (wrap (: (, AST AST) [tag value])) + + _ + (fail (text:++ "Unknown structure member: " tag-name))) _ - (fail "Structures members must be unqualified.")))) + (fail (text:++ "Invalid structure member: " (ast:show token)))))) (list:join tokens'))] (wrap (list (record$ members)))))) diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux index ea79ff9ad..a23e969b3 100644 --- a/source/lux/codata/function.lux +++ b/source/lux/codata/function.lux @@ -23,5 +23,5 @@ ## [Structures] (defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) - (def m;unit id) - (def m;++ .)) + (def unit id) + (def ++ .)) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index 9c72fdb16..1529c0dae 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -34,13 +34,13 @@ ## [Structs] (defstruct #export Lazy/Functor (Functor Lazy) - (def (F;map f ma) + (def (map f ma) (lambda [k] (ma (. k f))))) (defstruct #export Lazy/Monad (Monad Lazy) - (def M;_functor Lazy/Functor) + (def _functor Lazy/Functor) - (def (M;wrap a) + (def (wrap a) (... a)) - (def M;join !)) + (def join !)) diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux index 56b3e0286..e776f73ec 100644 --- a/source/lux/codata/reader.lux +++ b/source/lux/codata/reader.lux @@ -14,17 +14,17 @@ ## [Structures] (defstruct #export Reader/Functor (All [r] (Functor (Reader r))) - (def (F;map f fa) + (def (map f fa) (lambda [env] (f (fa env))))) (defstruct #export Reader/Monad (All [r] (Monad (Reader r))) - (def M;_functor Reader/Functor) + (def _functor Reader/Functor) - (def (M;wrap x) + (def (wrap x) (lambda [env] x)) - (def (M;join mma) + (def (join mma) (lambda [env] (mma env env)))) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index d85ef3dbc..ec0a6bf63 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -13,20 +13,20 @@ ## [Structures] (defstruct #export State/Functor (Functor State) - (def (F;map f ma) + (def (map f ma) (lambda [state] (let [[state' a] (ma state)] [state' (f a)])))) (defstruct #export State/Monad (All [s] (Monad (State s))) - (def M;_functor State/Functor) + (def _functor State/Functor) - (def (M;wrap x) + (def (wrap x) (lambda [state] [state x])) - (def (M;join mma) + (def (join mma) (lambda [state] (let [[state' ma] (mma state)] (ma state'))))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 5415213d7..d0f84f0c7 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -110,14 +110,14 @@ ## [Structures] (defstruct #export Stream/Functor (Functor Stream) - (def (F;map f fa) + (def (map f fa) (let [[h t] (! fa)] (... [(f h) (map f t)])))) (defstruct #export Stream/CoMonad (CoMonad Stream) - (def CM;_functor Stream/Functor) - (def CM;unwrap head) - (def (CM;split wa) + (def _functor Stream/Functor) + (def unwrap head) + (def (split wa) (:: Stream/Functor (F;map repeat wa)))) ## [Pattern-matching] diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index 29de09328..defaee22e 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -11,19 +11,19 @@ ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) - (def (E;= x y) + (def (= x y) (if x y (not y)))) (defstruct #export Bool/Show (S;Show Bool) - (def (S;show x) + (def (show x) (if x "true" "false"))) (do-template [ ] [(defstruct #export (m;Monoid Bool) - (def m;unit ) - (def (m;++ x y) + (def unit ) + (def (++ x y) ( x y)))] [ Or/Monoid false or] diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index e6e796123..4e0d41b22 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -10,9 +10,9 @@ ## [Structures] (defstruct #export Char/Eq (E;Eq Char) - (def (E;= x y) + (def (= x y) (_jvm_ceq x y))) (defstruct #export Char/Show (S;Show Char) - (def (S;show x) + (def (show x) ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) diff --git a/source/lux/data/either.lux b/source/lux/data/either.lux index 86d778965..38de1e2d1 100644 --- a/source/lux/data/either.lux +++ b/source/lux/data/either.lux @@ -46,18 +46,18 @@ ## [Structures] (defstruct #export Error/Functor (All [a] (Functor (Either a))) - (def (F;map f ma) + (def (map f ma) (case ma (#;Left msg) (#;Left msg) (#;Right datum) (#;Right (f datum))))) (defstruct #export Error/Monad (All [a] (Monad (Either a))) - (def M;_functor Error/Functor) + (def _functor Error/Functor) - (def (M;wrap a) + (def (wrap a) (#;Right a)) - (def (M;join mma) + (def (join mma) (case mma (#;Left msg) (#;Left msg) (#;Right ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index e06a24f94..6b996cf1e 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -14,16 +14,16 @@ ## [Structures] (defstruct #export Id/Functor (Functor Id) - (def (F;map f fa) + (def (map f fa) (let [(#Id a) fa] (#Id (f a))))) (defstruct #export Id/Monad (Monad Id) - (def M;_functor Id/Functor) - (def (M;wrap a) (#Id a)) - (def (M;join mma) (let [(#Id ma) mma] ma))) + (def _functor Id/Functor) + (def (wrap a) (#Id a)) + (def (join mma) (let [(#Id ma) mma] ma))) (defstruct #export Id/CoMonad (CoMonad Id) - (def CM;_functor Id/Functor) - (def (CM;unwrap wa) (let [(#Id a) wa] a)) - (def (CM;split wa) (#Id wa))) + (def _functor Id/Functor) + (def (unwrap wa) (let [(#Id a) wa] a)) + (def (split wa) (#Id wa))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index 144410f5c..032381404 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -27,16 +27,16 @@ ## [Structures] (defstruct #export IO/Functor (F;Functor IO) - (def (F;map f ma) + (def (map f ma) (io (f (ma []))))) (defstruct #export IO/Monad (M;Monad IO) - (def M;_functor IO/Functor) + (def _functor IO/Functor) - (def (M;wrap x) + (def (wrap x) (io x)) - (def (M;join mma) + (def (join mma) (mma []))) ## [Functions] diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 10bbb8086..c9a4c7598 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -235,14 +235,14 @@ ## [Structures] ## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) -## (def (E;= xs ys) +## (def (= xs ys) ## (case [xs ys] ## [#;Nil #;Nil] ## true ## [(#;Cons x xs') (#;Cons y ys')] ## (and (:: eq (E;= x y)) -## (E;= xs' ys')) +## (= xs' ys')) ## [_ _] ## false @@ -250,25 +250,25 @@ (defstruct #export List/Monoid (All [a] (Monoid (List a))) - (def m;unit #;Nil) - (def (m;++ xs ys) + (def unit #;Nil) + (def (++ xs ys) (case xs #;Nil ys (#;Cons x xs') (#;Cons x (++ xs' ys))))) (defstruct #export List/Functor (Functor List) - (def (F;map f ma) + (def (map f ma) (case ma #;Nil #;Nil (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) (defstruct #export List/Monad (Monad List) - (def M;_functor List/Functor) + (def _functor List/Functor) - (def (M;wrap a) + (def (wrap a) (#;Cons [a #;Nil])) - (def (M;join mma) + (def (join mma) (using List/Monoid (foldL ++ unit mma)))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index bb4eee6df..5df03f378 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -18,25 +18,25 @@ ## [Structures] (defstruct #export Maybe/Monoid (All [a] (Monoid (Maybe a))) - (def m;unit #;None) - (def (m;++ xs ys) + (def unit #;None) + (def (++ xs ys) (case xs #;None ys (#;Some x) (#;Some x)))) (defstruct #export Maybe/Functor (Functor Maybe) - (def (F;map f ma) + (def (map f ma) (case ma #;None #;None (#;Some a) (#;Some (f a))))) (defstruct #export Maybe/Monad (Monad Maybe) - (def M;_functor Maybe/Functor) + (def _functor Maybe/Functor) - (def (M;wrap x) + (def (wrap x) (#;Some x)) - (def (M;join mma) + (def (join mma) (case mma #;None #;None (#;Some xs) xs))) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index cc327ad0c..2d94ad43b 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -15,20 +15,20 @@ ## Number (do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] [(defstruct #export (N;Number ) - (def (N;+ x y) (<+> x y)) - (def (N;- x y) (<-> x y)) - (def (N;* x y) (<*> x y)) - (def (N;/ x y) ( x y)) - (def (N;% x y) (<%> x y)) - (def (N;from-int x) + (def (+ x y) (<+> x y)) + (def (- x y) (<-> x y)) + (def (* x y) (<*> x y)) + (def (/ x y) ( x y)) + (def (% x y) (<%> x y)) + (def (from-int x) ( x)) - (def (N;negate x) + (def (negate x) (<*> <-1> x)) - (def (N;abs x) + (def (abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (N;signum x) + (def (signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else @@ -39,18 +39,18 @@ ## Eq (defstruct #export Int/Eq (E;Eq Int) - (def (E;= x y) (_jvm_leq x y))) + (def (= x y) (_jvm_leq x y))) ## Ord (do-template [ <=> ] [(defstruct #export (O;Ord ) - (def O;_eq ) - (def (O;< x y) ( x y)) - (def (O;<= x y) + (def _eq ) + (def (< x y) ( x y)) + (def (<= x y) (or ( x y) (<=> x y))) - (def (O;> x y) ( x y)) - (def (O;>= x y) + (def (> x y) ( x y)) + (def (>= x y) (or ( x y) (<=> x y))))] @@ -59,16 +59,16 @@ ## Bounded (do-template [ ] [(defstruct #export (B;Bounded ) - (def B;top ) - (def B;bottom ))] + (def top ) + (def bottom ))] [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) ## Monoid (do-template [ <++>] [(defstruct #export (m;Monoid ) - (def m;unit ) - (def (m;++ x y) (<++> x y)))] + (def unit ) + (def (++ x y) (<++> x y)))] [ IntAdd/Monoid Int 0 _jvm_ladd] [ IntMul/Monoid Int 1 _jvm_lmul] @@ -79,7 +79,7 @@ ## Show (do-template [ ] [(defstruct #export (S;Show ) - (def (S;show x) + (def (show x) ))] [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux index 27f1bf7b0..2b7090265 100644 --- a/source/lux/data/number/real.lux +++ b/source/lux/data/number/real.lux @@ -15,20 +15,20 @@ ## Number (do-template [ <+> <-> <*> <%> <=> <<> <0> <1> <-1>] [(defstruct #export (N;Number ) - (def (N;+ x y) (<+> x y)) - (def (N;- x y) (<-> x y)) - (def (N;* x y) (<*> x y)) - (def (N;/ x y) ( x y)) - (def (N;% x y) (<%> x y)) - (def (N;from-int x) + (def (+ x y) (<+> x y)) + (def (- x y) (<-> x y)) + (def (* x y) (<*> x y)) + (def (/ x y) ( x y)) + (def (% x y) (<%> x y)) + (def (from-int x) ( x)) - (def (N;negate x) + (def (negate x) (<*> <-1> x)) - (def (N;abs x) + (def (abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (N;signum x) + (def (signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else @@ -39,18 +39,18 @@ ## Eq (defstruct #export Real/Eq (E;Eq Real) - (def (E;= x y) (_jvm_deq x y))) + (def (= x y) (_jvm_deq x y))) ## Ord (do-template [ <=> ] [(defstruct #export (O;Ord ) - (def O;_eq ) - (def (O;< x y) ( x y)) - (def (O;<= x y) + (def _eq ) + (def (< x y) ( x y)) + (def (<= x y) (or ( x y) (<=> x y))) - (def (O;> x y) ( x y)) - (def (O;>= x y) + (def (> x y) ( x y)) + (def (>= x y) (or ( x y) (<=> x y))))] @@ -59,16 +59,16 @@ ## Bounded (do-template [ ] [(defstruct #export (B;Bounded ) - (def B;top ) - (def B;bottom ))] + (def top ) + (def bottom ))] [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) ## Monoid (do-template [ <++>] [(defstruct #export (m;Monoid ) - (def m;unit ) - (def (m;++ x y) (<++> x y)))] + (def unit ) + (def (++ x y) (<++> x y)))] [RealAdd/Monoid Real 0.0 _jvm_dadd] [RealMul/Monoid Real 1.0 _jvm_dmul] @@ -79,7 +79,7 @@ ## Show (do-template [ ] [(defstruct #export (S;Show ) - (def (S;show x) + (def (show x) ))] [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 0040a96c5..533308dd0 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -115,12 +115,12 @@ ## [Structures] (defstruct #export Text/Eq (E;Eq Text) - (def (E;= x y) + (def (= x y) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y]))) (defstruct #export Text/Ord (O;Ord Text) - (def O;_eq Text/Eq) + (def _eq Text/Eq) (do-template [ ] [(def ( x y) @@ -128,17 +128,17 @@ x [y])) 0))] - [O;< i<] - [O;<= i<=] - [O;> i>] - [O;>= i>=])) + [< i<] + [<= i<=] + [> i>] + [>= i>=])) (defstruct #export Text/Show (S;Show Text) - (def S;show id)) + (def show id)) (defstruct #export Text/Monoid (m;Monoid Text) - (def m;unit "") - (def (m;++ x y) + (def unit "") + (def (++ x y) (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y]))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux index 316e1fbcc..bf26eac9a 100644 --- a/source/lux/data/writer.lux +++ b/source/lux/data/writer.lux @@ -15,17 +15,17 @@ ## [Structures] (defstruct #export Writer/Functor (All [l] (Functor (Writer l))) - (def (F;map f fa) + (def (map f fa) (let [[log datum] fa] [log (f datum)]))) (defstruct #export (Writer/Monad mon) (All [l] (-> (Monoid l) (Monad (Writer l)))) - (def M;_functor Writer/Functor) + (def _functor Writer/Functor) - (def (M;wrap x) + (def (wrap x) [(:: mon m;unit) x]) - (def (M;join mma) + (def (join mma) (let [[log1 [log2 a]] mma] [(:: mon (m;++ log1 log2)) a]))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 92c43bbee..32ca78570 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -26,7 +26,7 @@ ## [Structures] (defstruct #export Lux/Functor (F;Functor Lux) - (def (F;map f fa) + (def (map f fa) (lambda [state] (case (fa state) (#;Left msg) @@ -36,11 +36,11 @@ (#;Right [state' (f a)]))))) (defstruct #export Lux/Monad (M;Monad Lux) - (def M;_functor Lux/Functor) - (def (M;wrap x) + (def _functor Lux/Functor) + (def (wrap x) (lambda [state] (#;Right [state x]))) - (def (M;join mma) + (def (join mma) (lambda [state] (case (mma state) (#;Left msg) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 1732350ce..7d888f659 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -35,7 +35,7 @@ ## [Structures] (defstruct #export Parser/Functor (F;Functor Parser) - (def (F;map f ma) + (def (map f ma) (lambda [tokens] (case (ma tokens) #;None @@ -45,12 +45,12 @@ (#;Some [tokens' (f a)]))))) (defstruct #export Parser/Monad (M;Monad Parser) - (def M;_functor Parser/Functor) + (def _functor Parser/Functor) - (def (M;wrap x tokens) + (def (wrap x tokens) (#;Some [tokens x])) - (def (M;join mma) + (def (join mma) (lambda [tokens] (case (mma tokens) #;None diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index b8ffa825f..694c6bfc4 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -421,7 +421,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from file-name file-content) state)) + (&/set$ &/$source (&reader/from name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 0fcb5097b..af6c1ecc3 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -48,7 +48,6 @@ (fail* msg) ))) -;; [Exports] (defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] (let [matcher (doto (.matcher regex line) (.region column (.length line)) @@ -72,6 +71,7 @@ (.group matcher 1) (.group matcher 2))))) +;; [Exports] (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] @@ -125,7 +125,6 @@ (defn read-text [^String text] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-text [file-name line-num column-num text line]) (if (.startsWith line text column-num) (let [match-length (.length text) column-num* (+ column-num match-length)] @@ -135,15 +134,15 @@ (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Text failed: " text)))))) -(def ^:private ^String +source-dir+ "input/") -(defn from [^String file-name ^String file-content] - (let [lines (&/->list (string/split-lines file-content)) - file-name (.substring file-name (.length +source-dir+))] - (&/|map (fn [line+line-num] - (|let [[line-num line] line+line-num] - (&/T (&/T file-name (inc line-num) 0) - line))) - (&/|filter (fn [line+line-num] - (|let [[line-num line] line+line-num] - (not= "" line))) - (&/enumerate lines))))) +(defn from [^String name ^String source-code] + (->> source-code + (string/split-lines) + (&/->list) + (&/enumerate) + (&/|filter (fn [line+line-num] + (|let [[line-num line] line+line-num] + (not= "" line)))) + (&/|map (fn [line+line-num] + (|let [[line-num line] line+line-num] + (&/T (&/T name (inc line-num) 0) + line)))))) diff --git a/test/test/lux/reader.clj b/test/test/lux/reader.clj new file mode 100644 index 000000000..9b4954c5a --- /dev/null +++ b/test/test/lux/reader.clj @@ -0,0 +1,57 @@ +(ns text.lux.reader + (:use clojure.test) + (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] + [reader :as &reader]) + :reload-all)) + +;; [Utils] +(def source (&reader/from "yolo" "lol\nmeme\nnyan cat\n\nlolcat")) +(def init-state (&/set$ &/$source source (&/init-state nil))) + +;; [Tests] +(deftest test-source-code-reading + (is (= 4 (&/|length source)))) + +(deftest test-text-reading + ;; Should be capable of recognizing literal texts. + (let [input "lo"] + (|case (&/run-state (&reader/read-text input) init-state) + (&/$Right state [cursor output]) + (is (= input output)) + + _ + (is false "Couldn't read.") + ))) + +(deftest test-regex-reading + ;; Should be capable of matching simple, grouping regex-patterns. + (|case (&/run-state (&reader/read-regex #"l(.)l") init-state) + (&/$Right state [cursor output]) + (is (= "lol" "lol")) + + _ + (is false "Couldn't read.") + )) + +(deftest test-regex2-reading + ;; Should be capable of matching double, grouping regex-patterns. + (|case (&/run-state (&reader/read-regex2 #"(.)(..)") init-state) + (&/$Right state [cursor [left right]]) + (is (and (= "l" left) + (= "ol" right))) + + _ + (is false "Couldn't read.") + )) + +(deftest test-regex+-reading + ;; Should be capable of matching multi-line regex-patterns. + (|case (&/run-state (&reader/read-regex+ #"(?is)^(.*?)(cat|$)") init-state) + (&/$Right state [cursor output]) + (is (= "lol\nmeme\nnyan " output)) + + _ + (is false "Couldn't read.") + )) + +;; (run-all-tests) -- cgit v1.2.3 From 0a0fab3581eedbc13df2af40e3db8bc2d2fd8178 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 30 Aug 2015 01:20:08 -0400 Subject: - Removed the (now obsolete) `' macro. - Implemented hygienic macros by adding global symbol resolution inside the ` macro. --- source/lux.lux | 789 ++++++++++++++++++++++--------------------- source/lux/control/monad.lux | 12 +- source/lux/data/io.lux | 2 +- source/lux/data/list.lux | 22 +- source/lux/data/maybe.lux | 5 +- source/lux/host/jvm.lux | 109 +++--- source/lux/meta/syntax.lux | 16 +- 7 files changed, 496 insertions(+), 459 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 3ba8ec897..0ce03829b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -880,8 +880,22 @@ _ (fail "Wrong syntax for list&"))) +(defmacro #export (^ tokens) + (_lux_case tokens + (#Cons [_ (#SymbolS "" class-name)] #Nil) + (return (list (form$ (list (tag$ ["lux" "DataT"]) (text$ class-name))))) + + _ + (fail "Wrong syntax for ^"))) + +(defmacro #export (, tokens) + (return (list (form$ (list (tag$ ["lux" "TupleT"]) + (foldL (lambda'' [tail head] (form$ (list (tag$ ["lux" "Cons"]) head tail))) + (tag$ ["lux" "Nil"]) + (reverse tokens))))))) + (defmacro (lambda' tokens) - (let'' [name tokens'] (_lux_: (#TupleT (list Text ($' List AST))) + (let'' [name tokens'] (_lux_: (, Text ($' List AST)) (_lux_case tokens (#Cons [[_ (#SymbolS ["" name])] tokens']) [name tokens'] @@ -953,7 +967,7 @@ )) (def''' (as-pairs xs) - (All [a] (-> ($' List a) ($' List (#TupleT (list a a))))) + (All [a] (-> ($' List a) ($' List (, a a)))) (_lux_case xs (#Cons x (#Cons y xs')) (#Cons [x y] (as-pairs xs')) @@ -964,7 +978,7 @@ (defmacro (let' tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (-> AST (#TupleT (list AST AST)) + (return (list (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body binding] (_lux_case binding @@ -1009,8 +1023,7 @@ (_meta (#TagS ["lux" "Nil"])) (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) - (_meta (#TupleS (list token (untemplate-list tokens'))))))))) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) (def''' #export (list:++ xs ys) (All [a] (-> ($' List a) ($' List a) ($' List a))) @@ -1031,140 +1044,12 @@ _ (fail "Wrong syntax for $"))) -(def''' (splice replace? untemplate tag elems) - (-> Bool (-> AST AST) AST ($' List AST) AST) - (_lux_case replace? - true - (_lux_case (any? spliced? elems) - true - (let' [elems' (map (lambda' [elem] - (_lux_case elem - [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] - spliced - - _ - (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) - (tag$ ["lux" "Nil"]))))))))) - elems)] - (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "list:++"]) - elems')))))) - - false - (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) - false - (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) - -(def''' (untemplate replace? subst token) - (-> Bool Text AST AST) - (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) - [_ [_ (#BoolS value)]] - (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - - [_ [_ (#IntS value)]] - (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - - [_ [_ (#RealS value)]] - (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - - [_ [_ (#CharS value)]] - (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - - [_ [_ (#TextS value)]] - (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - - [_ [_ (#TagS [module name])]] - (let' [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - - [_ [_ (#SymbolS [module name])]] - (let' [module' (_lux_case module - "" - subst - - _ - module)] - (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - - [_ [_ (#TupleS elems)]] - (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - - [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] - unquoted - - [_ [meta (#FormS elems)]] - (let' [[_ form'] (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - [meta form']) - - [_ [_ (#RecordS fields)]] - (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (-> (#TupleT (list AST AST)) AST) - (lambda' [kv] - (let' [[k v] kv] - (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) - fields))))) - )) - -(defmacro (`' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate true "" template))) - - _ - (fail "Wrong syntax for `'"))) - -(defmacro #export (' tokens) - (_lux_case tokens - (#Cons [template #Nil]) - (return (list (untemplate false "" template))) - - _ - (fail "Wrong syntax for '"))) - -(defmacro #export (|> tokens) - (_lux_case tokens - (#Cons [init apps]) - (return (list (foldL (_lux_: (-> AST AST AST) - (lambda' [acc app] - (_lux_case app - [_ (#TupleS parts)] - (tuple$ (list:++ parts (list acc))) - - [_ (#FormS parts)] - (form$ (list:++ parts (list acc))) - - _ - (`' ((~ app) (~ acc)))))) - init - apps))) - - _ - (fail "Wrong syntax for |>"))) - -(defmacro #export (if tokens) - (_lux_case tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (return (list (`' (_lux_case (~ test) - true (~ then) - false (~ else))))) - - _ - (fail "Wrong syntax for if"))) - ## (deftype (Lux a) ## (-> Compiler (Either Text (, Compiler a)))) (def''' #export Lux Type (All [a] - (-> Compiler ($' Either Text (#TupleT (list Compiler a)))))) + (-> Compiler ($' Either Text (, Compiler a))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1175,10 +1060,10 @@ Type (#NamedT ["lux" "Monad"] (All [m] - (#TupleT (list (All [a] (-> a ($' m a))) - (All [a b] (-> (-> a ($' m b)) - ($' m a) - ($' m b)))))))) + (, (All [a] (-> a ($' m a))) + (All [a b] (-> (-> a ($' m b)) + ($' m a) + ($' m b))))))) (_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad @@ -1210,37 +1095,28 @@ (#Right state' a) (f a state'))))}) -(defmacro #export (^ tokens) - (_lux_case tokens - (#Cons [_ (#SymbolS "" class-name)] #Nil) - (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) - - _ - (fail "Wrong syntax for ^"))) - -(defmacro #export (, tokens) - (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) - (defmacro (do tokens) (_lux_case tokens (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) - (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) + (let' [g!wrap (symbol$ ["" "wrap"]) + g!bind (symbol$ ["" "12bind34"]) + body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var [_ (#TagS "" "let")] - (`' (;let' (~ value) (~ body'))) + (form$ (list (symbol$ ["lux" "let'"]) value body')) _ - (`' (bind (_lux_lambda (~ (symbol$ ["" ""])) - (~ var) - (~ body')) - (~ value))))))) + (form$ (list g!bind + (form$ (list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body')) + value)))))) body (reverse (as-pairs bindings)))] - (return (list (`' (_lux_case (~ monad) - {#;return wrap #;bind bind} - (~ body')))))) + (return (list (form$ (list (symbol$ ["" "_lux_case"]) + monad + (record$ (list [(tag$ ["lux" "return"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) + body'))))) _ (fail "Wrong syntax for do"))) @@ -1265,6 +1141,232 @@ (wrap (#Cons y ys))) ))) +(defmacro #export (if tokens) + (_lux_case tokens + (#Cons test (#Cons then (#Cons else #Nil))) + (return (list (form$ (list (symbol$ ["" "_lux_case"]) test + (bool$ true) then + (bool$ false) else)))) + + _ + (fail "Wrong syntax for if"))) + +(def''' (get k plist) + (All [a] + (-> Text ($' List (, Text a)) ($' Maybe a))) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) + + #Nil + #None)) + +(def''' (put k v dict) + (All [a] + (-> Text a ($' List (, Text a)) ($' List (, Text a)))) + (_lux_case dict + #Nil + (list [k v]) + + (#Cons [[k' v'] dict']) + (if (text:= k k') + (#Cons [[k' v] dict']) + (#Cons [[k' v'] (put k v dict')])))) + +(def''' (text:++ x y) + (-> Text Text Text) + (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] + x [y])) + +(def''' (ident->text ident) + (-> Ident Text) + (let' [[module name] ident] + ($ text:++ module ";" name))) + +(def''' (resolve-global-symbol ident state) + (-> Ident ($' Lux Ident)) + (let' [[module name] ident + {#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (_lux_case (get module modules) + (#Some {#module-aliases _ #defs defs #imports _ #tags tags #types types}) + (_lux_case (get name defs) + (#Some [_ def-data]) + (_lux_case def-data + (#AliasD real-name) + (#Right [state real-name]) + + _ + (#Right [state ident])) + + #None + (#Left ($ text:++ "Unknown definition: " (ident->text ident)))) + + #None + (#Left ($ text:++ "Unknown module: " module " @ " (ident->text ident)))))) + +(def''' (splice replace? untemplate tag elems) + (-> Bool (-> AST ($' Lux AST)) AST ($' List AST) ($' Lux AST)) + (_lux_case replace? + true + (_lux_case (any? spliced? elems) + true + (do Lux/Monad + [elems' (_lux_: ($' Lux ($' List AST)) + (map% Lux/Monad + (_lux_: (-> AST ($' Lux AST)) + (lambda' [elem] + (_lux_case elem + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] + (wrap spliced) + + _ + (do Lux/Monad + [=elem (untemplate elem)] + (wrap (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))))) + elems))] + (wrap (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) + elems'))))))) + + false + (do Lux/Monad + [=elems (map% Lux/Monad untemplate elems)] + (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))) + false + (do Lux/Monad + [=elems (map% Lux/Monad untemplate elems)] + (wrap (wrap-meta (form$ (list tag (untemplate-list =elems)))))))) + +(def''' (untemplate replace? subst token) + (-> Bool Text AST ($' Lux AST)) + (_lux_case (_lux_: (, Bool AST) [replace? token]) + [_ [_ (#BoolS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))) + + [_ [_ (#IntS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))) + + [_ [_ (#RealS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))) + + [_ [_ (#CharS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))) + + [_ [_ (#TextS value)]] + (return (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))) + + [_ [_ (#TagS [module name])]] + (let' [module' (_lux_case module + "" + subst + + _ + module)] + (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))) + + [true [_ (#SymbolS [module name])]] + (do Lux/Monad + [real-name (_lux_case module + "" + (resolve-global-symbol [subst name]) + + _ + (wrap (_lux_: Ident [module name]))) + #let [[module name] real-name]] + (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name)))))))) + + [false [_ (#SymbolS [module name])]] + (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name))))))) + + [_ [_ (#TupleS elems)]] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) + + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] + (return unquoted) + + [_ [meta (#FormS elems)]] + (do Lux/Monad + [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + #let [[_ form'] output]] + (return (_lux_: AST [meta form']))) + + [_ [_ (#RecordS fields)]] + (do Lux/Monad + [=fields (map% Lux/Monad + (_lux_: (-> (, AST AST) ($' Lux AST)) + (lambda' [kv] + (let' [[k v] kv] + (do Lux/Monad + [=k (untemplate replace? subst k) + =v (untemplate replace? subst v)] + (wrap (tuple$ (list =k =v))))))) + fields)] + (wrap (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) + )) + +(def'' (get-module-name state) + ($' Lux Text) + (_lux_case state + {#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") + + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) + +(defmacro #export (` tokens) + (_lux_case tokens + (#Cons template #Nil) + (do Lux/Monad + [current-module get-module-name + =template (untemplate true current-module template)] + (wrap (list =template))) + + _ + (fail "Wrong syntax for `"))) + +(defmacro #export (' tokens) + (_lux_case tokens + (#Cons template #Nil) + (do Lux/Monad + [=template (untemplate false "" template)] + (wrap (list =template))) + + _ + (fail "Wrong syntax for '"))) + +(defmacro #export (|> tokens) + (_lux_case tokens + (#Cons [init apps]) + (return (list (foldL (_lux_: (-> AST AST AST) + (lambda' [acc app] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (list:++ parts (list acc))) + + [_ (#FormS parts)] + (form$ (list:++ parts (list acc))) + + _ + (` ((~ app) (~ acc)))))) + init + apps))) + + _ + (fail "Wrong syntax for |>"))) + (def''' (. f g) (All [a b c] (-> (-> b c) (-> a b) (-> a c))) @@ -1409,58 +1511,10 @@ (-> Bool Bool) (if x false true)) -(def''' (text:++ x y) - (-> Text Text Text) - (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] - x [y])) - -(def''' (ident->text ident) - (-> Ident Text) - (let' [[module name] ident] - ($ text:++ module ";" name))) - -(def''' (get k plist) - (All [a] - (-> Text ($' List (, Text a)) ($' Maybe a))) - (_lux_case plist - (#Cons [[k' v] plist']) - (if (text:= k k') - (#Some v) - (get k plist')) - - #Nil - #None)) - -(def''' (put k v dict) - (All [a] - (-> Text a ($' List (, Text a)) ($' List (, Text a)))) - (_lux_case dict - #Nil - (list [k v]) - - (#Cons [[k' v'] dict']) - (if (text:= k k') - (#Cons [[k' v] dict']) - (#Cons [[k' v'] (put k v dict')])))) - (def''' (->text x) (-> (^ java.lang.Object) Text) (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])) -(def''' (get-module-name state) - ($' Lux Text) - (_lux_case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (_lux_case (reverse envs) - #Nil - (#Left "Can't get the module name without a module!") - - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) - (#Right [state module-name])))) - (def''' (find-macro' modules current-module module name) (-> ($' List (, Text ($' Module Compiler))) Text Text Text @@ -1589,7 +1643,7 @@ [_ (#FormS (#Cons [type-fn args]))] (foldL (_lux_: (-> AST AST AST) - (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) + (lambda' [type-fn arg] (` (#;AppT [(~ type-fn) (~ arg)])))) (walk-type type-fn) (map walk-type args)) @@ -1614,7 +1668,7 @@ (defmacro #export (: tokens) (_lux_case tokens (#Cons type (#Cons value #Nil)) - (return (list (`' (_lux_: (;type (~ type)) (~ value))))) + (return (list (` (;_lux_: (;type (~ type)) (~ value))))) _ (fail "Wrong syntax for :"))) @@ -1622,7 +1676,7 @@ (defmacro #export (:! tokens) (_lux_case tokens (#Cons type (#Cons value #Nil)) - (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) + (return (list (` (;_lux_:! (type (~ type)) (~ value))))) _ (fail "Wrong syntax for :!"))) @@ -1651,7 +1705,7 @@ (lambda' [case] (_lux_case case [_ (#TagS "" member-name)] - (return [member-name (`' Unit)]) + (return [member-name (` Unit)]) [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] (return [member-name member-type]) @@ -1659,7 +1713,7 @@ _ (fail "Wrong syntax for variant case.")))) cases)] - (return [(`' (#;VariantT (~ (untemplate-list (map second members))))) + (return [(` (#;VariantT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) @@ -1677,7 +1731,7 @@ _ (fail "Wrong syntax for variant case.")))) (as-pairs pairs))] - (return [(`' (#TupleT (~ (untemplate-list (map second members))))) + (return [(` (#TupleT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) @@ -1720,12 +1774,12 @@ [type tags??] type+tags?? with-export (: (List AST) (if export? - (list (`' (_lux_export (~ type-name)))) + (list (` (;_lux_export (~ type-name)))) #Nil)) with-tags (: (List AST) (_lux_case tags?? (#Some tags) - (list (`' (_lux_declare-tags [(~@ tags)] (~ type-name)))) + (list (` (;_lux_declare-tags [(~@ tags)] (~ type-name)))) _ (list))) @@ -1734,21 +1788,21 @@ (if (empty? args) (let' [g!param (symbol$ ["" ""]) prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] - (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) - ;Void)))) + type+ (replace-syntax (list [name (` ((~ prime-name) (~ g!param)))]) type)] + (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) + Void)))) #None) (_lux_case args #Nil (#Some type) _ - (#Some (`' (;All (~ type-name) [(~@ args)] (~ type)))))))] + (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] (_lux_case type' (#Some type'') - (return (list& (`' (_lux_def (~ type-name) (;type (#;NamedT [(~ (text$ module-name)) - (~ (text$ name))] - (~ type''))))) + (return (list& (` (;_lux_def (~ type-name) (type (#;NamedT [(~ (text$ module-name)) + (~ (text$ name))] + (~ type''))))) (list:++ with-export with-tags))) #None @@ -1763,7 +1817,7 @@ (#Cons value actions) (let' [dummy (symbol$ ["" ""])] (return (list (foldL (_lux_: (-> AST AST AST) - (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) + (lambda' [post pre] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) value actions)))) @@ -1802,17 +1856,17 @@ body _ - (`' (;lambda' (~ name) [(~@ args)] (~ body))))) + (` (lambda' (~ name) [(~@ args)] (~ body))))) body'' (: AST (_lux_case ?type (#Some type) - (`' (: (~ type) (~ body'))) + (` (: (~ type) (~ body'))) #None body'))] - (return (list& (`' (_lux_def (~ name) (~ body''))) + (return (list& (` (;_lux_def (~ name) (~ body''))) (if export? - (list (`' (_lux_export (~ name)))) + (list (` (;_lux_export (~ name)))) #Nil)))) #None @@ -1841,8 +1895,8 @@ _ (wrap (list branch)))))) (as-pairs branches))] - (wrap (list (`' (_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + (wrap (list (` (;_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) _ (fail "Wrong syntax for case"))) @@ -1878,16 +1932,6 @@ _ (fail "Wrong syntax for \\or"))) -(defmacro #export (` tokens) - (do Lux/Monad - [module-name get-module-name] - (case tokens - (\ (list template)) - (wrap (list (untemplate true module-name template))) - - _ - (fail "Wrong syntax for `")))) - (def' (symbol? ast) (-> AST Bool) (case ast @@ -1906,7 +1950,7 @@ (lambda' [body' lr] (let' [[l r] lr] (if (symbol? l) - (` (_lux_case (~ r) (~ l) (~ body'))) + (` (;_lux_case (~ r) (~ l) (~ body'))) (` (case (~ r) (~ l) (~ body'))))))) body) list @@ -1969,14 +2013,14 @@ body+ (: AST (foldL (: (-> AST AST AST) (lambda' [body' arg] (if (symbol? arg) - (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) - (` (_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) + (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) + (` (;_lux_lambda (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) body (reverse tail)))] (return (list (if (symbol? head) - (` (_lux_lambda (~ g!name) (~ head) (~ body+))) - (` (_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) + (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) + (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) #None (fail "Wrong syntax for lambda"))) @@ -2013,7 +2057,7 @@ body _ - (` (;lambda (~ name) [(~@ args)] (~ body))))) + (` (lambda (~ name) [(~@ args)] (~ body))))) body (: AST (case ?type (#Some type) @@ -2021,9 +2065,9 @@ #None body))] - (return (list& (` (_lux_def (~ name) (~ body))) + (return (list& (` (;_lux_def (~ name) (~ body))) (if export? - (list (` (_lux_export (~ name)))) + (list (` (;_lux_export (~ name)))) (list))))) #None @@ -2079,19 +2123,19 @@ def-name (symbol$ name) tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) types (map second members) - sig-type (: AST (` (#;TupleT (~ (untemplate-list types))))) - sig-decl (: AST (` (_lux_declare-tags [(~@ tags)] (~ def-name)))) + sig-type (: AST (` (#TupleT (~ (untemplate-list types))))) + sig-decl (: AST (` (;_lux_declare-tags [(~@ tags)] (~ def-name)))) sig+ (: AST (case args #Nil sig-type _ - (` (#;NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type))))))]] - (return (list& (` (_lux_def (~ def-name) (~ sig+))) + (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type))))))]] + (return (list& (` (;_lux_def (~ def-name) (~ sig+))) sig-decl (if export? - (list (` (_lux_export (~ def-name)))) + (list (` (;_lux_export (~ def-name)))) #Nil)))) #None @@ -2370,29 +2414,22 @@ #let [tag-mappings (: (List (, Text AST)) (map (lambda [tag] [(second tag) (tag$ tag)]) tags))] - _ (: (Lux Unit) - (let [msg ($ text:++ "struct/tag-mappings: " "[" (|> tag-mappings (map first) (interpose " ") (foldL text:++ "")) "]" " " (type:show struct-type)) - _ (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.Object"] - (_jvm_getstatic "java.lang.System" "out") [msg])] - (return (: Unit [])))) - ] - (do Lux/Monad - [members (map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [token] - (case token - (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) - (case (get tag-name tag-mappings) - (#Some tag) - (wrap (: (, AST AST) [tag value])) - - _ - (fail (text:++ "Unknown structure member: " tag-name))) + members (map% Lux/Monad + (: (-> AST (Lux (, AST AST))) + (lambda [token] + (case token + (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) + (case (get tag-name tag-mappings) + (#Some tag) + (wrap (: (, AST AST) [tag value])) _ - (fail (text:++ "Invalid structure member: " (ast:show token)))))) - (list:join tokens'))] - (wrap (list (record$ members)))))) + (fail (text:++ "Unknown structure member: " tag-name))) + + _ + (fail (text:++ "Invalid structure member: " (ast:show token)))))) + (list:join tokens'))] + (wrap (list (record$ members))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) @@ -2417,13 +2454,13 @@ (let [defs' (: AST (case args #Nil - (` (;struct (~@ defs))) + (` (struct (~@ defs))) _ - (` (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (` (lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] (return (list& (` (def (~ name) (~ type) (~ defs'))) (if export? - (list (` (_lux_export (~ name)))) + (list (` (;_lux_export (~ name)))) #Nil)))) #None @@ -2670,85 +2707,6 @@ cases)] output)) -(defmacro #export (import tokens) - (do Lux/Monad - [imports (parse-imports tokens) - imports (map% Lux/Monad - (: (-> Import (Lux Import)) - (lambda [import] - (case import - [m-name m-alias m-referrals m-openings] - (do Lux/Monad - [m-name (clean-module m-name)] - (wrap (: Import [m-name m-alias m-referrals m-openings])))))) - imports) - unknowns' (map% Lux/Monad - (: (-> Import (Lux (List Text))) - (lambda [import] - (case import - [m-name _ _ _] - (do Lux/Monad - [? (module-exists? m-name)] - (wrap (if ? - (list) - (list m-name))))))) - imports) - #let [unknowns (list:join unknowns')]] - (case unknowns - #Nil - (do Lux/Monad - [output' (map% Lux/Monad - (: (-> Import (Lux (List AST))) - (lambda [import] - (case import - [m-name m-alias m-referrals m-openings] - (do Lux/Monad - [defs (case m-referrals - #All - (exported-defs m-name) - - (#Only +defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (wrap (filter (is-member? +defs) *defs))) - - (#Exclude -defs) - (do Lux/Monad - [*defs (exported-defs m-name)] - (wrap (filter (. not (is-member? -defs)) *defs))) - - #Nothing - (wrap (list))) - #let [openings (: (List AST) - (case m-openings - #None - (list) - - (#Some prefix structs) - (map (: (-> Ident AST) - (lambda [struct] - (let [[_ name] struct] - (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) - structs)))]] - (wrap ($ list:++ - (: (List AST) (list (` (_lux_import (~ (text$ m-name)))))) - (: (List AST) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) - (map (: (-> Text AST) - (lambda [def] - (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) - defs) - openings)))))) - imports)] - (wrap (list:join output'))) - - _ - (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))) - unknowns) - (: (List AST) (list (` (import (~@ tokens)))))))))) - (def (try-both f x1 x2) (All [a b] (-> (-> a (Maybe b)) a a (Maybe b))) @@ -2895,17 +2853,17 @@ (lambda [[sname stype]] (use-field sname stype))) (zip2 tags members)) #let [pattern (record$ slots)]] - (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) + (return (list (` (;_lux_case (~ struct) (~ pattern) (~ body)))))) _ (fail "Can only \"use\" records."))) _ (let [dummy (symbol$ ["" ""])] - (return (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body)))))))) + (return (list (` (;_lux_case (~ struct) + (~ dummy) + (;using (~ dummy) + (~ body)))))))) _ (fail "Wrong syntax for using"))) @@ -2961,7 +2919,7 @@ g!output g!_)])) (zip2 tags (enumerate members))))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output)))))) + (return (list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) _ (fail "get@ can only use records."))) @@ -2984,7 +2942,7 @@ (return (list:join decls'))) _ - (return (list (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+)))))))) + (return (list (` (;_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+)))))))) (defmacro #export (open tokens) (case tokens @@ -3014,6 +2972,85 @@ _ (fail "Wrong syntax for open"))) +(defmacro #export (import tokens) + (do Lux/Monad + [imports (parse-imports tokens) + imports (map% Lux/Monad + (: (-> Import (Lux Import)) + (lambda [import] + (case import + [m-name m-alias m-referrals m-openings] + (do Lux/Monad + [m-name (clean-module m-name)] + (wrap (: Import [m-name m-alias m-referrals m-openings])))))) + imports) + unknowns' (map% Lux/Monad + (: (-> Import (Lux (List Text))) + (lambda [import] + (case import + [m-name _ _ _] + (do Lux/Monad + [? (module-exists? m-name)] + (wrap (if ? + (list) + (list m-name))))))) + imports) + #let [unknowns (list:join unknowns')]] + (case unknowns + #Nil + (do Lux/Monad + [output' (map% Lux/Monad + (: (-> Import (Lux (List AST))) + (lambda [import] + (case import + [m-name m-alias m-referrals m-openings] + (do Lux/Monad + [defs (case m-referrals + #All + (exported-defs m-name) + + (#Only +defs) + (do Lux/Monad + [*defs (exported-defs m-name)] + (wrap (filter (is-member? +defs) *defs))) + + (#Exclude -defs) + (do Lux/Monad + [*defs (exported-defs m-name)] + (wrap (filter (. not (is-member? -defs)) *defs))) + + #Nothing + (wrap (list))) + #let [openings (: (List AST) + (case m-openings + #None + (list) + + (#Some prefix structs) + (map (: (-> Ident AST) + (lambda [struct] + (let [[_ name] struct] + (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) + structs)))]] + (wrap ($ list:++ + (: (List AST) (list (` (;_lux_import (~ (text$ m-name)))))) + (: (List AST) + (case m-alias + #None (list) + (#Some alias) (list (` (;_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) + (map (: (-> Text AST) + (lambda [def] + (` (;_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + defs) + openings)))))) + imports)] + (wrap (list:join output'))) + + _ + (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (;_lux_import (~ (text$ m-name)))))) + unknowns) + (: (List AST) (list (` (;import (~@ tokens)))))))))) + (def (foldL% M f x ys) (All [m a b] (-> (Monad m) (-> a b (m a)) a (List b) @@ -3077,7 +3114,7 @@ value r-var)])) pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) _ (fail "set@ can only use records."))) @@ -3112,7 +3149,7 @@ (` ((~ fun) (~ r-var))) r-var)])) pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) _ (fail "update@ can only use records."))) @@ -3169,35 +3206,35 @@ (-> Type AST) (case type (#DataT name) - (` (#;DataT (~ (text$ name)))) + (` (#DataT (~ (text$ name)))) (#;VariantT cases) - (` (#;VariantT (~ (untemplate-list (map type->syntax cases))))) + (` (#VariantT (~ (untemplate-list (map type->syntax cases))))) (#TupleT parts) - (` (#;TupleT (~ (untemplate-list (map type->syntax parts))))) + (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) (#LambdaT in out) - (` (#;LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) + (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) (#BoundT idx) - (` (#;BoundT (~ (int$ idx)))) + (` (#BoundT (~ (int$ idx)))) (#VarT id) - (` (#;VarT (~ (int$ id)))) + (` (#VarT (~ (int$ id)))) (#ExT id) - (` (#;ExT (~ (int$ id)))) + (` (#ExT (~ (int$ id)))) (#UnivQ env type) (let [env' (untemplate-list (map type->syntax env))] - (` (#;UnivQ (~ env') (~ (type->syntax type))))) + (` (#UnivQ (~ env') (~ (type->syntax type))))) (#AppT fun arg) - (` (#;AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) + (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) (#NamedT [module name] type) - (` (#;NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type)))))) + (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type)))))) (defmacro #export (loop tokens) (case tokens @@ -3224,14 +3261,14 @@ (lambda [_] (gensym ""))) inits)] (return (list (` (let [(~@ (interleave aliases inits))] - (loop [(~@ (interleave vars aliases))] + (;loop [(~@ (interleave vars aliases))] (~ body))))))))) _ (fail "Wrong syntax for loop"))) (defmacro #export (export tokens) - (return (map (: (-> AST AST) (lambda [token] (` (_lux_export (~ token))))) tokens))) + (return (map (: (-> AST AST) (lambda [token] (` (;_lux_export (~ token))))) tokens))) (defmacro #export (\slots tokens) (case tokens diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index df48da863..8e59ae941 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -59,18 +59,18 @@ (let [[var value] binding] (case var [_ (#;TagS ["" "let"])] - (` (;let (~ value) (~ body'))) + (` (let (~ value) (~ body'))) _ - (` (;|> (~ value) ((~ g!map) (;lambda [(~ var)] (~ body'))) (~ g!join))) + (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) )))) body (reverse (as-pairs bindings)))] - (#;Right [state (#;Cons [(` (;case (~ monad) - {#;;_functor {#F;map (~ g!map)} #;;wrap (~ (' wrap)) #;;join (~ g!join)} - (~ body'))) - #;Nil])])) + (#;Right [state (#;Cons (` (case (~ monad) + {#_functor {#F;map (~ g!map)} #wrap (~ (' wrap)) #join (~ g!join)} + (~ body'))) + #;Nil)])) _ (#;Left "Wrong syntax for do"))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index 032381404..2d2a2bc35 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -20,7 +20,7 @@ (case tokens (\ (list value)) (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) + (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) _ (#;Left "Wrong syntax for io"))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index c9a4c7598..7df2eb358 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -214,21 +214,19 @@ ## [Syntax] (defmacro #export (list xs state) - (#;Right [state (#;Cons [(foldL (: (-> AST AST AST) - (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)])))) - (: AST (` #;Nil)) - (reverse xs)) - #;Nil])])) + (#;Right state (#;Cons (foldL (: (-> AST AST AST) + (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) + (: AST (` #;Nil)) + (reverse xs)) + #;Nil))) (defmacro #export (list& xs state) (case (reverse xs) - (#;Cons [last init]) - (#;Right [state (list (foldL (: (-> AST AST AST) - (lambda [tail head] - (` (#;Cons [(~ head) (~ tail)])))) - last - init))]) + (#;Cons last init) + (#;Right state (list (foldL (: (-> AST AST AST) + (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) + last + init))) _ (#;Left "Wrong syntax for list&"))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index 5df03f378..77dbec5b1 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -45,12 +45,13 @@ (defmacro #export (? tokens state) (case tokens (\ (list maybe else)) - (let [g!value (symbol$ ["" "_"])] + (let [g!value (symbol$ ["" "_"]) + g!_ (symbol$ ["" "12_34"])] (#;Right state (list (` (case (~ maybe) (#;Some (~ g!value)) (~ g!value) - _ + (~ g!_) (~ else)))))) _ diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 40021d8fa..d7992509a 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -82,21 +82,21 @@ ## [Syntax] (defsyntax #export (throw ex) - (emit (list (` (_jvm_throw (~ ex)))))) + (emit (list (` (;_jvm_throw (~ ex)))))) (defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident AST) AST) - (lambda [catch] - (let [[class ex body] catch] - (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches) - (case finally - #;None - (list) - - (#;Some finally) - (: (List AST) (list (` (_jvm_finally (~ finally)))))))))))))) + (emit (list (` (;_jvm_try (~ body) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident AST) AST) + (lambda [catch] + (let [[class ex body] catch] + (` (;_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches) + (case finally + #;None + (list) + + (#;Some finally) + (: (List AST) (list (` (;_jvm_finally (~ finally)))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) @@ -104,8 +104,8 @@ (let [[modifiers name inputs output] member] (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) members)] - (emit (list (` (_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ members'))))))) + (emit (list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + (~@ members'))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [fields (*^ field-decl^)] @@ -133,36 +133,37 @@ [(~@ (map text$ modifiers))] (~ body)))))) methods)]] - (emit (list (` (_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) + (emit (list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ fields')] + [(~@ methods')])))))) (defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (_jvm_new (~ (text$ class)) - [(~@ (map text$ arg-classes))] - [(~@ args)]))))) + (emit (list (` (;_jvm_new (~ (text$ class)) + [(~@ (map text$ arg-classes))] + [(~@ args)]))))) (defsyntax #export (instance? [class local-symbol^] obj) - (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + (emit (list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) (defsyntax #export (locking lock body) (do Lux/Monad [g!lock (gensym "") - g!body (gensym "")] - (emit (list (` (;let [(~ g!lock) (~ lock) - _ (_jvm_monitorenter (~ g!lock)) - (~ g!body) (~ body) - _ (_jvm_monitorexit (~ g!lock))] - (~ g!body))))) + g!body (gensym "") + g!_ (gensym "")] + (emit (list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) )) (defsyntax #export (null? obj) - (emit (list (` (_jvm_null? (~ obj)))))) + (emit (list (` (;_jvm_null? (~ obj)))))) (defsyntax #export (program [args symbol^] body) - (emit (list (` (_jvm_program (~ (symbol$ args)) - (~ body)))))) + (emit (list (` (;_jvm_program (~ (symbol$ args)) + (~ body)))))) (defsyntax #export (.? [field local-symbol^] obj) (case obj @@ -171,7 +172,7 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) + (emit (list (` (;_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) _ (fail "Can only get field from object."))) @@ -179,8 +180,8 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.? (~ (text$ field)) (~ g!obj))))))))) + (emit (list (` (let [(~ g!obj) (~ obj)] + (;;.? (~ (text$ field)) (~ g!obj))))))))) (defsyntax #export (.= [field local-symbol^] value obj) (case obj @@ -189,7 +190,7 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) + (emit (list (` (;_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) _ (fail "Can only set field of object."))) @@ -197,8 +198,8 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.= (~ (text$ field)) (~ value) (~ g!obj))))))))) + (emit (list (` (let [(~ g!obj) (~ obj)] + (;;.= (~ (text$ field)) (~ value) (~ g!obj))))))))) (defsyntax #export (.! [call method-call^] obj) (let [[m-name ?m-classes m-args] call] @@ -208,8 +209,8 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] - (~ obj) [(~@ m-args)])))) + (emit (list (` (;_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] + (~ obj) [(~@ m-args)])))) _ (fail "Can only call method on object."))) @@ -217,31 +218,31 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (;let [(~ g!obj) (~ obj)] - (.! ((~ (symbol$ ["" m-name])) - [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] - [(~@ m-args)]) - (~ g!obj)))))))))) + (emit (list (` (let [(~ g!obj) (~ obj)] + (;;.! ((~ (symbol$ ["" m-name])) + [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] + [(~@ m-args)]) + (~ g!obj)))))))))) (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) - (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + (emit (list (` (;_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) - (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + (emit (list (` (;_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) (defsyntax #export (..! [call method-call^] [class local-symbol^]) (let [[m-name m-classes m-args] call] - (emit (list (` (_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) - [(~@ (map text$ m-classes))] - [(~@ m-args)])))))) + (emit (list (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) + [(~@ (map text$ m-classes))] + [(~@ m-args)])))))) (defsyntax #export (->maybe expr) (do Lux/Monad [g!val (gensym "")] - (emit (list (` (;let [(~ g!val) (~ expr)] - (;if (null? (~ g!val)) - #;None - (#;Some (~ g!val))))))))) + (emit (list (` (let [(~ g!val) (~ expr)] + (if (null? (~ g!val)) + #;None + (#;Some (~ g!val))))))))) (defsyntax #export (try$ expr) (emit (list (` (try (#;Right (~ expr)) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 7d888f659..df79772c1 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -242,20 +242,20 @@ body' (foldL (: (-> AST (, AST AST) AST) (lambda [body name+parser] (let [[name parser] name+parser] - (` (_lux_case ((~ parser) (~ g!tokens)) - (#;Some [(~ g!tokens) (~ name)]) - (~ body) + (` (;_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) - (~ g!_) - (l;fail (~ error-msg))))))) + (~ g!_) + (l;fail (~ error-msg))))))) body (: (List (, AST AST)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) macro-def (: AST - (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] + (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] (wrap (list& macro-def (if exported? - (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list (` (;_lux_export (~ (symbol$ ["" name]))))) (list))))) _ -- cgit v1.2.3 From 817d244adff361104ae0aa6ce53efe6c2bc07552 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 30 Aug 2015 18:36:17 -0400 Subject: - Added unit-tests for lexer. - Fixed a bug when lexing multi-line comments. --- src/lux/lexer.clj | 20 ++-- src/lux/reader.clj | 27 ++--- test/test/lux/lexer.clj | 264 +++++++++++++++++++++++++++++++++++++++++++++++ test/test/lux/reader.clj | 4 +- 4 files changed, 281 insertions(+), 34 deletions(-) create mode 100644 test/test/lux/lexer.clj diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 4c7741769..b3a47f3e0 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -64,20 +64,12 @@ (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") - ;; :let [_ (prn 'immediate comment)] - _ (&reader/read-text ")#")] + [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex+ #"(?is)^(?!#\()((?!\)#).)*")] (return (&/T meta comment))) - (|do [;; :let [_ (prn 'pre/_0)] - [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") - ;; :let [_ (prn 'pre pre)] - [_ inner] (lex-multi-line-comment nil) - ;; :let [_ (prn 'inner inner)] - [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") - ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] - ] + (|do [[meta pre] (&reader/read-regex+ #"(?is)^((?!#\().)*") + [_ ($Comment inner)] (lex-multi-line-comment nil) + [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")] (return (&/T meta (str pre "#(" inner ")#" post)))))) - ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] (return (&/T meta (&/V $Comment comment))))) @@ -91,8 +83,8 @@ (return (&/T meta (&/V token))))) ^:private lex-bool $Bool #"^(true|false)" - ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" - ^:private lex-real $Real #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" + ^:private lex-int $Int #"^-?(0|[1-9][0-9]*)" + ^:private lex-real $Real #"^-?(0\.[0-9]+|[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char diff --git a/src/lux/reader.clj b/src/lux/reader.clj index af6c1ecc3..7b1559f07 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -55,13 +55,6 @@ (when (.find matcher) (.group matcher 0)))) -(defn ^:private re-find1! [^java.util.regex.Pattern regex column ^String line] - (let [matcher (doto (.matcher regex line) - (.region column (.length line)) - (.useAnchoringBounds true))] - (when (.find matcher) - (.group matcher 1)))) - (defn ^:private re-find3! [^java.util.regex.Pattern regex column ^String line] (let [matcher (doto (.matcher regex line) (.region column (.length line)) @@ -75,11 +68,8 @@ (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-regex [file-name line-num column-num regex line]) - (if-let [^String match (do ;; (prn '[regex line] [regex line]) - (re-find! regex column-num line))] - (let [;; _ (prn 'match match) - match-length (.length match) + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) match)) @@ -90,7 +80,6 @@ (defn read-regex2 [regex] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-regex2 [file-name line-num column-num regex line]) (if-let [[^String match tok1 tok2] (re-find3! regex column-num line)] (let [match-length (.length match) column-num* (+ column-num match-length)] @@ -111,15 +100,17 @@ (&/$Cons [[file-name line-num column-num] ^String line] reader**) - (if-let [^String match (do ;; (prn 'read-regex+ regex line) - (re-find1! regex column-num line))] + (if-let [^String match (re-find! regex column-num line)] (let [match-length (.length match) - column-num* (+ column-num match-length)] + column-num* (+ column-num match-length) + prefix* (if (= 0 column-num) + (str prefix "\n" match) + (str prefix match))] (if (= column-num* (.length line)) - (recur (str prefix match "\n") reader**) + (recur prefix* reader**) (&/V &/$Right (&/T (&/Cons$ (&/T (&/T file-name line-num column-num*) line) reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) + (&/T (&/T file-name line-num column-num) prefix*))))) (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] diff --git a/test/test/lux/lexer.clj b/test/test/lux/lexer.clj new file mode 100644 index 000000000..c36e4ea65 --- /dev/null +++ b/test/test/lux/lexer.clj @@ -0,0 +1,264 @@ +(ns test.lux.lexer + (:use clojure.test) + (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] + [reader :as &reader] + [lexer :as &lexer]) + [lux.analyser.module :as &a-module] + :reload-all)) + +;; [Utils] +(def ^:private module-name "test") + +(defn ^:private make-state [source-code] + (&/set$ &/$source (&reader/from module-name source-code) + (&/init-state nil))) + +;; [Tests] +(deftest lex-white-space + (let [input " \t"] + (|case (&/run-state &lexer/lex (make-state input)) + (&/$Right state [cursor (&lexer/$White_Space output)]) + (is (= input output)) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-comment + ;; Should be capable of recognizing both single-line & multi-line comments. + (let [input1 " YOLO" + input2 "\nLOL\n" + input3 " NYAN\n#(\nCAT )#\n"] + (|case (&/run-state (|do [[_ single-line] &lexer/lex + [_ multi-line] &lexer/lex + [_ multi-line-embedded] &lexer/lex] + (return (&/T single-line multi-line multi-line-embedded))) + (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#"))) + (&/$Right state [(&lexer/$Comment output1) + (&lexer/$Comment output2) + (&lexer/$Comment output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-bool + (let [input1 "true" + input2 "false"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex] + (return (&/T output1 output2))) + (make-state (str input1 "\n" input2))) + (&/$Right state [(&lexer/$Bool output1) + (&lexer/$Bool output2)]) + (are [input output] (= input output) + input1 output1 + input2 output2) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-int + (let [input1 "0" + input2 "12" + input3 "-123"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T output1 output2 output3))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state [(&lexer/$Int output1) + (&lexer/$Int output2) + (&lexer/$Int output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-real + (let [input1 "0.00123" + input2 "12.01020300" + input3 "-12.3"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T output1 output2 output3))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state [(&lexer/$Real output1) + (&lexer/$Real output2) + (&lexer/$Real output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + input3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-char + (let [input1 "a" + input2 "\\n" + input3 " " + input4 "\\t" + input5 "\\b" + input6 "\\r" + input7 "\\f" + input8 "\\\"" + input9 "\\\\"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex + [_ output6] &lexer/lex + [_ output7] &lexer/lex + [_ output8] &lexer/lex + [_ output9] &lexer/lex] + (return (&/T output1 output2 output3 output4 output5 output6 output7 output8 output9))) + (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\"" + "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\"" + "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\""))) + (&/$Right state [(&lexer/$Char output1) + (&lexer/$Char output2) + (&lexer/$Char output3) + (&lexer/$Char output4) + (&lexer/$Char output5) + (&lexer/$Char output6) + (&lexer/$Char output7) + (&lexer/$Char output8) + (&lexer/$Char output9)]) + (are [input output] (= input output) + input1 output1 + "\n" output2 + input3 output3 + "\t" output4 + "\b" output5 + "\r" output6 + "\f" output7 + "\"" output8 + "\\" output9) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-text + (let [input1 "" + input2 "abc" + input3 "yolo\\nlol\\tmeme"] + (|case (&/run-state (|do [[_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex] + (return (&/T output1 output2 output3))) + (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\""))) + (&/$Right state [(&lexer/$Text output1) + (&lexer/$Text output2) + (&lexer/$Text output3)]) + (are [input output] (= input output) + input1 output1 + input2 output2 + "yolo\nlol\tmeme" output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-symbol + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex] + (return (&/T output1 output2 output3 output4 output5))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5))) + (&/$Right state [(&lexer/$Symbol output1) + (&lexer/$Symbol output2) + (&lexer/$Symbol output3) + (&lexer/$Symbol output4) + (&lexer/$Symbol output5)]) + (are [input output] (&/ident= input output) + (&/T "" "foo") output1 + (&/T "test" "bar0123456789") output2 + (&/T "lux" "b1a2z3") output3 + (&/T "test" "quux") output4 + (&/T "" "!_@$%^&*-+=.<>?/|\\~`':") output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-tag + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex] + (return (&/T output1 output2 output3 output4 output5))) + (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5))) + (&/$Right state [(&lexer/$Tag output1) + (&lexer/$Tag output2) + (&lexer/$Tag output3) + (&lexer/$Tag output4) + (&lexer/$Tag output5)]) + (are [input output] (&/ident= input output) + (&/T "" "foo") output1 + (&/T "test" "bar0123456789") output2 + (&/T "lux" "b1a2z3") output3 + (&/T "test" "quux") output4 + (&/T "" "!_@$%^&*-+=.<>?/|\\~`':") output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest lex-delimiter + (let [input1 "(" + input2 ")" + input3 "[" + input4 "]" + input5 "{" + input6 "}"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + [_ output1] &lexer/lex + [_ output2] &lexer/lex + [_ output3] &lexer/lex + [_ output4] &lexer/lex + [_ output5] &lexer/lex + [_ output6] &lexer/lex] + (return (&/T output1 output2 output3 output4 output5 output6))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5 "\n" input6))) + (&/$Right state [(&lexer/$Open_Paren) + (&lexer/$Close_Paren) + (&lexer/$Open_Bracket) + (&lexer/$Close_Bracket) + (&lexer/$Open_Brace) + (&lexer/$Close_Brace)]) + (is true) + + _ + (is false "Couldn't read.") + ))) + +;; (run-all-tests) diff --git a/test/test/lux/reader.clj b/test/test/lux/reader.clj index 9b4954c5a..6d3ee0e06 100644 --- a/test/test/lux/reader.clj +++ b/test/test/lux/reader.clj @@ -1,11 +1,11 @@ -(ns text.lux.reader +(ns test.lux.reader (:use clojure.test) (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] [reader :as &reader]) :reload-all)) ;; [Utils] -(def source (&reader/from "yolo" "lol\nmeme\nnyan cat\n\nlolcat")) +(def source (&reader/from "test" "lol\nmeme\nnyan cat\n\nlolcat")) (def init-state (&/set$ &/$source source (&/init-state nil))) ;; [Tests] -- cgit v1.2.3 From a0533814cbc3b4b59850f97e9e72abc8bb83ff57 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 30 Aug 2015 20:07:37 -0400 Subject: - Added call/cc to lux/codata/lazy. - Added some minor compiler optimizations. --- source/lux/codata/lazy.lux | 6 +++++ source/lux/data/io.lux | 4 ++-- src/lux/analyser.clj | 55 +++++++++++++++++++++++----------------------- src/lux/analyser/case.clj | 2 +- src/lux/compiler/lux.clj | 12 +++++----- 5 files changed, 42 insertions(+), 37 deletions(-) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index 1529c0dae..fb0c0bcb3 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -32,6 +32,12 @@ (-> (Lazy a) a)) (thunk id)) +(def #export (call/cc f) + (All [a b c] (Lazy (-> a (Lazy b c)) (Lazy a c))) + (lambda [k] + (f (lambda [a _] (k a)) + k))) + ## [Structs] (defstruct #export Lazy/Functor (Functor Lazy) (def (map f ma) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index 2d2a2bc35..1ca68f518 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -42,10 +42,10 @@ ## [Functions] (def #export (print x) (-> Text (IO (,))) - (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.Object"] + (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.String"] (_jvm_getstatic "java.lang.System" "out") [x]))) (def #export (println x) (-> Text (IO (,))) - (io (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.Object"] + (io (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.String"] (_jvm_getstatic "java.lang.System" "out") [x]))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3ff214ee0..552ccd77d 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -559,33 +559,34 @@ (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] ;; (prn 'analyse-ast (&/show-ast token)) - (&/with-cursor (aget token 0) - (&/with-expected-type exo-type - (|case token - [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - - [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - - [meta (&/$FormS (&/$Cons ?fn ?args))] - (fn [state] - (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - _ - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - _ - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) + (|let [[cursor _] token] + (&/with-cursor cursor + (&/with-expected-type exo-type + (|case token + [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + + [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + + [meta (&/$FormS (&/$Cons ?fn ?args))] + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index e86d55497..7a1ec4860 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -233,7 +233,7 @@ ;; :let [_ (println "#13")] case-type (&type/variant-case idx value-type*) ;; :let [_ (println "#14" (&type/show-type case-type))] - [=test =kont] (case (&/|length ?values) + [=test =kont] (case (int (&/|length ?values)) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 3aa25ac99..6a02ed21d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -34,13 +34,11 @@ (do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (try (doto *writer* - (.visitTypeInsn Opcodes/NEW ) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL "" )) - (catch Exception e - (assert false (prn-str ' (alength value) (aget value 0) (aget value 1)))))]] + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW ) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] (return nil))) compile-int "java/lang/Long" "(J)V" long -- cgit v1.2.3 From 1857af8628216353c4fa0b75a921d66b266aa0b9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 31 Aug 2015 12:35:50 -0400 Subject: - Found a compromise with the issue of certain definitions clashing with each other when saving the class files in case-insensitive file-systems (https://github.com/LuxLang/lux/issues/8). The names of certain definitions were changed slightly to avoid clashes and the compiler throws an error if the names end up clashing prior to saving the .class file. --- source/lux.lux | 516 +++++++++++++++++++++---------------------- source/lux/codata/lazy.lux | 4 +- source/lux/codata/stream.lux | 12 +- source/lux/data/io.lux | 20 +- source/lux/data/list.lux | 16 +- source/lux/data/text.lux | 14 +- source/lux/host/jvm.lux | 116 +++++----- source/lux/meta/lux.lux | 20 +- source/lux/meta/syntax.lux | 28 +-- src/lux/compiler/base.clj | 9 +- 10 files changed, 379 insertions(+), 376 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 0ce03829b..9e5fbea7b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -826,16 +826,16 @@ (#Cons [_ (#TupleS args)] (#Cons body #Nil)) (parse-univq-args args (lambda'' [names] - (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) - (lambda'' [body' name'] - (form$ (#Cons (tag$ ["lux" "UnivQ"]) - (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) - (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) - body) - names) - (return (#Cons body' #Nil))))) + (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) + (lambda'' [body' name'] + (form$ (#Cons (tag$ ["lux" "UnivQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) + (update-bounds body')) #Nil)))))) + (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) + body) + names) + (return (#Cons body' #Nil))))) _ (fail "Wrong syntax for All")) @@ -859,7 +859,7 @@ _ (fail "Wrong syntax for ->"))) -(defmacro (list xs) +(defmacro (@list xs) (return (#Cons (foldL (lambda'' [tail head] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) @@ -868,31 +868,31 @@ (reverse xs)) #Nil))) -(defmacro (list& xs) +(defmacro (@list& xs) (_lux_case (reverse xs) (#Cons last init) - (return (list (foldL (lambda'' [tail head] - (form$ (list (tag$ ["lux" "Cons"]) - (tuple$ (list head tail))))) - last - init))) + (return (@list (foldL (lambda'' [tail head] + (form$ (@list (tag$ ["lux" "Cons"]) + (tuple$ (@list head tail))))) + last + init))) _ - (fail "Wrong syntax for list&"))) + (fail "Wrong syntax for @list&"))) (defmacro #export (^ tokens) (_lux_case tokens (#Cons [_ (#SymbolS "" class-name)] #Nil) - (return (list (form$ (list (tag$ ["lux" "DataT"]) (text$ class-name))))) + (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name))))) _ (fail "Wrong syntax for ^"))) (defmacro #export (, tokens) - (return (list (form$ (list (tag$ ["lux" "TupleT"]) - (foldL (lambda'' [tail head] (form$ (list (tag$ ["lux" "Cons"]) head tail))) - (tag$ ["lux" "Nil"]) - (reverse tokens))))))) + (return (@list (form$ (@list (tag$ ["lux" "TupleT"]) + (foldL (lambda'' [tail head] (form$ (@list (tag$ ["lux" "Cons"]) head tail))) + (tag$ ["lux" "Nil"]) + (reverse tokens))))))) (defmacro (lambda' tokens) (let'' [name tokens'] (_lux_: (, Text ($' List AST)) @@ -909,16 +909,16 @@ (fail "lambda' requires a non-empty arguments tuple.") (#Cons [harg targs]) - (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" name]) - harg - (foldL (lambda'' [body' arg] - (form$ (list (symbol$ ["" "_lux_lambda"]) - (symbol$ ["" ""]) - arg - body'))) - body - (reverse targs))))))) + (return (@list (form$ (@list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" name]) + harg + (foldL (lambda'' [body' arg] + (form$ (@list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))) _ (fail "Wrong syntax for lambda'")))) @@ -928,39 +928,39 @@ (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - (form$ (list (symbol$ ["lux" "lambda'"]) - name - (tuple$ args) - body)))))) - (form$ (list (symbol$ ["" "_lux_export"]) name)))) + (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) + name + (form$ (@list (symbol$ ["" "_lux_:"]) + type + (form$ (@list (symbol$ ["lux" "lambda'"]) + name + (tuple$ args) + body)))))) + (form$ (@list (symbol$ ["" "_lux_export"]) name)))) (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - body)))) - (form$ (list (symbol$ ["" "_lux_export"]) name)))) + (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) + name + (form$ (@list (symbol$ ["" "_lux_:"]) + type + body)))) + (form$ (@list (symbol$ ["" "_lux_export"]) name)))) (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) - type - (form$ (list (symbol$ ["lux" "lambda'"]) - name - (tuple$ args) - body)))))))) + (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) + name + (form$ (@list (symbol$ ["" "_lux_:"]) + type + (form$ (@list (symbol$ ["lux" "lambda'"]) + name + (tuple$ args) + body)))))))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list (form$ (list (symbol$ ["" "_lux_def"]) - name - (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) + (return (@list (form$ (@list (symbol$ ["" "_lux_def"]) + name + (form$ (@list (symbol$ ["" "_lux_:"]) type body)))))) _ (fail "Wrong syntax for def'") @@ -978,14 +978,14 @@ (defmacro (let' tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (-> AST (, AST AST) - AST) - (lambda' [body binding] - (_lux_case binding - [label value] - (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) - body - (reverse (as-pairs bindings))))) + (return (@list (foldL (_lux_: (-> AST (, AST AST) + AST) + (lambda' [body binding] + (_lux_case binding + [label value] + (form$ (@list (symbol$ ["" "_lux_case"]) value label body))))) + body + (reverse (as-pairs bindings))))) _ (fail "Wrong syntax for let'"))) @@ -1013,8 +1013,8 @@ (def''' (wrap-meta content) (-> AST AST) - (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1))) - content))) + (tuple$ (@list (tuple$ (@list (text$ "") (int$ -1) (int$ -1))) + content))) (def''' (untemplate-list tokens) (-> ($' List AST) AST) @@ -1023,7 +1023,7 @@ (_meta (#TagS ["lux" "Nil"])) (#Cons [token tokens']) - (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) + (_meta (#FormS (@list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) (def''' #export (list:++ xs ys) (All [a] (-> ($' List a) ($' List a) ($' List a))) @@ -1037,9 +1037,9 @@ (defmacro #export ($ tokens) (_lux_case tokens (#Cons op (#Cons init args)) - (return (list (foldL (lambda' [a1 a2] (form$ (list op a1 a2))) - init - args))) + (return (@list (foldL (lambda' [a1 a2] (form$ (@list op a1 a2))) + init + args))) _ (fail "Wrong syntax for $"))) @@ -1105,18 +1105,18 @@ (let' [[var value] binding] (_lux_case var [_ (#TagS "" "let")] - (form$ (list (symbol$ ["lux" "let'"]) value body')) + (form$ (@list (symbol$ ["lux" "let'"]) value body')) _ - (form$ (list g!bind - (form$ (list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body')) - value)))))) + (form$ (@list g!bind + (form$ (@list (symbol$ ["" "_lux_lambda"]) (symbol$ ["" ""]) var body')) + value)))))) body (reverse (as-pairs bindings)))] - (return (list (form$ (list (symbol$ ["" "_lux_case"]) - monad - (record$ (list [(tag$ ["lux" "return"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) - body'))))) + (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) + monad + (record$ (@list [(tag$ ["lux" "return"]) g!wrap] [(tag$ ["lux" "bind"]) g!bind])) + body'))))) _ (fail "Wrong syntax for do"))) @@ -1144,9 +1144,9 @@ (defmacro #export (if tokens) (_lux_case tokens (#Cons test (#Cons then (#Cons else #Nil))) - (return (list (form$ (list (symbol$ ["" "_lux_case"]) test - (bool$ true) then - (bool$ false) else)))) + (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) test + (bool$ true) then + (bool$ false) else)))) _ (fail "Wrong syntax for if"))) @@ -1168,7 +1168,7 @@ (-> Text a ($' List (, Text a)) ($' List (, Text a)))) (_lux_case dict #Nil - (list [k v]) + (@list [k v]) (#Cons [[k' v'] dict']) (if (text:= k k') @@ -1227,41 +1227,41 @@ _ (do Lux/Monad [=elem (untemplate elem)] - (wrap (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) - (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list =elem (tag$ ["lux" "Nil"])))))))))))) + (wrap (form$ (@list (symbol$ ["" "_lux_:"]) + (form$ (@list (tag$ ["lux" "AppT"]) (tuple$ (@list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) + (form$ (@list (tag$ ["lux" "Cons"]) (tuple$ (@list =elem (tag$ ["lux" "Nil"])))))))))))) elems))] - (wrap (wrap-meta (form$ (list tag - (form$ (list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "list:++"]) - elems'))))))) + (wrap (wrap-meta (form$ (@list tag + (form$ (@list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) + elems'))))))) false (do Lux/Monad [=elems (map% Lux/Monad untemplate elems)] - (wrap (wrap-meta (form$ (list tag (untemplate-list =elems))))))) + (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems))))))) false (do Lux/Monad [=elems (map% Lux/Monad untemplate elems)] - (wrap (wrap-meta (form$ (list tag (untemplate-list =elems)))))))) + (wrap (wrap-meta (form$ (@list tag (untemplate-list =elems)))))))) (def''' (untemplate replace? subst token) (-> Bool Text AST ($' Lux AST)) (_lux_case (_lux_: (, Bool AST) [replace? token]) [_ [_ (#BoolS value)]] - (return (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))) [_ [_ (#IntS value)]] - (return (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))) [_ [_ (#RealS value)]] - (return (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))) [_ [_ (#CharS value)]] - (return (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))) [_ [_ (#TextS value)]] - (return (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))) [_ [_ (#TagS [module name])]] (let' [module' (_lux_case module @@ -1270,7 +1270,7 @@ _ module)] - (return (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name)))))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "TagS"]) (tuple$ (@list (text$ module') (text$ name)))))))) [true [_ (#SymbolS [module name])]] (do Lux/Monad @@ -1281,10 +1281,10 @@ _ (wrap (_lux_: Ident [module name]))) #let [[module name] real-name]] - (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name)))))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name)))))))) [false [_ (#SymbolS [module name])]] - (return (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module) (text$ name))))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name))))))) [_ [_ (#TupleS elems)]] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) @@ -1307,9 +1307,9 @@ (do Lux/Monad [=k (untemplate replace? subst k) =v (untemplate replace? subst v)] - (wrap (tuple$ (list =k =v))))))) + (wrap (tuple$ (@list =k =v))))))) fields)] - (wrap (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) + (wrap (wrap-meta (form$ (@list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) )) (def'' (get-module-name state) @@ -1332,7 +1332,7 @@ (do Lux/Monad [current-module get-module-name =template (untemplate true current-module template)] - (wrap (list =template))) + (wrap (@list =template))) _ (fail "Wrong syntax for `"))) @@ -1342,7 +1342,7 @@ (#Cons template #Nil) (do Lux/Monad [=template (untemplate false "" template)] - (wrap (list =template))) + (wrap (@list =template))) _ (fail "Wrong syntax for '"))) @@ -1350,19 +1350,19 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (_lux_: (-> AST AST AST) - (lambda' [acc app] - (_lux_case app - [_ (#TupleS parts)] - (tuple$ (list:++ parts (list acc))) + (return (@list (foldL (_lux_: (-> AST AST AST) + (lambda' [acc app] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (list:++ parts (@list acc))) - [_ (#FormS parts)] - (form$ (list:++ parts (list acc))) + [_ (#FormS parts)] + (form$ (list:++ parts (@list acc))) - _ - (` ((~ app) (~ acc)))))) - init - apps))) + _ + (` ((~ app) (~ acc)))))) + init + apps))) _ (fail "Wrong syntax for |>"))) @@ -1577,7 +1577,7 @@ xs (#Cons [x xs']) - (list& x sep (interpose sep xs')))) + (@list& x sep (interpose sep xs')))) (def''' (macro-expand token) (-> AST ($' Lux ($' List AST))) @@ -1594,10 +1594,10 @@ (wrap (list:join expansion'))) #None - (return (list token)))) + (return (@list token)))) _ - (return (list token)))) + (return (@list token)))) (def''' (macro-expand-all syntax) (-> AST ($' Lux ($' List AST))) @@ -1615,22 +1615,22 @@ #None (do Lux/Monad - [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] - (wrap (list (form$ (list:join parts'))))))) + [parts' (map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] + (wrap (@list (form$ (list:join parts'))))))) [_ (#FormS (#Cons [harg targs]))] (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (map% Lux/Monad macro-expand-all targs)] - (wrap (list (form$ (list:++ harg+ (list:join targs+)))))) + (wrap (@list (form$ (list:++ harg+ (list:join targs+)))))) [_ (#TupleS members)] (do Lux/Monad [members' (map% Lux/Monad macro-expand-all members)] - (wrap (list (tuple$ (list:join members'))))) + (wrap (@list (tuple$ (list:join members'))))) _ - (return (list syntax)))) + (return (@list syntax)))) (def''' (walk-type type) (-> AST AST) @@ -1650,25 +1650,25 @@ _ type)) -(defmacro #export (type tokens) +(defmacro #export (@type tokens) (_lux_case tokens (#Cons type #Nil) (do Lux/Monad [type+ (macro-expand-all type)] (_lux_case type+ (#Cons type' #Nil) - (wrap (list (walk-type type'))) + (wrap (@list (walk-type type'))) _ (fail "The expansion of the type-syntax had to yield a single element."))) _ - (fail "Wrong syntax for type"))) + (fail "Wrong syntax for @type"))) (defmacro #export (: tokens) (_lux_case tokens (#Cons type (#Cons value #Nil)) - (return (list (` (;_lux_: (;type (~ type)) (~ value))))) + (return (@list (` (;_lux_: (@type (~ type)) (~ value))))) _ (fail "Wrong syntax for :"))) @@ -1676,7 +1676,7 @@ (defmacro #export (:! tokens) (_lux_case tokens (#Cons type (#Cons value #Nil)) - (return (list (` (;_lux_:! (type (~ type)) (~ value))))) + (return (@list (` (;_lux_:! (@type (~ type)) (~ value))))) _ (fail "Wrong syntax for :!"))) @@ -1774,21 +1774,21 @@ [type tags??] type+tags?? with-export (: (List AST) (if export? - (list (` (;_lux_export (~ type-name)))) + (@list (` (;_lux_export (~ type-name)))) #Nil)) with-tags (: (List AST) (_lux_case tags?? (#Some tags) - (list (` (;_lux_declare-tags [(~@ tags)] (~ type-name)))) + (@list (` (;_lux_declare-tags [(~@ tags)] (~ type-name)))) _ - (list))) + (@list))) type' (: (Maybe AST) (if rec? (if (empty? args) (let' [g!param (symbol$ ["" ""]) prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (` ((~ prime-name) (~ g!param)))]) type)] + type+ (replace-syntax (@list [name (` ((~ prime-name) (~ g!param)))]) type)] (#Some (` ((All (~ prime-name) [(~ g!param)] (~ type+)) Void)))) #None) @@ -1800,10 +1800,10 @@ (#Some (` (All (~ type-name) [(~@ args)] (~ type)))))))] (_lux_case type' (#Some type'') - (return (list& (` (;_lux_def (~ type-name) (type (#;NamedT [(~ (text$ module-name)) - (~ (text$ name))] - (~ type''))))) - (list:++ with-export with-tags))) + (return (@list& (` (;_lux_def (~ type-name) (@type (#;NamedT [(~ (text$ module-name)) + (~ (text$ name))] + (~ type''))))) + (list:++ with-export with-tags))) #None (fail "Wrong syntax for deftype")))) @@ -1816,10 +1816,10 @@ (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] - (return (list (foldL (_lux_: (-> AST AST AST) - (lambda' [post pre] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) - value - actions)))) + (return (@list (foldL (_lux_: (-> AST AST AST) + (lambda' [post pre] (` (;_lux_case (~ pre) (~ dummy) (~ post))))) + value + actions)))) _ (fail "Wrong syntax for exec"))) @@ -1864,10 +1864,10 @@ #None body'))] - (return (list& (` (;_lux_def (~ name) (~ body''))) - (if export? - (list (` (;_lux_export (~ name)))) - #Nil)))) + (return (@list& (` (;_lux_def (~ name) (~ body''))) + (if export? + (@list (` (;_lux_export (~ name)))) + #Nil)))) #None (fail "Wrong syntax for def'")))) @@ -1875,7 +1875,7 @@ (def' (rejoin-pair pair) (-> (, AST AST) (List AST)) (let' [[left right] pair] - (list left right))) + (@list left right))) (defmacro #export (case tokens) (_lux_case tokens @@ -1888,15 +1888,15 @@ (_lux_case pattern [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] (do Lux/Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] (wrap (list:join expansions))) _ - (wrap (list branch)))))) + (wrap (@list branch)))))) (as-pairs branches))] - (wrap (list (` (;_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + (wrap (@list (` (;_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) _ (fail "Wrong syntax for case"))) @@ -1908,7 +1908,7 @@ [pattern+ (macro-expand-all pattern)] (case pattern+ (#Cons pattern' #Nil) - (wrap (list pattern' body)) + (wrap (@list pattern' body)) _ (fail "\\ can only expand to 1 pattern."))) @@ -1926,7 +1926,7 @@ _ (do Lux/Monad [patterns' (map% Lux/Monad macro-expand-all patterns)] - (wrap (list:join (map (lambda' [pattern] (list pattern body)) + (wrap (list:join (map (lambda' [pattern] (@list pattern body)) (list:join patterns')))))) _ @@ -1943,7 +1943,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list [_ (#TupleS bindings)] body)) + (\ (@list [_ (#TupleS bindings)] body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> AST (, AST AST) AST) @@ -1953,7 +1953,7 @@ (` (;_lux_case (~ r) (~ l) (~ body'))) (` (case (~ r) (~ l) (~ body'))))))) body) - list + @list return) (fail "let requires an even number of parts")) @@ -1999,10 +1999,10 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens - (\ (list [_ (#TupleS (#Cons head tail))] body)) + (\ (@list [_ (#TupleS (#Cons head tail))] body)) (#Some ["" ""] head tail body) - (\ (list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body)) + (\ (@list [_ (#SymbolS ["" name])] [_ (#TupleS (#Cons head tail))] body)) (#Some ["" name] head tail body) _ @@ -2018,9 +2018,9 @@ (case (~ g!blank) (~ arg) (~ body'))))))) body (reverse tail)))] - (return (list (if (symbol? head) - (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) - (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) + (return (@list (if (symbol? head) + (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) + (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) #None (fail "Wrong syntax for lambda"))) @@ -2035,16 +2035,16 @@ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' - (\ (list [_ (#FormS (#Cons name args))] type body)) + (\ (@list [_ (#FormS (#Cons name args))] type body)) (#Some name args (#Some type) body) - (\ (list name type body)) + (\ (@list name type body)) (#Some name #Nil (#Some type) body) - (\ (list [_ (#FormS (#Cons name args))] body)) + (\ (@list [_ (#FormS (#Cons name args))] body)) (#Some name args #None body) - (\ (list name body)) + (\ (@list name body)) (#Some name #Nil #None body) _ @@ -2065,10 +2065,10 @@ #None body))] - (return (list& (` (;_lux_def (~ name) (~ body))) - (if export? - (list (` (;_lux_export (~ name)))) - (list))))) + (return (@list& (` (;_lux_def (~ name) (~ body))) + (if export? + (@list (` (;_lux_export (~ name)))) + (@list))))) #None (fail "Wrong syntax for def")))) @@ -2089,17 +2089,17 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#TagS "" "export")] tokens')) + (\ (@list& [_ (#TagS "" "export")] tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) + (\ (@list& [_ (#FormS (@list& [_ (#SymbolS name)] args))] sigs)) (#Some name args sigs) - (\ (list& [_ (#SymbolS name)] sigs)) + (\ (@list& [_ (#SymbolS name)] sigs)) (#Some name #Nil sigs) _ @@ -2113,7 +2113,7 @@ (: (-> AST (Lux (, Text AST))) (lambda [token] (case token - (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) + (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) (wrap (: (, Text AST) [name type])) _ @@ -2132,11 +2132,11 @@ _ (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type))))))]] - (return (list& (` (;_lux_def (~ def-name) (~ sig+))) - sig-decl - (if export? - (list (` (;_lux_export (~ def-name)))) - #Nil)))) + (return (@list& (` (;_lux_def (~ def-name) (~ sig+))) + sig-decl + (if export? + (@list (` (;_lux_export (~ def-name)))) + #Nil)))) #None (fail "Wrong syntax for defsig")))) @@ -2297,7 +2297,7 @@ (-> Type Type (Maybe Type)) (case type-fn (#UnivQ env body) - (#Some (beta-reduce (list& type-fn param env) body)) + (#Some (beta-reduce (@list& type-fn param env) body)) (#AppT F A) (do Maybe/Monad @@ -2418,7 +2418,7 @@ (: (-> AST (Lux (, AST AST))) (lambda [token] (case token - (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) + (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) (case (get tag-name tag-mappings) (#Some tag) (wrap (: (, AST AST) [tag value])) @@ -2429,22 +2429,22 @@ _ (fail (text:++ "Invalid structure member: " (ast:show token)))))) (list:join tokens'))] - (wrap (list (record$ members))))) + (wrap (@list (record$ members))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#TagS "" "export")] tokens')) + (\ (@list& [_ (#TagS "" "export")] tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' - (\ (list& [_ (#FormS (list& name args))] type defs)) + (\ (@list& [_ (#FormS (@list& name args))] type defs)) (#Some name args type defs) - (\ (list& name type defs)) + (\ (@list& name type defs)) (#Some name #Nil type defs) _ @@ -2458,10 +2458,10 @@ _ (` (lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] - (return (list& (` (def (~ name) (~ type) (~ defs'))) - (if export? - (list (` (;_lux_export (~ name)))) - #Nil)))) + (return (@list& (` (def (~ name) (~ type) (~ defs'))) + (if export? + (@list (` (;_lux_export (~ name)))) + #Nil)))) #None (fail "Wrong syntax for defstruct")))) @@ -2473,11 +2473,11 @@ (do-template [ ] [(defmacro #export ( tokens) (case (reverse tokens) - (\ (list& last init)) - (return (list (foldL (: (-> AST AST AST) - (lambda [post pre] (` ))) - last - init))) + (\ (@list& last init)) + (return (@list (foldL (: (-> AST AST AST) + (lambda [post pre] (` ))) + last + init))) _ (fail )))] @@ -2494,7 +2494,7 @@ (deftype Openings (, Text (List Ident))) -(deftype Import +(deftype Importation (, Text (Maybe Text) Referrals (Maybe Openings))) (def (extract-defs defs) @@ -2513,7 +2513,7 @@ (def (parse-alias tokens) (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) + (\ (@list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) _ @@ -2522,17 +2522,17 @@ (def (parse-referrals tokens) (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "refer")] referral tokens')) + (\ (@list& [_ (#TagS "" "refer")] referral tokens')) (case referral [_ (#TagS "" "all")] (return (: (, Referrals (List AST)) [#All tokens'])) - (\ [_ (#FormS (list& [_ (#TagS "" "only")] defs))]) + (\ [_ (#FormS (@list& [_ (#TagS "" "only")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) - (\ [_ (#FormS (list& [_ (#TagS "" "exclude")] defs))]) + (\ [_ (#FormS (@list& [_ (#TagS "" "exclude")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) @@ -2555,7 +2555,7 @@ (def (parse-openings tokens) (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens - (\ (list& [_ (#TagS "" "open")] [_ (#FormS (list& [_ (#TextS prefix)] structs))] tokens')) + (\ (@list& [_ (#TagS "" "open")] [_ (#FormS (@list& [_ (#TextS prefix)] structs))] tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) @@ -2572,24 +2572,24 @@ [_ (#SymbolS "" sub-name)] (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ [_ (#FormS (list& [_ (#SymbolS "" sub-name)] parts))]) - (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) + (\ [_ (#FormS (@list& [_ (#SymbolS "" sub-name)] parts))]) + (return (form$ (@list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ (fail "Wrong import syntax.")))) tokens)) (def (parse-imports imports) - (-> (List AST) (Lux (List Import))) + (-> (List AST) (Lux (List Importation))) (do Lux/Monad [imports' (map% Lux/Monad - (: (-> AST (Lux (List Import))) + (: (-> AST (Lux (List Importation))) (lambda [token] (case token [_ (#SymbolS "" m-name)] - (wrap (list [m-name #None #All #None])) + (wrap (@list [m-name #None #All #None])) - (\ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) + (\ [_ (#FormS (@list& [_ (#SymbolS "" m-name)] extra))]) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2601,7 +2601,7 @@ sub-imports (parse-imports extra)] (wrap (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) [#Nothing #None #None] sub-imports - _ (list& [m-name alias referral openings] sub-imports)))) + _ (@list& [m-name alias referral openings] sub-imports)))) _ (fail "Wrong syntax for import")))) @@ -2637,8 +2637,8 @@ (lambda [gdef] (let [[name [export? _]] gdef] (if export? - (list name) - (list))))) + (@list name) + (@list))))) (let [{#module-aliases _ #defs defs #imports _ #tags tags #types types} =module] defs))] (#Right state (list:join to-alias))) @@ -2656,7 +2656,7 @@ (#Cons x xs') (if (p x) - (split-with' p (list& x ys) xs') + (split-with' p (@list& x ys) xs') [ys xs]))) (def (split-with p xs) @@ -2670,8 +2670,8 @@ (do Lux/Monad [module-name get-module-name] (case (split-module module) - (\ (list& "." parts)) - (return (|> (list& module-name parts) (interpose "/") (foldL text:++ ""))) + (\ (@list& "." parts)) + (return (|> (@list& module-name parts) (interpose "/") (foldL text:++ ""))) parts (let [[ups parts'] (split-with (text:= "..") parts) @@ -2683,7 +2683,7 @@ (fail (text:++ "Can't clean module: " module)) (#Some top-module) - (return (|> (list& top-module parts') (interpose "/") (foldL text:++ "")))) + (return (|> (@list& top-module parts') (interpose "/") (foldL text:++ "")))) ))) )) @@ -2691,7 +2691,7 @@ (All [a] (-> (-> a Bool) (List a) (List a))) (case xs #;Nil - (list) + (@list) (#;Cons x xs') (if (p x) @@ -2812,13 +2812,13 @@ (#Cons x xs') (case ys (#Cons y ys') - (list& [x y] (zip2 xs' ys')) + (@list& [x y] (zip2 xs' ys')) _ - (list)) + (@list)) _ - (list))) + (@list))) (def (use-field [module name] type) (-> Ident Type (Lux (, AST AST))) @@ -2840,7 +2840,7 @@ (defmacro #export (using tokens) (case tokens - (\ (list struct body)) + (\ (@list struct body)) (case struct [_ (#SymbolS name)] (do Lux/Monad @@ -2853,17 +2853,17 @@ (lambda [[sname stype]] (use-field sname stype))) (zip2 tags members)) #let [pattern (record$ slots)]] - (return (list (` (;_lux_case (~ struct) (~ pattern) (~ body)))))) + (return (@list (` (;_lux_case (~ struct) (~ pattern) (~ body)))))) _ (fail "Can only \"use\" records."))) _ (let [dummy (symbol$ ["" ""])] - (return (list (` (;_lux_case (~ struct) - (~ dummy) - (;using (~ dummy) - (~ body)))))))) + (return (@list (` (;_lux_case (~ struct) + (~ dummy) + (;using (~ dummy) + (~ body)))))))) _ (fail "Wrong syntax for using"))) @@ -2878,13 +2878,13 @@ (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") (case (reverse tokens) - (\ (list& else branches')) - (return (list (foldL (: (-> AST (, AST AST) AST) - (lambda [else branch] - (let [[right left] branch] - (` (if (~ left) (~ right) (~ else)))))) - else - (as-pairs branches')))) + (\ (@list& else branches')) + (return (@list (foldL (: (-> AST (, AST AST) AST) + (lambda [else branch] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) _ (fail "Wrong syntax for cond")))) @@ -2904,7 +2904,7 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list [_ (#TagS slot')] record)) + (\ (@list [_ (#TagS slot')] record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -2919,7 +2919,7 @@ g!output g!_)])) (zip2 tags (enumerate members))))] - (return (list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) + (return (@list (` (;_lux_case (~ record) (~ pattern) (~ g!output)))))) _ (fail "get@ can only use records."))) @@ -2942,15 +2942,15 @@ (return (list:join decls'))) _ - (return (list (` (;_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+)))))))) + (return (@list (` (;_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+)))))))) (defmacro #export (open tokens) (case tokens - (\ (list& [_ (#SymbolS struct-name)] tokens')) + (\ (@list& [_ (#SymbolS struct-name)] tokens')) (do Lux/Monad [@module get-module-name #let [prefix (case tokens' - (\ (list [_ (#TextS prefix)])) + (\ (@list [_ (#TextS prefix)])) prefix _ @@ -2976,31 +2976,31 @@ (do Lux/Monad [imports (parse-imports tokens) imports (map% Lux/Monad - (: (-> Import (Lux Import)) + (: (-> Importation (Lux Importation)) (lambda [import] (case import [m-name m-alias m-referrals m-openings] (do Lux/Monad [m-name (clean-module m-name)] - (wrap (: Import [m-name m-alias m-referrals m-openings])))))) + (wrap (: Importation [m-name m-alias m-referrals m-openings])))))) imports) unknowns' (map% Lux/Monad - (: (-> Import (Lux (List Text))) + (: (-> Importation (Lux (List Text))) (lambda [import] (case import [m-name _ _ _] (do Lux/Monad [? (module-exists? m-name)] (wrap (if ? - (list) - (list m-name))))))) + (@list) + (@list m-name))))))) imports) #let [unknowns (list:join unknowns')]] (case unknowns #Nil (do Lux/Monad [output' (map% Lux/Monad - (: (-> Import (Lux (List AST))) + (: (-> Importation (Lux (List AST))) (lambda [import] (case import [m-name m-alias m-referrals m-openings] @@ -3020,11 +3020,11 @@ (wrap (filter (. not (is-member? -defs)) *defs))) #Nothing - (wrap (list))) + (wrap (@list))) #let [openings (: (List AST) (case m-openings #None - (list) + (@list) (#Some prefix structs) (map (: (-> Ident AST) @@ -3033,11 +3033,11 @@ (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] (wrap ($ list:++ - (: (List AST) (list (` (;_lux_import (~ (text$ m-name)))))) + (: (List AST) (@list (` (;_lux_import (~ (text$ m-name)))))) (: (List AST) (case m-alias - #None (list) - (#Some alias) (list (` (;_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) + #None (@list) + (#Some alias) (@list (` (;_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) (map (: (-> Text AST) (lambda [def] (` (;_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) @@ -3049,7 +3049,7 @@ _ (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (;_lux_import (~ (text$ m-name)))))) unknowns) - (: (List AST) (list (` (;import (~@ tokens)))))))))) + (: (List AST) (@list (` (;import (~@ tokens)))))))))) (def (foldL% M f x ys) (All [m a b] @@ -3066,7 +3066,7 @@ (defmacro #export (:: tokens) (case tokens - (\ (list& start parts)) + (\ (@list& start parts)) (do Lux/Monad [output (foldL% Lux/Monad (: (-> AST AST (Lux AST)) @@ -3075,21 +3075,21 @@ [_ (#SymbolS slot)] (return (: AST (` (get@ (~ (tag$ slot)) (~ so-far))))) - (\ [_ (#FormS (list& [_ (#SymbolS slot)] args))]) + (\ [_ (#FormS (@list& [_ (#SymbolS slot)] args))]) (return (: AST (` ((get@ (~ (tag$ slot)) (~ so-far)) (~@ args))))) _ (fail "Wrong syntax for ::")))) start parts)] - (return (list output))) + (return (@list output))) _ (fail "Wrong syntax for ::"))) (defmacro #export (set@ tokens) (case tokens - (\ (list [_ (#TagS slot')] value record)) + (\ (@list [_ (#TagS slot')] value record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3114,7 +3114,7 @@ value r-var)])) pattern'))] - (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) + (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) _ (fail "set@ can only use records."))) @@ -3124,7 +3124,7 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list [_ (#TagS slot')] fun record)) + (\ (@list [_ (#TagS slot')] fun record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3149,7 +3149,7 @@ (` ((~ fun) (~ r-var))) r-var)])) pattern'))] - (return (list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) + (return (@list (` (;_lux_case (~ record) (~ pattern) (~ output))))))) _ (fail "update@ can only use records."))) @@ -3159,9 +3159,9 @@ (defmacro #export (\template tokens) (case tokens - (\ (list [_ (#TupleS data)] - [_ (#TupleS bindings)] - [_ (#TupleS templates)])) + (\ (@list [_ (#TupleS data)] + [_ (#TupleS bindings)] + [_ (#TupleS templates)])) (case (: (Maybe (List AST)) (do Maybe/Monad [bindings' (map% Maybe/Monad get-name bindings) @@ -3192,7 +3192,7 @@ #Nil (#Cons y ys') - (list& x y (interleave xs' ys'))))) + (@list& x y (interleave xs' ys'))))) (do-template [ ] [(def ( p xs) @@ -3253,7 +3253,7 @@ (return (list (` ((: (-> (~@ (map type->syntax init-types)) (~ (type->syntax expected))) (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] - (~ body))) + (~ body))) (~@ inits)))))) (do Lux/Monad [aliases (map% Lux/Monad @@ -3262,7 +3262,7 @@ inits)] (return (list (` (let [(~@ (interleave aliases inits))] (;loop [(~@ (interleave vars aliases))] - (~ body))))))))) + (~ body))))))))) _ (fail "Wrong syntax for loop"))) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index fb0c0bcb3..542bb9922 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -19,9 +19,9 @@ ## [Syntax] (defmacro #export (... tokens state) (case tokens - (\ (list value)) + (\ (@list value)) (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + (#;Right [state (@list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) _ (#;Left "Wrong syntax for ..."))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index d0f84f0c7..a25a19b5f 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -10,7 +10,7 @@ (meta lux macro syntax) - (data (list #as l #refer (#only list list& List/Monad)) + (data (list #as l #refer (#only @list @list& List/Monad)) (number (int #open ("i" Int/Number Int/Ord))) bool) (codata (lazy #as L #refer #all)))) @@ -67,8 +67,8 @@ (-> (Stream a) (List a))) (let [[x xs'] (! xs)] (if - (list& x ( xs')) - (list)))) + (@list& x ( xs')) + (@list)))) (def #export ( det xs) (All [a] @@ -85,7 +85,7 @@ (if (let [[tail next] ( xs')] [(#;Cons [x tail]) next]) - [(list) xs])))] + [(@list) xs])))] [take-while drop-while split-with (-> a Bool) (det x) det] [take drop split Int (i> det 0) (i+ -1 det)] @@ -128,5 +128,5 @@ #let [patterns+ (: (List AST) (do List/Monad [pattern (l;reverse patterns)] - (: (List AST) (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))))]] - (wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) + (: (List AST) (@list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))))]] + (wrap (@list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index 1ca68f518..5c54c0369 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -16,25 +16,25 @@ (-> (,) a)) ## [Syntax] -(defmacro #export (io tokens state) +(defmacro #export (@io tokens state) (case tokens - (\ (list value)) + (\ (@list value)) (let [blank (symbol$ ["" ""])] - (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) + (#;Right [state (@list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) _ - (#;Left "Wrong syntax for io"))) + (#;Left "Wrong syntax for @io"))) ## [Structures] (defstruct #export IO/Functor (F;Functor IO) (def (map f ma) - (io (f (ma []))))) + (@io (f (ma []))))) (defstruct #export IO/Monad (M;Monad IO) (def _functor IO/Functor) (def (wrap x) - (io x)) + (@io x)) (def (join mma) (mma []))) @@ -42,10 +42,10 @@ ## [Functions] (def #export (print x) (-> Text (IO (,))) - (io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.String"] - (_jvm_getstatic "java.lang.System" "out") [x]))) + (@io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.String"] + (_jvm_getstatic "java.lang.System" "out") [x]))) (def #export (println x) (-> Text (IO (,))) - (io (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.String"] - (_jvm_getstatic "java.lang.System" "out") [x]))) + (@io (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.String"] + (_jvm_getstatic "java.lang.System" "out") [x]))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 7df2eb358..489ac5b4f 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -213,23 +213,23 @@ (@ (i+ -1 i) xs')))) ## [Syntax] -(defmacro #export (list xs state) +(defmacro #export (@list xs state) (#;Right state (#;Cons (foldL (: (-> AST AST AST) (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) (: AST (` #;Nil)) (reverse xs)) #;Nil))) -(defmacro #export (list& xs state) +(defmacro #export (@list& xs state) (case (reverse xs) (#;Cons last init) - (#;Right state (list (foldL (: (-> AST AST AST) + (#;Right state (@list (foldL (: (-> AST AST AST) (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) last init))) _ - (#;Left "Wrong syntax for list&"))) + (#;Left "Wrong syntax for @list&"))) ## [Structures] ## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) @@ -257,14 +257,14 @@ (defstruct #export List/Functor (Functor List) (def (map f ma) (case ma - #;Nil #;Nil - (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) + #;Nil #;Nil + (#;Cons a ma') (#;Cons (f a) (map f ma'))))) (defstruct #export List/Monad (Monad List) (def _functor List/Functor) (def (wrap a) - (#;Cons [a #;Nil])) + (#;Cons a #;Nil)) (def (join mma) (using List/Monoid @@ -282,4 +282,4 @@ (let [pre (filter (>= x) xs') post (filter (< x) xs') ++ (:: List/Monoid m;++)] - ($ ++ (sort ord pre) (list x) (sort ord post)))))) + ($ ++ (sort ord pre) (@list x) (sort ord post)))))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 533308dd0..e54dff5c0 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -13,7 +13,7 @@ (monad #as M #refer #all)) (data (number (int #open ("i" Int/Number Int/Ord))) maybe - (list #refer (#only foldL list list&))))) + (list #refer (#only foldL @list @list&))))) ## [Functions] (def #export (size x) @@ -158,18 +158,18 @@ (-> Text (List AST)) (case (extract-var template) (#;Some [pre var post]) - (list& (text$ pre) (symbol$ ["" var]) - (unravel-template post)) + (@list& (text$ pre) (symbol$ ["" var]) + (unravel-template post)) #;None - (list (text$ template)))) + (@list (text$ template)))) (defmacro #export (<> tokens state) (case tokens - (\ (list [_ (#;TextS template)])) + (\ (@list [_ (#;TextS template)])) (let [++ (symbol$ ["" ""])] - (#;Right state (list (` (;let [(~ ++) (;:: Text/Monoid m;++)] - (;$ (~ ++) (~@ (unravel-template template)))))))) + (#;Right state (@list (` (;let [(~ ++) (;:: Text/Monoid m;++)] + (;$ (~ ++) (~@ (unravel-template template)))))))) _ (#;Left "Wrong syntax for <>"))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index d7992509a..7a564826c 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -82,21 +82,21 @@ ## [Syntax] (defsyntax #export (throw ex) - (emit (list (` (;_jvm_throw (~ ex)))))) + (emit (@list (` (;_jvm_throw (~ ex)))))) (defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (list (` (;_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident AST) AST) - (lambda [catch] - (let [[class ex body] catch] - (` (;_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches) - (case finally - #;None - (list) - - (#;Some finally) - (: (List AST) (list (` (;_jvm_finally (~ finally)))))))))))))) + (emit (@list (` (;_jvm_try (~ body) + (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident AST) AST) + (lambda [catch] + (let [[class ex body] catch] + (` (;_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches) + (case finally + #;None + (@list) + + (#;Some finally) + (: (List AST) (@list (` (;_jvm_finally (~ finally)))))))))))))) (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) @@ -104,8 +104,8 @@ (let [[modifiers name inputs output] member] (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) members)] - (emit (list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ members'))))))) + (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + (~@ members'))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [fields (*^ field-decl^)] @@ -126,44 +126,44 @@ [(~@ (map (: (-> (, Text Text) AST) (lambda [in] (let [[left right] in] - (form$ (list (symbol$ ["" left]) - (text$ right)))))) + (form$ (@list (symbol$ ["" left]) + (text$ right)))))) inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))] (~ body)))))) methods)]] - (emit (list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) + (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ fields')] + [(~@ methods')])))))) (defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (list (` (;_jvm_new (~ (text$ class)) - [(~@ (map text$ arg-classes))] - [(~@ args)]))))) + (emit (@list (` (;_jvm_new (~ (text$ class)) + [(~@ (map text$ arg-classes))] + [(~@ args)]))))) (defsyntax #export (instance? [class local-symbol^] obj) - (emit (list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) + (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) (defsyntax #export (locking lock body) (do Lux/Monad [g!lock (gensym "") g!body (gensym "") g!_ (gensym "")] - (emit (list (` (let [(~ g!lock) (~ lock) - (~ g!_) (;_jvm_monitorenter (~ g!lock)) - (~ g!body) (~ body) - (~ g!_) (;_jvm_monitorexit (~ g!lock))] - (~ g!body))))) + (emit (@list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) )) (defsyntax #export (null? obj) - (emit (list (` (;_jvm_null? (~ obj)))))) + (emit (@list (` (;_jvm_null? (~ obj)))))) (defsyntax #export (program [args symbol^] body) - (emit (list (` (;_jvm_program (~ (symbol$ args)) - (~ body)))))) + (emit (@list (` (;_jvm_program (~ (symbol$ args)) + (~ body)))))) (defsyntax #export (.? [field local-symbol^] obj) (case obj @@ -172,7 +172,7 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (;_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) + (emit (@list (` (;_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) _ (fail "Can only get field from object."))) @@ -180,8 +180,8 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (let [(~ g!obj) (~ obj)] - (;;.? (~ (text$ field)) (~ g!obj))))))))) + (emit (@list (` (let [(~ g!obj) (~ obj)] + (;;.? (~ (text$ field)) (~ g!obj))))))))) (defsyntax #export (.= [field local-symbol^] value obj) (case obj @@ -190,7 +190,7 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (;_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) + (emit (@list (` (;_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) _ (fail "Can only set field of object."))) @@ -198,8 +198,8 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (let [(~ g!obj) (~ obj)] - (;;.= (~ (text$ field)) (~ value) (~ g!obj))))))))) + (emit (@list (` (let [(~ g!obj) (~ obj)] + (;;.= (~ (text$ field)) (~ value) (~ g!obj))))))))) (defsyntax #export (.! [call method-call^] obj) (let [[m-name ?m-classes m-args] call] @@ -209,8 +209,8 @@ [obj-type (find-var-type obj-name)] (case obj-type (#;DataT class) - (emit (list (` (;_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] - (~ obj) [(~@ m-args)])))) + (emit (@list (` (;_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] + (~ obj) [(~@ m-args)])))) _ (fail "Can only call method on object."))) @@ -218,33 +218,33 @@ _ (do Lux/Monad [g!obj (gensym "")] - (emit (list (` (let [(~ g!obj) (~ obj)] - (;;.! ((~ (symbol$ ["" m-name])) - [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] - [(~@ m-args)]) - (~ g!obj)))))))))) + (emit (@list (` (let [(~ g!obj) (~ obj)] + (;;.! ((~ (symbol$ ["" m-name])) + [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] + [(~@ m-args)]) + (~ g!obj)))))))))) (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) - (emit (list (` (;_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + (emit (@list (` (;_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) - (emit (list (` (;_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + (emit (@list (` (;_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) (defsyntax #export (..! [call method-call^] [class local-symbol^]) (let [[m-name m-classes m-args] call] - (emit (list (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) - [(~@ (map text$ m-classes))] - [(~@ m-args)])))))) + (emit (@list (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) + [(~@ (map text$ m-classes))] + [(~@ m-args)])))))) (defsyntax #export (->maybe expr) (do Lux/Monad [g!val (gensym "")] - (emit (list (` (let [(~ g!val) (~ expr)] - (if (null? (~ g!val)) - #;None - (#;Some (~ g!val))))))))) + (emit (@list (` (let [(~ g!val) (~ expr)] + (if (null? (~ g!val)) + #;None + (#;Some (~ g!val))))))))) (defsyntax #export (try$ expr) - (emit (list (` (try (#;Right (~ expr)) - (~ (' (catch java.lang.Exception e - (#;Left (.! (getMessage [] []) e)))))))))) + (emit (@list (` (try (#;Right (~ expr)) + (~ (' (catch java.lang.Exception e + (#;Left (.! (getMessage [] []) e)))))))))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 32ca78570..df3ebae48 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -131,10 +131,10 @@ (wrap (:: List/Monad (M;join expansion')))) #;None - (:: Lux/Monad (M;wrap (list syntax))))) + (:: Lux/Monad (M;wrap (@list syntax))))) _ - (:: Lux/Monad (M;wrap (list syntax))))) + (:: Lux/Monad (M;wrap (@list syntax))))) (def #export (macro-expand-all syntax) (-> AST (Lux (List AST))) @@ -152,22 +152,22 @@ #;None (do Lux/Monad - [parts' (M;map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] - (wrap (list (form$ (:: List/Monad (M;join parts')))))))) + [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] + (wrap (@list (form$ (:: List/Monad (M;join parts')))))))) [_ (#;FormS (#;Cons [harg targs]))] (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (M;map% Lux/Monad macro-expand-all targs)] - (wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) + (wrap (@list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) [_ (#;TupleS members)] (do Lux/Monad [members' (M;map% Lux/Monad macro-expand-all members)] - (wrap (list (tuple$ (:: List/Monad (M;join members')))))) + (wrap (@list (tuple$ (:: List/Monad (M;join members')))))) _ - (:: Lux/Monad (M;wrap (list syntax))))) + (:: Lux/Monad (M;wrap (@list syntax))))) (def #export (gensym prefix state) (-> Text (Lux AST)) @@ -191,7 +191,7 @@ (do Lux/Monad [token+ (macro-expand token)] (case token+ - (\ (list token')) + (\ (@list token')) (wrap token') _ @@ -216,8 +216,8 @@ (lambda [gdef] (let [[name [export? _]] gdef] (if export? - (list name) - (list))))) + (@list name) + (@list))))) (get@ #;defs =module)))])) #;None diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index df79772c1..3bc3196e2 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -27,7 +27,7 @@ (All [a] (-> (List (, a a)) (List a))) (case pairs #;Nil #;Nil - (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + (#;Cons [[x y] pairs']) (@list& x y (join-pairs pairs')))) ## [Types] (deftype #export (Parser a) @@ -160,10 +160,10 @@ (All [a] (-> (Parser a) (Parser (List a)))) (case (p tokens) - #;None (#;Some [tokens (list)]) + #;None (#;Some [tokens (@list)]) (#;Some [tokens' x]) (run-parser (do Parser/Monad [xs (*^ p)] - (wrap (list& x xs))) + (wrap (@list& x xs))) tokens'))) (def #export (+^ p) @@ -172,7 +172,7 @@ (do Parser/Monad [x p xs (*^ p)] - (wrap (list& x xs)))) + (wrap (@list& x xs)))) (def #export (&^ p1 p2) (All [a b] @@ -212,21 +212,21 @@ (defmacro #export (defsyntax tokens) (let [[exported? tokens] (: (, Bool (List AST)) (case tokens - (\ (list& [_ (#;TagS ["" "export"])] tokens')) + (\ (@list& [_ (#;TagS ["" "export"])] tokens')) [true tokens'] _ [false tokens]))] (case tokens - (\ (list [_ (#;FormS (list& [_ (#;SymbolS ["" name])] args))] - body)) + (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] + body)) (do Lux/Monad [names+parsers (M;map% Lux/Monad (: (-> AST (Lux (, AST AST))) (lambda [arg] (case arg - (\ [_ (#;TupleS (list [_ (#;SymbolS var-name)] - parser))]) + (\ [_ (#;TupleS (@list [_ (#;SymbolS var-name)] + parser))]) (wrap [(symbol$ var-name) parser]) (\ [_ (#;SymbolS var-name)]) @@ -249,14 +249,14 @@ (~ g!_) (l;fail (~ error-msg))))))) body - (: (List (, AST AST)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) + (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) macro-def (: AST (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) (~ body'))))]] - (wrap (list& macro-def - (if exported? - (list (` (;_lux_export (~ (symbol$ ["" name]))))) - (list))))) + (wrap (@list& macro-def + (if exported? + (@list (` (;_lux_export (~ (symbol$ ["" name]))))) + (@list))))) _ (l;fail "Wrong syntax for defsyntax")))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index b6efaada8..edb1441ca 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -46,9 +46,12 @@ (def tag-group-separator "\n") ;; [Utils] -(defn ^:private write-file [^String file ^bytes data] - (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] - (.write stream data))) +(defn ^:private write-file [^String file-name ^bytes data] + (let [;; file-name (.toLowerCase file-name) + ] + (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) + (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] + (.write stream data))))) (defn ^:private write-output [module name data] (let [module* (&host/->module-class module) -- cgit v1.2.3 From 7f0aa70c6115f9321e13f0452d724b9b40c3f981 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 31 Aug 2015 15:54:45 -0400 Subject: - Compiler no longer allows an alias to be reused for another module when importing. - Compiler now cleans the module's .class files prior to compiling to avoid keeping old .class files around. --- src/lux/analyser/module.clj | 28 +++++++++++++++------------- src/lux/compiler.clj | 3 ++- 2 files changed, 17 insertions(+), 14 deletions(-) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 6eca13b44..8c27fc08d 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -137,19 +137,6 @@ (return* state (->> state (&/get$ &/$modules) (&/|contains? name))))) -(defn alias [module alias reference] - (fn [state] - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - #(&/update$ $module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) - nil))) - (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] @@ -157,6 +144,21 @@ (return* state real-name) (fail* (str "Unknown alias: " name)))))) +(defn alias [module alias reference] + (fn [state] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $module-aliases) (&/|get alias))] + (fail* (str "Can't re-use alias \"" alias "\" @ " module)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) + nil)))) + (defn find-def [module name] (|do [current-module &/get-module-name] (fn [state] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 694c6bfc4..e16a84b20 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -408,7 +408,8 @@ (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) + (|do [_ (&&cache/delete name) + _ (&a-module/enter-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) -- cgit v1.2.3 From 2cfaf65019015ffe34fba5d5a723b94350cd4e84 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Sep 2015 11:18:26 -0400 Subject: - Added a macro to write recursive types. - Corrected some code that still involved the old names for the list macros. - Corrected some code in the pattern-matcher analyser to it fails properly when encountering invalid pattern-syntax. --- source/lux.lux | 196 +++++++++++++++++++++++------------------ source/lux/control/comonad.lux | 8 +- source/lux/data/maybe.lux | 21 ++--- source/program.lux | 29 +++--- src/lux/analyser/case.clj | 3 + 5 files changed, 139 insertions(+), 118 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 9e5fbea7b..722369131 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1537,6 +1537,17 @@ _ #None))) +(def''' (normalize ident) + (-> Ident ($' Lux Ident)) + (_lux_case ident + ["" name] + (do Lux/Monad + [module-name get-module-name] + (wrap (_lux_: Ident [module-name name]))) + + _ + (return ident))) + (def''' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) (do Lux/Monad @@ -1550,22 +1561,20 @@ #cursor cursor} (#Right state (find-macro' modules current-module module name))))))) +(def''' (macro? ident) + (-> Ident ($' Lux Bool)) + (do Lux/Monad + [ident (normalize ident) + output (find-macro ident)] + (wrap (_lux_case output + (#Some _) true + #None false)))) + (def''' (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (foldL list:++ #Nil xs)) -(def''' (normalize ident) - (-> Ident ($' Lux Ident)) - (_lux_case ident - ["" name] - (do Lux/Monad - [module-name get-module-name] - (wrap (_lux_: Ident [module-name name]))) - - _ - (return ident))) - (def''' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) @@ -1582,7 +1591,7 @@ (def''' (macro-expand token) (-> AST ($' Lux ($' List AST))) (_lux_case token - [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1602,7 +1611,7 @@ (def''' (macro-expand-all syntax) (-> AST ($' Lux ($' List AST))) (_lux_case syntax - [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1615,14 +1624,13 @@ #None (do Lux/Monad - [parts' (map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] - (wrap (@list (form$ (list:join parts'))))))) + [args' (map% Lux/Monad macro-expand-all args)] + (wrap (@list (form$ (#Cons (symbol$ macro-name) (list:join args')))))))) - [_ (#FormS (#Cons [harg targs]))] + [_ (#FormS members)] (do Lux/Monad - [harg+ (macro-expand-all harg) - targs+ (map% Lux/Monad macro-expand-all targs)] - (wrap (@list (form$ (list:++ harg+ (list:join targs+)))))) + [members' (map% Lux/Monad macro-expand-all members)] + (wrap (@list (form$ (list:join members'))))) [_ (#TupleS members)] (do Lux/Monad @@ -1740,6 +1748,28 @@ _ (return [type #None]))) +(def''' (gensym prefix state) + (-> Text ($' Lux AST)) + (_lux_case state + {#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} + (#Right {#source source #modules modules + #envs envs #type-vars types #host host + #seed (i+ 1 seed) #eval? eval? #expected expected + #cursor cursor} + (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) + +(defmacro #export (Rec tokens) + (_lux_case tokens + (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) + (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)] + (return (@list (` (#UnivQ #Nil (~ body')))))) + + _ + (fail "Wrong syntax for Rec"))) + (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens @@ -1872,6 +1902,48 @@ #None (fail "Wrong syntax for def'")))) +(def' (ast:show ast) + (-> AST Text) + (_lux_case ast + [_ ast] + (_lux_case ast + (#BoolS val) + (->text val) + + (#IntS val) + (->text val) + + (#RealS val) + (->text val) + + (#CharS val) + ($ text:++ "#\"" (->text val) "\"") + + (#TextS val) + ($ text:++ "\"" (->text val) "\"") + + (#FormS parts) + ($ text:++ "(" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) ")") + + (#TupleS parts) + ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]") + + (#SymbolS prefix name) + ($ text:++ prefix ";" name) + + (#TagS prefix name) + ($ text:++ "#" prefix ";" name) + + (#RecordS kvs) + ($ text:++ "{" + (|> kvs + (map (: (-> (, AST AST) Text) + (lambda' [kv] (let' [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v)))))) + (interpose " ") + (foldL text:++ "")) + "}") + ))) + (def' (rejoin-pair pair) (-> (, AST AST) (List AST)) (let' [[left right] pair] @@ -1888,9 +1960,13 @@ (_lux_case pattern [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] (do Lux/Monad - [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux/Monad expander (as-pairs expansion))] - (wrap (list:join expansions))) + [??? (macro? macro-name)] + (if ??? + (do Lux/Monad + [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux/Monad expander (as-pairs expansion))] + (wrap (list:join expansions))) + (wrap (@list branch)))) _ (wrap (@list branch)))))) @@ -1905,7 +1981,8 @@ (case tokens (#Cons body (#Cons pattern #Nil)) (do Lux/Monad - [pattern+ (macro-expand-all pattern)] + [module-name get-module-name + pattern+ (macro-expand-all pattern)] (case pattern+ (#Cons pattern' #Nil) (wrap (@list pattern' body)) @@ -1960,42 +2037,6 @@ _ (fail "Wrong syntax for let"))) -(def' (ast:show ast) - (-> AST Text) - (case ast - [_ ast] - (case ast - (\or (#BoolS val) (#IntS val) (#RealS val)) - (->text val) - - (#CharS val) - ($ text:++ "#\"" (->text val) "\"") - - (#TextS val) - ($ text:++ "\"" (->text val) "\"") - - (#FormS parts) - ($ text:++ "(" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) ")") - - (#TupleS parts) - ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]") - - (#SymbolS prefix name) - ($ text:++ prefix ";" name) - - (#TagS prefix name) - ($ text:++ "#" prefix ";" name) - - (#RecordS kvs) - ($ text:++ "{" - (|> kvs - (map (: (-> (, AST AST) Text) - (lambda' [kv] (let [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v)))))) - (interpose " ") - (foldL text:++ "")) - "}") - ))) - (defmacro #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens @@ -2073,19 +2114,6 @@ #None (fail "Wrong syntax for def")))) -(def (gensym prefix state) - (-> Text (Lux AST)) - (case state - {#source source #modules modules - #envs envs #type-vars types #host host - #seed seed #eval? eval? #expected expected - #cursor cursor} - (#Right {#source source #modules modules - #envs envs #type-vars types #host host - #seed (i+ 1 seed) #eval? eval? #expected expected - #cursor cursor} - (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) - (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens @@ -3238,7 +3266,7 @@ (defmacro #export (loop tokens) (case tokens - (\ (list [_ (#TupleS bindings)] body)) + (\ (@list [_ (#TupleS bindings)] body)) (let [pairs (as-pairs bindings) vars (map first pairs) inits (map second pairs)] @@ -3250,19 +3278,19 @@ #None (fail "Wrong syntax for loop"))) init-types (map% Lux/Monad find-var-type inits') expected expected-type] - (return (list (` ((: (-> (~@ (map type->syntax init-types)) - (~ (type->syntax expected))) - (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] - (~ body))) - (~@ inits)))))) + (return (@list (` ((: (-> (~@ (map type->syntax init-types)) + (~ (type->syntax expected))) + (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] + (~ body))) + (~@ inits)))))) (do Lux/Monad [aliases (map% Lux/Monad (: (-> AST (Lux AST)) (lambda [_] (gensym ""))) inits)] - (return (list (` (let [(~@ (interleave aliases inits))] - (;loop [(~@ (interleave vars aliases))] - (~ body))))))))) + (return (@list (` (let [(~@ (interleave aliases inits))] + (;loop [(~@ (interleave vars aliases))] + (~ body))))))))) _ (fail "Wrong syntax for loop"))) @@ -3272,7 +3300,7 @@ (defmacro #export (\slots tokens) (case tokens - (\ (list body [_ (#TupleS (list& hslot' tslots'))])) + (\ (@list body [_ (#TupleS (@list& hslot' tslots'))])) (do Lux/Monad [slots (: (Lux (, Ident (List Ident))) (case (: (Maybe (, Ident (List Ident))) @@ -3293,7 +3321,7 @@ #let [[idx tags type] output slot-pairings (map (: (-> Ident (, Text AST)) (lambda [[module name]] [name (symbol$ ["" name])])) - (list& hslot tslots)) + (@list& hslot tslots)) pattern (record$ (map (: (-> Ident (, AST AST)) (lambda [[module name]] (let [tag (tag$ [module name])] @@ -3301,7 +3329,7 @@ (#Some binding) [tag binding] #None [tag g!_])))) tags))]] - (return (list pattern body))) + (return (@list pattern body))) _ (fail "Wrong syntax for \\slots"))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index 052b8768d..8e12c24c0 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -29,7 +29,7 @@ ## [Syntax] (defmacro #export (be tokens state) (case tokens - (\ (list monad [_ (#;TupleS bindings)] body)) + (\ (@list comonad [_ (#;TupleS bindings)] body)) (let [body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] @@ -42,9 +42,9 @@ (~ value))))))) body (reverse (as-pairs bindings)))] - (#;Right [state (list (` (;case (~ monad) - {#;return ;return #;bind ;bind} - (~ body'))))])) + (#;Right [state (@list (` (;case (~ comonad) + {#;return ;return #;bind ;bind} + (~ body'))))])) _ (#;Left "Wrong syntax for be"))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index 77dbec5b1..7c0affd68 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -41,18 +41,9 @@ #;None #;None (#;Some xs) xs))) -## [Syntax] -(defmacro #export (? tokens state) - (case tokens - (\ (list maybe else)) - (let [g!value (symbol$ ["" "_"]) - g!_ (symbol$ ["" "12_34"])] - (#;Right state (list (` (case (~ maybe) - (#;Some (~ g!value)) - (~ g!value) - - (~ g!_) - (~ else)))))) - - _ - (#;Left "Wrong syntax for ?"))) +## [Functions] +(def #export (? else maybe) + (All [a] (-> a (Maybe a) a)) + (case maybe + (#;Some x) x + _ else)) diff --git a/source/program.lux b/source/program.lux index 716e3e6c6..1b6c6f398 100644 --- a/source/program.lux +++ b/source/program.lux @@ -4,32 +4,30 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (control monoid + (lux (control (monoid #as m) functor monad comonad bounded - dict eq hash - ord - show - number - stack) + (ord #as O) + (show #as S) + number) (data bool char (either #as e) - error id io - list + (list #refer #all #open ("list:" List/Functor)) maybe - (number int + (number (int #refer #all #open ("" Int/Show)) real) - (text #refer (#only <>)) + (text #refer (#only <>) #open ("text:" Text/Monoid)) writer - tuple) - (codata (stream #as S) + tuple + ) + (codata (stream #as s) lazy function (reader #as r) @@ -39,13 +37,14 @@ lux macro syntax) - (math #as m) + math )) (program args (case args - (\ (list name)) + (\ (@list name)) (println (<> "Hello, #{name}!")) _ - (println "Hello, world!"))) + (println "Hello, world!") + )) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 7a1ec4860..f302088d9 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -241,6 +241,9 @@ ;; :let [_ (println "#15")] ] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + + _ + (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] -- cgit v1.2.3 From e085c8c685b1e22827443a43d6f20b5ab6e72d6a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Sep 2015 16:48:54 -0400 Subject: - Fixed the implementation of the Rec macro, which forgot to do application on Void to achieve "recursion". - Introduced ExQ types into the type-system (still pending work on inference). --- source/lux.lux | 171 ++++++++++++++++++++++++++++++++++++------------------- src/lux/base.clj | 1 + src/lux/type.clj | 2 + 3 files changed, 114 insertions(+), 60 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 722369131..5f5c6925b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -8,51 +8,51 @@ ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) ## Basic types -(_lux_def Bool (9 ["lux" "Bool"] - (0 "java.lang.Boolean"))) +(_lux_def Bool (10 ["lux" "Bool"] + (0 "java.lang.Boolean"))) (_lux_export Bool) -(_lux_def Int (9 ["lux" "Int"] - (0 "java.lang.Long"))) +(_lux_def Int (10 ["lux" "Int"] + (0 "java.lang.Long"))) (_lux_export Int) -(_lux_def Real (9 ["lux" "Real"] - (0 "java.lang.Double"))) +(_lux_def Real (10 ["lux" "Real"] + (0 "java.lang.Double"))) (_lux_export Real) -(_lux_def Char (9 ["lux" "Char"] - (0 "java.lang.Character"))) +(_lux_def Char (10 ["lux" "Char"] + (0 "java.lang.Character"))) (_lux_export Char) -(_lux_def Text (9 ["lux" "Text"] - (0 "java.lang.String"))) +(_lux_def Text (10 ["lux" "Text"] + (0 "java.lang.String"))) (_lux_export Text) -(_lux_def Unit (9 ["lux" "Unit"] - (2 (0)))) +(_lux_def Unit (10 ["lux" "Unit"] + (2 (0)))) (_lux_export Unit) -(_lux_def Void (9 ["lux" "Void"] - (1 (0)))) +(_lux_def Void (10 ["lux" "Void"] + (1 (0)))) (_lux_export Void) -(_lux_def Ident (9 ["lux" "Ident"] - (2 (1 Text (1 Text (0)))))) +(_lux_def Ident (10 ["lux" "Ident"] + (2 (1 Text (1 Text (0)))))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons a (List a)))) (_lux_def List - (9 ["lux" "List"] - (7 (0) - (1 (1 ## "lux;Nil" - (2 (0)) - (1 ## "lux;Cons" - (2 (1 (4 1) - (1 (8 (4 0) (4 1)) - (0)))) - (0))))))) + (10 ["lux" "List"] + (7 (0) + (1 (1 ## "lux;Nil" + (2 (0)) + (1 ## "lux;Cons" + (2 (1 (4 1) + (1 (9 (4 0) (4 1)) + (0)))) + (0))))))) (_lux_export List) (_lux_declare-tags [#Nil #Cons] List) @@ -60,13 +60,13 @@ ## (| #None ## (1 a))) (_lux_def Maybe - (9 ["lux" "Maybe"] - (7 (0) - (1 (1 ## "lux;None" - (2 (0)) - (1 ## "lux;Some" - (4 1) - (0))))))) + (10 ["lux" "Maybe"] + (7 (0) + (1 (1 ## "lux;None" + (2 (0)) + (1 ## "lux;Some" + (4 1) + (0))))))) (_lux_export Maybe) (_lux_declare-tags [#None #Some] Maybe) @@ -78,40 +78,43 @@ ## (#BoundT Int) ## (#VarT Int) ## (#UnivQ (List Type) Type) +## (#ExQ (List Type) Type) ## (#AppT Type Type) ## (#NamedT Ident Type) ## )) (_lux_def Type - (9 ["lux" "Type"] - (_lux_case (8 (4 0) (4 1)) - Type - (_lux_case (8 List Type) - TypeList - (8 (7 (0) - (1 (1 ## "lux;DataT" - Text - (1 ## "lux;VariantT" - TypeList - (1 ## "lux;TupleT" + (10 ["lux" "Type"] + (_lux_case (9 (4 0) (4 1)) + Type + (_lux_case (9 List Type) + TypeList + (9 (7 (0) + (1 (1 ## "lux;DataT" + Text + (1 ## "lux;VariantT" TypeList - (1 ## "lux;LambdaT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;BoundT" - Int - (1 ## "lux;VarT" + (1 ## "lux;TupleT" + TypeList + (1 ## "lux;LambdaT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;BoundT" Int - (1 ## "lux;ExT" + (1 ## "lux;VarT" Int - (1 ## "lux;UnivQ" - (2 (1 TypeList (1 Type (0)))) - (1 ## "lux;AppT" - (2 (1 Type (1 Type (0)))) - (1 ## "lux;NamedT" - (2 (1 Ident (1 Type (0)))) - (0))))))))))))) - Void))))) + (1 ## "lux;ExT" + Int + (1 ## "lux;UnivQ" + (2 (1 TypeList (1 Type (0)))) + (1 ## "lux;ExQ" + (2 (1 TypeList (1 Type (0)))) + (1 ## "lux;AppT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;NamedT" + (2 (1 Ident (1 Type (0)))) + (0)))))))))))))) + Void))))) (_lux_export Type) -(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #UnivQ #AppT #NamedT] Type) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #UnivQ #ExQ #AppT #NamedT] Type) ## (deftype (Bindings k v) ## (& #counter Int @@ -841,6 +844,33 @@ (fail "Wrong syntax for All")) )) +(defmacro #export (Ex tokens) + (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil))) + (_lux_case tokens + (#Cons [_ (#SymbolS "" self-name)] tokens) + [self-name tokens] + + _ + ["" tokens])) + (_lux_case tokens + (#Cons [_ (#TupleS args)] (#Cons body #Nil)) + (parse-univq-args args + (lambda'' [names] + (let'' body' (foldL (_lux_: (#LambdaT AST (#LambdaT Text AST)) + (lambda'' [body' name'] + (form$ (#Cons (tag$ ["lux" "ExQ"]) + (#Cons (tag$ ["lux" "Nil"]) + (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) + (update-bounds body')) #Nil)))))) + (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) + body) + names) + (return (#Cons body' #Nil))))) + + _ + (fail "Wrong syntax for Ex")) + )) + (def'' (reverse list) (All [a] (#LambdaT ($' List a) ($' List a))) (foldL (lambda'' [tail head] (#Cons head tail)) @@ -1765,7 +1795,7 @@ (_lux_case tokens (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)] - (return (@list (` (#UnivQ #Nil (~ body')))))) + (return (@list (` (#AppT (#UnivQ #Nil (~ body')) Void))))) _ (fail "Wrong syntax for Rec"))) @@ -2056,7 +2086,7 @@ (if (symbol? arg) (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) (` (;_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) + (case (~ g!blank) (~ arg) (~ body'))))))) body (reverse tail)))] (return (@list (if (symbol? head) @@ -2266,6 +2296,9 @@ (#UnivQ ?env ?body) ($ text:++ "(All " (type:show ?body) ")") + (#ExQ ?env ?body) + ($ text:++ "(Ex " (type:show ?body) ")") + (#NamedT name type) (ident->text name) )) @@ -2303,6 +2336,14 @@ _ type) + (#ExQ ?local-env ?local-def) + (case ?local-env + #Nil + (#ExQ env ?local-def) + + _ + type) + (#LambdaT ?input ?output) (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) @@ -2352,6 +2393,9 @@ (#UnivQ _ body) (resolve-struct-type body) + (#ExQ _ body) + (resolve-struct-type body) + (#NamedT name type) (resolve-struct-type type) @@ -2398,6 +2442,9 @@ (#UnivQ env body) (resolve-type-tags body) + + (#ExQ env body) + (resolve-type-tags body) (#NamedT [module name] _) (do Lux/Monad @@ -3257,6 +3304,10 @@ (#UnivQ env type) (let [env' (untemplate-list (map type->syntax env))] (` (#UnivQ (~ env') (~ (type->syntax type))))) + + (#ExQ env type) + (let [env' (untemplate-list (map type->syntax env))] + (` (#ExQ (~ env') (~ (type->syntax type))))) (#AppT fun arg) (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) diff --git a/src/lux/base.clj b/src/lux/base.clj index b99437a2c..4db1d26bc 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -51,6 +51,7 @@ "VarT" "ExT" "UnivQ" + "ExQ" "AppT" "NamedT") diff --git a/src/lux/type.clj b/src/lux/type.clj index 36590ddd2..82eab3dd4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -105,6 +105,8 @@ Int ;; UnivQ (Tuple$ (&/|list TypeList Type)) + ;; ExQ + (Tuple$ (&/|list TypeList Type)) ;; AppT TypePair ;; NamedT -- cgit v1.2.3 From f270a49ce40829dc28c6254d7ed4eeb19f360f59 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Sep 2015 22:27:06 -0400 Subject: - Added the lux/meta/type module (still missing equality due to an issue with type-inference & Type/Show needs some pending corrections). --- source/lux/meta/type.lux | 157 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 157 insertions(+) create mode 100644 source/lux/meta/type.lux diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux new file mode 100644 index 000000000..d32ea993b --- /dev/null +++ b/source/lux/meta/type.lux @@ -0,0 +1,157 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux (control show + eq + monad) + (data (text #open ("text:" Text/Monoid Text/Eq)) + (number/int #open ("int:" Int/Eq Int/Show)) + maybe + (list #refer #all #open ("list:" List/Monad))) + )) + +## [Structures] +(defstruct #export Type/Show (Show Type) + (def (show type) + (case type + (#;DataT name) + ($ text:++ "(^ " name ")") + + (#;TupleT members) + (case members + #;Nil + "(,)" + + _ + ($ text:++ "(, " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) + + (#;VariantT members) + (case members + #;Nil + "(|)" + + _ + ($ text:++ "(| " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) + + (#;LambdaT input output) + ($ text:++ "(-> " (show input) " " (show output) ")") + + (#;VarT id) + ($ text:++ "⌈" (int:show id) "⌋") + + (#;BoundT idx) + (int:show idx) + + (#;ExT id) + ($ text:++ "⟨" (int:show id) "⟩") + + (#;AppT fun param) + ($ text:++ "(" (show fun) " " (show param) ")") + + (#;UnivQ env body) + ($ text:++ "(All " (show body) ")") + + (#;ExQ env body) + ($ text:++ "(Ex " (show body) ")") + + (#;NamedT [module name] type) + ($ text:++ module ";" name) + ))) + +## (defstruct #export Type/Eq (Eq Type) +## (def (= x y) +## (case [x y] +## [(#;DataT xname) (#;DataT yname)] +## (text:= xname yname) + +## (\or [(#;VarT xid) (#;VarT yid)] +## [(#;ExT xid) (#;ExT yid)] +## [(#;BoundT xid) (#;BoundT yid)]) +## (int:= xid yid) + +## (\or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)] +## [(#;AppT xleft xright) (#;AppT yleft yright)]) +## (and (= xleft yleft) +## (= xright yright)) + +## [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)] +## (and (text:= xmodule ymodule) +## (text:= xname yname) +## (= xtype ytype)) + +## (\or [(#;TupleT xmembers) (#;TupleT ymembers)] +## [(#;VariantT xmembers) (#;VariantT ymembers)]) +## (and (int:= (size xmembers) (size ymembers)) +## (foldL (lambda [prev [x y]] +## (and prev (= v y))) +## true +## (zip2 xmembers ymembers))) + +## (\or [(#;UnivQ yenv ybody) (#;UnivQ yenv ybody)] +## [(#;ExQ yenv ybody) (#;ExQ yenv ybody)]) +## (and (int:= (size xenv) (size yenv)) +## (foldL (lambda [prev [x y]] +## (and prev (= v y))) +## (= xbody ybody) +## (zip2 xenv yenv))) + +## _ +## false +## ))) + +## [Functions] +(def #export (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (\template [] + [( members) + ( (list:map (beta-reduce env) members))]) + [[#;VariantT] + [#;TupleT]] + + (\template [] + [( left right) + ( (beta-reduce env left) (beta-reduce env right))]) + [[#;LambdaT] + [#;AppT]] + + (\template [] + [( env def) + (case env + #;Nil + ( env def) + + _ + type)]) + [[#;UnivQ] + [#;ExQ]] + + (#;BoundT idx) + (? type (@ idx env)) + + (#;NamedT name type) + (beta-reduce env type) + + _ + type + )) + +(def #export (apply-type type-fun param) + (-> Type Type (Maybe Type)) + (case type-fun + (#;UnivQ env body) + (#;Some (beta-reduce (@list& type-fun param env) body)) + + (#;AppT F A) + (do Maybe/Monad + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (#;NamedT name type) + (apply-type type param) + + _ + #;None)) -- cgit v1.2.3 From a0eb061edbbb8bca666add620e4c82c4f3bc5fdc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 2 Sep 2015 08:11:14 -0400 Subject: - Added a new (albeit small) I/O library with host-dependent functions. --- source/lux/data/io.lux | 11 ----------- source/lux/host/io.lux | 35 +++++++++++++++++++++++++++++++++++ source/lux/host/jvm.lux | 2 +- source/lux/meta/lux.lux | 44 ++++++++++++++++++++++---------------------- source/program.lux | 30 ++++++++++++++++++------------ src/lux/analyser/host.clj | 2 +- 6 files changed, 77 insertions(+), 47 deletions(-) create mode 100644 source/lux/host/io.lux diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index 5c54c0369..4919d2edd 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -38,14 +38,3 @@ (def (join mma) (mma []))) - -## [Functions] -(def #export (print x) - (-> Text (IO (,))) - (@io (_jvm_invokevirtual "java.io.PrintStream" "print" ["java.lang.String"] - (_jvm_getstatic "java.lang.System" "out") [x]))) - -(def #export (println x) - (-> Text (IO (,))) - (@io (_jvm_invokevirtual "java.io.PrintStream" "println" ["java.lang.String"] - (_jvm_getstatic "java.lang.System" "out") [x]))) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux new file mode 100644 index 000000000..7611e41b7 --- /dev/null +++ b/source/lux/host/io.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + lux/data/io + (.. jvm)) + +## [Functions] +(do-template [ ] + [(def #export ( x) + (-> (IO (,))) + (@io (.! ( [] [x]) + (..? out java.lang.System))))] + + [write-char print Char char] + [write print Text java.lang.String] + [write-line println Text java.lang.String]) + +(do-template [ ] + [(def #export + (IO (Maybe )) + (let [in (..? in java.lang.System) + reader (new java.io.InputStreamReader [java.io.InputStream] [in]) + buff-reader (new java.io.BufferedReader [java.io.Reader] [reader])] + (@io (let [output (: (Either Text ) (try$ ))] + (exec (.! (close [] []) buff-reader) + (case output + (#;Left _) #;None + (#;Right input) (#;Some input)))))))] + + [read-char Char (_jvm_i2c (.! (read [] []) buff-reader))] + [read-line Text (.! (readLine [] []) buff-reader)] + ) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 7a564826c..eddedfdc5 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -247,4 +247,4 @@ (defsyntax #export (try$ expr) (emit (@list (` (try (#;Right (~ expr)) (~ (' (catch java.lang.Exception e - (#;Left (.! (getMessage [] []) e)))))))))) + (#;Left (_jvm_invokevirtual "java.lang.Throwable" "getMessage" [] e [])))))))))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index df3ebae48..dd14e708d 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -247,26 +247,25 @@ (#;Some y) (#;Some y))) (def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#;source source #;modules modules - #;envs envs #;type-vars types #;host host - #;seed seed #;eval? eval? #;expected expected - #;cursor cursor} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#;Some type) - #;None))))) - locals - closure)))) - envs)))) + (-> Text Compiler (Maybe Type)) + (case state + {#;source source #;modules modules + #;envs envs #;type-vars types #;host host + #;seed seed #;eval? eval? #;expected expected + #;cursor cursor} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= name bname) + (#;Some type) + #;None))))) + locals + closure)))) + envs))) (def (find-in-defs name state) (-> Ident Compiler (Maybe Type)) @@ -294,10 +293,11 @@ (def #export (find-var-type name) (-> Ident (Lux Type)) (do Lux/Monad - [name' (normalize name)] + [#let [[_ _name] name] + name' (normalize name)] (: (Lux Type) (lambda [state] - (case (find-in-env name state) + (case (find-in-env _name state) (#;Some struct-type) (#;Right [state struct-type]) diff --git a/source/program.lux b/source/program.lux index 1b6c6f398..69b9e811d 100644 --- a/source/program.lux +++ b/source/program.lux @@ -19,32 +19,38 @@ (either #as e) id io - (list #refer #all #open ("list:" List/Functor)) + list maybe - (number (int #refer #all #open ("" Int/Show)) - real) + (number (int #refer (#only)) + (real #refer (#only))) (text #refer (#only <>) #open ("text:" Text/Monoid)) - writer - tuple + (writer #refer (#only)) + (tuple #refer (#only)) ) (codata (stream #as s) - lazy - function + (lazy #refer (#only)) + (function #refer (#only)) (reader #as r) - state) - (host jvm) + (state #refer (#only))) + (host jvm + io) (meta ast lux macro - syntax) + syntax + type) math )) (program args (case args (\ (@list name)) - (println (<> "Hello, #{name}!")) + (write-line (<> "Hello, #{name}!")) _ - (println "Hello, world!") + (do IO/Monad + [_ (write "Please, tell me your name: ") + name' read-line + #let [name (? "???" name')]] + (write-line (<> "Hello, #{name}!"))) )) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 796b2d147..c6c5cb39b 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -358,7 +358,7 @@ idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (|case [?finally] + =finally (|case ?finally (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] -- cgit v1.2.3 From 5d00a72dc36171a8f5c3292bacc802705fd1bb18 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 2 Sep 2015 10:17:32 -0400 Subject: Added a lightweight code of conduct for the community. --- code_of_conduct.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 code_of_conduct.md diff --git a/code_of_conduct.md b/code_of_conduct.md new file mode 100644 index 000000000..01b8644f1 --- /dev/null +++ b/code_of_conduct.md @@ -0,0 +1,22 @@ +# Contributor Code of Conduct + +As contributors and maintainers of this project, and in the interest of fostering an open and welcoming community, we pledge to respect all people who contribute through reporting issues, posting feature requests, updating documentation, submitting pull requests or patches, and other activities. + +We are committed to making participation in this project a harassment-free experience for everyone, regardless of level of experience, gender, gender identity and expression, sexual orientation, disability, personal appearance, body size, race, ethnicity, age, religion, or nationality. + +Examples of unacceptable behavior by participants include: + +* The use of sexualized language or imagery +* Personal attacks +* Trolling or insulting/derogatory comments +* Public or private harassment +* Publishing other's private information, such as physical or electronic addresses, without explicit permission +* Other unethical or unprofessional conduct. + +Project maintainers have the right and responsibility to remove, edit, or reject comments, commits, code, wiki edits, issues, and other contributions that are not aligned to this Code of Conduct. By adopting this Code of Conduct, project maintainers commit themselves to fairly and consistently applying these principles to every aspect of managing this project. Project maintainers who do not follow or enforce the Code of Conduct may be permanently removed from the project team. + +This code of conduct applies both within project spaces and in public spaces when an individual is representing the project or its community. + +Instances of abusive, harassing, or otherwise unacceptable behavior may be reported by opening an issue or contacting one or more of the project maintainers. + +This Code of Conduct is adapted from the [Contributor Covenant](http://contributor-covenant.org), version 1.2.0, available at [http://contributor-covenant.org/version/1/2/0/](http://contributor-covenant.org/version/1/2/0/) -- cgit v1.2.3 From 9acccd0847d6bb28e706223439eb44e5a3fe9aff Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 3 Sep 2015 10:44:44 -0400 Subject: Tests for the parser. --- test/test/lux/lexer.clj | 5 + test/test/lux/parser.clj | 269 +++++++++++++++++++++++++++++++++++++++++++++++ test/test/lux/reader.clj | 5 + 3 files changed, 279 insertions(+) create mode 100644 test/test/lux/parser.clj diff --git a/test/test/lux/lexer.clj b/test/test/lux/lexer.clj index c36e4ea65..72602639d 100644 --- a/test/test/lux/lexer.clj +++ b/test/test/lux/lexer.clj @@ -1,3 +1,8 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + (ns test.lux.lexer (:use clojure.test) (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] diff --git a/test/test/lux/parser.clj b/test/test/lux/parser.clj new file mode 100644 index 000000000..13bd3500c --- /dev/null +++ b/test/test/lux/parser.clj @@ -0,0 +1,269 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns test.lux.parser + (:use (clojure test + template)) + (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] + [reader :as &reader] + [parser :as &parser]) + [lux.analyser.module :as &a-module] + :reload-all)) + +;; [Utils] +(def ^:private module-name "test") + +(defn ^:private make-state [source-code] + (&/set$ &/$source (&reader/from module-name source-code) + (&/init-state nil))) + +;; [Tests] +(deftest parse-white-space + (let [input " \t"] + (|case (&/run-state &parser/parse (make-state input)) + (&/$Right state (&/$Nil)) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-comment + (let [input1 " YOLO" + input2 "\nLOL\n" + input3 " NYAN\n#(\nCAT )#\n"] + (|case (&/run-state &parser/parse (make-state (str "##" input1 "\n" "#(" input2 ")#" "\n" "#(" input3 ")#"))) + (&/$Right state (&/$Nil)) + (is true) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-bool + (let [input1 "true" + input2 "false"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse] + (return (&/|++ output1 output2))) + (make-state (str input1 "\n" input2))) + (&/$Right state (&/$Cons [_ (&/$BoolS output1)] (&/$Cons [_ (&/$BoolS output2)] (&/$Nil)))) + (are [input output] (= input output) + true output1 + false output2) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-int + (let [input1 "0" + input2 "12" + input3 "-123"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state (&/$Cons [_ (&/$IntS output1)] (&/$Cons [_ (&/$IntS output2)] (&/$Cons [_ (&/$IntS output3)] (&/$Nil))))) + (are [input output] (= input output) + 0 output1 + 12 output2 + -123 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-real + (let [input1 "0.00123" + input2 "12.01020300" + input3 "-12.3"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str input1 "\n" input2 "\n" input3))) + (&/$Right state (&/$Cons [_ (&/$RealS output1)] (&/$Cons [_ (&/$RealS output2)] (&/$Cons [_ (&/$RealS output3)] (&/$Nil))))) + (are [input output] (= input output) + 0.00123 output1 + 12.010203 output2 + -12.3 output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-char + (let [input1 "a" + input2 "\\n" + input3 " " + input4 "\\t" + input5 "\\b" + input6 "\\r" + input7 "\\f" + input8 "\\\"" + input9 "\\\\"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse + output6 &parser/parse + output7 &parser/parse + output8 &parser/parse + output9 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 (&/|++ output5 (&/|++ output6 (&/|++ output7 (&/|++ output8 output9)))))))))) + (make-state (str "#\"" input1 "\"" "\n" "#\"" input2 "\"" "\n" "#\"" input3 "\"" + "\n" "#\"" input4 "\"" "\n" "#\"" input5 "\"" "\n" "#\"" input6 "\"" + "\n" "#\"" input7 "\"" "\n" "#\"" input8 "\"" "\n" "#\"" input9 "\""))) + (&/$Right state (&/$Cons [_ (&/$CharS output1)] + (&/$Cons [_ (&/$CharS output2)] + (&/$Cons [_ (&/$CharS output3)] + (&/$Cons [_ (&/$CharS output4)] + (&/$Cons [_ (&/$CharS output5)] + (&/$Cons [_ (&/$CharS output6)] + (&/$Cons [_ (&/$CharS output7)] + (&/$Cons [_ (&/$CharS output8)] + (&/$Cons [_ (&/$CharS output9)] + (&/$Nil))))))))))) + (are [input output] (= input output) + \a output1 + \newline output2 + \space output3 + \tab output4 + \backspace output5 + \return output6 + \formfeed output7 + \" output8 + \\ output9) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-text + (let [input1 "" + input2 "abc" + input3 "yolo\\nlol\\tmeme"] + (|case (&/run-state (|do [output1 &parser/parse + output2 &parser/parse + output3 &parser/parse] + (return (&/|++ output1 (&/|++ output2 output3)))) + (make-state (str "\"" input1 "\"" "\n" "\"" input2 "\"" "\n" "\"" input3 "\""))) + (&/$Right state (&/$Cons [_ (&/$TextS output1)] (&/$Cons [_ (&/$TextS output2)] (&/$Cons [_ (&/$TextS output3)] (&/$Nil))))) + (are [input output] (= input output) + input1 output1 + input2 output2 + "yolo\nlol\tmeme" output3) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-symbol + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5)))))) + (make-state (str input1 "\n" input2 "\n" input3 "\n" input4 "\n" input5))) + (&/$Right state (&/$Cons [_ (&/$SymbolS output1)] + (&/$Cons [_ (&/$SymbolS output2)] + (&/$Cons [_ (&/$SymbolS output3)] + (&/$Cons [_ (&/$SymbolS output4)] + (&/$Cons [_ (&/$SymbolS output5)] + (&/$Nil))))))) + (are [input output] (&/ident= input output) + (&/T "" "foo") output1 + (&/T "test" "bar0123456789") output2 + (&/T "lux" "b1a2z3") output3 + (&/T "test" "quux") output4 + (&/T "" "!_@$%^&*-+=.<>?/|\\~`':") output5) + + _ + (is false "Couldn't read.") + ))) + +(deftest parse-tag + (let [input1 "foo" + input2 "test;bar0123456789" + input3 ";b1a2z3" + input4 ";;quux" + input5 "!_@$%^&*-+=.<>?/|\\~`':"] + (|case (&/run-state (|do [_ (&a-module/enter-module module-name) + output1 &parser/parse + output2 &parser/parse + output3 &parser/parse + output4 &parser/parse + output5 &parser/parse] + (return (&/|++ output1 (&/|++ output2 (&/|++ output3 (&/|++ output4 output5)))))) + (make-state (str "#" input1 "\n" "#" input2 "\n" "#" input3 "\n" "#" input4 "\n" "#" input5))) + (&/$Right state (&/$Cons [_ (&/$TagS output1)] + (&/$Cons [_ (&/$TagS output2)] + (&/$Cons [_ (&/$TagS output3)] + (&/$Cons [_ (&/$TagS output4)] + (&/$Cons [_ (&/$TagS output5)] + (&/$Nil))))))) + (are [input output] (&/ident= input output) + (&/T "" "foo") output1 + (&/T "test" "bar0123456789") output2 + (&/T "lux" "b1a2z3") output3 + (&/T "test" "quux") output4 + (&/T "" "!_@$%^&*-+=.<>?/|\\~`':") output5) + + _ + (is false "Couldn't read.") + ))) + +(do-template [ ] + (deftest + (let [input1 "yolo 123 \"lol\" #meme"] + (|case (&/run-state &parser/parse + (make-state (str input1 ))) + (&/$Right state (&/$Cons [_ ( (&/$Cons [_ (&/$SymbolS symv)] + (&/$Cons [_ (&/$IntS intv)] + (&/$Cons [_ (&/$TextS textv)] + (&/$Cons [_ (&/$TagS tagv)] + (&/$Nil))))))] + (&/$Nil))) + (do (is (&/ident= (&/T "" "yolo") symv)) + (is (= 123 intv)) + (is (= "lol" textv)) + (is (&/ident= (&/T "" "meme") tagv))) + + _ + (is false "Couldn't read.") + ))) + + parse-form &/$FormS "(" ")" + parse-tuple &/$TupleS "[" "]" + ) + +(deftest parse-record + (let [input1 "yolo 123 \"lol\" #meme"] + (|case (&/run-state &parser/parse + (make-state (str "{" input1 "}"))) + (&/$Right state (&/$Cons [_ (&/$RecordS (&/$Cons [[_ (&/$SymbolS symv)] [_ (&/$IntS intv)]] + (&/$Cons [[_ (&/$TextS textv)] [_ (&/$TagS tagv)]] + (&/$Nil))))] + (&/$Nil))) + (do (is (&/ident= (&/T "" "yolo") symv)) + (is (= 123 intv)) + (is (= "lol" textv)) + (is (&/ident= (&/T "" "meme") tagv))) + + _ + (is false "Couldn't read.") + ))) + +(run-all-tests) diff --git a/test/test/lux/reader.clj b/test/test/lux/reader.clj index 6d3ee0e06..ca4797f10 100644 --- a/test/test/lux/reader.clj +++ b/test/test/lux/reader.clj @@ -1,3 +1,8 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + (ns test.lux.reader (:use clojure.test) (:require (lux [base :as & :refer [deftags |do return* return fail fail* |let |case]] -- cgit v1.2.3 From 455018ec68f2c127db489048351bc48f3982fe23 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 01:03:19 -0400 Subject: - Expanded the standard library. - Fixed some minor bugs. - Added the updated code for the parser (forgot to add it to a previous commit). --- source/lux.lux | 16 ++++---- source/lux/control/enum.lux | 25 +++++++++++++ source/lux/control/fold.lux | 42 +++++++++++++++++++++ source/lux/control/monad.lux | 51 +++++++++++++++---------- source/lux/data/ident.lux | 33 +++++++++++++++++ source/lux/data/list.lux | 88 ++++++++++++++++++++++++++++++++++++++++++-- source/lux/data/maybe.lux | 3 +- source/lux/data/text.lux | 14 +++++-- source/lux/data/tuple.lux | 3 +- source/lux/math.lux | 22 ++++++++++- source/lux/meta/ast.lux | 72 +++++++++++++++++++++++++++++++++++- source/program.lux | 5 ++- src/lux/parser.clj | 49 ++++++++---------------- src/lux/type.clj | 6 +-- 14 files changed, 350 insertions(+), 79 deletions(-) create mode 100644 source/lux/control/enum.lux create mode 100644 source/lux/control/fold.lux create mode 100644 source/lux/data/ident.lux diff --git a/source/lux.lux b/source/lux.lux index 5f5c6925b..164dea835 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -2932,23 +2932,23 @@ _ (fail "Can only \"use\" records."))) + + [_ (#TupleS members)] + (return (@list (foldL (: (-> AST AST AST) + (lambda [body' struct'] (` (;;using (~ struct') (~ body'))))) + body + members))) _ (let [dummy (symbol$ ["" ""])] (return (@list (` (;_lux_case (~ struct) (~ dummy) - (;using (~ dummy) - (~ body)))))))) + (;;using (~ dummy) + (~ body)))))))) _ (fail "Wrong syntax for using"))) -(def (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [y x] - (f x y))) - (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux new file mode 100644 index 000000000..34910c837 --- /dev/null +++ b/source/lux/control/enum.lux @@ -0,0 +1,25 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux/control ord)) + +## [Signatures] +(defsig #export (Enum e) + (: (Ord e) _ord) + (: (-> e e) succ) + (: (-> e e) pre)) + +## [Functions] +(def #export (range' <= succ from to) + (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) + (if (<= from to) + (#;Cons from (range' <= succ (succ from) to)) + #;Nil)) + +(def #export (range enum from to) + (All [a] (-> (Enum a) a a (List a))) + (using enum + (range' <= succ from to))) diff --git a/source/lux/control/fold.lux b/source/lux/control/fold.lux new file mode 100644 index 000000000..d0aef1576 --- /dev/null +++ b/source/lux/control/fold.lux @@ -0,0 +1,42 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux (control monoid + eq) + (data/number/int #open ("i" Int/Number Int/Eq)))) + +## [Signatures] +(defsig #export (Fold F) + (: (All [a b] + (-> (-> a b a) a (F b) a)) + foldL) + (: (All [a b] + (-> (-> b a a) a (F b) a)) + foldR)) + +## [Functions] +(def #export (foldM mon fold xs) + (All [F a] (-> (Monoid a) (Fold F) (F a) a)) + (using [mon fold] + (foldL ++ unit xs))) + +(def #export (size fold xs) + (All [F a] (-> (Fold F) (F a) Int)) + (using fold + (foldL (lambda [count _] (i+ 1 count)) + 0 + xs))) + +(def #export (member? eq fold x xs) + (All [F a] (-> (Eq a) (Fold F) a (F a) Bool)) + (using [eq fold] + (foldL (lambda [prev x'] (or prev (= x x'))) + false + xs))) + +(def #export (empty? fold xs) + (All [F a] (-> (Fold F) (F a) Bool)) + (i= 0 (size fold xs))) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 8e59ae941..b286545a7 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -6,8 +6,7 @@ (;import lux (.. (functor #as F) (monoid #as M)) - (lux/meta macro - ast)) + (lux/meta macro)) ## [Utils] (def (foldL f init xs) @@ -17,21 +16,21 @@ #;Nil init - (#;Cons [x xs']) + (#;Cons x xs') (foldL f (f init x) xs'))) (def (reverse xs) (All [a] (-> (List a) (List a))) - (foldL (lambda [tail head] (#;Cons [head tail])) + (foldL (lambda [tail head] (#;Cons head tail)) #;Nil xs)) (def (as-pairs xs) (All [a] (-> (List a) (List (, a a)))) (case xs - (#;Cons [x1 (#;Cons [x2 xs'])]) - (#;Cons [[x1 x2] (as-pairs xs')]) + (#;Cons x1 (#;Cons x2 xs')) + (#;Cons [x1 x2] (as-pairs xs')) _ #;Nil)) @@ -50,10 +49,9 @@ ## [Syntax] (defmacro #export (do tokens state) (case tokens - ## (\ (list monad [_ (#;TupleS bindings)] body)) - (#;Cons [monad (#;Cons [[_ (#;TupleS bindings)] (#;Cons [body #;Nil])])]) - (let [g!map (symbol$ ["" " map "]) - g!join (symbol$ ["" " join "]) + (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] @@ -82,16 +80,31 @@ (using m (join (map f ma)))) -(def #export (map% m f xs) - (All [m a b] - (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) +(def #export (seq% monad xs) + (All [M a] + (-> (Monad M) (List (M a)) (M (List a)))) + (case xs + #;Nil + (:: monad (;;wrap #;Nil)) + + (#;Cons x xs') + (do monad + [_x x + _xs (seq% monad xs')] + (wrap (#;Cons _x _xs))) + )) + +(def #export (map% monad f xs) + (All [M a b] + (-> (Monad M) (-> a (M b)) (List a) (M (List b)))) + ## (seq% monad (:: monad ;;_functor (F;map f xs))) (case xs #;Nil - (:: m (;;wrap #;Nil)) + (:: monad (;;wrap #;Nil)) - (#;Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (wrap (#;Cons [y ys]))) + (#;Cons x xs') + (do monad + [_x (f x) + _xs (map% monad f xs')] + (wrap (#;Cons _x _xs))) )) diff --git a/source/lux/data/ident.lux b/source/lux/data/ident.lux new file mode 100644 index 000000000..cb2353e43 --- /dev/null +++ b/source/lux/data/ident.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux (control (eq #as E) + (show #as S)) + (data (text #open ("text:" Text/Monoid Text/Eq))))) + +## [Types] +## (deftype Ident +## (, Text Text)) + +## [Functions] +(do-template [ ] + [(def #export ( [left right]) + (-> Ident Text) + )] + + [module left] + [name right] + ) + +## [Structures] +(defstruct #export Ident/Eq (E;Eq Ident) + (def (= [xmodule xname] [ymodule yname]) + (and (text:= xmodule ymodule) + (text:= xname yname)))) + +(defstruct #export Ident/Show (S;Show Ident) + (def (show [module name]) + ($ text:++ module ";" name))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 489ac5b4f..b2049d419 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -8,7 +8,8 @@ (functor #as F #refer #all) (monad #as M #refer #all) (eq #as E) - (ord #as O)) + (ord #as O) + (fold #as f)) (data (number (int #open ("i" Int/Number Int/Ord))) bool) meta/macro)) @@ -39,6 +40,23 @@ (#;Cons [x xs']) (f x (foldR f init xs')))) +(defstruct #export List/Fold (f;Fold List) + (def (foldL f init xs) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + + (def (foldR f init xs) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (f x (foldR f init xs'))))) + (def #export (fold mon xs) (All [a] (-> (m;Monoid a) (List a) a)) @@ -224,13 +242,75 @@ (case (reverse xs) (#;Cons last init) (#;Right state (@list (foldL (: (-> AST AST AST) - (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) - last - init))) + (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) + last + init))) _ (#;Left "Wrong syntax for @list&"))) +## (defmacro #export (zip tokens state) +## (if (i> (size tokens) 0) +## (using List/Functor +## (let [indices (range 0 (i+ 1 (size tokens))) +## vars+lists (map (lambda [idx] +## (let [base (text:++ "_" idx)] +## [[["" -1 -1] (#SymbolS "" base)] +## [["" -1 -1] (#SymbolS "" (text:++ base "s"))]])) +## indices) +## pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) +## vars+lists))]) +## g!step [["" -1 -1] (#SymbolS "" "\tstep\t")] +## g!arg [["" -1 -1] (#SymbolS "" "\targ\t")] +## g!blank [["" -1 -1] (#SymbolS "" "\t_\t")] +## code (` ((lambda (~ g!step) [(~ g!arg)] +## (case (~ g!arg) +## (~ pattern) +## (#;Cons [(~@ vars)] ((~ g!step) [(~ (map second vars))])) + +## (~ g!blank) +## #;Nil)) +## [(~@ tokens)]))] +## (#;Right state (@list code)))) +## (#;Left "Can't zip no lists."))) + +## (defmacro #export (zip-with tokens state) +## (case tokens +## (@list& _f tokens) +## (case _f +## [_ (#;SymbolS _)] +## (if (i> (size tokens) 0) +## (using List/Functor +## (let [indices (range 0 (i+ 1 (size tokens))) +## vars+lists (map (lambda [idx] +## (let [base (text:++ "_" idx)] +## [[["" -1 -1] (#SymbolS "" base)] +## [["" -1 -1] (#SymbolS "" (text:++ base "s"))]])) +## indices) +## pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) +## vars+lists))]) +## g!step [["" -1 -1] (#SymbolS "" "\tstep\t")] +## g!arg [["" -1 -1] (#SymbolS "" "\targ\t")] +## g!blank [["" -1 -1] (#SymbolS "" "\t_\t")] +## code (` ((lambda (~ g!step) [(~ g!arg)] +## (case (~ g!arg) +## (~ pattern) +## (#;Cons ((~ _f) (~@ vars)) ((~ g!step) [(~ (map second vars))])) + +## (~ g!blank) +## #;Nil)) +## [(~@ tokens)]))] +## (#;Right state (@list code)))) +## (#;Left "Can't zip-with no lists.")) + +## _ +## (let [g!temp [["" -1 -1] (#SymbolS "" "\ttemp\t")]] +## (#;Right state (@list (` (let [(~ g!temp) (~ _f)] +## (;;zip-with (~@ (@list& g!temp tokens))))))))) + +## _ +## (#;Left "Wrong syntax for zip-with"))) + ## [Structures] ## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) ## (def (= xs ys) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index 7c0affd68..2db3d768d 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -4,8 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (meta macro - ast) + (lux (meta macro) (control (monoid #as m #refer #all) (functor #as F #refer #all) (monad #as M #refer #all))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index e54dff5c0..f701f6079 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -4,8 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (meta macro - ast) + (lux (meta macro) (control (monoid #as m) (eq #as E) (ord #as O) @@ -151,9 +150,18 @@ [_ in] (split 2 in) post-idx (index-of "}" in) [var post] (split post-idx in) - [_ post] (split 1 post)] + #let [[_ post] (? (: (, Text Text) ["" ""]) + (split 1 post))]] (wrap [pre var post]))) +(do-template [ ] + [(def ( value) + (-> AST) + [["" -1 -1] ( value)])] + + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS]) + (def (unravel-template template) (-> Text (List AST)) (case (extract-var template) diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux index f89f9b5ee..6eef74670 100644 --- a/source/lux/data/tuple.lux +++ b/source/lux/data/tuple.lux @@ -24,8 +24,7 @@ (def #export (uncurry f) (All [a b c] - (-> (-> a b c) - (-> (, a b) c))) + (-> (-> a b c) (-> (, a b) c))) (lambda [xy] (let [[x y] xy] (f x y)))) diff --git a/source/lux/math.lux b/source/lux/math.lux index f6fad566f..0f247cea8 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -3,7 +3,8 @@ ## If a copy of the MPL was not distributed with this file, ## You can obtain one at http://mozilla.org/MPL/2.0/. -(;import lux) +(;import lux + (lux/data/number/int #open ("i:" Int/Number))) ## [Constants] (do-template [ ] @@ -58,3 +59,22 @@ [atan2 "atan2"] [pow "pow"] ) + +(def (gcd' a b) + (-> Int Int Int) + (case b + 0 a + _ (gcd' b (i:% a b)))) + +(def #export (gcd a b) + (-> Int Int Int) + (gcd' (i:abs a) (i:abs b))) + +(def #export (lcm x y) + (-> Int Int Int) + (case (: (, Int Int) [x y]) + (\or [_ 0] [0 _]) + 0 + + _ + (i:abs (i:* (i:/ x (gcd x y)) y)))) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index a601739a1..78882c854 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -3,7 +3,17 @@ ## If a copy of the MPL was not distributed with this file, ## You can obtain one at http://mozilla.org/MPL/2.0/. -(;import lux) +(;import lux + (lux (control (show #as S #refer #all) + (eq #as E #refer #all)) + (data bool + (number int + real) + char + (text #refer #all #open ("text:" Text/Monoid)) + ident + (list #refer (#only List interpose) #open ("" List/Functor List/Fold)) + ))) ## [Types] ## (deftype (AST' w) @@ -41,3 +51,63 @@ [tuple$ (List AST) #;TupleS] [record$ (List (, AST AST)) #;RecordS] ) + +## [Structures] +(defstruct #export AST/Show (Show AST) + (def (show ast) + (case ast + (\template [ ] + [[_ ( value)] + (:: (S;show value))]) + [[#;BoolS Bool/Show] + [#;IntS Int/Show] + [#;RealS Real/Show] + [#;CharS Char/Show] + [#;TextS Text/Show]] + + (\template [ ] + [[_ ( ident)] + (text:++ (:: Ident/Show (S;show ident)))]) + [[#;SymbolS ""] [#;TagS "#"]] + + (\template [ ] + [[_ ( members)] + ($ text:++ (|> members (map show) (interpose "") (foldL text:++ text:unit)) )]) + [[#;FormS "(" ")"] [#;TupleS "[" "]"]] + + [_ (#;RecordS pairs)] + ($ text:++ "{" (|> pairs (map (lambda [[left right]] ($ text:++ (show left) " " (show right)))) (interpose "") (foldL text:++ text:unit)) "}") + ))) + +## (defstruct #export AST/Eq (Eq AST) +## (def (eq x y) +## (case [x y] +## (\template [ ] +## [[( x') ( y')] +## (:: (E;eq x' y'))]) +## [[#;BoolS Bool/Eq] +## [#;IntS Int/Eq] +## [#;RealS Real/Eq] +## [#;CharS Char/Eq] +## [#;TextS Text/Eq] +## [#;SymbolS Ident/Eq] +## [#;TagS Ident/Eq]] + +## (\template [] +## [[( xs') ( ys')] +## (and (:: Int/Eq (E;= (size xs') (size ys'))) +## (foldL (lambda [old [x' y']] +## (and old (= x' y'))) +## true +## (zip2 xs' ys')))]) +## [[#;FormS] [#;TupleS]] + +## [(#;RecordS xs') (#;RecordS ys')] +## (and (:: Int/Eq (E;= (size xs') (size ys'))) +## (foldL (lambda [old [[xl' xr'] [yl' yr']]] +## (and old (= xl' yl') (= xr' yr'))) +## true +## (zip2 xs' ys'))) + +## _ +## false))) diff --git a/source/program.lux b/source/program.lux index 69b9e811d..140710a4a 100644 --- a/source/program.lux +++ b/source/program.lux @@ -13,7 +13,8 @@ hash (ord #as O) (show #as S) - number) + number + enum) (data bool char (either #as e) @@ -21,7 +22,7 @@ io list maybe - (number (int #refer (#only)) + (number (int #refer (#only) #open ("i:" Int/Show)) (real #refer (#only))) (text #refer (#only <>) #open ("text:" Text/Monoid)) (writer #refer (#only)) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 2609bf9a5..dbd6ca2c5 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -10,25 +10,6 @@ (lux [base :as & :refer [deftags |do return fail |case]] [lexer :as &lexer]))) -;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" - ) - ;; [Utils] (do-template [ ] (defn [parse] @@ -41,8 +22,8 @@ _ (fail (str "[Parser Error] Unbalanced " "."))))) - ^:private parse-form $Close_Paren "parantheses" &/$FormS - ^:private parse-tuple $Close_Bracket "brackets" &/$TupleS + ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS + ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS ) (defn ^:private parse-record [parse] @@ -50,7 +31,7 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - [meta ($Close_Brace _)] + [meta (&lexer/$Close_Brace _)] (if (even? (&/|length elems)) (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) @@ -63,42 +44,42 @@ (|do [token &lexer/lex :let [[meta token*] token]] (|case token* - ($White_Space _) + (&lexer/$White_Space _) (return (&/|list)) - ($Comment _) + (&lexer/$Comment _) (return (&/|list)) - ($Bool ?value) + (&lexer/$Bool ?value) (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))) - ($Int ?value) + (&lexer/$Int ?value) (return (&/|list (&/T meta (&/V &/$IntS (Long/parseLong ?value))))) - ($Real ?value) + (&lexer/$Real ?value) (return (&/|list (&/T meta (&/V &/$RealS (Double/parseDouble ?value))))) - ($Char ^String ?value) + (&lexer/$Char ^String ?value) (return (&/|list (&/T meta (&/V &/$CharS (.charAt ?value 0))))) - ($Text ?value) + (&lexer/$Text ?value) (return (&/|list (&/T meta (&/V &/$TextS ?value)))) - ($Symbol ?ident) + (&lexer/$Symbol ?ident) (return (&/|list (&/T meta (&/V &/$SymbolS ?ident)))) - ($Tag ?ident) + (&lexer/$Tag ?ident) (return (&/|list (&/T meta (&/V &/$TagS ?ident)))) - ($Open_Paren _) + (&lexer/$Open_Paren _) (|do [syntax (parse-form parse)] (return (&/|list (&/T meta syntax)))) - ($Open_Bracket _) + (&lexer/$Open_Bracket _) (|do [syntax (parse-tuple parse)] (return (&/|list (&/T meta syntax)))) - ($Open_Brace _) + (&lexer/$Open_Brace _) (|do [syntax (parse-record parse)] (return (&/|list (&/T meta syntax)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 82eab3dd4..8300d470c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -724,9 +724,9 @@ (fn [state] (|case ((|do [F1 (deref ?eid)] (fn [state] - (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state)] + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state) (&/$Right state* output) (return* state* output) -- cgit v1.2.3 From 0f596a44ffc486b7e0369eebd3b79d22315e8814 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 02:11:23 -0400 Subject: - Removed the (unnecessary) lux/meta/macro module. --- source/lux.lux | 122 ++++++++++++++++++++++++++--------------- source/lux/codata/lazy.lux | 3 +- source/lux/codata/stream.lux | 1 - source/lux/control/comonad.lux | 3 +- source/lux/control/monad.lux | 3 +- source/lux/data/io.lux | 9 +-- source/lux/data/list.lux | 3 +- source/lux/data/maybe.lux | 6 +- source/lux/data/text.lux | 3 +- source/lux/meta/lux.lux | 3 +- source/lux/meta/macro.lux | 28 ---------- source/lux/meta/syntax.lux | 3 +- source/program.lux | 1 - 13 files changed, 90 insertions(+), 98 deletions(-) delete mode 100644 source/lux/meta/macro.lux diff --git a/source/lux.lux b/source/lux.lux index 164dea835..76ca9517f 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -621,7 +621,7 @@ ))) (_lux_declare-macro def'') -(def'' (defmacro tokens) +(def'' (defmacro' tokens) Macro (_lux_case tokens (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) @@ -646,13 +646,13 @@ #Nil])])) _ - (fail "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) + (fail "Wrong syntax for defmacro'"))) +(_lux_declare-macro defmacro') -(defmacro #export (comment tokens) +(defmacro' #export (comment tokens) (return #Nil)) -(defmacro ($' tokens) +(defmacro' ($' tokens) (_lux_case tokens (#Cons x #Nil) (return tokens) @@ -817,7 +817,7 @@ (#Cons x xs') (foldL f (f init x) xs'))) -(defmacro #export (All tokens) +(defmacro' #export (All tokens) (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil))) (_lux_case tokens (#Cons [_ (#SymbolS "" self-name)] tokens) @@ -844,7 +844,7 @@ (fail "Wrong syntax for All")) )) -(defmacro #export (Ex tokens) +(defmacro' #export (Ex tokens) (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil))) (_lux_case tokens (#Cons [_ (#SymbolS "" self-name)] tokens) @@ -877,7 +877,7 @@ #Nil list)) -(defmacro #export (-> tokens) +(defmacro' #export (-> tokens) (_lux_case (reverse tokens) (#Cons output inputs) (return (#Cons (foldL (_lux_: (#LambdaT AST (#LambdaT AST AST)) @@ -889,7 +889,7 @@ _ (fail "Wrong syntax for ->"))) -(defmacro (@list xs) +(defmacro' (@list xs) (return (#Cons (foldL (lambda'' [tail head] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) @@ -898,7 +898,7 @@ (reverse xs)) #Nil))) -(defmacro (@list& xs) +(defmacro' (@list& xs) (_lux_case (reverse xs) (#Cons last init) (return (@list (foldL (lambda'' [tail head] @@ -910,7 +910,7 @@ _ (fail "Wrong syntax for @list&"))) -(defmacro #export (^ tokens) +(defmacro' #export (^ tokens) (_lux_case tokens (#Cons [_ (#SymbolS "" class-name)] #Nil) (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name))))) @@ -918,13 +918,13 @@ _ (fail "Wrong syntax for ^"))) -(defmacro #export (, tokens) +(defmacro' #export (, tokens) (return (@list (form$ (@list (tag$ ["lux" "TupleT"]) (foldL (lambda'' [tail head] (form$ (@list (tag$ ["lux" "Cons"]) head tail))) (tag$ ["lux" "Nil"]) (reverse tokens))))))) -(defmacro (lambda' tokens) +(defmacro' (lambda' tokens) (let'' [name tokens'] (_lux_: (, Text ($' List AST)) (_lux_case tokens (#Cons [[_ (#SymbolS ["" name])] tokens']) @@ -953,7 +953,7 @@ _ (fail "Wrong syntax for lambda'")))) -(defmacro (def''' tokens) +(defmacro' (def''' tokens) (_lux_case tokens (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] @@ -1005,7 +1005,7 @@ _ #Nil)) -(defmacro (let' tokens) +(defmacro' (let' tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) (return (@list (foldL (_lux_: (-> AST (, AST AST) @@ -1064,7 +1064,7 @@ #Nil ys)) -(defmacro #export ($ tokens) +(defmacro' #export ($ tokens) (_lux_case tokens (#Cons op (#Cons init args)) (return (@list (foldL (lambda' [a1 a2] (form$ (@list op a1 a2))) @@ -1125,7 +1125,7 @@ (#Right state' a) (f a state'))))}) -(defmacro (do tokens) +(defmacro' (do tokens) (_lux_case tokens (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) (let' [g!wrap (symbol$ ["" "wrap"]) @@ -1171,7 +1171,7 @@ (wrap (#Cons y ys))) ))) -(defmacro #export (if tokens) +(defmacro' #export (if tokens) (_lux_case tokens (#Cons test (#Cons then (#Cons else #Nil))) (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) test @@ -1279,19 +1279,19 @@ (-> Bool Text AST ($' Lux AST)) (_lux_case (_lux_: (, Bool AST) [replace? token]) [_ [_ (#BoolS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (bool$ value))))) [_ [_ (#IntS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (int$ value))))) [_ [_ (#RealS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (real$ value))))) [_ [_ (#CharS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (char$ value))))) [_ [_ (#TextS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (text$ value))))) [_ [_ (#TagS [module name])]] (let' [module' (_lux_case module @@ -1353,31 +1353,31 @@ #Nil (#Left "Can't get the module name without a module!") - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Cons {#name module-name #inner-closures _ #locals _ #closure _} _) (#Right [state module-name])))) -(defmacro #export (` tokens) +(defmacro' #export (` tokens) (_lux_case tokens (#Cons template #Nil) (do Lux/Monad [current-module get-module-name =template (untemplate true current-module template)] - (wrap (@list =template))) + (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ (fail "Wrong syntax for `"))) -(defmacro #export (' tokens) +(defmacro' #export (' tokens) (_lux_case tokens (#Cons template #Nil) (do Lux/Monad [=template (untemplate false "" template)] - (wrap (@list =template))) + (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ (fail "Wrong syntax for '"))) -(defmacro #export (|> tokens) +(defmacro' #export (|> tokens) (_lux_case tokens (#Cons [init apps]) (return (@list (foldL (_lux_: (-> AST AST AST) @@ -1467,7 +1467,7 @@ (#Cons [x xs']) (list:++ (f x) (join-map f xs')))) -(defmacro #export (do-template tokens) +(defmacro' #export (do-template tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) @@ -1688,7 +1688,7 @@ _ type)) -(defmacro #export (@type tokens) +(defmacro' #export (@type tokens) (_lux_case tokens (#Cons type #Nil) (do Lux/Monad @@ -1703,7 +1703,7 @@ _ (fail "Wrong syntax for @type"))) -(defmacro #export (: tokens) +(defmacro' #export (: tokens) (_lux_case tokens (#Cons type (#Cons value #Nil)) (return (@list (` (;_lux_: (@type (~ type)) (~ value))))) @@ -1711,7 +1711,7 @@ _ (fail "Wrong syntax for :"))) -(defmacro #export (:! tokens) +(defmacro' #export (:! tokens) (_lux_case tokens (#Cons type (#Cons value #Nil)) (return (@list (` (;_lux_:! (@type (~ type)) (~ value))))) @@ -1791,7 +1791,7 @@ #cursor cursor} (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) -(defmacro #export (Rec tokens) +(defmacro' #export (Rec tokens) (_lux_case tokens (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)] @@ -1800,7 +1800,7 @@ _ (fail "Wrong syntax for Rec"))) -(defmacro #export (deftype tokens) +(defmacro' #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens (#Cons [_ (#TagS "" "export")] tokens') @@ -1872,7 +1872,7 @@ (fail "Wrong syntax for deftype")) )) -(defmacro #export (exec tokens) +(defmacro' #export (exec tokens) (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] @@ -1884,7 +1884,7 @@ _ (fail "Wrong syntax for exec"))) -(defmacro (def' tokens) +(defmacro' (def' tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens (#Cons [_ (#TagS "" "export")] tokens') @@ -1979,7 +1979,7 @@ (let' [[left right] pair] (@list left right))) -(defmacro #export (case tokens) +(defmacro' #export (case tokens) (_lux_case tokens (#Cons value branches) (do Lux/Monad @@ -2007,7 +2007,7 @@ _ (fail "Wrong syntax for case"))) -(defmacro #export (\ tokens) +(defmacro' #export (\ tokens) (case tokens (#Cons body (#Cons pattern #Nil)) (do Lux/Monad @@ -2023,7 +2023,7 @@ _ (fail "Wrong syntax for \\"))) -(defmacro #export (\or tokens) +(defmacro' #export (\or tokens) (case tokens (#Cons body patterns) (case patterns @@ -2048,7 +2048,7 @@ _ false)) -(defmacro #export (let tokens) +(defmacro' #export (let tokens) (case tokens (\ (@list [_ (#TupleS bindings)] body)) (if (multiple? 2 (length bindings)) @@ -2067,7 +2067,7 @@ _ (fail "Wrong syntax for let"))) -(defmacro #export (lambda tokens) +(defmacro' #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens (\ (@list [_ (#TupleS (#Cons head tail))] body)) @@ -2086,7 +2086,7 @@ (if (symbol? arg) (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) (` (;_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) + (case (~ g!blank) (~ arg) (~ body'))))))) body (reverse tail)))] (return (@list (if (symbol? head) @@ -2096,7 +2096,7 @@ #None (fail "Wrong syntax for lambda"))) -(defmacro #export (def tokens) +(defmacro' #export (def tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens (#Cons [_ (#TagS "" "export")] tokens') @@ -2144,6 +2144,40 @@ #None (fail "Wrong syntax for def")))) +(defmacro' #export (defmacro tokens) + (let [[exported? tokens] (: (, Bool (List AST)) + (case tokens + (\ (@list& [_ (#TagS ["" "export"])] tokens')) + [true tokens'] + + _ + [false tokens])) + name+args+body?? (: (Maybe (, Ident (List AST) AST)) + (case tokens + (\ (@list [_ (#;FormS (@list& [_ (#SymbolS name)] args))] body)) + (#Some [name args body]) + + (\ (@list [_ (#;SymbolS name)] body)) + (#Some [name #Nil body]) + + _ + #None))] + (case name+args+body?? + (#Some [name args body]) + (let [name (symbol$ name) + decls (list:++ (: (List AST) (if exported? (@list (` (;_lux_export (~ name)))) #;Nil)) + (: (List AST) (@list (` (;;_lux_declare-macro (~ name)))))) + def-sig (: AST + (case args + #;Nil name + _ (` ((~ name) (~@ args)))))] + (return (@list& (` (;;def (~ def-sig) ;;Macro (~ body))) + decls))) + + + #None + (fail "Wrong syntax for defmacro")))) + (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index 542bb9922..37fbbac64 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -4,8 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (meta macro - ast) + (lux (meta ast) (control (functor #as F #refer #all) (monad #as M #refer #all)) (data list)) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index a25a19b5f..e2464248c 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -8,7 +8,6 @@ (monad #as M #refer #all) (comonad #as CM #refer #all)) (meta lux - macro syntax) (data (list #as l #refer (#only @list @list& List/Monad)) (number (int #open ("i" Int/Number Int/Ord))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index 8e12c24c0..32e7c64c1 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -5,8 +5,7 @@ (;import lux (../functor #as F) - lux/data/list - lux/meta/macro) + lux/data/list) ## [Signatures] (defsig #export (CoMonad w) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index b286545a7..883875a03 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -5,8 +5,7 @@ (;import lux (.. (functor #as F) - (monoid #as M)) - (lux/meta macro)) + (monoid #as M))) ## [Utils] (def (foldL f init xs) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index 4919d2edd..a0bfda3e0 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -4,12 +4,9 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (meta macro - ast) - (control (functor #as F) + (lux (control (functor #as F) (monad #as M))) - (.. list - (text #as T #open ("text:" Text/Monoid)))) + (.. list)) ## [Types] (deftype #export (IO a) @@ -19,7 +16,7 @@ (defmacro #export (@io tokens state) (case tokens (\ (@list value)) - (let [blank (symbol$ ["" ""])] + (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] (#;Right [state (@list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) _ diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index b2049d419..0da0b3ecb 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -11,8 +11,7 @@ (ord #as O) (fold #as f)) (data (number (int #open ("i" Int/Number Int/Ord))) - bool) - meta/macro)) + bool))) ## [Types] ## (deftype (List a) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index 2db3d768d..1303270a7 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -4,11 +4,9 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (meta macro) - (control (monoid #as m #refer #all) + (lux (control (monoid #as m #refer #all) (functor #as F #refer #all) - (monad #as M #refer #all))) - (.. list)) + (monad #as M #refer #all)))) ## [Types] ## (deftype (Maybe a) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index f701f6079..3fad6c7aa 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -4,8 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (meta macro) - (control (monoid #as m) + (lux (control (monoid #as m) (eq #as E) (ord #as O) (show #as S) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index dd14e708d..a34f92253 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -4,8 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (.. macro - ast) + (.. ast) (lux/control (monoid #as m) (functor #as F) (monad #as M #refer (#only do)) diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux deleted file mode 100644 index f554f45b4..000000000 --- a/source/lux/meta/macro.lux +++ /dev/null @@ -1,28 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux) - -## [Syntax] -(def #export (defmacro tokens state) - Macro - (case tokens - (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) ((~ name) (~@ args)) - (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) - (~ body))) - (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) - #;Nil])])]) - - (#;Cons [[_ (#;TagS ["" "export"])] (#;Cons [[_ (#;FormS (#;Cons [name args]))] (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["lux" "def"])]) (~ [["" -1 -1] (#;TagS ["" "export"])]) ((~ name) (~@ args)) - (~ [["" -1 -1] (#;SymbolS ["lux" "Macro"])]) - (~ body))) - (#;Cons [(` ((~ [["" -1 -1] (#;SymbolS ["" "_lux_declare-macro"])]) (~ name))) - #;Nil])])]) - - _ - (#;Left "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 3bc3196e2..3d62bba2e 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -4,8 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (.. (macro #as m #refer #all) - ast + (.. ast (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) (monad #as M #refer (#only do)) diff --git a/source/program.lux b/source/program.lux index 140710a4a..fa8b3a055 100644 --- a/source/program.lux +++ b/source/program.lux @@ -37,7 +37,6 @@ io) (meta ast lux - macro syntax type) math -- cgit v1.2.3 From 514d03851b20c2f8b818ee26194a93515a685ae5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 19:52:07 -0400 Subject: - Added type-inference when constructing tuples. --- source/lux.lux | 126 ++++++++++++++++++++++----------------------- source/lux/data/text.lux | 3 +- source/lux/math.lux | 2 +- source/lux/meta/lux.lux | 69 ++++++++++++++----------- source/lux/meta/syntax.lux | 11 ++-- src/lux/analyser.clj | 7 ++- src/lux/analyser/base.clj | 4 +- src/lux/analyser/host.clj | 10 ++-- src/lux/analyser/lux.clj | 66 +++++++++++++----------- src/lux/compiler/lux.clj | 4 +- src/lux/type.clj | 12 ++++- 11 files changed, 167 insertions(+), 147 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 76ca9517f..c1e7b0046 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -305,7 +305,6 @@ Ident #Nil)))))))) (_lux_export DefData') -(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData') ## (deftype LuxVar ## (| (#Local Int) @@ -409,6 +408,12 @@ ASTList)))) (_lux_export Macro) +(_lux_def DefData + (#NamedT ["lux" "DefData"] + (#AppT DefData' Macro))) +(_lux_export DefData) +(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData) + ## Base functions & macros ## (def _cursor ## Cursor @@ -925,13 +930,12 @@ (reverse tokens))))))) (defmacro' (lambda' tokens) - (let'' [name tokens'] (_lux_: (, Text ($' List AST)) - (_lux_case tokens - (#Cons [[_ (#SymbolS ["" name])] tokens']) - [name tokens'] + (let'' [name tokens'] (_lux_case tokens + (#Cons [[_ (#SymbolS ["" name])] tokens']) + [name tokens'] - _ - ["" tokens])) + _ + ["" tokens]) (_lux_case tokens' (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) (_lux_case args @@ -1277,7 +1281,7 @@ (def''' (untemplate replace? subst token) (-> Bool Text AST ($' Lux AST)) - (_lux_case (_lux_: (, Bool AST) [replace? token]) + (_lux_case [replace? token] [_ [_ (#BoolS value)]] (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (bool$ value))))) @@ -1470,9 +1474,8 @@ (defmacro' #export (do-template tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) - [(map% Maybe/Monad get-name bindings) - (map% Maybe/Monad tuple->list data)]) + (_lux_case [(map% Maybe/Monad get-name bindings) + (map% Maybe/Monad tuple->list data)] [(#Some bindings') (#Some data')] (let' [apply (_lux_: (-> RepEnv ($' List AST)) (lambda' [env] (map (apply-template env) templates)))] @@ -1553,7 +1556,7 @@ [$module (get module modules) gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} (_lux_: ($' Module Compiler) $module)] (get name bindings))] - (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + (_lux_case (_lux_: (, Bool DefData) gdef) [exported? (#MacroD macro')] (if exported? (#Some macro') @@ -1801,20 +1804,18 @@ (fail "Wrong syntax for Rec"))) (defmacro' #export (deftype tokens) - (let' [[export? tokens'] (: (, Bool (List AST)) - (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] - - _ - [false tokens])) - [rec? tokens'] (: (, Bool (List AST)) - (_lux_case tokens' - (#Cons [_ (#TagS "" "rec")] tokens') + (let' [[export? tokens'] (_lux_case tokens + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ - [false tokens'])) + [false tokens]) + [rec? tokens'] (_lux_case tokens' + (#Cons [_ (#TagS "" "rec")] tokens') + [true tokens'] + + _ + [false tokens']) parts (: (Maybe (, Text (List AST) AST)) (_lux_case tokens' (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) @@ -1885,13 +1886,12 @@ (fail "Wrong syntax for exec"))) (defmacro' (def' tokens) - (let' [[export? tokens'] (: (, Bool (List AST)) - (_lux_case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] + (let' [[export? tokens'] (_lux_case tokens + (#Cons [_ (#TagS "" "export")] tokens') + [true tokens'] - _ - [false tokens])) + _ + [false tokens]) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (_lux_case tokens' (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) @@ -2097,13 +2097,12 @@ (fail "Wrong syntax for lambda"))) (defmacro' #export (def tokens) - (let [[export? tokens'] (: (, Bool (List AST)) - (case tokens - (#Cons [_ (#TagS "" "export")] tokens') - [true tokens'] + (let [[export? tokens'] (case tokens + (#Cons [_ (#TagS "" "export")] tokens') + [true tokens'] - _ - [false tokens])) + _ + [false tokens]) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' (\ (@list [_ (#FormS (#Cons name args))] type body)) @@ -2145,13 +2144,12 @@ (fail "Wrong syntax for def")))) (defmacro' #export (defmacro tokens) - (let [[exported? tokens] (: (, Bool (List AST)) - (case tokens - (\ (@list& [_ (#TagS ["" "export"])] tokens')) - [true tokens'] + (let [[exported? tokens] (case tokens + (\ (@list& [_ (#TagS ["" "export"])] tokens')) + [true tokens'] - _ - [false tokens])) + _ + [false tokens]) name+args+body?? (: (Maybe (, Ident (List AST) AST)) (case tokens (\ (@list [_ (#;FormS (@list& [_ (#SymbolS name)] args))] body)) @@ -2179,13 +2177,12 @@ (fail "Wrong syntax for defmacro")))) (defmacro #export (defsig tokens) - (let [[export? tokens'] (: (, Bool (List AST)) - (case tokens - (\ (@list& [_ (#TagS "" "export")] tokens')) - [true tokens'] + (let [[export? tokens'] (case tokens + (\ (@list& [_ (#TagS "" "export")] tokens')) + [true tokens'] - _ - [false tokens])) + _ + [false tokens]) ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' (\ (@list& [_ (#FormS (@list& [_ (#SymbolS name)] args))] sigs)) @@ -2206,7 +2203,7 @@ (lambda [token] (case token (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) - (wrap (: (, Text AST) [name type])) + (wrap [name type]) _ (fail "Signatures require typed members!")))) @@ -2530,7 +2527,7 @@ (\ [_ (#FormS (@list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS "" tag-name)] value))]) (case (get tag-name tag-mappings) (#Some tag) - (wrap (: (, AST AST) [tag value])) + (wrap [tag value]) _ (fail (text:++ "Unknown structure member: " tag-name))) @@ -2541,13 +2538,12 @@ (wrap (@list (record$ members))))) (defmacro #export (defstruct tokens) - (let [[export? tokens'] (: (, Bool (List AST)) - (case tokens - (\ (@list& [_ (#TagS "" "export")] tokens')) - [true tokens'] + (let [[export? tokens'] (case tokens + (\ (@list& [_ (#TagS "" "export")] tokens')) + [true tokens'] - _ - [false tokens])) + _ + [false tokens]) ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' (\ (@list& [_ (#FormS (@list& name args))] type defs)) @@ -2623,10 +2619,10 @@ (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens (\ (@list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) - (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) + (return [(#Some alias) tokens']) _ - (return (: (, (Maybe Text) (List AST)) [#None tokens])))) + (return [#None tokens]))) (def (parse-referrals tokens) (-> (List AST) (Lux (, Referrals (List AST)))) @@ -2634,23 +2630,23 @@ (\ (@list& [_ (#TagS "" "refer")] referral tokens')) (case referral [_ (#TagS "" "all")] - (return (: (, Referrals (List AST)) [#All tokens'])) + (return [#All tokens']) (\ [_ (#FormS (@list& [_ (#TagS "" "only")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] - (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) + (return [(#Only defs') tokens'])) (\ [_ (#FormS (@list& [_ (#TagS "" "exclude")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] - (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) + (return [(#Exclude defs') tokens'])) _ (fail "Incorrect syntax for referral.")) _ - (return (: (, Referrals (List AST)) [#Nothing tokens])))) + (return [#Nothing tokens]))) (def (extract-symbol syntax) (-> AST (Lux Ident)) @@ -2667,10 +2663,10 @@ (\ (@list& [_ (#TagS "" "open")] [_ (#FormS (@list& [_ (#TextS prefix)] structs))] tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] - (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) + (return [(#Some prefix structs') tokens'])) _ - (return (: (, (Maybe Openings) (List AST)) [#None tokens])))) + (return [#None tokens]))) (def (decorate-imports super-name tokens) (-> Text (List AST) (Lux (List AST))) @@ -2708,7 +2704,7 @@ #let [[openings extra] openings+extra] extra (decorate-imports m-name extra) sub-imports (parse-imports extra)] - (wrap (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) + (wrap (case [referral alias openings] [#Nothing #None #None] sub-imports _ (@list& [m-name alias referral openings] sub-imports)))) @@ -2741,7 +2737,7 @@ #cursor cursor} (case (get module modules) (#Some =module) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST)))))) + (let [to-alias (map (: (-> (, Text (, Bool DefData)) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 3fad6c7aa..6c3a3dfee 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -149,8 +149,7 @@ [_ in] (split 2 in) post-idx (index-of "}" in) [var post] (split post-idx in) - #let [[_ post] (? (: (, Text Text) ["" ""]) - (split 1 post))]] + #let [[_ post] (? ["" ""] (split 1 post))]] (wrap [pre var post]))) (do-template [ ] diff --git a/source/lux/math.lux b/source/lux/math.lux index 0f247cea8..a60ce512c 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -72,7 +72,7 @@ (def #export (lcm x y) (-> Int Int Int) - (case (: (, Int Int) [x y]) + (case [x y] (\or [_ 0] [0 _]) 0 diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index a34f92253..c71fd70b0 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -77,7 +77,7 @@ (#;Some $module) (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name)) (#;Some gdef) - (case (: (, Bool (DefData' Macro)) gdef) + (case (: (, Bool DefData) gdef) [exported? (#;MacroD macro')] (if (or exported? (text:= module current-module)) (#;Some macro') @@ -210,7 +210,7 @@ (case (get module (get@ #;modules state)) (#;Some =module) (using List/Monad - (#;Right [state (join (map (: (-> (, Text (, Bool (DefData' Macro))) + (#;Right [state (join (map (: (-> (, Text (, Bool DefData)) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] @@ -222,22 +222,6 @@ #;None (#;Left ($ text:++ "Unknown module: " module)))) -(def (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (F;map (lambda [env] - (case env - {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} - ($ text:++ name ": " (|> locals - (F;map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (:: List/Functor) - (interpose " ") - (foldL text:++ text:unit)))))) - (:: List/Functor) - (interpose "\n") - (foldL text:++ text:unit))) - (def (try-both f x1 x2) (All [a b] (-> (-> a (Maybe b)) a a (Maybe b))) @@ -245,7 +229,7 @@ #;None (f x2) (#;Some y) (#;Some y))) -(def (find-in-env name state) +(def #export (find-in-env name state) (-> Text Compiler (Maybe Type)) (case state {#;source source #;modules modules @@ -266,8 +250,8 @@ closure)))) envs))) -(def (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) +(def (find-in-defs' name state) + (-> Ident Compiler (Maybe DefData)) (let [[v-prefix v-name] name {#;source source #;modules modules #;envs envs #;type-vars types #;host host @@ -284,10 +268,23 @@ (#;Some [_ def-data]) (case def-data - (#;TypeD value) (#;Some Type) - (#;ValueD type _) (#;Some type) - (#;MacroD m) (#;Some Macro) - (#;AliasD name') (find-in-defs name' state)))))) + (#;AliasD name') (find-in-defs' name' state) + _ (#;Some def-data) + ))) + )) + +(def #export (find-in-defs name state) + (-> Ident Compiler (Maybe Type)) + (case (find-in-defs' name state) + (#;Some def-data) + (case def-data + (#;ValueD [type value]) (#;Some type) + (#;MacroD _) (#;Some Macro) + (#;TypeD _) (#;Some Type) + _ #;None) + + #;None + #;None)) (def #export (find-var-type name) (-> Ident (Lux Type)) @@ -306,9 +303,21 @@ (#;Right [state struct-type]) _ - (let [{#;source source #;modules modules - #;envs envs #;type-vars types #;host host - #;seed seed #;eval? eval? #;expected expected - #;cursor cursor} state] - (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + (#;Left ($ text:++ "Unknown var: " (ident->text name))))))) + )) + +(def #export (find-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (: (Lux Type) + (lambda [state] + (case (find-in-defs' name' state) + (#;Some def-data) + (case def-data + (#;TypeD type) (#;Right [state type]) + _ (#;Left ($ text:++ "Definition is not a type: " (ident->text name)))) + + _ + (#;Left ($ text:++ "Unknown var: " (ident->text name)))))) )) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 3d62bba2e..01acefd36 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -209,13 +209,12 @@ ## [Syntax] (defmacro #export (defsyntax tokens) - (let [[exported? tokens] (: (, Bool (List AST)) - (case tokens - (\ (@list& [_ (#;TagS ["" "export"])] tokens')) - [true tokens'] + (let [[exported? tokens] (case tokens + (\ (@list& [_ (#;TagS ["" "export"])] tokens')) + [true tokens'] - _ - [false tokens]))] + _ + [false tokens])] (case tokens (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] body)) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 552ccd77d..fbc360628 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -529,8 +529,11 @@ (fn [state] (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) (catch Error e - (prn e) - (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) + (prn 'analyse-basic-ast/Error-1 e) + (prn 'analyse-basic-ast/Error-2 (&/show-ast token)) + (prn 'analyse-basic-ast/Error-3 (&type/show-type exo-type)) + (throw e)) + ) (&/$Right state* output) (return* state* output) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 8c52748d7..414d005f1 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -126,9 +126,9 @@ ) ;; [Exports] -(defn expr-type [syntax+] +(defn expr-type* [syntax+] (|let [[_ type] syntax+] - (return type))) + type)) (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index c6c5cb39b..0b333ce07 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -209,14 +209,12 @@ (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) - =elem (analyse-1+ analyse ?elem) - =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) + =elem (analyse-1+ analyse ?elem)] + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) (&&/expr-type* =array)))))) (defn analyse-jvm-aaload [analyse ?array ?idx] - (|do [=array (analyse-1+ analyse ?array) - =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) + (|do [=array (analyse-1+ analyse ?array)] + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) (&&/expr-type* =array)))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 375c82f27..62202c1c9 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -28,23 +28,31 @@ ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$TupleT ?members) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] (return (&/|list (&/T (&/V &&/$tuple =elems) exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) + + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) - - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))))) (defn ^:private analyse-variant-body [analyse exo-type ?values] (|do [output (|case ?values @@ -206,8 +214,7 @@ (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] - ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] + ((|do [_ (&type/check exo-type (&&/expr-type* =local))] (return (&/|list =local))) (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) @@ -271,8 +278,8 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [_ (when (or (= "defsig" (aget real-name 1)) - ;; ;; (= "type" (aget real-name 1)) - ;; ;; (= &&/$struct r-name) + ;; ;; (= "..?" (aget real-name 1)) + ;; ;; (= "try$" (aget real-name 1)) ;; ) ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") @@ -297,8 +304,7 @@ _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") =value (analyse-1+ analyse ?value) - =value-type (&&/expr-type =value) - =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] + =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))] (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) @@ -376,11 +382,10 @@ (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name - (analyse-1+ analyse ?value)) - =value-type (&&/expr-type =value)] + (analyse-1+ analyse ?value))] (|case =value [(&&/$var (&/$Global ?r-module ?r-name)) _] - (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) + (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] ] @@ -412,16 +417,17 @@ _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) -(defn analyse-import [analyse compile-module compile-token ?path] +(defn analyse-import [analyse compile-module compile-token path] + ;; (prn 'analyse-import path) (|do [module-name &/get-module-name - _ (if (= module-name ?path) - (fail (str "[Analyser Error] Module can't import itself: " ?path)) + _ (if (= module-name path) + (fail (str "[Analyser Error] Module can't import itself: " path)) (return nil))] (&/save-module - (|do [already-compiled? (&&module/exists? ?path) - ;; :let [_ (prn 'analyse-import module-name ?path already-compiled?)] - _ (&&module/add-import ?path) - _ (&/when% (not already-compiled?) (compile-module ?path))] + (|do [already-compiled? (&&module/exists? path) + ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] + _ (&&module/add-import path) + _ (&/when% (not already-compiled?) (compile-module path))] (return (&/|list)))))) (defn analyse-export [analyse compile-token name] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 6a02ed21d..c17d10494 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -176,8 +176,8 @@ ))) (defn compile-def [compile ?name ?body] - (|do [=value-type (&a/expr-type ?body) - :let [def-type (cond (&type/type= &type/Type =value-type) + (|do [:let [=value-type (&a/expr-type* ?body) + def-type (cond (&type/type= &type/Type =value-type) "type" :else diff --git a/src/lux/type.clj b/src/lux/type.clj index 8300d470c..f067867d8 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -395,7 +395,7 @@ (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter dec) + ;; (&/update$ &/$counter dec) (&/set$ &/$mappings (&/|remove id mappings*))) state) nil))) @@ -949,3 +949,13 @@ _ (fail (str "[Type Error] Type is not named: " (show-type type))) )) + +(defn unknown? [type] + "(-> Type (Lux Bool))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (return (not ?))) + + _ + (return false))) -- cgit v1.2.3 From 77aae538ed0d128e291292b5defe80967d181be9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 20:37:10 -0400 Subject: - Added the (untested) inference of tuple destructuring. - Removed several (unnecessary) type annotations. --- source/lux.lux | 143 +++++++++++++++++++++------------------------ source/lux/data/list.lux | 4 +- source/lux/meta/lux.lux | 2 +- source/lux/meta/syntax.lux | 5 +- src/lux/analyser/base.clj | 8 +++ src/lux/analyser/case.clj | 60 ++++++++++++------- src/lux/analyser/lux.clj | 18 ++---- src/lux/type.clj | 13 ++++- 8 files changed, 134 insertions(+), 119 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index c1e7b0046..d661b9268 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -691,8 +691,7 @@ (def'' (make-env xs ys) (#LambdaT ($' List Text) (#LambdaT ($' List AST) RepEnv)) - (_lux_case (_lux_: (#TupleT (#Cons ($' List Text) (#Cons ($' List AST) #Nil))) - [xs ys]) + (_lux_case [xs ys] [(#Cons x xs') (#Cons y ys')] (#Cons [x y] (make-env xs' ys')) @@ -823,13 +822,12 @@ (foldL f (f init x) xs'))) (defmacro' #export (All tokens) - (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil))) - (_lux_case tokens - (#Cons [_ (#SymbolS "" self-name)] tokens) - [self-name tokens] + (let'' [self-name tokens] (_lux_case tokens + (#Cons [_ (#SymbolS "" self-name)] tokens) + [self-name tokens] - _ - ["" tokens])) + _ + ["" tokens]) (_lux_case tokens (#Cons [_ (#TupleS args)] (#Cons body #Nil)) (parse-univq-args args @@ -850,13 +848,12 @@ )) (defmacro' #export (Ex tokens) - (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil))) - (_lux_case tokens - (#Cons [_ (#SymbolS "" self-name)] tokens) - [self-name tokens] + (let'' [self-name tokens] (_lux_case tokens + (#Cons [_ (#SymbolS "" self-name)] tokens) + [self-name tokens] - _ - ["" tokens])) + _ + ["" tokens]) (_lux_case tokens (#Cons [_ (#TupleS args)] (#Cons body #Nil)) (parse-univq-args args @@ -1313,7 +1310,7 @@ (resolve-global-symbol [subst name]) _ - (wrap (_lux_: Ident [module name]))) + (wrap [module name])) #let [[module name] real-name]] (return (wrap-meta (form$ (@list (tag$ ["lux" "SymbolS"]) (tuple$ (@list (text$ module) (text$ name)))))))) @@ -1330,7 +1327,7 @@ (do Lux/Monad [output (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) #let [[_ form'] output]] - (return (_lux_: AST [meta form']))) + (return [meta form'])) [_ [_ (#RecordS fields)]] (do Lux/Monad @@ -1576,7 +1573,7 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (wrap (_lux_: Ident [module-name name]))) + (wrap [module-name name])) _ (return ident))) @@ -1910,20 +1907,18 @@ #None))] (_lux_case parts (#Some name args ?type body) - (let' [body' (: AST - (_lux_case args - #Nil - body + (let' [body' (_lux_case args + #Nil + body - _ - (` (lambda' (~ name) [(~@ args)] (~ body))))) - body'' (: AST - (_lux_case ?type - (#Some type) - (` (: (~ type) (~ body'))) - - #None - body'))] + _ + (` (lambda' (~ name) [(~@ args)] (~ body)))) + body'' (_lux_case ?type + (#Some type) + (` (: (~ type) (~ body'))) + + #None + body')] (return (@list& (` (;_lux_def (~ name) (~ body''))) (if export? (@list (` (;_lux_export (~ name)))) @@ -2081,14 +2076,14 @@ (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) - body+ (: AST (foldL (: (-> AST AST AST) - (lambda' [body' arg] - (if (symbol? arg) - (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) - (` (;_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) - body - (reverse tail)))] + body+ (foldL (: (-> AST AST AST) + (lambda' [body' arg] + (if (symbol? arg) + (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) + (` (;_lux_lambda (~ g!blank) (~ g!blank) + (case (~ g!blank) (~ arg) (~ body'))))))) + body + (reverse tail))] (return (@list (if (symbol? head) (` (;_lux_lambda (~ g!name) (~ head) (~ body+))) (` (;_lux_lambda (~ g!name) (~ g!blank) (case (~ g!blank) (~ head) (~ body+)))))))) @@ -2121,20 +2116,18 @@ #None))] (case parts (#Some name args ?type body) - (let [body (: AST - (case args - #Nil - body + (let [body (case args + #Nil + body - _ - (` (lambda (~ name) [(~@ args)] (~ body))))) - body (: AST - (case ?type - (#Some type) - (` (: (~ type) (~ body))) - - #None - body))] + _ + (` (lambda (~ name) [(~@ args)] (~ body)))) + body (case ?type + (#Some type) + (` (: (~ type) (~ body))) + + #None + body)] (return (@list& (` (;_lux_def (~ name) (~ body))) (if export? (@list (` (;_lux_export (~ name)))) @@ -2163,12 +2156,12 @@ (case name+args+body?? (#Some [name args body]) (let [name (symbol$ name) - decls (list:++ (: (List AST) (if exported? (@list (` (;_lux_export (~ name)))) #;Nil)) - (: (List AST) (@list (` (;;_lux_declare-macro (~ name)))))) - def-sig (: AST - (case args - #;Nil name - _ (` ((~ name) (~@ args)))))] + decls (: (List AST) + (list:++ (if exported? (@list (` (;_lux_export (~ name)))) #;Nil) + (@list (` (;;_lux_declare-macro (~ name)))))) + def-sig (case args + #;Nil name + _ (` ((~ name) (~@ args))))] (return (@list& (` (;;def (~ def-sig) ;;Macro (~ body))) decls))) @@ -2212,15 +2205,14 @@ def-name (symbol$ name) tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) types (map second members) - sig-type (: AST (` (#TupleT (~ (untemplate-list types))))) - sig-decl (: AST (` (;_lux_declare-tags [(~@ tags)] (~ def-name)))) - sig+ (: AST - (case args - #Nil - sig-type + sig-type (` (#TupleT (~ (untemplate-list types)))) + sig-decl (` (;_lux_declare-tags [(~@ tags)] (~ def-name))) + sig+ (case args + #Nil + sig-type - _ - (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type))))))]] + _ + (` (#NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type)))))]] (return (@list& (` (;_lux_def (~ def-name) (~ sig+))) sig-decl (if export? @@ -2556,13 +2548,12 @@ #None))] (case ?parts (#Some name args type defs) - (let [defs' (: AST - (case args - #Nil - (` (struct (~@ defs))) + (let [defs' (case args + #Nil + (` (struct (~@ defs))) - _ - (` (lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + _ + (` (lambda (~ name) [(~@ args)] (;struct (~@ defs)))))] (return (@list& (` (def (~ name) (~ type) (~ defs'))) (if export? (@list (` (;_lux_export (~ name)))) @@ -3036,7 +3027,7 @@ (-> Text Ident AST Type (Lux (List AST))) (do Lux/Monad [output (resolve-type-tags type) - #let [source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))]] + #let [source+ (` (get@ (~ (tag$ [module name])) (~ source)))]] (case output (#Some [tags members]) (do Lux/Monad @@ -3087,7 +3078,7 @@ [m-name m-alias m-referrals m-openings] (do Lux/Monad [m-name (clean-module m-name)] - (wrap (: Importation [m-name m-alias m-referrals m-openings])))))) + (wrap [m-name m-alias m-referrals m-openings]))))) imports) unknowns' (map% Lux/Monad (: (-> Importation (Lux (List Text))) @@ -3178,11 +3169,11 @@ (lambda [so-far part] (case part [_ (#SymbolS slot)] - (return (: AST (` (get@ (~ (tag$ slot)) (~ so-far))))) + (return (` (get@ (~ (tag$ slot)) (~ so-far)))) (\ [_ (#FormS (@list& [_ (#SymbolS slot)] args))]) - (return (: AST (` ((get@ (~ (tag$ slot)) (~ so-far)) - (~@ args))))) + (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args)))) _ (fail "Wrong syntax for ::")))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 0da0b3ecb..a6ca4e0f7 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -233,7 +233,7 @@ (defmacro #export (@list xs state) (#;Right state (#;Cons (foldL (: (-> AST AST AST) (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) - (: AST (` #;Nil)) + (` #;Nil) (reverse xs)) #;Nil))) @@ -301,7 +301,7 @@ ## [(~@ tokens)]))] ## (#;Right state (@list code)))) ## (#;Left "Can't zip-with no lists.")) - + ## _ ## (let [g!temp [["" -1 -1] (#SymbolS "" "\ttemp\t")]] ## (#;Right state (@list (` (let [(~ g!temp) (~ _f)] diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index c71fd70b0..edf3a8667 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -110,7 +110,7 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (wrap (: Ident [module-name name]))) + (wrap [module-name name])) _ (:: Lux/Monad (M;wrap ident)))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 01acefd36..ee5a37d53 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -248,9 +248,8 @@ (l;fail (~ error-msg))))))) body (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) - macro-def (: AST - (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] + macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body')))]] (wrap (@list& macro-def (if exported? (@list (` (;_lux_export (~ (symbol$ ["" name]))))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 414d005f1..7f7980e76 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -139,6 +139,14 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) +(defn analyse-1+ [analyse ?token] + (&type/with-var + (fn [$var] + (|do [=expr (analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) + (defn resolved-ident [ident] (|let [[?module ?name] ident] (|do [module* (if (.equals "" ?module) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f302088d9..3b12270c2 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -184,11 +184,7 @@ (&/$RecordS pairs) (|do [?members (&&record/order-record pairs) - ;; :let [_ (prn 'PRE (&type/show-type value-type))] - value-type* (adjust-type value-type) - ;; :let [_ (prn 'POST (&type/show-type value-type*))] - ;; value-type* (resolve-type value-type) - ] + value-type* (adjust-type value-type)] (|case value-type* (&/$TupleT ?member-types) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) @@ -333,6 +329,15 @@ (return (&/V $VariantTotal (&/T total? structs)))) )))) +(defn check-totality+ [check-totality] + (fn [?token] + (&type/with-var + (fn [$var] + (|do [=output (check-totality $var ?token) + ?type (&type/deref+ $var) + =type (&type/clean $var ?type)] + (return (&/T =output =type))))))) + (defn ^:private check-totality [value-type struct] ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct @@ -340,34 +345,45 @@ (return ?total) ($BoolTotal ?total ?values) - (return (or ?total - (= #{true false} (set (&/->seq ?values))))) + (|do [_ (&type/check value-type &type/Bool)] + (return (or ?total + (= #{true false} (set (&/->seq ?values)))))) ($IntTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Int)] + (return ?total)) ($RealTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Real)] + (return ?total)) ($CharTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Char)] + (return ?total)) ($TextTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Text)] + (return ?total)) ($TupleTotal ?total ?structs) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$TupleT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (|do [unknown? (&type/unknown? value-type)] + (if unknown? + (|do [=structs (&/map% (check-totality+ check-totality) ?structs) + _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))] + (return (or ?total + (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) - _ - (fail "[Pattern-maching Error] Tuple is not total.")))) + _ + (fail "[Pattern-maching Error] Tuple is not total.")))))) ($VariantTotal ?total ?structs) (if ?total diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 62202c1c9..3a9b822ca 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,19 +18,11 @@ [module :as &&module] [record :as &&record]))) -(defn ^:private analyse-1+ [analyse ?token] - (&type/with-var - (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token) - :let [[?item ?type] =expr] - =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) - ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [unknown? (&type/unknown? exo-type)] (if unknown? - (|do [=elems (&/map% #(|do [=analysis (analyse-1+ analyse %)] + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] (return =analysis)) ?elems) _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] @@ -52,7 +44,7 @@ (analyse-tuple analyse exo-type** ?elems)))) _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))))) + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) (&type/show-type exo-type)))))))) (defn ^:private analyse-variant-body [analyse exo-type ?values] (|do [output (|case ?values @@ -303,7 +295,7 @@ (|do [:let [num-branches (&/|length ?branches)] _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") - =value (analyse-1+ analyse ?value) + =value (&&/analyse-1+ analyse ?value) =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))] (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) @@ -382,7 +374,7 @@ (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name - (analyse-1+ analyse ?value))] + (&&/analyse-1+ analyse ?value))] (|case =value [(&&/$var (&/$Global ?r-module ?r-name)) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) @@ -452,6 +444,6 @@ (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (analyse-1+ analyse ?value)] + =value (&&/analyse-1+ analyse ?value)] (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index f067867d8..5fbc33de2 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -336,6 +336,14 @@ (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id))))) +(defn deref+ [type] + (|case type + (&/$VarT id) + (deref id) + + _ + (fail (str "[Type Error] Type is not a variable: " (show-type type))))) + (defn set-var [id type] (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] @@ -914,8 +922,9 @@ (|do [type* (apply-type ?all ?param)] (actual-type type*)) - (&/$VarT ?id) - (deref ?id) + (&/$VarT id) + (|do [=type (deref id)] + (actual-type =type)) (&/$NamedT ?name ?type) (actual-type ?type) -- cgit v1.2.3 From 08584c8d9a462ce0bd3ffb6d9535ecb3f7043289 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 7 Sep 2015 01:33:53 -0400 Subject: - Type checking of polymorphic functions now relies on ExT types to guarantee that type-variables don't unify to anything, instead of relying on VarT types. - Fixed some bugs in the standard library due to improper behavior of the type-checker. - The analysis and pattern-matching code for records now reuses that of tuples. --- source/lux/codata/state.lux | 3 +- source/lux/meta/syntax.lux | 5 +- src/lux/analyser.clj | 6 ++ src/lux/analyser/case.clj | 26 +------ src/lux/analyser/lux.clj | 161 +++++++++++++++++++++++--------------------- src/lux/type.clj | 14 +++- 6 files changed, 110 insertions(+), 105 deletions(-) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index ec0a6bf63..de7220a45 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -12,7 +12,8 @@ (-> s (, s a))) ## [Structures] -(defstruct #export State/Functor (Functor State) +(defstruct #export State/Functor (All [s] + (Functor (State s))) (def (map f ma) (lambda [state] (let [[state' a] (ma state)] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index ee5a37d53..4ee3163b0 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -183,13 +183,14 @@ (def #export (|^ p1 p2 tokens) (All [a b] - (-> (Parser a) (Parser b) (Parser (Either b)))) + (-> (Parser a) (Parser b) (Parser (Either a b)))) (case (p1 tokens) (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) #;None (run-parser (do Parser/Monad [x2 p2] (wrap (#;Right x2))) - tokens))) + tokens) + )) (def #export (||^ ps tokens) (All [a] diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index fbc360628..9a57191f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -532,6 +532,12 @@ (prn 'analyse-basic-ast/Error-1 e) (prn 'analyse-basic-ast/Error-2 (&/show-ast token)) (prn 'analyse-basic-ast/Error-3 (&type/show-type exo-type)) + (|case ((&type/deref+ exo-type) state) + (&/$Right [_state _exo-type]) + (prn 'analyse-basic-ast/Error-4 (&type/show-type _exo-type)) + + _ + (prn 'analyse-basic-ast/Error-4 'YOLO)) (throw e)) ) (&/$Right state* output) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 3b12270c2..f2afdb0e9 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -49,14 +49,9 @@ (resolve-type type*)) (&/$UnivQ _) - ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] (&type/actual-type =type)) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [=type (&type/apply-type type $var)] - ;; (&type/actual-type =type)))) _ (&type/actual-type type))) @@ -126,7 +121,7 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[_ pattern*] pattern] + (|let [[meta pattern*] pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type @@ -183,23 +178,8 @@ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs) - value-type* (adjust-type value-type)] - (|case value-type* - (&/$TupleT ?member-types) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/Cons$ =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont)))) - - _ - (fail "[Pattern-matching Error] Record requires record-type."))) + (|do [?members (&&record/order-record pairs)] + (analyse-pattern value-type (&/T meta (&/V &/$TupleS ?members)) kont)) (&/$TagS ?ident) (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 3a9b822ca..f22cc6c9a 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -44,19 +44,39 @@ (analyse-tuple analyse exo-type** ?elems)))) _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) (&type/show-type exo-type)))))))) + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + ))))) -(defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [output (|case ?values - (&/$Nil) - (analyse-tuple analyse exo-type (&/|list)) - - (&/$Cons ?value (&/$Nil)) - (analyse exo-type ?value) +(defn with-attempt [m-value on-error] + (fn [state] + (|case (m-value state) + (&/$Left msg) + ((on-error msg) state) + + output + output))) - _ - (analyse-tuple analyse exo-type ?values) - )] +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (with-attempt + (|case ?values + (&/$Nil) + (analyse-tuple analyse exo-type (&/|list)) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse exo-type ?values)) + (fn [err] + (fail (str err "\n" + 'analyse-variant-body " " (&type/show-type exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) + ;; (assert false + ;; (str err "\n" + ;; 'analyse-variant-body " " (&type/show-type exo-type) + ;; " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) + ))] (|case output (&/$Cons x (&/$Nil)) (return x) @@ -78,7 +98,13 @@ (&/$VariantT ?cases) (|case (&/|at idx ?cases) (&/$Some vtype) - (|do [=value (analyse-variant-body analyse vtype ?values)] + (|do [=value (with-attempt + (analyse-variant-body analyse vtype ?values) + (fn [err] + (|do [_exo-type (&type/deref+ exo-type)] + (fail (str err "\n" + 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) exo-type)))) @@ -95,41 +121,8 @@ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - ;; (when @&type/!flag - ;; (prn 'analyse-record (&type/show-type exo-type) - ;; (&/->seq (&/|map (fn [pair] - ;; (|let [[k v] pair] - ;; (str (&/show-ast k) " " (&/show-ast v)))) - ;; ?elems)))) - (|do [exo-type* (|case exo-type - (&/$VarT ?id) - (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - - (&/$UnivQ _) - (|do [$var &type/existential - =type (&type/apply-type exo-type $var)] - (&type/actual-type =type)) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [=type (&type/apply-type exo-type $var)] - ;; (&type/actual-type =type)))) - - _ - (&type/actual-type exo-type)) - types (|case exo-type* - (&/$TupleT ?table) - (return ?table) - - _ - (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*) "\n" (&type/show-type exo-type)))) - _ (&/assert! (= (&/|length types) (&/|length ?elems)) - (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) - members (&&record/order-record ?elems) - =members (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - types members)] - (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) + (|do [members (&&record/order-record ?elems)] + (analyse-tuple analyse exo-type members))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -222,7 +215,10 @@ ;; (prn 'analyse-apply* (aget fun-type 0)) (|case ?args (&/$Nil) - (|do [_ (&type/check exo-type fun-type)] + (|do [;; :let [_ (prn 'analyse-apply*/_0 (&type/show-type exo-type) (&type/show-type fun-type))] + _ (&type/check exo-type fun-type) + ;; :let [_ (prn 'analyse-apply*/_1 'SUCCESS (str "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))] + ] (return (&/T fun-type (&/|list)))) (&/$Cons ?arg ?args*) @@ -248,7 +244,12 @@ (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) - =arg (&&/analyse-1 analyse ?input-t ?arg)] + =arg (with-attempt + (&&/analyse-1 analyse ?input-t ?arg) + (fn [err] + (fail (str err "\n" + 'analyse-apply* " " (&type/show-type exo-type) " " (&type/show-type ?fun-type*) + " " "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))))] (return (&/T =output-t (&/Cons$ =arg =args)))) ;; [[&/$VarT ?id-t]] @@ -325,35 +326,39 @@ (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type* (&type/apply-type exo-type $var) - [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - (|case $var - (&/$VarT ?id) - (|do [? (&type/bound? ?id)] - (if ? - (|do [dtype (&type/deref ?id) - ;; dtype* (&type/actual-type dtype) - ] - (|case dtype - (&/$BoundT ?vname) - (return (&/T _expr exo-type)) - - (&/$ExT _) - (return (&/T _expr exo-type)) - - (&/$VarT ?_id) - (|do [?? (&type/bound? ?_id)] - ;; (return (&/T _expr exo-type)) - (if ?? - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))) - (return (&/T _expr exo-type))) - ) - - _ - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))))) - (return (&/T _expr exo-type)))))))) + (|do [$var &type/existential + exo-type* (&type/apply-type exo-type $var) + [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] + (return (&/T _expr exo-type))) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [exo-type* (&type/apply-type exo-type $var) + ;; [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] + ;; (|case $var + ;; (&/$VarT ?id) + ;; (|do [? (&type/bound? ?id)] + ;; (if ? + ;; (|do [dtype (&type/deref ?id) + ;; ;; dtype* (&type/actual-type dtype) + ;; ] + ;; (|case dtype + ;; (&/$BoundT ?vname) + ;; (return (&/T _expr exo-type)) + + ;; (&/$ExT _) + ;; (return (&/T _expr exo-type)) + + ;; (&/$VarT ?_id) + ;; (|do [?? (&type/bound? ?_id)] + ;; ;; (return (&/T _expr exo-type)) + ;; (if ?? + ;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))) + ;; (return (&/T _expr exo-type))) + ;; ) + + ;; _ + ;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))))) + ;; (return (&/T _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] diff --git a/src/lux/type.clj b/src/lux/type.clj index 5fbc33de2..889d4fc47 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -342,7 +342,9 @@ (deref id) _ - (fail (str "[Type Error] Type is not a variable: " (show-type type))))) + ;; (assert false (str "[Type Error] Type is not a variable: " (show-type type))) + (fail (str "[Type Error] Type is not a variable: " (show-type type))) + )) (defn set-var [id type] (fn [state] @@ -370,6 +372,7 @@ id)))) (def existential + ;; (Lux Type) (|do [seed &/gen-id] (return (&/V &/$ExT seed)))) @@ -650,6 +653,9 @@ (&/$NamedT ?name ?type) (apply-type ?type param) + + (&/$ExT id) + (return (App$ type-fn param)) _ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) @@ -728,6 +734,11 @@ (check* class-loader fixpoints expected bound)) state))) + [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] + (if (= eid aid) + (check* class-loader fixpoints eA aA) + (fail (check-error expected actual))) + [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] (fn [state] (|case ((|do [F1 (deref ?eid)] @@ -757,6 +768,7 @@ [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) state)))) + ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) -- cgit v1.2.3 From 7194d9277594662e12c3536044e2251e39a6da4f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 8 Sep 2015 10:13:31 -0400 Subject: - A few minor fixes in the standard library. - The "impl" methods in lambda classes are now marked "final" --- source/lux/control/enum.lux | 2 +- source/lux/control/monad.lux | 1 - source/lux/data/id.lux | 14 ++++---- source/lux/data/list.lux | 27 +++++++------- source/lux/data/number/int.lux | 7 ++++ source/lux/data/number/real.lux | 7 ++++ source/lux/meta/ast.lux | 14 ++++---- src/lux/compiler/lambda.clj | 69 ++++++++++++++++++----------------- src/lux/compiler/lux.clj | 80 +++++++++++++++++++++-------------------- src/lux/type.clj | 64 ++++++++++++++++++--------------- 10 files changed, 154 insertions(+), 131 deletions(-) diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux index 34910c837..c54eab75b 100644 --- a/source/lux/control/enum.lux +++ b/source/lux/control/enum.lux @@ -10,7 +10,7 @@ (defsig #export (Enum e) (: (Ord e) _ord) (: (-> e e) succ) - (: (-> e e) pre)) + (: (-> e e) pred)) ## [Functions] (def #export (range' <= succ from to) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 883875a03..0c7827c34 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -60,7 +60,6 @@ _ (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) - ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) )))) body (reverse (as-pairs bindings)))] diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 6b996cf1e..e4f2a775f 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -10,20 +10,18 @@ ## [Types] (deftype #export (Id a) - (| (#Id a))) + a) ## [Structures] (defstruct #export Id/Functor (Functor Id) - (def (map f fa) - (let [(#Id a) fa] - (#Id (f a))))) + (def map id)) (defstruct #export Id/Monad (Monad Id) (def _functor Id/Functor) - (def (wrap a) (#Id a)) - (def (join mma) (let [(#Id ma) mma] ma))) + (def wrap id) + (def join id)) (defstruct #export Id/CoMonad (CoMonad Id) (def _functor Id/Functor) - (def (unwrap wa) (let [(#Id a) wa] a)) - (def (split wa) (#Id wa))) + (def unwrap id) + (def split id)) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index a6ca4e0f7..8a7f97698 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -311,19 +311,20 @@ ## (#;Left "Wrong syntax for zip-with"))) ## [Structures] -## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) -## (def (= xs ys) -## (case [xs ys] -## [#;Nil #;Nil] -## true - -## [(#;Cons x xs') (#;Cons y ys')] -## (and (:: eq (E;= x y)) -## (= xs' ys')) - -## [_ _] -## false -## ))) +(defstruct #export (List/Eq eq) + (All [a] (-> (E;Eq a) (E;Eq (List a)))) + (def (= xs ys) + (case [xs ys] + [#;Nil #;Nil] + true + + [(#;Cons x xs') (#;Cons y ys')] + (and (:: eq (E;= x y)) + (= xs' ys')) + + [_ _] + false + ))) (defstruct #export List/Monoid (All [a] (Monoid (List a))) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index 2d94ad43b..20ea5fced 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -8,6 +8,7 @@ (monoid #as m) (eq #as E) (ord #as O) + (enum #as EN) (bounded #as B) (show #as S))) @@ -56,6 +57,12 @@ [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) +## Enum +(defstruct Int/Enum (EN;Enum Int) + (def _ord Int/Ord) + (def succ (lambda [n] (:: Int/Number (N;+ n 1)))) + (def pred (lambda [n] (:: Int/Number (N;- n 1))))) + ## Bounded (do-template [ ] [(defstruct #export (B;Bounded ) diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux index 2b7090265..7301f2932 100644 --- a/source/lux/data/number/real.lux +++ b/source/lux/data/number/real.lux @@ -8,6 +8,7 @@ (monoid #as m) (eq #as E) (ord #as O) + (enum #as EN) (bounded #as B) (show #as S))) @@ -56,6 +57,12 @@ [Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt]) +## Enum +(defstruct Real/Enum (EN;Enum Real) + (def _ord Real/Ord) + (def succ (lambda [n] (:: Real/Number (N;+ n 1.0)))) + (def pred (lambda [n] (:: Real/Number (N;- n 1.0))))) + ## Bounded (do-template [ ] [(defstruct #export (B;Bounded ) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index 78882c854..8d649cf4a 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -10,9 +10,9 @@ (number int real) char - (text #refer #all #open ("text:" Text/Monoid)) + (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid)) ident - (list #refer (#only List interpose) #open ("" List/Functor List/Fold)) + (list #refer #all #open ("" List/Functor)) ))) ## [Types] @@ -80,11 +80,11 @@ ))) ## (defstruct #export AST/Eq (Eq AST) -## (def (eq x y) +## (def (= x y) ## (case [x y] ## (\template [ ] -## [[( x') ( y')] -## (:: (E;eq x' y'))]) +## [[[_ ( x')] [_ ( y')]] +## (:: (E;= x' y'))]) ## [[#;BoolS Bool/Eq] ## [#;IntS Int/Eq] ## [#;RealS Real/Eq] @@ -94,7 +94,7 @@ ## [#;TagS Ident/Eq]] ## (\template [] -## [[( xs') ( ys')] +## [[[_ ( xs')] [_ ( ys')]] ## (and (:: Int/Eq (E;= (size xs') (size ys'))) ## (foldL (lambda [old [x' y']] ## (and old (= x' y'))) @@ -102,7 +102,7 @@ ## (zip2 xs' ys')))]) ## [[#;FormS] [#;TupleS]] -## [(#;RecordS xs') (#;RecordS ys')] +## [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] ## (and (:: Int/Eq (E;= (size xs') (size ys'))) ## (foldL (lambda [old [[xl' xr'] [yl' yr']]] ## (and old (= xl' yl') (= xr' yr'))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 8fefab156..86bc08534 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -60,19 +60,20 @@ (.visitMaxs 0 0) (.visitEnd))) -(defn ^:private add-lambda-impl [class compile impl-signature impl-body] - (&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) - (.visitCode)) - (|do [^MethodVisitor *writer* &/get-writer - :let [$start (new Label) - $end (new Label)] - ret (compile impl-body) - :let [_ (doto *writer* - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))) +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] + (defn ^:private add-lambda-impl [class compile impl-signature impl-body] + (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" impl-signature nil nil) + (.visitCode)) + (|do [^MethodVisitor *writer* &/get-writer + :let [$start (new Label) + $end (new Label)] + ret (compile impl-body) + :let [_ (doto *writer* + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret))))) (defn ^:private instance-closure [compile lambda-class closed-over init-signature] (|do [^MethodVisitor *writer* &/get-writer @@ -88,23 +89,25 @@ (return nil))) ;; [Exports] -(defn compile-lambda [compile ?scope ?env ?body] - ;; (prn 'compile-lambda (->> ?scope &/->seq)) - (|do [:let [name (&host/location (&/|tail ?scope)) - class-name (str (&host/->module-class (&/|head ?scope)) "/" name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" (into-array [&&/function-class])) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) - (doseq [?name+?captured (&/->seq ?env)]))) - (add-lambda-apply class-name ?env) - (add-lambda- class-name ?env) - )] - _ (add-lambda-impl =class compile lambda-impl-signature ?body) - :let [_ (.visitEnd =class)] - _ (&&/save-class! name (.toByteArray =class))] - (instance-closure compile class-name ?env (lambda--signature ?env)))) +(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-lambda [compile ?scope ?env ?body] + ;; (prn 'compile-lambda (->> ?scope &/->seq)) + (|do [:let [name (&host/location (&/|tail ?scope)) + class-name (str (&host/->module-class (&/|head ?scope)) "/" name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 lambda-flags + class-name nil "java/lang/Object" (into-array [&&/function-class])) + (-> (doto (.visitField datum-flags captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [(&a/$captured _ ?captured-id ?source) _]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (add-lambda-apply class-name ?env) + (add-lambda- class-name ?env) + )] + _ (add-lambda-impl =class compile lambda-impl-signature ?body) + :let [_ (.visitEnd =class)] + _ (&&/save-class! name (.toByteArray =class))] + (instance-closure compile class-name ?env (lambda--signature ?env))))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index c17d10494..e85af8b0d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -175,45 +175,47 @@ (return nil))) ))) -(defn compile-def [compile ?name ?body] - (|do [:let [=value-type (&a/expr-type* ?body) - def-type (cond (&type/type= &type/Type =value-type) - "type" - - :else - "value")] - ^ClassWriter *writer* &/get-writer - module-name &/get-module-name - :let [datum-sig "Ljava/lang/Object;" - def-name (&/normalize-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [&&/function-class])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/datum-field datum-sig nil nil) - (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/meta-field datum-sig nil nil) - (doto (.visitEnd))))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (compile ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] - _ (compile-def-type compile current-class ?body def-type) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd *writer*)] - _ (&&/save-class! def-name (.toByteArray =class)) - class-loader &/loader - :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] - _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] - (return nil))) +(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] + (defn compile-def [compile ?name ?body] + (|do [:let [=value-type (&a/expr-type* ?body) + def-type (cond (&type/type= &type/Type =value-type) + "type" + + :else + "value")] + ^ClassWriter *writer* &/get-writer + module-name &/get-module-name + :let [datum-sig "Ljava/lang/Object;" + def-name (&/normalize-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 class-flags + current-class nil "java/lang/Object" (into-array [&&/function-class])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/datum-field datum-sig nil nil) + (doto (.visitEnd))) + (-> (.visitField field-flags &/meta-field datum-sig nil nil) + (doto (.visitEnd))))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] + _ (compile-def-type compile current-class ?body def-type) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (&&/save-class! def-name (.toByteArray =class)) + class-loader &/loader + :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] + _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] + (return nil)))) (defn compile-ann [compile *type* ?value-ex ?type-ex] (compile ?value-ex)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 889d4fc47..4672b18d4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -739,35 +739,35 @@ (check* class-loader fixpoints eA aA) (fail (check-error expected actual))) - [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] - (fn [state] - (|case ((|do [F1 (deref ?eid)] - (fn [state] - (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((check* class-loader fixpoints (App$ F1 A1) actual) - state)))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (App$ F2 A2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) - [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) - state)))) + ;; [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] + ;; (fn [state] + ;; (|case ((|do [F1 (deref ?eid)] + ;; (fn [state] + ;; (|case ((|do [F2 (deref ?aid)] + ;; (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; ((check* class-loader fixpoints (App$ F1 A1) actual) + ;; state)))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; (|case ((|do [F2 (deref ?aid)] + ;; (check* class-loader fixpoints expected (App$ F2 A2))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) + ;; [fixpoints** _] (check* class-loader fixpoints* A1 A2)] + ;; (return (&/T fixpoints** nil))) + ;; state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] @@ -788,6 +788,7 @@ [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) + ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) @@ -810,6 +811,7 @@ [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) + ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) @@ -817,6 +819,10 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) + ;; [(&/$AppT eF eA) (&/$AppT aF aA)] + ;; (|do [_ (check* class-loader fixpoints eF aF)] + ;; (check* class-loader fixpoints eA aA)) + [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) -- cgit v1.2.3 From dbbd680d0a47c64eeb2627d458c22e8ea16206d5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 9 Sep 2015 18:36:22 -0400 Subject: - Added type inference for functions. - Fixed a bug wherein the "case" macro ignored tokens when receiving uneven inputs. --- source/lux.lux | 46 ++++++++-------- src/lux/analyser/host.clj | 43 +++++++++------ src/lux/analyser/lux.clj | 130 +++++++++++++++++++++++++++++----------------- src/lux/compiler/type.clj | 3 ++ src/lux/type.clj | 16 +++++- 5 files changed, 148 insertions(+), 90 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index d661b9268..e2daeaf0e 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1534,7 +1534,7 @@ (i= 0 (i% n div))) (def''' (length list) - (-> List Int) + (All [a] (-> ($' List a) Int)) (foldL (lambda' [acc _] (_jvm_ladd 1 acc)) 0 list)) (def''' #export (not x) @@ -1977,27 +1977,29 @@ (defmacro' #export (case tokens) (_lux_case tokens (#Cons value branches) - (do Lux/Monad - [expansions (map% Lux/Monad - (: (-> (, AST AST) (Lux (List (, AST AST)))) - (lambda' expander [branch] - (let' [[pattern body] branch] - (_lux_case pattern - [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] - (do Lux/Monad - [??? (macro? macro-name)] - (if ??? - (do Lux/Monad - [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args))) - expansions (map% Lux/Monad expander (as-pairs expansion))] - (wrap (list:join expansions))) - (wrap (@list branch)))) - - _ - (wrap (@list branch)))))) - (as-pairs branches))] - (wrap (@list (` (;_lux_case (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + (if (multiple? 2 (length branches)) + (do Lux/Monad + [expansions (map% Lux/Monad + (: (-> (, AST AST) (Lux (List (, AST AST)))) + (lambda' expander [branch] + (let' [[pattern body] branch] + (_lux_case pattern + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] + (do Lux/Monad + [??? (macro? macro-name)] + (if ??? + (do Lux/Monad + [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args))) + expansions (map% Lux/Monad expander (as-pairs expansion))] + (wrap (list:join expansions))) + (wrap (@list branch)))) + + _ + (wrap (@list branch)))))) + (as-pairs branches))] + (wrap (@list (` (;_lux_case (~ value) + (~@ (|> expansions list:join (map rejoin-pair) list:join))))))) + (fail "case expects an even number of tokens")) _ (fail "Wrong syntax for case"))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 0b333ce07..9a05a6695 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -49,6 +49,29 @@ _ type)) +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn ^:private as-otype+ [type] + "(-> Type Type)" + (|case type + (&/$DataT tname) + (&/V &/$DataT (as-otype tname)) + + _ + type)) + ;; [Resources] (do-template [ ] (let [input-type (&/V &/$DataT ) @@ -144,7 +167,7 @@ =classes ?args) :let [output-type =return] - _ (&type/check exo-type output-type)] + _ (&type/check exo-type (as-otype+ output-type))] (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] @@ -163,7 +186,7 @@ =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] - _ (&type/check exo-type output-type)] + _ (&type/check exo-type (as-otype+ output-type))] (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual @@ -181,7 +204,7 @@ (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] - _ (&type/check exo-type output-type)] + _ (&type/check exo-type (as-otype+ output-type))] (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] @@ -252,20 +275,6 @@ :concurrency nil} modifiers)) -(defn ^:private as-otype [tname] - (case tname - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - tname - )) - (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index f22cc6c9a..39eda451f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -301,27 +301,80 @@ (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) +(defn ^:private count-univq [type] + "(-> Type Int)" + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +(defn ^:private embed-inferred-input [input output] + "(-> Type Type Type)" + (|case output + (&/$UnivQ env output*) + (&type/Univ$ env (embed-inferred-input input output*)) + + _ + (&type/Lambda$ input output))) + (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) - ;; (|do [$var &type/existential - ;; exo-type** (&type/apply-type exo-type* $var)] - ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - - (&/$LambdaT ?arg-t ?return-t) - (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) - - _ - (fail (str "[Analyser Error] Functions require function types: " - (&type/show-type exo-type*)))))) + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/deref id)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (&type/with-var + (fn [$input] + (&type/with-var + (fn [$output] + (|do [[lambda-analysis lambda-type] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body) + =input (&type/resolve-type $input) + =output (&type/resolve-type $output) + inferred-type (|case =input + (&/$VarT iid) + (|do [:let [=input* (&type/Bound$ (->> (count-univq =output) (* 2) (+ 1)))] + _ (&type/set-var iid =input*) + =output* (&type/clean $input =output) + =output** (&type/clean $output =output*)] + (return (&type/Univ$ (&/|list) (embed-inferred-input =input* =output**)))) + + _ + (|do [=output* (&type/clean $input =output) + =output** (&type/clean $output =output*)] + (return (embed-inferred-input =input =output**)))) + _ (&type/check exo-type inferred-type) + ] + (return (&/T lambda-analysis inferred-type))) + )))))) + + _ + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) + ;; (|do [$var &type/existential + ;; exo-type** (&type/apply-type exo-type* $var)] + ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + + (&/$LambdaT ?arg-t ?return-t) + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body))] + (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) + + + + _ + (fail (str "[Analyser Error] Functions require function types: " + (&type/show-type exo-type*))))) + )) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type @@ -330,35 +383,14 @@ exo-type* (&type/apply-type exo-type $var) [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] (return (&/T _expr exo-type))) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [exo-type* (&type/apply-type exo-type $var) - ;; [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - ;; (|case $var - ;; (&/$VarT ?id) - ;; (|do [? (&type/bound? ?id)] - ;; (if ? - ;; (|do [dtype (&type/deref ?id) - ;; ;; dtype* (&type/actual-type dtype) - ;; ] - ;; (|case dtype - ;; (&/$BoundT ?vname) - ;; (return (&/T _expr exo-type)) - - ;; (&/$ExT _) - ;; (return (&/T _expr exo-type)) - - ;; (&/$VarT ?_id) - ;; (|do [?? (&type/bound? ?_id)] - ;; ;; (return (&/T _expr exo-type)) - ;; (if ?? - ;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))) - ;; (return (&/T _expr exo-type))) - ;; ) - - ;; _ - ;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))))) - ;; (return (&/T _expr exo-type)))))))) + + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (analyse-lambda* analyse exo-type ?self ?arg ?body))) _ (|do [exo-type* (&type/actual-type exo-type)] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 0d0300844..d75f6afef 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -80,4 +80,7 @@ (&/$NamedT [?module ?name] ?type) (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) (->analysis ?type)))) + + _ + (assert false (&type/show-type type)) )) diff --git a/src/lux/type.clj b/src/lux/type.clj index 4672b18d4..3b7349fca 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -26,8 +26,8 @@ (def ^:private empty-env (&/V &/$Nil nil)) (defn Data$ [name] (&/V &/$DataT name)) -(defn Bound$ [name] - (&/V &/$BoundT name)) +(defn Bound$ [idx] + (&/V &/$BoundT idx)) (defn Var$ [id] (&/V &/$VarT id)) (defn Lambda$ [in out] @@ -986,3 +986,15 @@ _ (return false))) + +(defn resolve-type [type] + "(-> Type (Lux Type))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (if ? + (deref id) + (return type))) + + _ + (return type))) -- cgit v1.2.3 From c0613f6fb6d225c022c306ce70c8b18c0ec9cf71 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 10 Sep 2015 20:03:14 -0400 Subject: - Implemented inference for constructing records. --- src/lux/analyser.clj | 2 +- src/lux/analyser/base.clj | 9 ++- src/lux/analyser/case.clj | 4 +- src/lux/analyser/lux.clj | 146 ++++++++++++++++++++++++++--------------- src/lux/analyser/module.clj | 31 ++++----- src/lux/analyser/record.clj | 154 ++++++-------------------------------------- 6 files changed, 139 insertions(+), 207 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 9a57191f5..d17eeea2a 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -499,7 +499,7 @@ (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) - (&&lux/analyse-tuple analyse exo-type ?elems) + (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems) (&/$RecordS ?elems) (&&lux/analyse-record analyse exo-type ?elems) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 7f7980e76..e27b2e42e 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -130,15 +130,18 @@ (|let [[_ type] syntax+] type)) -(defn analyse-1 [analyse exo-type elem] - (|do [output (analyse exo-type elem)] - (|case output +(defn cap-1 [action] + (|do [result action] + (|case result (&/$Cons x (&/$Nil)) (return x) _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) +(defn analyse-1 [analyse exo-type elem] + (cap-1 (analyse exo-type elem))) + (defn analyse-1+ [analyse ?token] (&type/with-var (fn [$var] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f2afdb0e9..7226b98e4 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -178,8 +178,8 @@ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/T meta (&/V &/$TupleS ?members)) kont)) + (|do [[rec-members rec-type] (&&record/order-record pairs)] + (analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont)) (&/$TagS ?ident) (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 39eda451f..a6f41c9fd 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,35 +18,84 @@ [module :as &&module] [record :as &&record]))) +;; [Utils] +(defn ^:private count-univq [type] + "(-> Type Int)" + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +(defn ^:private next-bound-type [type] + "(-> Type Type)" + (&type/Bound$ (->> (count-univq type) (* 2) (+ 1)))) + +(defn ^:private embed-inferred-input [input output] + "(-> Type Type Type)" + (|case output + (&/$UnivQ env output*) + (&type/Univ$ env (embed-inferred-input input output*)) + + _ + (&type/Lambda$ input output))) + ;; [Exports] -(defn analyse-tuple [analyse exo-type ?elems] - (|do [unknown? (&type/unknown? exo-type)] - (if unknown? - (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] - (return =analysis)) - ?elems) - _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$TupleT ?members) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) - - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) +(defn analyse-tuple [analyse ?exo-type ?elems] + (|case ?exo-type + (&/$Left exo-type) + (|do [;; :let [_ (println 'analyse-tuple/$Left (&type/show-type exo-type))] + exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type tuple-type)] + _ (&type/set-var iid =var*) + tuple-type* (&type/clean $var tuple-type)] + (return (&type/Univ$ (&/|list) tuple-type*))) + + _ + (&type/clean $var tuple-type))] + (return (&/|list (&/T tuple-analysis inferred-type)))))) - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) - ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) - ))))) + _ + (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) + + (&/$Right exo-type) + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var) + [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] + (return (&/|list (&/T tuple-analysis exo-type)))) + + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + )))))) (defn with-attempt [m-value on-error] (fn [state] @@ -61,13 +110,13 @@ (|do [output (with-attempt (|case ?values (&/$Nil) - (analyse-tuple analyse exo-type (&/|list)) + (analyse-tuple analyse (&/V &/$Right exo-type) (&/|list)) (&/$Cons ?value (&/$Nil)) (analyse exo-type ?value) _ - (analyse-tuple analyse exo-type ?values)) + (analyse-tuple analyse (&/V &/$Right exo-type) ?values)) (fn [err] (fail (str err "\n" 'analyse-variant-body " " (&type/show-type exo-type) @@ -121,8 +170,19 @@ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - (|do [members (&&record/order-record ?elems)] - (analyse-tuple analyse exo-type members))) + (|do [[rec-members rec-type] (&&record/order-record ?elems)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + (|do [[tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) + _ (&type/check exo-type tuple-type)] + (return (&/|list (&/T tuple-analysis exo-type)))))) + + _ + (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + ))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -301,24 +361,6 @@ (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) -(defn ^:private count-univq [type] - "(-> Type Int)" - (|case type - (&/$UnivQ env type*) - (inc (count-univq type*)) - - _ - 0)) - -(defn ^:private embed-inferred-input [input output] - "(-> Type Type Type)" - (|case output - (&/$UnivQ env output*) - (&type/Univ$ env (embed-inferred-input input output*)) - - _ - (&type/Lambda$ input output))) - (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|case exo-type (&/$VarT id) @@ -336,7 +378,7 @@ =output (&type/resolve-type $output) inferred-type (|case =input (&/$VarT iid) - (|do [:let [=input* (&type/Bound$ (->> (count-univq =output) (* 2) (+ 1)))] + (|do [:let [=input* (next-bound-type =output)] _ (&type/set-var iid =input*) =output* (&type/clean $input =output) =output** (&type/clean $output =output*)] @@ -424,7 +466,9 @@ (do ;; (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - _ (println 'DEF (str module-name ";" ?name))]] + [def-analysis def-type] =value + _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) + )]] (return (&/|list))))) )))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 8c27fc08d..aaed26a7a 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -343,20 +343,17 @@ nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(defn tag-index [module tag-name] - "(-> Text Text (Lux Int))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] - (return* state (aget idx+tags 0)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - -(defn tag-group [module tag-name] - "(-> Text Text (Lux (List Ident)))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] - (return* state (aget idx+tags 1)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) +(do-template [ ] + (defn [module tag-name] + + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+type (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags+type )) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + + tag-index 0 "(-> Text Text (Lux Int))" + tag-group 1 "(-> Text Text (Lux (List Ident)))" + tag-type 2 "(-> Text Text (Lux Type))" + ) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 8b70bbcb4..0f860888b 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -6,139 +6,26 @@ (ns lux.analyser.record (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return fail |case]]) + (lux [base :as & :refer [deftags |let |do return fail |case]] + [type :as &type]) (lux.analyser [base :as &&] [module :as &&module]))) -;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) - ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" - (|do [tag-group (|case pairs - (&/$Nil) - (return (&/|list)) - - (&/$Cons [[_ (&/$TagS tag1)] _] _) - (|do [[module name] (&&/resolved-ident tag1)] - (&&module/tag-group module name)) - - _ - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + (|do [[tag-group tag-type] (|case pairs + (&/$Nil) + (return (&/T (&/|list) &type/Unit)) + + (&/$Cons [[_ (&/$TagS tag1)] _] _) + (|do [[module name] (&&/resolved-ident tag1) + tags (&&module/tag-group module name) + type (&&module/tag-type module name)] + (return (&/T tags type))) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv [[_ (&/$TagS k)] v] @@ -147,9 +34,10 @@ _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - pairs)] - (&/map% (fn [tag] - (if-let [member (&/|get tag =pairs)] - (return member) - (fail (str "[Analyser Error] Unknown tag: " tag)))) - (&/|map &/ident->text tag-group)))) + pairs) + =members (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (fail (str "[Analyser Error] Unknown tag: " tag)))) + (&/|map &/ident->text tag-group))] + (return (&/T =members tag-type)))) -- cgit v1.2.3 From d74df875db45cdbe67d7de2fbbf0c971cc570881 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 10 Sep 2015 23:44:25 -0400 Subject: - Added inference during construction of variants. --- src/lux/analyser.clj | 31 +++++++++----- src/lux/analyser/base.clj | 5 +++ src/lux/analyser/lux.clj | 106 +++++++++++++++++++++++++++++++--------------- 3 files changed, 98 insertions(+), 44 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index d17eeea2a..a9689a9d0 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -43,6 +43,23 @@ _ (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) +(defn analyse-variant+ [analyser exo-type ident values] + (|do [[module tag-name] (&/normalize ident) + idx (&&module/tag-index module tag-name)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if (or ? (&&/type-tag? module tag-name)) + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + (|do [wanted-type (&&module/tag-type module tag-name) + [variant-analysis variant-type] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) + _ (&type/check exo-type variant-type)] + (return (&/|list (&/T variant-analysis exo-type)))))) + + _ + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + ))) + (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays @@ -505,9 +522,7 @@ (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (|do [[module tag-name] (&/normalize ?ident) - idx (&&module/tag-index module tag-name)] - (&&lux/analyse-variant analyse exo-type idx (&/|list))) + (analyse-variant+ analyse exo-type ?ident (&/|list)) (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) @@ -573,16 +588,10 @@ (&/with-expected-type exo-type (|case token [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx ?values) [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + (analyse-variant+ (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) [meta (&/$FormS (&/$Cons ?fn ?args))] (fn [state] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index e27b2e42e..1507a3a76 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -156,3 +156,8 @@ &/get-module-name (return ?module))] (return (&/T module* ?name))))) + +(let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] + (defn type-tag? [module name] + (and (= "lux" module) + (contains? tag-names name)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index a6f41c9fd..b8239d1a9 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -133,41 +133,75 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) -(defn analyse-variant [analyse exo-type idx ?values] - (|do [exo-type* (|case exo-type - (&/$VarT ?id) - (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - (|do [_ (&type/set-var ?id &type/Type)] - (&type/actual-type &type/Type)))) - - _ - (&type/actual-type exo-type))] - (|case exo-type* - (&/$VariantT ?cases) - (|case (&/|at idx ?cases) - (&/$Some vtype) - (|do [=value (with-attempt - (analyse-variant-body analyse vtype ?values) - (fn [err] - (|do [_exo-type (&type/deref+ exo-type)] - (fail (str err "\n" - 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) - " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] - (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) - exo-type)))) +(defn analyse-variant [analyse ?exo-type idx ?values] + (|case ?exo-type + (&/$Left exo-type) + (|do [;; :let [_ (println 'analyse-variant/Left 0 (&type/show-type exo-type))] + exo-type* (&type/actual-type exo-type) + ;; :let [_ (println 'analyse-variant/Left 1 (&type/show-type exo-type*))] + ] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))] + [variant-analysis variant-type] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) + ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))] + =var (&type/resolve-type $var) + ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))] + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type variant-type)] + _ (&type/set-var iid =var*) + variant-type* (&type/clean $var variant-type)] + (return (&type/Univ$ (&/|list) variant-type*))) - (&/$None) - (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + _ + (&type/clean $var variant-type)) + ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))] + ] + (return (&/|list (&/T variant-analysis inferred-type)))))) - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** idx ?values)))) - - _ - (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) + _ + (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) + + (&/$Right exo-type) + ;; [_ exo-type] + (|do [;; :let [_ (println 'analyse-variant/Right 0 (&type/show-type exo-type))] + exo-type* (|case exo-type + (&/$VarT ?id) + (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + (|do [_ (&type/set-var ?id &type/Type)] + (&type/actual-type &type/Type)))) + + _ + (&type/actual-type exo-type))] + (|case exo-type* + (&/$VariantT ?cases) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (with-attempt + (analyse-variant-body analyse vtype ?values) + (fn [err] + (|do [_exo-type (&type/deref+ exo-type)] + (fail (str err "\n" + 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-variant analyse (&/V &/$Right exo-type**) idx ?values)) + + _ + (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))) (defn analyse-record [analyse exo-type ?elems] (|do [[rec-members rec-type] (&&record/order-record ?elems)] @@ -465,6 +499,12 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + ;; _ (if (and (= "lux" module-name) + ;; (= "Type" ?name)) + ;; (|do [newly-defined-Type + ;; :let [_ (&type/redefine-type! newly-defined-Type)]] + ;; (return nil)) + ;; (return nil)) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) [def-analysis def-type] =value _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) -- cgit v1.2.3 From 113143d5d2e86185a8fca5214cfa57b4456bfbbb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 11 Sep 2015 01:37:26 -0400 Subject: - Updated the standard library. --- source/lux.lux | 171 ++++++++--------------------------------- source/lux/codata/stream.lux | 2 +- source/lux/control/comonad.lux | 2 +- source/lux/data/bool.lux | 2 +- source/lux/data/list.lux | 160 ++++++++++++++++---------------------- source/lux/data/text.lux | 17 ++-- source/lux/host/io.lux | 22 +++--- source/lux/host/jvm.lux | 151 ++---------------------------------- source/lux/meta/ast.lux | 60 +++++++-------- source/lux/meta/lux.lux | 4 +- source/lux/meta/syntax.lux | 2 +- source/lux/meta/type.lux | 82 ++++++++++---------- 12 files changed, 198 insertions(+), 477 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index e2daeaf0e..f5cc8d3d1 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -663,10 +663,10 @@ (return tokens) (#Cons x (#Cons y xs)) - (return (#Cons (_meta (#FormS (#Cons (symbol$ ["lux" "$'"]) - (#Cons (_meta (#FormS (#Cons (tag$ ["lux" "AppT"]) - (#Cons x (#Cons y #Nil))))) - xs)))) + (return (#Cons (form$ (#Cons (symbol$ ["lux" "$'"]) + (#Cons (form$ (#Cons (tag$ ["lux" "AppT"]) + (#Cons x (#Cons y #Nil)))) + xs))) #Nil)) _ @@ -1056,7 +1056,7 @@ (#Cons [token tokens']) (_meta (#FormS (@list (_meta (#TagS ["lux" "Cons"])) token (untemplate-list tokens')))))) -(def''' #export (list:++ xs ys) +(def''' (list:++ xs ys) (All [a] (-> ($' List a) ($' List a) ($' List a))) (_lux_case xs (#Cons x xs') @@ -1065,6 +1065,15 @@ #Nil ys)) +(def''' #export (splice-helper xs ys) + (-> ($' List AST) ($' List AST) ($' List AST)) + (_lux_case xs + (#Cons x xs') + (#Cons x (splice-helper xs' ys)) + + #Nil + ys)) + (defmacro' #export ($ tokens) (_lux_case tokens (#Cons op (#Cons init args)) @@ -1264,7 +1273,7 @@ elems))] (wrap (wrap-meta (form$ (@list tag (form$ (@list& (symbol$ ["lux" "$"]) - (symbol$ ["lux" "list:++"]) + (symbol$ ["lux" "splice-helper"]) elems'))))))) false @@ -1494,9 +1503,6 @@ [i= _jvm_leq Int] [i> _jvm_lgt Int] [i< _jvm_llt Int] - [r= _jvm_deq Real] - [r> _jvm_dgt Real] - [r< _jvm_dlt Real] ) (do-template [ ] @@ -1508,8 +1514,6 @@ [i>= i> i= Int] [i<= i< i= Int] - [r>= r> r= Real] - [r<= r< r= Real] ) (do-template [ ] @@ -1522,11 +1526,6 @@ [i* _jvm_lmul Int] [i/ _jvm_ldiv Int] [i% _jvm_lrem Int] - [r+ _jvm_dadd Real] - [r- _jvm_dsub Real] - [r* _jvm_dmul Real] - [r/ _jvm_ddiv Real] - [r% _jvm_drem Real] ) (def''' (multiple? div n) @@ -1927,48 +1926,6 @@ #None (fail "Wrong syntax for def'")))) -(def' (ast:show ast) - (-> AST Text) - (_lux_case ast - [_ ast] - (_lux_case ast - (#BoolS val) - (->text val) - - (#IntS val) - (->text val) - - (#RealS val) - (->text val) - - (#CharS val) - ($ text:++ "#\"" (->text val) "\"") - - (#TextS val) - ($ text:++ "\"" (->text val) "\"") - - (#FormS parts) - ($ text:++ "(" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) ")") - - (#TupleS parts) - ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]") - - (#SymbolS prefix name) - ($ text:++ prefix ";" name) - - (#TagS prefix name) - ($ text:++ "#" prefix ";" name) - - (#RecordS kvs) - ($ text:++ "{" - (|> kvs - (map (: (-> (, AST AST) Text) - (lambda' [kv] (let' [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v)))))) - (interpose " ") - (foldL text:++ "")) - "}") - ))) - (def' (rejoin-pair pair) (-> (, AST AST) (List AST)) (let' [[left right] pair] @@ -2274,60 +2231,6 @@ (#Cons (substring2 0 idx module) (split-module (substring1 (i+ 1 idx) module)))))) -(def (split-slot slot) - (-> Text (, Text Text)) - (let [idx (index-of ";" slot) - module (substring2 0 idx slot) - name (substring1 (i+ 1 idx) slot)] - [module name])) - -(def (type:show type) - (-> Type Text) - (case type - (#DataT name) - ($ text:++ "(^ " name ")") - - (#TupleT members) - (case members - #;Nil - "(,)" - - _ - ($ text:++ "(, " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) - - (#VariantT members) - (case members - #;Nil - "(|)" - - _ - ($ text:++ "(| " (|> members (map type:show) (interpose " ") (foldL text:++ "")) ")")) - - (#LambdaT input output) - ($ text:++ "(-> " (type:show input) " " (type:show output) ")") - - (#VarT id) - ($ text:++ "⌈" (->text id) "⌋") - - (#BoundT idx) - (->text idx) - - (#ExT ?id) - ($ text:++ "⟨" (->text ?id) "⟩") - - (#AppT ?lambda ?param) - ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - - (#UnivQ ?env ?body) - ($ text:++ "(All " (type:show ?body) ")") - - (#ExQ ?env ?body) - ($ text:++ "(Ex " (type:show ?body) ")") - - (#NamedT name type) - (ident->text name) - )) - (def (@ idx xs) (All [a] (-> Int (List a) (Maybe a))) @@ -2527,7 +2430,7 @@ (fail (text:++ "Unknown structure member: " tag-name))) _ - (fail (text:++ "Invalid structure member: " (ast:show token)))))) + (fail "Invalid structure member.")))) (list:join tokens'))] (wrap (@list (record$ members))))) @@ -2833,20 +2736,6 @@ closure)))) envs))) -(def (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (map (lambda [env] - (case env - {#name name #inner-closures _ #locals {#counter _ #mappings locals} #closure _} - ($ text:++ name ": " (|> locals - (map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (interpose " ") - (foldL text:++ "")))))) - (interpose "\n") - (foldL text:++ ""))) - (def (find-in-defs name state) (-> Ident Compiler (Maybe Type)) (let [[v-prefix v-name] name @@ -2891,7 +2780,7 @@ #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] - (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) + (#Left ($ text:++ "Unknown var: " (ident->text ident)))))) (case (find-in-defs ident state) (#Some struct-type) (#Right state struct-type) @@ -2901,7 +2790,7 @@ #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] - (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) + (#Left ($ text:++ "Unknown var: " (ident->text ident)))))) ))) (def (zip2 xs ys) @@ -3300,20 +3189,20 @@ [every? true and]) -(def (type->syntax type) +(def (type->ast type) (-> Type AST) (case type (#DataT name) (` (#DataT (~ (text$ name)))) (#;VariantT cases) - (` (#VariantT (~ (untemplate-list (map type->syntax cases))))) + (` (#VariantT (~ (untemplate-list (map type->ast cases))))) (#TupleT parts) - (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) + (` (#TupleT (~ (untemplate-list (map type->ast parts))))) (#LambdaT in out) - (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) + (` (#LambdaT (~ (type->ast in)) (~ (type->ast out)))) (#BoundT idx) (` (#BoundT (~ (int$ idx)))) @@ -3325,18 +3214,18 @@ (` (#ExT (~ (int$ id)))) (#UnivQ env type) - (let [env' (untemplate-list (map type->syntax env))] - (` (#UnivQ (~ env') (~ (type->syntax type))))) + (let [env' (untemplate-list (map type->ast env))] + (` (#UnivQ (~ env') (~ (type->ast type))))) (#ExQ env type) - (let [env' (untemplate-list (map type->syntax env))] - (` (#ExQ (~ env') (~ (type->syntax type))))) + (let [env' (untemplate-list (map type->ast env))] + (` (#ExQ (~ env') (~ (type->ast type))))) (#AppT fun arg) - (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) + (` (#AppT (~ (type->ast fun)) (~ (type->ast arg)))) (#NamedT [module name] type) - (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type)))))) + (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->ast type)))))) (defmacro #export (loop tokens) (case tokens @@ -3352,8 +3241,8 @@ #None (fail "Wrong syntax for loop"))) init-types (map% Lux/Monad find-var-type inits') expected expected-type] - (return (@list (` ((: (-> (~@ (map type->syntax init-types)) - (~ (type->syntax expected))) + (return (@list (` ((: (-> (~@ (map type->ast init-types)) + (~ (type->ast expected))) (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] (~ body))) (~@ inits)))))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index e2464248c..96de64fd4 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -105,7 +105,7 @@ (def #export (partition p xs) (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) - [(filter p xs) (filter (complement p) xs)]) + [(filter p xs) (filter (comp p) xs)]) ## [Structures] (defstruct #export Stream/Functor (Functor Stream) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index 32e7c64c1..7ea3b58a9 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -5,7 +5,7 @@ (;import lux (../functor #as F) - lux/data/list) + (lux/data/list #refer #all #open ("" List/Fold))) ## [Signatures] (defsig #export (CoMonad w) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index defaee22e..a3e28733b 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -31,6 +31,6 @@ ) ## [Functions] -(def #export complement +(def #export comp (All [a] (-> (-> a Bool) (-> a Bool))) (. not)) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 8a7f97698..54f8fed4c 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -10,8 +10,11 @@ (eq #as E) (ord #as O) (fold #as f)) - (data (number (int #open ("i" Int/Number Int/Ord))) - bool))) + (data (number (int #open ("i:" Int/Number Int/Ord Int/Show))) + bool + (text #open ("text:" Text/Monoid)) + tuple) + codata/function)) ## [Types] ## (deftype (List a) @@ -19,26 +22,6 @@ ## (#Cons (, a (List a))))) ## [Functions] -(def #export (foldL f init xs) - (All [a b] - (-> (-> a b a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (foldL f (f init x) xs'))) - -(def #export (foldR f init xs) - (All [a b] - (-> (-> b a a) a (List b) a)) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (f x (foldR f init xs')))) - (defstruct #export List/Fold (f;Fold List) (def (foldL f init xs) (case xs @@ -56,6 +39,8 @@ (#;Cons [x xs']) (f x (foldR f init xs'))))) +(open List/Fold) + (def #export (fold mon xs) (All [a] (-> (m;Monoid a) (List a) a)) @@ -83,7 +68,7 @@ (def #export (partition p xs) (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) - [(filter p xs) (filter (complement p) xs)]) + [(filter p xs) (filter (comp p) xs)]) (def #export (as-pairs xs) (All [a] (-> (List a) (List (, a a)))) @@ -98,7 +83,7 @@ [(def #export ( n xs) (All [a] (-> Int (List a) (List a))) - (if (i> n 0) + (if (i:> n 0) (case xs #;Nil #;Nil @@ -107,8 +92,8 @@ ) ))] - [take (#;Cons [x (take (i+ -1 n) xs')]) #;Nil] - [drop (drop (i+ -1 n) xs') xs] + [take (#;Cons [x (take (i:+ -1 n) xs')]) #;Nil] + [drop (drop (i:+ -1 n) xs') xs] ) (do-template [ ] @@ -131,13 +116,13 @@ (def #export (split n xs) (All [a] (-> Int (List a) (, (List a) (List a)))) - (if (i> n 0) + (if (i:> n 0) (case xs #;Nil [#;Nil #;Nil] (#;Cons [x xs']) - (let [[tail rest] (split (i+ -1 n) xs')] + (let [[tail rest] (split (i:+ -1 n) xs')] [(#;Cons [x tail]) rest])) [#;Nil xs])) @@ -162,8 +147,8 @@ (def #export (repeat n x) (All [a] (-> Int a (List a))) - (if (i> n 0) - (#;Cons [x (repeat (i+ -1 n) x)]) + (if (i:> n 0) + (#;Cons [x (repeat (i:+ -1 n) x)]) #;Nil)) (def #export (iterate f x) @@ -206,7 +191,7 @@ (def #export (size list) (-> List Int) - (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + (foldL (lambda [acc _] (i:+ 1 acc)) 0 list)) (do-template [ ] [(def #export ( p xs) @@ -225,9 +210,9 @@ #;None (#;Cons [x xs']) - (if (i= 0 i) + (if (i:= 0 i) (#;Some x) - (@ (i+ -1 i) xs')))) + (@ (i:+ -1 i) xs')))) ## [Syntax] (defmacro #export (@list xs state) @@ -248,68 +233,6 @@ _ (#;Left "Wrong syntax for @list&"))) -## (defmacro #export (zip tokens state) -## (if (i> (size tokens) 0) -## (using List/Functor -## (let [indices (range 0 (i+ 1 (size tokens))) -## vars+lists (map (lambda [idx] -## (let [base (text:++ "_" idx)] -## [[["" -1 -1] (#SymbolS "" base)] -## [["" -1 -1] (#SymbolS "" (text:++ base "s"))]])) -## indices) -## pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) -## vars+lists))]) -## g!step [["" -1 -1] (#SymbolS "" "\tstep\t")] -## g!arg [["" -1 -1] (#SymbolS "" "\targ\t")] -## g!blank [["" -1 -1] (#SymbolS "" "\t_\t")] -## code (` ((lambda (~ g!step) [(~ g!arg)] -## (case (~ g!arg) -## (~ pattern) -## (#;Cons [(~@ vars)] ((~ g!step) [(~ (map second vars))])) - -## (~ g!blank) -## #;Nil)) -## [(~@ tokens)]))] -## (#;Right state (@list code)))) -## (#;Left "Can't zip no lists."))) - -## (defmacro #export (zip-with tokens state) -## (case tokens -## (@list& _f tokens) -## (case _f -## [_ (#;SymbolS _)] -## (if (i> (size tokens) 0) -## (using List/Functor -## (let [indices (range 0 (i+ 1 (size tokens))) -## vars+lists (map (lambda [idx] -## (let [base (text:++ "_" idx)] -## [[["" -1 -1] (#SymbolS "" base)] -## [["" -1 -1] (#SymbolS "" (text:++ base "s"))]])) -## indices) -## pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) -## vars+lists))]) -## g!step [["" -1 -1] (#SymbolS "" "\tstep\t")] -## g!arg [["" -1 -1] (#SymbolS "" "\targ\t")] -## g!blank [["" -1 -1] (#SymbolS "" "\t_\t")] -## code (` ((lambda (~ g!step) [(~ g!arg)] -## (case (~ g!arg) -## (~ pattern) -## (#;Cons ((~ _f) (~@ vars)) ((~ g!step) [(~ (map second vars))])) - -## (~ g!blank) -## #;Nil)) -## [(~@ tokens)]))] -## (#;Right state (@list code)))) -## (#;Left "Can't zip-with no lists.")) - -## _ -## (let [g!temp [["" -1 -1] (#SymbolS "" "\ttemp\t")]] -## (#;Right state (@list (` (let [(~ g!temp) (~ _f)] -## (;;zip-with (~@ (@list& g!temp tokens))))))))) - -## _ -## (#;Left "Wrong syntax for zip-with"))) - ## [Structures] (defstruct #export (List/Eq eq) (All [a] (-> (E;Eq a) (E;Eq (List a)))) @@ -363,3 +286,50 @@ post (filter (< x) xs') ++ (:: List/Monoid m;++)] ($ ++ (sort ord pre) (@list x) (sort ord post)))))) + +## [Syntax] +(def (symbol$ name) + (-> Text AST) + [["" -1 -1] (#;SymbolS "" name)]) + +(def (range from to) + (-> Int Int (List Int)) + (if (i:<= from to) + (@list& from (range (i:+ 1 from) to)) + (@list))) + +(defmacro #export (zip tokens state) + (case tokens + (\ (@list [_ (#;IntS num-lists)])) + (if (i:> num-lists 0) + (using List/Functor + (let [indices (range 0 (i:- num-lists 1)) + type-vars (: (List AST) (map (. symbol$ i:show) indices)) + zip-type (` (All [(~@ type-vars)] + (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) + type-vars)) + (List (, (~@ type-vars)))))) + vars+lists (map (lambda [idx] + (let [base (text:++ "_" (i:show idx))] + [(symbol$ base) + (symbol$ (text:++ base "s"))])) + indices) + pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (symbol$ "\tstep\t") + g!blank (symbol$ "\t_\t") + list-vars (map second vars+lists) + code (` (: (~ zip-type) + (lambda (~ g!step) [(~@ list-vars)] + (case [(~@ list-vars)] + (~ pattern) + (#;Cons [(~@ (map first vars+lists))] + ((~ g!step) (~@ list-vars))) + + (~ g!blank) + #;Nil))))] + (#;Right [state (@list code)]))) + (#;Left "Can't zip no lists.")) + + _ + (#;Left "Wrong syntax for zip"))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 6c3a3dfee..bbcb42d71 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -10,8 +10,7 @@ (show #as S) (monad #as M #refer #all)) (data (number (int #open ("i" Int/Number Int/Ord))) - maybe - (list #refer (#only foldL @list @list&))))) + maybe))) ## [Functions] (def #export (size x) @@ -164,18 +163,20 @@ (-> Text (List AST)) (case (extract-var template) (#;Some [pre var post]) - (@list& (text$ pre) (symbol$ ["" var]) - (unravel-template post)) + (#;Cons (text$ pre) + (#;Cons (symbol$ ["" var]) + (unravel-template post))) #;None - (@list (text$ template)))) + (#;Cons (text$ template) #;Nil))) (defmacro #export (<> tokens state) (case tokens - (\ (@list [_ (#;TextS template)])) + (#;Cons [_ (#;TextS template)] #;Nil) (let [++ (symbol$ ["" ""])] - (#;Right state (@list (` (;let [(~ ++) (;:: Text/Monoid m;++)] - (;$ (~ ++) (~@ (unravel-template template)))))))) + (#;Right state (#;Cons (` (;let [(~ ++) (;:: Text/Monoid m;++)] + (;$ (~ ++) (~@ (unravel-template template))))) + #;Nil))) _ (#;Left "Wrong syntax for <>"))) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux index 7611e41b7..7c017a62e 100644 --- a/source/lux/host/io.lux +++ b/source/lux/host/io.lux @@ -11,25 +11,25 @@ (do-template [ ] [(def #export ( x) (-> (IO (,))) - (@io (.! ( [] [x]) - (..? out java.lang.System))))] + (@io (_jvm_invokevirtual "java.io.PrintStream" [] + (_jvm_getstatic "java.lang.System" "out") [x])))] - [write-char print Char char] - [write print Text java.lang.String] - [write-line println Text java.lang.String]) + [write-char "print" Char "char"] + [write "print" Text "java.lang.String"] + [write-line "println" Text "java.lang.String"]) (do-template [ ] [(def #export (IO (Maybe )) - (let [in (..? in java.lang.System) - reader (new java.io.InputStreamReader [java.io.InputStream] [in]) - buff-reader (new java.io.BufferedReader [java.io.Reader] [reader])] + (let [in (_jvm_getstatic "java.lang.System" "in") + reader (_jvm_new "java.io.InputStreamReader" ["java.io.InputStream"] [in]) + buff-reader (_jvm_new "java.io.BufferedReader" ["java.io.Reader"] [reader])] (@io (let [output (: (Either Text ) (try$ ))] - (exec (.! (close [] []) buff-reader) + (exec (_jvm_invokeinterface "java.io.Closeable" "close" [] buff-reader []) (case output (#;Left _) #;None (#;Right input) (#;Some input)))))))] - [read-char Char (_jvm_i2c (.! (read [] []) buff-reader))] - [read-line Text (.! (readLine [] []) buff-reader)] + [read-char Char (_jvm_i2c (_jvm_invokevirtual "java.io.BufferedReader" "read" [] buff-reader []))] + [read-line Text (_jvm_invokevirtual "java.io.BufferedReader" "readLine" [] buff-reader [])] ) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index eddedfdc5..6f121a633 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -9,29 +9,13 @@ (monad #as M #refer (#only do))) (data (list #as l #refer #all #open ("" List/Functor)) (text #as text) - (number (int #open ("i" Int/Eq)))) + number/int) (meta lux ast syntax))) ## [Utils] ## Parsers -(def finally^ - (Parser AST) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "finally"]) - expr id^] - (wrap expr)))) - -(def catch^ - (Parser (, Text Ident AST)) - (form^ (do Parser/Monad - [_ (symbol?^ ["" "catch"]) - ex-class local-symbol^ - ex symbol^ - expr id^] - (wrap [ex-class ex expr])))) - (def method-decl^ (Parser (, (List Text) Text (List Text) Text)) (form^ (do Parser/Monad @@ -66,38 +50,7 @@ body id^] (wrap [modifiers name inputs output body])))) -(def method-call^ - (Parser (, Text (List Text) (List AST))) - (form^ (do Parser/Monad - [method local-symbol^ - arity-classes (tuple^ (*^ local-symbol^)) - arity-args (tuple^ (*^ id^)) - _ (: (Parser (,)) - (if (i= (size arity-classes) - (size arity-args)) - (wrap []) - (lambda [_] #;None)))] - (wrap [method arity-classes arity-args]) - ))) - ## [Syntax] -(defsyntax #export (throw ex) - (emit (@list (` (;_jvm_throw (~ ex)))))) - -(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) - (emit (@list (` (;_jvm_try (~ body) - (~@ (:: List/Monoid (m;++ (map (: (-> (, Text Ident AST) AST) - (lambda [catch] - (let [[class ex body] catch] - (` (;_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) - catches) - (case finally - #;None - (@list) - - (#;Some finally) - (: (List AST) (@list (` (;_jvm_finally (~ finally)))))))))))))) - (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) (lambda [member] @@ -138,113 +91,19 @@ [(~@ fields')] [(~@ methods')])))))) -(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) - (emit (@list (` (;_jvm_new (~ (text$ class)) - [(~@ (map text$ arg-classes))] - [(~@ args)]))))) - -(defsyntax #export (instance? [class local-symbol^] obj) - (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) - -(defsyntax #export (locking lock body) - (do Lux/Monad - [g!lock (gensym "") - g!body (gensym "") - g!_ (gensym "")] - (emit (@list (` (let [(~ g!lock) (~ lock) - (~ g!_) (;_jvm_monitorenter (~ g!lock)) - (~ g!body) (~ body) - (~ g!_) (;_jvm_monitorexit (~ g!lock))] - (~ g!body))))) - )) - -(defsyntax #export (null? obj) - (emit (@list (` (;_jvm_null? (~ obj)))))) - (defsyntax #export (program [args symbol^] body) (emit (@list (` (;_jvm_program (~ (symbol$ args)) (~ body)))))) -(defsyntax #export (.? [field local-symbol^] obj) - (case obj - [_ (#;SymbolS obj-name)] - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (@list (` (;_jvm_getfield (~ (text$ class)) (~ (text$ field)))))) - - _ - (fail "Can only get field from object."))) - - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (@list (` (let [(~ g!obj) (~ obj)] - (;;.? (~ (text$ field)) (~ g!obj))))))))) - -(defsyntax #export (.= [field local-symbol^] value obj) - (case obj - [_ (#;SymbolS obj-name)] - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (@list (` (;_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ value))))) - - _ - (fail "Can only set field of object."))) - - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (@list (` (let [(~ g!obj) (~ obj)] - (;;.= (~ (text$ field)) (~ value) (~ g!obj))))))))) - -(defsyntax #export (.! [call method-call^] obj) - (let [[m-name ?m-classes m-args] call] - (case obj - [_ (#;SymbolS obj-name)] - (do Lux/Monad - [obj-type (find-var-type obj-name)] - (case obj-type - (#;DataT class) - (emit (@list (` (;_jvm_invokevirtual (~ (text$ class)) (~ (text$ m-name)) [(~@ (map text$ ?m-classes))] - (~ obj) [(~@ m-args)])))) - - _ - (fail "Can only call method on object."))) - - _ - (do Lux/Monad - [g!obj (gensym "")] - (emit (@list (` (let [(~ g!obj) (~ obj)] - (;;.! ((~ (symbol$ ["" m-name])) - [(~@ (map (lambda [c] (symbol$ ["" c])) ?m-classes))] - [(~@ m-args)]) - (~ g!obj)))))))))) - -(defsyntax #export (..? [field local-symbol^] [class local-symbol^]) - (emit (@list (` (;_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) - -(defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) - (emit (@list (` (;_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) - -(defsyntax #export (..! [call method-call^] [class local-symbol^]) - (let [[m-name m-classes m-args] call] - (emit (@list (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ m-name)) - [(~@ (map text$ m-classes))] - [(~@ m-args)])))))) - (defsyntax #export (->maybe expr) (do Lux/Monad [g!val (gensym "")] (emit (@list (` (let [(~ g!val) (~ expr)] - (if (null? (~ g!val)) + (if (;_jvm_null? (~ g!val)) #;None (#;Some (~ g!val))))))))) (defsyntax #export (try$ expr) - (emit (@list (` (try (#;Right (~ expr)) - (~ (' (catch java.lang.Exception e - (#;Left (_jvm_invokevirtual "java.lang.Throwable" "getMessage" [] e [])))))))))) + (emit (@list (` (;_jvm_try (#;Right (~ expr)) + (~ (' (_jvm_catch "java.lang.Exception" e + (#;Left (_jvm_invokevirtual "java.lang.Throwable" "getMessage" [] e [])))))))))) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index 8d649cf4a..398acf6cc 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -12,7 +12,7 @@ char (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid)) ident - (list #refer #all #open ("" List/Functor)) + (list #refer #all #open ("" List/Functor List/Fold)) ))) ## [Types] @@ -79,35 +79,35 @@ ($ text:++ "{" (|> pairs (map (lambda [[left right]] ($ text:++ (show left) " " (show right)))) (interpose "") (foldL text:++ text:unit)) "}") ))) -## (defstruct #export AST/Eq (Eq AST) -## (def (= x y) -## (case [x y] -## (\template [ ] -## [[[_ ( x')] [_ ( y')]] -## (:: (E;= x' y'))]) -## [[#;BoolS Bool/Eq] -## [#;IntS Int/Eq] -## [#;RealS Real/Eq] -## [#;CharS Char/Eq] -## [#;TextS Text/Eq] -## [#;SymbolS Ident/Eq] -## [#;TagS Ident/Eq]] +(defstruct #export AST/Eq (Eq AST) + (def (= x y) + (case [x y] + (\template [ ] + [[[_ ( x')] [_ ( y')]] + (:: (E;= x' y'))]) + [[#;BoolS Bool/Eq] + [#;IntS Int/Eq] + [#;RealS Real/Eq] + [#;CharS Char/Eq] + [#;TextS Text/Eq] + [#;SymbolS Ident/Eq] + [#;TagS Ident/Eq]] -## (\template [] -## [[[_ ( xs')] [_ ( ys')]] -## (and (:: Int/Eq (E;= (size xs') (size ys'))) -## (foldL (lambda [old [x' y']] -## (and old (= x' y'))) -## true -## (zip2 xs' ys')))]) -## [[#;FormS] [#;TupleS]] + (\template [] + [[[_ ( xs')] [_ ( ys')]] + (and (:: Int/Eq (E;= (size xs') (size ys'))) + (foldL (lambda [old [x' y']] + (and old (= x' y'))) + true + ((zip 2) xs' ys')))]) + [[#;FormS] [#;TupleS]] -## [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] -## (and (:: Int/Eq (E;= (size xs') (size ys'))) -## (foldL (lambda [old [[xl' xr'] [yl' yr']]] -## (and old (= xl' yl') (= xr' yr'))) -## true -## (zip2 xs' ys'))) + [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] + (and (:: Int/Eq (E;= (size xs') (size ys'))) + (foldL (lambda [old [[xl' xr'] [yl' yr']]] + (and old (= xl' yl') (= xr' yr'))) + true + ((zip 2) xs' ys'))) -## _ -## false))) + _ + false))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index edf3a8667..66f1a554b 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -9,7 +9,7 @@ (functor #as F) (monad #as M #refer (#only do)) (show #as S)) - (lux/data list + (lux/data (list #refer #all #open ("list:" List/Monoid)) (text #as T #open ("text:" Text/Monoid Text/Eq)) (number/int #as I #open ("i" Int/Number)))) @@ -65,7 +65,7 @@ #;Nil #;None - (#;Cons [[k' v] plist']) + (#;Cons [k' v] plist') (if (text:= k k') (#;Some v) (get k plist')))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 4ee3163b0..5425a2d9c 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -12,7 +12,7 @@ (data (bool #as b) (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) - list + (list #refer #all #open ("" List/Fold)) (number (int #open ("i" Int/Eq)) (real #open ("r" Real/Eq)))))) diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux index d32ea993b..4147e37d4 100644 --- a/source/lux/meta/type.lux +++ b/source/lux/meta/type.lux @@ -13,6 +13,8 @@ (list #refer #all #open ("list:" List/Monad))) )) +(open List/Fold) + ## [Structures] (defstruct #export Type/Show (Show Type) (def (show type) @@ -61,46 +63,46 @@ ($ text:++ module ";" name) ))) -## (defstruct #export Type/Eq (Eq Type) -## (def (= x y) -## (case [x y] -## [(#;DataT xname) (#;DataT yname)] -## (text:= xname yname) - -## (\or [(#;VarT xid) (#;VarT yid)] -## [(#;ExT xid) (#;ExT yid)] -## [(#;BoundT xid) (#;BoundT yid)]) -## (int:= xid yid) - -## (\or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)] -## [(#;AppT xleft xright) (#;AppT yleft yright)]) -## (and (= xleft yleft) -## (= xright yright)) - -## [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)] -## (and (text:= xmodule ymodule) -## (text:= xname yname) -## (= xtype ytype)) - -## (\or [(#;TupleT xmembers) (#;TupleT ymembers)] -## [(#;VariantT xmembers) (#;VariantT ymembers)]) -## (and (int:= (size xmembers) (size ymembers)) -## (foldL (lambda [prev [x y]] -## (and prev (= v y))) -## true -## (zip2 xmembers ymembers))) - -## (\or [(#;UnivQ yenv ybody) (#;UnivQ yenv ybody)] -## [(#;ExQ yenv ybody) (#;ExQ yenv ybody)]) -## (and (int:= (size xenv) (size yenv)) -## (foldL (lambda [prev [x y]] -## (and prev (= v y))) -## (= xbody ybody) -## (zip2 xenv yenv))) - -## _ -## false -## ))) +(defstruct #export Type/Eq (Eq Type) + (def (= x y) + (case [x y] + [(#;DataT xname) (#;DataT yname)] + (text:= xname yname) + + (\or [(#;VarT xid) (#;VarT yid)] + [(#;ExT xid) (#;ExT yid)] + [(#;BoundT xid) (#;BoundT yid)]) + (int:= xid yid) + + (\or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)] + [(#;AppT xleft xright) (#;AppT yleft yright)]) + (and (= xleft yleft) + (= xright yright)) + + [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)] + (and (text:= xmodule ymodule) + (text:= xname yname) + (= xtype ytype)) + + (\or [(#;TupleT xmembers) (#;TupleT ymembers)] + [(#;VariantT xmembers) (#;VariantT ymembers)]) + (and (int:= (size xmembers) (size ymembers)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + true + ((zip 2) xmembers ymembers))) + + (\or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)] + [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) + (and (int:= (size xenv) (size yenv)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + (= xbody ybody) + ((zip 2) xenv yenv))) + + _ + false + ))) ## [Functions] (def #export (beta-reduce env type) -- cgit v1.2.3 From 5a26c40dc215dfb22a77cad28455deff28ca9976 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 11 Sep 2015 19:46:30 -0400 Subject: - Implemented the with-open macro. - Cleaned-up a bit the tag-generation macro "deftags". --- source/lux/host/io.lux | 31 +++++- source/lux/host/jvm.lux | 4 +- src/lux/analyser/base.clj | 226 ++++++++++++++++++++++---------------------- src/lux/analyser/case.clj | 36 +++---- src/lux/analyser/module.clj | 13 +-- src/lux/base.clj | 127 +++++++++++++------------ src/lux/lexer.clj | 32 +++---- src/lux/reader.clj | 8 +- 8 files changed, 251 insertions(+), 226 deletions(-) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux index 7c017a62e..4542b0519 100644 --- a/source/lux/host/io.lux +++ b/source/lux/host/io.lux @@ -4,7 +4,12 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - lux/data/io + (lux (data io + (list #refer #all #open ("" List/Fold))) + (meta ast + syntax + lux) + control/monad) (.. jvm)) ## [Functions] @@ -16,7 +21,8 @@ [write-char "print" Char "char"] [write "print" Text "java.lang.String"] - [write-line "println" Text "java.lang.String"]) + [write-line "println" Text "java.lang.String"] + ) (do-template [ ] [(def #export @@ -24,7 +30,7 @@ (let [in (_jvm_getstatic "java.lang.System" "in") reader (_jvm_new "java.io.InputStreamReader" ["java.io.InputStream"] [in]) buff-reader (_jvm_new "java.io.BufferedReader" ["java.io.Reader"] [reader])] - (@io (let [output (: (Either Text ) (try$ ))] + (@io (let [output (: (Either Text ) (try ))] (exec (_jvm_invokeinterface "java.io.Closeable" "close" [] buff-reader []) (case output (#;Left _) #;None @@ -33,3 +39,22 @@ [read-char Char (_jvm_i2c (_jvm_invokevirtual "java.io.BufferedReader" "read" [] buff-reader []))] [read-line Text (_jvm_invokevirtual "java.io.BufferedReader" "readLine" [] buff-reader [])] ) + +## [Syntax] +(def simple-bindings^ + (Parser (List (, Text AST))) + (tuple^ (*^ (&^ local-symbol^ id^)))) + +(defsyntax #export (with-open [bindings simple-bindings^] body) + (do Lux/Monad + [g!output (gensym "output") + #let [code (foldL (: (-> AST (, Text AST) AST) + (lambda [body [res-name res-value]] + (let [g!res-name (symbol$ ["" res-name])] + (` (let [(~ g!res-name) (~ res-value) + (~ g!output) (~ body)] + (exec (;_jvm_invokeinterface "java.io.Closeable" "close" [] (~ g!res-name) []) + (~ g!output))))))) + body + (reverse bindings))]] + (wrap (@list code)))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 6f121a633..c1e122bb6 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -95,7 +95,7 @@ (emit (@list (` (;_jvm_program (~ (symbol$ args)) (~ body)))))) -(defsyntax #export (->maybe expr) +(defsyntax #export (??? expr) (do Lux/Monad [g!val (gensym "")] (emit (@list (` (let [(~ g!val) (~ expr)] @@ -103,7 +103,7 @@ #;None (#;Some (~ g!val))))))))) -(defsyntax #export (try$ expr) +(defsyntax #export (try expr) (emit (@list (` (;_jvm_try (#;Right (~ expr)) (~ (' (_jvm_catch "java.lang.Exception" e (#;Left (_jvm_invokevirtual "java.lang.Throwable" "getMessage" [] e [])))))))))) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 1507a3a76..0bb40c71b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -10,120 +10,118 @@ [type :as &type]))) ;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) +(deftags + ["bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr"]) ;; [Exports] (defn expr-type* [syntax+] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 7226b98e4..a0f07cdce 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -15,26 +15,26 @@ [record :as &&record]))) ;; [Tags] -(deftags "" - "DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "TupleTotal" - "VariantTotal" +(deftags + ["DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "VariantTotal"] ) -(deftags "" - "StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "TupleTestAC" - "VariantTestAC" +(deftags + ["StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "VariantTestAC"] ) ;; [Utils] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index aaed26a7a..6740d6515 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -14,12 +14,13 @@ [host :as &host]))) ;; [Utils] -(deftags "" - "module-aliases" - "defs" - "imports" - "tags" - "types") +(deftags + ["module-aliases" + "defs" + "imports" + "tags" + "types"]) + (def ^:private +init+ (&/T ;; "lux;module-aliases" (&/|table) diff --git a/src/lux/base.clj b/src/lux/base.clj index 4db1d26bc..c0f28f519 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -9,93 +9,94 @@ clojure.core.match.array)) ;; [Tags] -(defmacro deftags [prefix & names] +(defmacro deftags [names] + (assert (vector? names)) `(do ~@(for [[name idx] (map vector names (range (count names)))] `(def ~(symbol (str "$" name)) ~idx)))) ;; List -(deftags "" - "Nil" - "Cons") +(deftags + ["Nil" + "Cons"]) ;; Maybe -(deftags "" - "None" - "Some") +(deftags + ["None" + "Some"]) ;; Either -(deftags "" - "Left" - "Right") +(deftags + ["Left" + "Right"]) ;; AST -(deftags "" - "BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS") +(deftags + ["BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS"]) ;; Type -(deftags "" - "DataT" - "VariantT" - "TupleT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "UnivQ" - "ExQ" - "AppT" - "NamedT") +(deftags + ["DataT" + "VariantT" + "TupleT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "UnivQ" + "ExQ" + "AppT" + "NamedT"]) ;; Vars -(deftags "lux;" - "Local" - "Global") +(deftags + ["Local" + "Global"]) ;; Definitions -(deftags "lux;" - "ValueD" - "TypeD" - "MacroD" - "AliasD") +(deftags + ["ValueD" + "TypeD" + "MacroD" + "AliasD"]) ;; Binding -(deftags "" - "counter" - "mappings") +(deftags + ["counter" + "mappings"]) ;; Env -(deftags "" - "name" - "inner-closures" - "locals" - "closure") +(deftags + ["name" + "inner-closures" + "locals" + "closure"]) ;; Host -(deftags "" - "writer" - "loader" - "classes") +(deftags + ["writer" + "loader" + "classes"]) ;; Compiler -(deftags "" - "source" - "cursor" - "modules" - "envs" - "type-vars" - "expected" - "seed" - "eval?" - "host") +(deftags + ["source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host"]) ;; [Exports] (def datum-field "_datum") diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index b3a47f3e0..fd694c51c 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -10,22 +10,22 @@ [lux.analyser.module :as &module])) ;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] ) ;; [Utils] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 7b1559f07..751df7e6d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,10 +10,10 @@ [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) ;; [Tags] -(deftags "" - "No" - "Done" - "Yes") +(deftags + ["No" + "Done" + "Yes"]) ;; [Utils] (defn ^:private with-line [body] -- cgit v1.2.3 From 5148900e02c8e05808afc8a3ec7fc51a901bcc7b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 11 Sep 2015 22:16:58 -0400 Subject: - Abandoned the old format for classes of having module names separated by underscores, and now using slashes and putting submodules inside the directories of their parent modules. --- src/lux/analyser/module.clj | 2 +- src/lux/compiler.clj | 2 +- src/lux/compiler/base.clj | 8 ++++---- src/lux/compiler/cache.clj | 17 ++++++++--------- src/lux/compiler/package.clj | 18 +++++++++++++----- src/lux/host.clj | 13 ++++++++----- 6 files changed, 35 insertions(+), 25 deletions(-) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 6740d6515..97365ba08 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -204,7 +204,7 @@ [exported? (&/$ValueD ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) + :let [macro (-> (.loadClass loader (str (&host/->class-name module) "." (&/normalize-name name))) (.getField &/datum-field) (.get nil))]] (fn [state*] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index e16a84b20..da9896bd5 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -392,7 +392,7 @@ .visitEnd))] _ (&&/save-class! (str id) bytecode) loader &/loader] - (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id)) + (-> (.loadClass ^ClassLoader loader (str (&host/->class-name module) "." id)) (.getField &/eval-field) (.get nil) return)))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index edb1441ca..7c1297aad 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -26,8 +26,8 @@ ;; [Constants] (def ^String version "0.3") (def ^String input-dir "source") -(def ^String output-dir "target/jvm") -(def ^String output-package (str output-dir "/program.jar")) +(def ^String output-dir "target/jvm/") +(def ^String output-package (str output-dir "program.jar")) (def ^String function-class "lux/Function") ;; Formats @@ -55,7 +55,7 @@ (defn ^:private write-output [module name data] (let [module* (&host/->module-class module) - module-dir (str output-dir "/" module*)] + module-dir (str output-dir module*)] (.mkdirs (File. module-dir)) (write-file (str module-dir "/" name ".class") data))) @@ -69,7 +69,7 @@ module &/get-module-name loader &/loader !classes &/classes - :let [real-name (str (&host/->module-class module) "." name) + :let [real-name (str (&host/->class-name module) "." name) _ (swap! !classes assoc real-name bytecode) _ (when (not eval?) (write-output module name bytecode)) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index da7ce35e9..e47da2678 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -32,11 +32,9 @@ (defn ^:private clean-file [^File file] "(-> File (,))" - (if (.isDirectory file) - (do (doseq [f (seq (.listFiles file))] - (clean-file f)) - (.delete file)) - (.delete file))) + (doseq [f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) (defn ^:private get-field [^String field-name ^Class class] "(-> Text Class Object)" @@ -45,12 +43,12 @@ ;; [Resources] (defn cached? [module] "(-> Text Bool)" - (.exists (new File (str &&/output-dir "/" (&host/->module-class module) "/_.class")))) + (.exists (new File (str &&/output-dir (&host/->module-class module) "/" &/module-class-name ".class")))) (defn delete [module] "(-> Text (Lux (,)))" (fn [state] - (do (clean-file (new File (str &&/output-dir "/" (&host/->module-class module)))) + (do (clean-file (new File (str &&/output-dir (&host/->module-class module)))) (return* state nil)))) (defn clean [state] @@ -80,8 +78,8 @@ (return true) (if (cached? module) (do ;; (prn 'load/HASH module module-hash) - (let [module* (&host/->module-class module) - module-path (str &&/output-dir "/" module*) + (let [module* (&host/->class-name module) + module-path (str &&/output-dir module) class-name (str module* "._") ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) (&&/load-class! loader class-name))] @@ -98,6 +96,7 @@ (&/->list imports)))] (if (->> loads &/->seq (every? true?)) (do (doseq [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) :let [file-name (.getName file)] :when (not= "_.class" file-name)] (let [real-name (second (re-find #"^(.*)\.class$" file-name)) diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj index b1468e540..4f703f5d1 100644 --- a/src/lux/compiler/package.clj +++ b/src/lux/compiler/package.clj @@ -30,6 +30,7 @@ (defn ^:private write-class! [^String path ^File file ^JarOutputStream out] "(-> Text File JarOutputStream Unit)" + ;; (prn 'write-class! path file) (with-open [in (new BufferedInputStream (new FileInputStream file))] (let [buffer (byte-array (* 10 kilobyte))] (doto out @@ -42,11 +43,18 @@ )) )) -(defn ^:private write-module! [^File file ^JarOutputStream out] - "(-> File JarOutputStream Unit)" - (let [module-name (.getName file)] - (doseq [$class (.listFiles file)] - (write-class! module-name $class out)))) +(let [output-dir-size (.length &&/output-dir)] + (defn ^:private write-module! [^File file ^JarOutputStream out] + "(-> File JarOutputStream Unit)" + (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file) + ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size)) + inner-files (.listFiles file) + inner-modules (filter #(.isDirectory %) inner-files) + inner-classes (filter #(not (.isDirectory %)) inner-files)] + (doseq [$class inner-classes] + (write-class! module-name $class out)) + (doseq [$module inner-modules] + (write-module! $module out))))) ;; [Resources] (defn package [module] diff --git a/src/lux/host.clj b/src/lux/host.clj index 3d61eec6a..2290f2f0a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -10,12 +10,15 @@ clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) - (:import (java.lang.reflect Field Method Modifier))) + (:import (java.lang.reflect Field Method Modifier) + java.util.regex.Pattern)) ;; [Constants] (def prefix "lux.") (def function-class (str prefix "Function")) -(def module-separator "_") +(def module-separator "/") +(def class-name-separator ".") +(def class-separator "/") ;; [Utils] (defn ^:private class->type [^Class class] @@ -35,13 +38,13 @@ ;; [Resources] (defn ^String ->class [class] - (string/replace class #"\." "/")) + (string/replace class (-> class-name-separator Pattern/quote re-pattern) class-separator)) (defn ^String ->class-name [module] - (string/replace module #"/" ".")) + (string/replace module (-> module-separator Pattern/quote re-pattern) class-name-separator)) (defn ^String ->module-class [module-name] - (string/replace module-name #"/" module-separator)) + (string/replace module-name (-> module-separator Pattern/quote re-pattern) class-separator)) (def ->package ->module-class) -- cgit v1.2.3 From 5fd179352bbf25bbe4000ae51132fd5553ba256a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 15:06:14 -0400 Subject: - Primitive data-types can now be parameterized by other types. --- source/lux.lux | 43 ++++++------ source/lux/data/list.lux | 3 + source/lux/meta/ast.lux | 4 +- source/lux/meta/type.lux | 24 +++++-- src/lux/analyser/host.clj | 48 +++++++------- src/lux/analyser/lux.clj | 12 ++-- src/lux/compiler/host.clj | 18 ++--- src/lux/compiler/type.clj | 62 ++++++++---------- src/lux/host.clj | 7 +- src/lux/type.clj | 164 +++++++++++++++++++++------------------------- 10 files changed, 190 insertions(+), 195 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index f5cc8d3d1..39cbb7765 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -9,23 +9,23 @@ ## Basic types (_lux_def Bool (10 ["lux" "Bool"] - (0 "java.lang.Boolean"))) + (0 "java.lang.Boolean" (0)))) (_lux_export Bool) (_lux_def Int (10 ["lux" "Int"] - (0 "java.lang.Long"))) + (0 "java.lang.Long" (0)))) (_lux_export Int) (_lux_def Real (10 ["lux" "Real"] - (0 "java.lang.Double"))) + (0 "java.lang.Double" (0)))) (_lux_export Real) (_lux_def Char (10 ["lux" "Char"] - (0 "java.lang.Character"))) + (0 "java.lang.Character" (0)))) (_lux_export Char) (_lux_def Text (10 ["lux" "Text"] - (0 "java.lang.String"))) + (0 "java.lang.String" (0)))) (_lux_export Text) (_lux_def Unit (10 ["lux" "Unit"] @@ -71,7 +71,7 @@ (_lux_declare-tags [#None #Some] Maybe) ## (deftype #rec Type -## (| (#DataT Text) +## (| (#DataT (, Text (List Type))) ## (#VariantT (List Type)) ## (#TupleT (List Type)) ## (#LambdaT Type Type) @@ -90,7 +90,7 @@ TypeList (9 (7 (0) (1 (1 ## "lux;DataT" - Text + (2 (1 Text (1 TypeList (0)))) (1 ## "lux;VariantT" TypeList (1 ## "lux;TupleT" @@ -279,11 +279,11 @@ (_lux_def Host (#NamedT ["lux" "Host"] (#TupleT (#Cons [## "lux;writer" - (#DataT "org.objectweb.asm.ClassWriter") + (#DataT "org.objectweb.asm.ClassWriter" #Nil) (#Cons [## "lux;loader" - (#DataT "java.lang.ClassLoader") + (#DataT "java.lang.ClassLoader" #Nil) (#Cons [## "lux;classes" - (#DataT "clojure.lang.Atom") + (#DataT "clojure.lang.Atom" #Nil) #Nil])])])))) (_lux_declare-tags [#writer #loader #classes] Host) @@ -912,14 +912,6 @@ _ (fail "Wrong syntax for @list&"))) -(defmacro' #export (^ tokens) - (_lux_case tokens - (#Cons [_ (#SymbolS "" class-name)] #Nil) - (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name))))) - - _ - (fail "Wrong syntax for ^"))) - (defmacro' #export (, tokens) (return (@list (form$ (@list (tag$ ["lux" "TupleT"]) (foldL (lambda'' [tail head] (form$ (@list (tag$ ["lux" "Cons"]) head tail))) @@ -1352,6 +1344,17 @@ (wrap (wrap-meta (form$ (@list (tag$ ["lux" "RecordS"]) (untemplate-list =fields)))))) )) +(defmacro' #export (^ tokens) + (_lux_case tokens + (#Cons [_ (#SymbolS "" class-name)] #Nil) + (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (tag$ ["lux" "Nil"]))))) + + (#Cons [_ (#SymbolS "" class-name)] params) + (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name) (untemplate-list params))))) + + _ + (fail "Wrong syntax for ^"))) + (def'' (get-module-name state) ($' Lux Text) (_lux_case state @@ -3192,8 +3195,8 @@ (def (type->ast type) (-> Type AST) (case type - (#DataT name) - (` (#DataT (~ (text$ name)))) + (#DataT name params) + (` (#DataT (~ (text$ name)) (~ (untemplate-list (map type->ast params))))) (#;VariantT cases) (` (#VariantT (~ (untemplate-list (map type->ast cases))))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 54f8fed4c..e538007bf 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -333,3 +333,6 @@ _ (#;Left "Wrong syntax for zip"))) + +(def #export zip2 (zip 2)) +(def #export zip3 (zip 3)) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index 398acf6cc..6d9271847 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -99,7 +99,7 @@ (foldL (lambda [old [x' y']] (and old (= x' y'))) true - ((zip 2) xs' ys')))]) + (zip2 xs' ys')))]) [[#;FormS] [#;TupleS]] [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] @@ -107,7 +107,7 @@ (foldL (lambda [old [[xl' xr'] [yl' yr']]] (and old (= xl' yl') (= xr' yr'))) true - ((zip 2) xs' ys'))) + (zip2 xs' ys'))) _ false))) diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux index 4147e37d4..a1c34b1ac 100644 --- a/source/lux/meta/type.lux +++ b/source/lux/meta/type.lux @@ -10,7 +10,7 @@ (data (text #open ("text:" Text/Monoid Text/Eq)) (number/int #open ("int:" Int/Eq Int/Show)) maybe - (list #refer #all #open ("list:" List/Monad))) + (list #refer #all #open ("list:" List/Monad List/Fold))) )) (open List/Fold) @@ -19,8 +19,13 @@ (defstruct #export Type/Show (Show Type) (def (show type) (case type - (#;DataT name) - ($ text:++ "(^ " name ")") + (#;DataT name params) + (case params + #;Nil + ($ text:++ "(^ " name ")") + + _ + ($ text:++ "(^ " name " " (|> params (list:map show) (interpose " ") (list:foldL text:++ "")) ")")) (#;TupleT members) (case members @@ -66,8 +71,13 @@ (defstruct #export Type/Eq (Eq Type) (def (= x y) (case [x y] - [(#;DataT xname) (#;DataT yname)] - (text:= xname yname) + [(#;DataT xname xparams) (#;DataT yname yparams)] + (and (text:= xname yname) + (int:= (size xparams) (size yparams)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + true + (zip2 xparams yparams))) (\or [(#;VarT xid) (#;VarT yid)] [(#;ExT xid) (#;ExT yid)] @@ -90,7 +100,7 @@ (foldL (lambda [prev [x y]] (and prev (= x y))) true - ((zip 2) xmembers ymembers))) + (zip2 xmembers ymembers))) (\or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)] [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) @@ -98,7 +108,7 @@ (foldL (lambda [prev [x y]] (and prev (= x y))) (= xbody ybody) - ((zip 2) xenv yenv))) + (zip2 xenv yenv))) _ false diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9a05a6695..610f3c660 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -34,7 +34,7 @@ (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" (|case token - [_ (&/$DataT _)] + [_ (&/$DataT _ _)] (return nil) _ @@ -43,8 +43,8 @@ (defn ^:private as-object [type] "(-> Type Type)" (|case type - (&/$DataT class) - (&/V &/$DataT (&type/as-obj class)) + (&/$DataT class params) + (&type/Data$ (&type/as-obj class) params) _ type)) @@ -66,16 +66,16 @@ (defn ^:private as-otype+ [type] "(-> Type Type)" (|case type - (&/$DataT tname) - (&/V &/$DataT (as-otype tname)) + (&/$DataT name params) + (&type/Data$ (as-otype name) params) _ type)) ;; [Resources] (do-template [ ] - (let [input-type (&/V &/$DataT ) - output-type (&/V &/$DataT )] + (let [input-type (&type/Data$ (&/|list)) + output-type (&type/Data$ (&/|list))] (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) @@ -160,10 +160,10 @@ =classes (&/map% extract-text ?classes) =return (&host/lookup-static-method class-loader ?class ?method =classes) ;; :let [_ (matchv ::M/objects [=return] - ;; [[&/$DataT _return-class]] + ;; [[&/$DataT _return-class (&/|list)]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) + (&&/analyse-1 analyse (&type/Data$ _class (&/|list)) _arg)) =classes ?args) :let [output-type =return] @@ -182,8 +182,8 @@ (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + =object (&&/analyse-1 analyse (&type/Data$ ?class (&/|list)) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c (&/|list)) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] @@ -199,9 +199,9 @@ =return (if (= "" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =object (&&/analyse-1 analyse (&type/Data$ ?class (&/|list)) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + (&&/analyse-1 analyse (&type/Data$ ?c (&/|list)) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] @@ -215,19 +215,19 @@ (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V &/$DataT "null")] + (|do [:let [output-type (&type/Data$ "null" (&/|list))] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&/V &/$DataT ?class)] + :let [output-type (&type/Data$ ?class (&/|list))] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) + (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&type/Data$ ?class (&/|list)) (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] @@ -313,11 +313,11 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&/V &/$DataT (as-otype itype)) + (&&env/with-local iname (&type/Data$ (as-otype itype) (&/|list)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) (&/|list)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs (&/Cons$ (&/T ";this" ?super-class) @@ -360,7 +360,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class (&/|list)) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) @@ -374,7 +374,7 @@ (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] + _ (&type/check (&type/Data$ "java.lang.Throwable" (&/|list)) _type)] (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] @@ -390,9 +390,9 @@ ) (do-template [ ] - (let [output-type (&/V &/$DataT )] + (let [output-type (&type/Data$ (&/|list))] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ (&/|list)) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -417,9 +417,9 @@ ) (do-template [ ] - (let [output-type (&/V &/$DataT )] + (let [output-type (&type/Data$ (&/|list))] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ (&/|list)) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index b8239d1a9..6205adccb 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -364,7 +364,7 @@ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] - ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; :let [_ (when (or (= "zip" (aget real-name 1)) ;; ;; (= "..?" (aget real-name 1)) ;; ;; (= "try$" (aget real-name 1)) ;; ) @@ -431,13 +431,9 @@ (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) - ;; (|do [$var &type/existential - ;; exo-type** (&type/apply-type exo-type* $var)] - ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)) (&/$LambdaT ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 0529ac900..db54af8ac 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,31 +52,31 @@ (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) - (&/$DataT "boolean") + (&/$DataT "boolean" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - (&/$DataT "byte") + (&/$DataT "byte" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - (&/$DataT "short") + (&/$DataT "short" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - (&/$DataT "int") + (&/$DataT "int" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - (&/$DataT "long") + (&/$DataT "long" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - (&/$DataT "float") + (&/$DataT "float" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - (&/$DataT "double") + (&/$DataT "double" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - (&/$DataT "char") + (&/$DataT "char" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - (&/$DataT _) + (&/$DataT _ (&/$Nil)) nil (&/$NamedT ?name ?type) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index d75f6afef..6c128df80 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -39,48 +39,44 @@ "(-> Analysis Analysis Analysis)" (variant$ &/$Cons (tuple$ (&/|list head tail)))) +(defn ^:private List$ [elems] + (&/fold (fn [tail head] + (Cons$ head tail)) + $Nil + (&/|reverse elems))) + ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" (|case type - (&/$DataT ?class) - (variant$ &/$DataT (text$ ?class)) + (&/$DataT class params) + (variant$ &/$DataT (tuple$ (&/|list (text$ class) + (List$ (&/|map ->analysis params))))) - (&/$TupleT ?members) - (variant$ &/$TupleT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) - - (&/$VariantT ?members) - (variant$ &/$VariantT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) - - (&/$LambdaT ?input ?output) - (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - - (&/$UnivQ ?env ?body) + (&/$TupleT members) + (variant$ &/$TupleT (List$ (&/|map ->analysis members))) + + (&/$VariantT members) + (variant$ &/$VariantT (List$ (&/|map ->analysis members))) + + (&/$LambdaT input output) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis input) (->analysis output)))) + + (&/$UnivQ env body) (variant$ &/$UnivQ - (tuple$ (&/|list (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?env)) - (->analysis ?body)))) + (tuple$ (&/|list (List$ (&/|map ->analysis env)) + (->analysis body)))) - (&/$BoundT ?idx) - (variant$ &/$BoundT (int$ ?idx)) + (&/$BoundT idx) + (variant$ &/$BoundT (int$ idx)) - (&/$AppT ?fun ?arg) - (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (&/$AppT fun arg) + (variant$ &/$AppT (tuple$ (&/|list (->analysis fun) (->analysis arg)))) - (&/$NamedT [?module ?name] ?type) - (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) - (->analysis ?type)))) + (&/$NamedT [module name] type*) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name))) + (->analysis type*)))) _ - (assert false (&type/show-type type)) + (assert false (prn '->analysis (&type/show-type type) (&/adt->text type))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 2290f2f0a..0936d90eb 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,8 +29,9 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) + (return (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base) + (&/|list))) ))) (defn ^:private method->type [^Method method] @@ -70,7 +71,7 @@ (defn ->java-sig [^objects type] "(-> Type Text)" (|case type - (&/$DataT ?name) + (&/$DataT ?name params) (->type-signature ?name) (&/$LambdaT _ _) diff --git a/src/lux/type.clj b/src/lux/type.clj index 3b7349fca..0da579cf4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -24,8 +24,8 @@ false)) (def ^:private empty-env (&/V &/$Nil nil)) -(defn Data$ [name] - (&/V &/$DataT name)) +(defn Data$ [name params] + (&/V &/$DataT (&/T name params))) (defn Bound$ [idx] (&/V &/$BoundT idx)) (defn Var$ [id] @@ -46,13 +46,13 @@ (&/V &/$NamedT (&/T name type))) -(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) -(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) -(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) -(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) -(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) -(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) -(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) +(def Bool (Named$ (&/T "lux" "Bool") (Data$ "java.lang.Boolean" (&/|list)))) +(def Int (Named$ (&/T "lux" "Int") (Data$ "java.lang.Long" (&/|list)))) +(def Real (Named$ (&/T "lux" "Real") (Data$ "java.lang.Double" (&/|list)))) +(def Char (Named$ (&/T "lux" "Char") (Data$ "java.lang.Character" (&/|list)))) +(def Text (Named$ (&/T "lux" "Text") (Data$ "java.lang.String" (&/|list)))) +(def Unit (Named$ (&/T "lux" "Unit") (Tuple$ (&/|list)))) +(def $Void (Named$ (&/T "lux" "Void") (Variant$ (&/|list)))) (def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO @@ -90,7 +90,7 @@ (App$ (Univ$ empty-env (Variant$ (&/|list ;; DataT - Text + (Tuple$ (&/|list Text TypeList)) ;; VariantT TypeList ;; TupleT @@ -221,11 +221,11 @@ (Tuple$ (&/|list ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") + (Data$ "org.objectweb.asm.ClassWriter" (&/|list)) ;; "lux;loader" - (Data$ "java.lang.ClassLoader") + (Data$ "java.lang.ClassLoader" (&/|list)) ;; "lux;classes" - (Data$ "clojure.lang.Atom"))))) + (Data$ "clojure.lang.Atom" (&/|list)))))) (def DefData* (Univ$ empty-env @@ -405,9 +405,7 @@ )))) (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$type-vars #(->> % - ;; (&/update$ &/$counter dec) - (&/set$ &/$mappings (&/|remove id mappings*))) + (return* (&/update$ &/$type-vars #(&/set$ &/$mappings (&/|remove id mappings*) %) state) nil))) state)))) @@ -418,12 +416,6 @@ _ (delete-var id)] (return output))) -(defn with-vars [amount k] - (|do [=vars (&/map% (constantly create-var) (&/|range amount)) - output (k (&/|map #(Var$ %) =vars)) - _ (&/map% delete-var (&/|reverse =vars))] - (return output))) - (defn clean* [?tid type] (|case type (&/$VarT ?id) @@ -486,8 +478,13 @@ (defn show-type [^objects type] (|case type - (&/$DataT name) - (str "(^ " name ")") + (&/$DataT name params) + (|case params + (&/$Nil) + (str "(^ " name ")") + + _ + (str "(^ " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) (&/$TupleT elems) (if (&/|empty? elems) @@ -535,8 +532,10 @@ (and (= ?xmodule ?ymodule) (= ?xname ?yname)) - [(&/$DataT xname) (&/$DataT yname)] - (.equals ^Object xname yname) + [(&/$DataT xname xparams) (&/$DataT yname yparams)] + (and (.equals ^Object xname yname) + (= (&/|length xparams) (&/|length yparams)) + (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) [(&/$TupleT xelems) (&/$TupleT yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) @@ -677,7 +676,7 @@ (def ^:private init-fixpoints (&/|list)) -(defn ^:private check* [class-loader fixpoints expected actual] +(defn ^:private check* [class-loader fixpoints invariant?? expected actual] (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) (|case [expected actual] @@ -704,13 +703,13 @@ (return (&/T fixpoints nil))) [(&/$Some etype) (&/$None _)] - (check* class-loader fixpoints etype actual) + (check* class-loader fixpoints invariant?? etype actual) [(&/$None _) (&/$Some atype)] - (check* class-loader fixpoints expected atype) + (check* class-loader fixpoints invariant?? expected atype) [(&/$Some etype) (&/$Some atype)] - (check* class-loader fixpoints etype atype)))) + (check* class-loader fixpoints invariant?? etype atype)))) [(&/$VarT ?id) _] (fn [state] @@ -720,7 +719,7 @@ (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints bound actual)) + (check* class-loader fixpoints invariant?? bound actual)) state))) [_ (&/$VarT ?id)] @@ -731,12 +730,12 @@ (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints expected bound)) + (check* class-loader fixpoints invariant?? expected bound)) state))) [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] (if (= eid aid) - (check* class-loader fixpoints eA aA) + (check* class-loader fixpoints invariant?? eA aA) (fail (check-error expected actual))) ;; [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] @@ -744,13 +743,13 @@ ;; (|case ((|do [F1 (deref ?eid)] ;; (fn [state] ;; (|case ((|do [F2 (deref ?aid)] - ;; (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + ;; (check* class-loader fixpoints invariant?? (App$ F1 A1) (App$ F2 A2))) ;; state) ;; (&/$Right state* output) ;; (return* state* output) ;; (&/$Left _) - ;; ((check* class-loader fixpoints (App$ F1 A1) actual) + ;; ((check* class-loader fixpoints invariant?? (App$ F1 A1) actual) ;; state)))) ;; state) ;; (&/$Right state* output) @@ -758,70 +757,70 @@ ;; (&/$Left _) ;; (|case ((|do [F2 (deref ?aid)] - ;; (check* class-loader fixpoints expected (App$ F2 A2))) + ;; (check* class-loader fixpoints invariant?? expected (App$ F2 A2))) ;; state) ;; (&/$Right state* output) ;; (return* state* output) ;; (&/$Left _) - ;; ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) - ;; [fixpoints** _] (check* class-loader fixpoints* A1 A2)] + ;; ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid)) + ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? A1 A2)] ;; (return (&/T fixpoints** nil))) ;; state)))) - ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) - ;; _ (check* class-loader fixpoints A1 A2)] + ;; (|do [_ (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid)) + ;; _ (check* class-loader fixpoints invariant?? A1 A2)] ;; (return (&/T fixpoints nil))) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints (App$ F1 A1) actual)) + (check* class-loader fixpoints invariant?? (App$ F1 A1) actual)) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) - [fixpoints** _] (check* class-loader fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] + ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] ;; (return (&/T fixpoints** nil))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (App$ F2 A2))) + (check* class-loader fixpoints invariant?? expected (App$ F2 A2))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) - [fixpoints** _] (check* class-loader fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] + ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] ;; (return (&/T fixpoints** nil))) ;; [(&/$AppT eF eA) (&/$AppT aF aA)] - ;; (|do [_ (check* class-loader fixpoints eF aF)] - ;; (check* class-loader fixpoints eA aA)) + ;; (|do [_ (check* class-loader fixpoints invariant?? eF aF)] + ;; (check* class-loader fixpoints invariant?? eA aA)) [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) @@ -842,44 +841,51 @@ (&/$None) (|do [expected* (apply-type F A)] - (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) + (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) [_ (&/$AppT F A)] (|do [actual* (apply-type F A)] - (check* class-loader fixpoints expected actual*)) + (check* class-loader fixpoints invariant?? expected actual*)) [(&/$UnivQ _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] - (check* class-loader fixpoints expected* actual)))) + (check* class-loader fixpoints invariant?? expected* actual)))) [_ (&/$UnivQ _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] - (check* class-loader fixpoints expected actual*)))) + (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name) (&/$DataT "null")] + [(&/$DataT e!name e!params) (&/$DataT "null" (&/$Nil))] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) - [(&/$DataT e!name) (&/$DataT a!name)] + [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] - (if (or (.equals ^Object e!name a!name) - (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) + (cond (and (.equals ^Object e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] + (return (&/T fixpoints nil))) + + (and (not invariant??) + (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) + (return (&/T fixpoints nil)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] - (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] - (check* class-loader fixpoints* eO aO)) + (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] + (check* class-loader fixpoints* invariant?? eO aO)) [(&/$TupleT e!members) (&/$TupleT a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] + (|do [[fp* _] (check* class-loader fp invariant?? e a)] (return fp*))) fixpoints e!members a!members)] @@ -887,7 +893,7 @@ [(&/$VariantT e!cases) (&/$VariantT a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] + (|do [[fp* _] (check* class-loader fp invariant?? e a)] (return fp*))) fixpoints e!cases a!cases)] @@ -899,10 +905,10 @@ (fail (check-error expected actual))) [(&/$NamedT ?ename ?etype) _] - (check* class-loader fixpoints ?etype actual) + (check* class-loader fixpoints invariant?? ?etype actual) [_ (&/$NamedT ?aname ?atype)] - (check* class-loader fixpoints expected ?atype) + (check* class-loader fixpoints invariant?? expected ?atype) [_ _] (fail (check-error expected actual)) @@ -910,29 +916,9 @@ (defn check [expected actual] (|do [class-loader &/loader - _ (check* class-loader init-fixpoints expected actual)] + _ (check* class-loader init-fixpoints false expected actual)] (return nil))) -(defn apply-lambda [func param] - (|case func - (&/$LambdaT input output) - (|do [_ (check* init-fixpoints input param)] - (return output)) - - (&/$UnivQ _) - (with-var - (fn [$var] - (|do [func* (apply-type func $var) - =return (apply-lambda func* param)] - (clean $var =return)))) - - (&/$NamedT ?name ?type) - (apply-lambda ?type param) - - _ - (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) - )) - (defn actual-type [type] "(-> Type (Lux Type))" (|case type -- cgit v1.2.3 From 3c1e63b8ea119601f6ba2c9eb709877c76683a8c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 17:28:30 -0400 Subject: - Added full support for arrays. --- source/lux/host/jvm.lux | 14 +++++-- src/lux/analyser.clj | 97 +++++++++++++++++++++++++++++++++++++++-------- src/lux/analyser/base.clj | 33 ++++++++++++++-- src/lux/analyser/host.clj | 64 +++++++++++++++++++++++++------ src/lux/compiler.clj | 87 +++++++++++++++++++++++++++++++++++++++--- src/lux/compiler/base.clj | 37 ++++++++---------- src/lux/compiler/host.clj | 59 +++++++++++++++++++++++++--- 7 files changed, 325 insertions(+), 66 deletions(-) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index c1e122bb6..ba29925a7 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -7,9 +7,9 @@ (lux (control (monoid #as m) (functor #as F) (monad #as M #refer (#only do))) - (data (list #as l #refer #all #open ("" List/Functor)) - (text #as text) - number/int) + (data (list #refer #all #open ("" List/Functor List/Fold)) + (number/int #refer #all #open ("i:" Int/Ord)) + maybe) (meta lux ast syntax))) @@ -107,3 +107,11 @@ (emit (@list (` (;_jvm_try (#;Right (~ expr)) (~ (' (_jvm_catch "java.lang.Exception" e (#;Left (_jvm_invokevirtual "java.lang.Throwable" "getMessage" [] e [])))))))))) + +(defsyntax #export (Array [dimensions (?^ int^)] type) + (let [dimensions (? 1 dimensions)] + (if (i:> dimensions 0) + (emit (@list (foldL (lambda [inner _] (` (#;DataT "Array" (@list (~ inner))))) + type + (repeat dimensions [])))) + (fail "Array must have positive dimension.")))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index a9689a9d0..bd0957bdf 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -63,24 +63,89 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] - (&/$Cons [_ (&/$SymbolS _ ?class)] - (&/$Cons [_ (&/$IntS ?length)] - (&/$Nil))))) - (&&host/analyse-jvm-new-array analyse ?class ?length) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil)))) + (&&host/analyse-jvm-znewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-zastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] - (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] - (&/$Cons ?elem - (&/$Nil)))))) - (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-zaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] - (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] - (&/$Nil))))) - (&&host/analyse-jvm-aaload analyse ?array ?idx) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-bnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-bastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-baload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-snewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-sastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-saload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-inewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-iastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-iaload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-lnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-lastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-laload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-fnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-fastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-faload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-dnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-dastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-daload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-cnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-castore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-caload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-anewarray analyse ?class ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil))))))) + (&&host/analyse-jvm-aastore analyse ?class ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil)))))) + (&&host/analyse-jvm-aaload analyse ?class ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) + (&&host/analyse-jvm-arraylength analyse ?array) ;; Classes & interfaces (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 0bb40c71b..8df7f23b2 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -39,9 +39,6 @@ "jvm-null?" "jvm-null" "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" "jvm-class" "jvm-interface" "jvm-try" @@ -50,6 +47,36 @@ "jvm-monitorexit" "jvm-program" + + "jvm-znewarray" + "jvm-zastore" + "jvm-zaload" + "jvm-bnewarray" + "jvm-bastore" + "jvm-baload" + "jvm-snewarray" + "jvm-sastore" + "jvm-saload" + "jvm-inewarray" + "jvm-iastore" + "jvm-iaload" + "jvm-lnewarray" + "jvm-lastore" + "jvm-laload" + "jvm-fnewarray" + "jvm-fastore" + "jvm-faload" + "jvm-dnewarray" + "jvm-dastore" + "jvm-daload" + "jvm-cnewarray" + "jvm-castore" + "jvm-caload" + "jvm-anewarray" + "jvm-aastore" + "jvm-aaload" + "jvm-arraylength" + "jvm-iadd" "jvm-isub" "jvm-imul" diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 610f3c660..4fbd67fdb 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -226,18 +226,58 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) -(defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&type/Data$ ?class (&/|list)) - (&/V &/$Nil nil))))))) - -(defn analyse-jvm-aastore [analyse ?array ?idx ?elem] - (|do [=array (analyse-1+ analyse ?array) - =elem (analyse-1+ analyse ?elem)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) (&&/expr-type* =array)))))) - -(defn analyse-jvm-aaload [analyse ?array ?idx] - (|do [=array (analyse-1+ analyse ?array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) (&&/expr-type* =array)))))) +(do-template [ ] + (let [elem-type (&type/Data$ (&/|list)) + array-type (&type/Data$ "Array" (&/|list elem-type))] + (defn [analyse length] + (return (&/|list (&/T (&/V length) array-type)))) + + (defn [analyse array idx] + (|do [=array (&&/analyse-1 analyse array-type array)] + (return (&/|list (&/T (&/V (&/T =array idx)) elem-type))))) + + (defn [analyse array idx elem] + (|do [=array (&&/analyse-1 analyse array-type array) + =elem (&&/analyse-1 analyse elem-type elem)] + (return (&/|list (&/T (&/V (&/T =array idx =elem)) array-type))))) + ) + + "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore + "java.lang.Byte" analyse-jvm-bnewarray &&/$jvm-bnewarray analyse-jvm-baload &&/$jvm-baload analyse-jvm-bastore &&/$jvm-bastore + "java.lang.Short" analyse-jvm-snewarray &&/$jvm-snewarray analyse-jvm-saload &&/$jvm-saload analyse-jvm-sastore &&/$jvm-sastore + "java.lang.Integer" analyse-jvm-inewarray &&/$jvm-inewarray analyse-jvm-iaload &&/$jvm-iaload analyse-jvm-iastore &&/$jvm-iastore + "java.lang.Long" analyse-jvm-lnewarray &&/$jvm-lnewarray analyse-jvm-laload &&/$jvm-laload analyse-jvm-lastore &&/$jvm-lastore + "java.lang.Float" analyse-jvm-fnewarray &&/$jvm-fnewarray analyse-jvm-faload &&/$jvm-faload analyse-jvm-fastore &&/$jvm-fastore + "java.lang.Double" analyse-jvm-dnewarray &&/$jvm-dnewarray analyse-jvm-daload &&/$jvm-daload analyse-jvm-dastore &&/$jvm-dastore + "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore + ) + +(defn analyse-jvm-anewarray [analyse class length] + (let [elem-type (&type/Data$ class (&/|list)) + array-type (&type/Data$ "Array" (&/|list elem-type))] + (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class length)) array-type))))) + +(defn analyse-jvm-aaload [analyse class array idx] + (let [elem-type (&type/Data$ class (&/|list)) + array-type (&type/Data$ "Array" (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array)] + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array idx)) elem-type)))))) + +(defn analyse-jvm-aastore [analyse class array idx elem] + (let [elem-type (&type/Data$ class (&/|list)) + array-type (&type/Data$ "Array" (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =elem (&&/analyse-1 analyse elem-type elem)] + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array idx =elem)) array-type)))))) + +(let [length-type (&type/Data$ "java.lang.Long" (&/|list))] + (defn analyse-jvm-arraylength [analyse array] + (&type/with-var + (fn [$var] + (let [elem-type $var + array-type (&type/Data$ "Array" (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array)] + (return (&/|list (&/T (&/V &&/$jvm-arraylength =array) length-type))))))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index da9896bd5..759fc98fc 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -223,14 +223,89 @@ (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - (&a/$jvm-new-array ?class ?length) - (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) + (&a/$jvm-znewarray ?length) + (&&host/compile-jvm-znewarray compile-expression ?type ?length) - (&a/$jvm-aastore ?array ?idx ?elem) - (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-zastore ?array ?idx ?elem) + (&&host/compile-jvm-zastore compile-expression ?type ?array ?idx ?elem) - (&a/$jvm-aaload ?array ?idx) - (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) + (&a/$jvm-zaload ?array ?idx) + (&&host/compile-jvm-zaload compile-expression ?type ?array ?idx) + + (&a/$jvm-bnewarray ?length) + (&&host/compile-jvm-bnewarray compile-expression ?type ?length) + + (&a/$jvm-bastore ?array ?idx ?elem) + (&&host/compile-jvm-bastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-baload ?array ?idx) + (&&host/compile-jvm-baload compile-expression ?type ?array ?idx) + + (&a/$jvm-snewarray ?length) + (&&host/compile-jvm-snewarray compile-expression ?type ?length) + + (&a/$jvm-sastore ?array ?idx ?elem) + (&&host/compile-jvm-sastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-saload ?array ?idx) + (&&host/compile-jvm-saload compile-expression ?type ?array ?idx) + + (&a/$jvm-inewarray ?length) + (&&host/compile-jvm-inewarray compile-expression ?type ?length) + + (&a/$jvm-iastore ?array ?idx ?elem) + (&&host/compile-jvm-iastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-iaload ?array ?idx) + (&&host/compile-jvm-iaload compile-expression ?type ?array ?idx) + + (&a/$jvm-lnewarray ?length) + (&&host/compile-jvm-lnewarray compile-expression ?type ?length) + + (&a/$jvm-lastore ?array ?idx ?elem) + (&&host/compile-jvm-lastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-laload ?array ?idx) + (&&host/compile-jvm-laload compile-expression ?type ?array ?idx) + + (&a/$jvm-fnewarray ?length) + (&&host/compile-jvm-fnewarray compile-expression ?type ?length) + + (&a/$jvm-fastore ?array ?idx ?elem) + (&&host/compile-jvm-fastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-faload ?array ?idx) + (&&host/compile-jvm-faload compile-expression ?type ?array ?idx) + + (&a/$jvm-dnewarray ?length) + (&&host/compile-jvm-dnewarray compile-expression ?type ?length) + + (&a/$jvm-dastore ?array ?idx ?elem) + (&&host/compile-jvm-dastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-daload ?array ?idx) + (&&host/compile-jvm-daload compile-expression ?type ?array ?idx) + + (&a/$jvm-cnewarray ?length) + (&&host/compile-jvm-cnewarray compile-expression ?type ?length) + + (&a/$jvm-castore ?array ?idx ?elem) + (&&host/compile-jvm-castore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-caload ?array ?idx) + (&&host/compile-jvm-caload compile-expression ?type ?array ?idx) + + (&a/$jvm-anewarray ?class ?length) + (&&host/compile-jvm-anewarray compile-expression ?type ?class ?length) + + (&a/$jvm-aastore ?class ?array ?idx ?elem) + (&&host/compile-jvm-aastore compile-expression ?type ?class ?array ?idx ?elem) + + (&a/$jvm-aaload ?class ?array ?idx) + (&&host/compile-jvm-aaload compile-expression ?type ?class ?array ?idx) + + (&a/$jvm-arraylength ?array) + (&&host/compile-jvm-arraylength compile-expression ?type ?array) (&a/$jvm-try ?body ?catches ?finally) (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 7c1297aad..7825bef94 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -76,26 +76,21 @@ _ (load-class! loader real-name)]] (return nil))) -(do-template [ ] - (defn [^MethodVisitor writer] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature )))) - ;; (doto writer - ;; ;; X - ;; (.visitTypeInsn Opcodes/NEW ) ;; XW - ;; (.visitInsn ) ;; WXW - ;; (.visitInsn ) ;; WWXW - ;; (.visitInsn Opcodes/POP) ;; WWX - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "" ) ;; W - ;; ) - ) +(do-template [ ] + (do (defn [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host/->type-signature ))))) + (defn [^MethodVisitor writer] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST ) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" ))))) - wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 - wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 - wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 - wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 - wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 - wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 - wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 - wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 + wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 + wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 + wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 + wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 + wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 + wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 + wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 + wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 ) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index db54af8ac..83c769b4b 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -287,14 +287,62 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] (return nil))) -(defn compile-jvm-new-array [compile *type* ?class ?length] +(do-template [ ] + (do (defn [compile *type* ?length] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn (int ?length)) + (.visitIntInsn Opcodes/NEWARRAY ))]] + (return nil))) + + (defn [compile *type* ?array ?idx] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitLdcInsn (int ?idx)) + (.visitInsn ) + )]] + (return nil))) + + (defn [compile *type* ?array ?idx ?elem] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int ?idx)))] + _ (compile ?elem) + :let [_ (doto *writer* + + (.visitInsn ))]] + (return nil))) + ) + + Opcodes/T_BOOLEAN compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean + Opcodes/T_BYTE compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte + Opcodes/T_SHORT compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short + Opcodes/T_INT compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int + Opcodes/T_LONG compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long + Opcodes/T_FLOAT compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float + Opcodes/T_DOUBLE compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double + Opcodes/T_CHAR compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char + ) + +(defn compile-jvm-anewarray [compile *type* ?class ?length] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int ?length)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] (return nil))) -(defn compile-jvm-aastore [compile *type* ?array ?idx ?elem] +(defn compile-jvm-aaload [compile *type* ?class ?array ?idx] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitLdcInsn (int ?idx)) + (.visitInsn Opcodes/AALOAD))]] + (return nil))) + +(defn compile-jvm-aastore [compile *type* ?class ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (doto *writer* @@ -304,12 +352,13 @@ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn compile-jvm-aaload [compile *type* ?array ?idx] +(defn compile-jvm-arraylength [compile *type* ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) - (.visitInsn Opcodes/AALOAD))]] + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] (return nil))) (defn compile-jvm-getstatic [compile *type* ?class ?field] -- cgit v1.2.3 From 1e5f1afbd0f8b54350e552c110dead87b4b5dca0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 18:31:29 -0400 Subject: - Fixed some errors with JVM interop. --- src/lux/analyser.clj | 29 ++++++--- src/lux/analyser/host.clj | 156 +++++++++++++++++++++++----------------------- src/lux/host.clj | 43 ++++++++----- 3 files changed, 128 insertions(+), 100 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index bd0957bdf..e1c167ce6 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -43,6 +43,14 @@ _ (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) +(defn ^:private extract-text [ast] + (|case ast + [_ (&/$TextS text)] + (return text) + + _ + (fail (str "[Analyser Error] Can't extract text: " (&/show-ast ast))))) + (defn analyse-variant+ [analyser exo-type ident values] (|do [[module tag-name] (&/normalize ident) idx (&&module/tag-index module tag-name)] @@ -155,13 +163,15 @@ (&/$Cons [_ (&/$TupleS ?fields)] (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil)))))))) - (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) + (|do [=interfaces (&/map% extract-text ?interfaces)] + (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?fields ?methods)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] (&/$Cons [_ (&/$TextS ?name)] (&/$Cons [_ (&/$TupleS ?supers)] ?methods)))) - (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) + (|do [=supers (&/map% extract-text ?supers)] + (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods)) ;; Programs (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] @@ -280,7 +290,8 @@ (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))) - (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-new analyse exo-type ?class =classes ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] (&/$Cons [_ (&/$TextS ?class)] @@ -316,7 +327,8 @@ (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))))) - (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method =classes ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] (&/$Cons [_ (&/$TextS ?class)] @@ -325,7 +337,8 @@ (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method =classes ?object ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] (&/$Cons [_ (&/$TextS ?class)] @@ -334,7 +347,8 @@ (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method =classes ?object ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] (&/$Cons [_ (&/$TextS ?class)] @@ -343,7 +357,8 @@ (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method =classes ?object ?args)) ;; Exceptions (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 4fbd67fdb..69e1ff47a 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -15,21 +15,21 @@ [env :as &&env]))) ;; [Utils] -(defn ^:private extract-text [text] - (|case text - [_ (&/$TextS ?text)] - (return ?text) +(defn ^:private extract-text [ast] + (|case ast + [_ (&/$TextS text)] + (return text) _ - (fail "[Analyser Error] Can't extract Text."))) + (fail "[Analyser/Host Error] Can't extract text."))) -(defn ^:private analyse-1+ [analyse ?token] +(defn ^:private analyse-1+ [analyse token] (&type/with-var (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token) - :let [[?item ?type] =expr] - =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (|do [=expr (&&/analyse-1 analyse $var token) + :let [[item type] =expr] + =type (&type/clean $var type)] + (return (&/T item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -76,9 +76,9 @@ (do-template [ ] (let [input-type (&type/Data$ (&/|list)) output-type (&type/Data$ (&/|list))] - (defn [analyse exo-type ?x ?y] - (|do [=x (&&/analyse-1 analyse input-type ?x) - =y (&&/analyse-1 analyse input-type ?y) + (defn [analyse exo-type x y] + (|do [=x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) @@ -123,92 +123,89 @@ analyse-jvm-dgt &&/$jvm-dgt "java.lang.Double" "java.lang.Boolean" ) -(defn analyse-jvm-getstatic [analyse exo-type ?class ?field] +(defn analyse-jvm-getstatic [analyse exo-type class field] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) + =type (&host/lookup-static-field class-loader class field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T class field)) output-type))))) -(defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] +(defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =object (&&/analyse-1 analyse ?object) + =type (&host/lookup-static-field class-loader class field) + =object (&&/analyse-1 analyse object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T class field =object)) output-type))))) -(defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] +(defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =value (&&/analyse-1 analyse =type ?value) + =type (&host/lookup-static-field class-loader class field) + =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T class field =value)) output-type))))) -(defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] +(defn analyse-jvm-putfield [analyse exo-type class field object value] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse =type ?value) + =type (&host/lookup-static-field class-loader class field) + =object (&&/analyse-1 analyse object) + =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T class field =object =value)) output-type))))) -(defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] +(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (&host/lookup-static-method class-loader ?class ?method =classes) + =return (&host/lookup-static-method class-loader class method classes) ;; :let [_ (matchv ::M/objects [=return] ;; [[&/$DataT _return-class (&/|list)]] - ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] + ;; (prn 'analyse-jvm-invokestatic class method _return-class))] =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&type/Data$ _class (&/|list)) _arg)) - =classes - ?args) + classes + args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T class method classes =args)) output-type))))) -(defn analyse-jvm-instanceof [analyse exo-type ?class ?object] - (|do [=object (analyse-1+ analyse ?object) +(defn analyse-jvm-instanceof [analyse exo-type class object] + (|do [=object (analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T class =object)) output-type))))) (do-template [ ] - (defn [analyse exo-type ?class ?method ?classes ?object ?args] + (defn [analyse exo-type class method classes object args] (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&type/Data$ ?class (&/|list)) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c (&/|list)) ?o)) - =classes ?args) + =return (&host/lookup-virtual-method class-loader class method classes) + =object (&&/analyse-1 analyse (&type/Data$ class (&/|list)) object) + =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + classes args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V (&/T class method classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface ) -(defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args] +(defn analyse-jvm-invokespecial [analyse exo-type class method classes object args] (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (if (= "" ?method) + =return (if (= "" method) (return &type/Unit) - (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&type/Data$ ?class (&/|list)) ?object) - =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&type/Data$ ?c (&/|list)) ?o)) - =classes ?args) + (&host/lookup-virtual-method class-loader class method classes)) + =object (&&/analyse-1 analyse (&type/Data$ class (&/|list)) object) + =args (&/map2% (fn [c o] + (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + classes args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T class method classes =object =args)) output-type))))) -(defn analyse-jvm-null? [analyse exo-type ?object] - (|do [=object (analyse-1+ analyse ?object) +(defn analyse-jvm-null? [analyse exo-type object] + (|do [=object (analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] @@ -219,12 +216,14 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) -(defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] - (|do [=classes (&/map% extract-text ?classes) - =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&type/Data$ ?class (&/|list))] +(defn analyse-jvm-new [analyse exo-type class classes args] + (|do [class-loader &/loader + =return (&host/lookup-constructor class-loader class classes) + =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + classes args) + :let [output-type (&type/Data$ class (&/|list))] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-new (&/T class classes =args)) output-type))))) (do-template [ ] (let [elem-type (&type/Data$ (&/|list)) @@ -316,8 +315,7 @@ modifiers)) (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] - (|do [=interfaces (&/map% extract-text ?interfaces) - =fields (&/map% (fn [?field] + (|do [=fields (&/map% (fn [?field] (|case ?field [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] (&/$Cons [_ (&/$TextS ?field-type)] @@ -360,7 +358,7 @@ (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) (&/|list)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/Cons$ (&/T ";this" ?super-class) + (&/Cons$ (&/T "this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers @@ -371,29 +369,29 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) + :let [_ (prn 'analyse-jvm-class ?name ?super-class)]] (return (&/|list)))) -(defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] - (|do [=supers (&/map% extract-text ?supers) - =methods (&/map% (fn [method] +(defn analyse-jvm-interface [analyse compile-token name supers methods] + (|do [=methods (&/map% (fn [method] (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?inputs)] - (&/$Cons [_ (&/$TextS ?output)] - (&/$Cons [_ (&/$TupleS ?modifiers)] + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Cons [_ (&/$TupleS modifiers)] (&/$Nil))))))] - (|do [=inputs (&/map% extract-text ?inputs) - =modifiers (analyse-modifiers ?modifiers)] - (return {:name ?method-name + (|do [=inputs (&/map% extract-text inputs) + =modifiers (analyse-modifiers modifiers)] + (return {:name method-name :modifiers =modifiers :inputs =inputs - :output ?output})) + :output output})) _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - ?methods) - _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] + methods) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] diff --git a/src/lux/host.clj b/src/lux/host.clj index 0936d90eb..81323b1d8 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -10,7 +10,7 @@ clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) - (:import (java.lang.reflect Field Method Modifier) + (:import (java.lang.reflect Field Method Constructor Modifier) java.util.regex.Pattern)) ;; [Constants] @@ -22,19 +22,21 @@ ;; [Utils] (defn ^:private class->type [^Class class] + "(-> Class Type)" (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" (str (if-let [pkg (.getPackage class)] (str (.getName pkg) ".") "") (.getSimpleName class)))] (if (.equals "void" base) - (return &type/Unit) - (return (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base) - (&/|list))) + &type/Unit + (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base) + (&/|list)) ))) (defn ^:private method->type [^Method method] + "(-> Method Type)" (class->type (.getReturnType method))) ;; [Resources] @@ -93,9 +95,8 @@ :when (and (.equals ^Object field (.getName =field)) (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] - (|do [=type (class->type type*)] - (return =type)) - (fail (str "[Analyser Error] Field does not exist: " target "." field)))) + (return (class->type type*)) + (fail (str "[Host Error] Field does not exist: " target "." field)))) lookup-static-field true lookup-field false @@ -107,17 +108,31 @@ (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object (Modifier/isStatic (.getModifiers =method))) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))] + (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types)))))] =method))] - (method->type method) - (fail (str "[Analyser Error] Method does not exist: " target "." method-name)))) + (return (method->type method)) + (fail (str "[Host Error] Method does not exist: " target "." method-name)))) lookup-static-method true lookup-virtual-method false ) +(defn lookup-constructor [class-loader target args] + (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (return &type/Unit) + (fail (str "[Host Error] Constructor does not exist: " target)))) + (defn location [scope] (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) -- cgit v1.2.3 From 45a102bae3707d1a5220d7e124221ed46882f22d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 19:00:56 -0400 Subject: - Added exhaustiveness testing for class definition. --- src/lux/analyser/host.clj | 29 +++++++++++++++++++++++++++-- src/lux/host.clj | 5 +++++ 2 files changed, 32 insertions(+), 2 deletions(-) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 69e1ff47a..0eb89b251 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -315,7 +315,9 @@ modifiers)) (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] - (|do [=fields (&/map% (fn [?field] + (|do [class-loader &/loader + abstract-methods (&/flat-map% (partial &host/abstract-methods class-loader) (&/Cons$ ?super-class ?interfaces)) + =fields (&/map% (fn [?field] (|case ?field [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] (&/$Cons [_ (&/$TextS ?field-type)] @@ -369,8 +371,31 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) + ;; Test for method completion + :let [methods-map (&/fold (fn [mmap mentry] + (assoc mmap (:name mentry) mentry)) + {} + =methods) + missing-method (&/fold (fn [missing abs-meth] + (|let [[am-name am-inputs] abs-meth] + (or missing + (if-let [meth-struct (get methods-map am-name)] + (let [meth-inputs (:inputs meth-struct)] + (if (and (= (&/|length meth-inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] (and prev (= mi ai))) + true + meth-inputs am-inputs)) + nil + am-name)) + am-name)))) + nil + abstract-methods)] + _ (if (nil? missing-method) + (return nil) + (fail (str "[Analyser Error] Missing method: " missing-method))) _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) - :let [_ (prn 'analyse-jvm-class ?name ?super-class)]] + ;; :let [_ (prn 'analyse-jvm-class ?name ?super-class)] + ] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token name supers methods] diff --git a/src/lux/host.clj b/src/lux/host.clj index 81323b1d8..8d6135d64 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -134,5 +134,10 @@ (return &type/Unit) (fail (str "[Host Error] Constructor does not exist: " target)))) +(defn abstract-methods [class-loader class] + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj class) true class-loader)) + :when (.equals true (Modifier/isAbstract (.getModifiers =method)))] + (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) + (defn location [scope] (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) -- cgit v1.2.3 From c9560da3760d0d277a715a966496451020f3f2f8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 22:36:34 -0400 Subject: - Added exhaustiveness testing for exception-handling code. - Added some optimizations for using List & Maybe within the compiler. --- source/lux.lux | 7 ++- source/lux/host/io.lux | 10 ++-- src/lux/analyser.clj | 4 +- src/lux/analyser/case.clj | 8 +-- src/lux/analyser/host.clj | 135 +++++++++++++++++++++++++++++++------------- src/lux/analyser/lux.clj | 26 ++++----- src/lux/analyser/module.clj | 2 +- src/lux/analyser/record.clj | 2 +- src/lux/base.clj | 53 ++++++++++------- src/lux/compiler/cache.clj | 6 +- src/lux/compiler/type.clj | 2 +- src/lux/host.clj | 4 +- src/lux/parser.clj | 8 +-- src/lux/type.clj | 45 ++++++++------- 14 files changed, 196 insertions(+), 116 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 39cbb7765..ee01c8bdf 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -275,7 +275,8 @@ ## (deftype Host ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader) -## #classes (^ clojure.lang.Atom))) +## #classes (^ clojure.lang.Atom) +## #catching (List Text))) (_lux_def Host (#NamedT ["lux" "Host"] (#TupleT (#Cons [## "lux;writer" @@ -284,7 +285,9 @@ (#DataT "java.lang.ClassLoader" #Nil) (#Cons [## "lux;classes" (#DataT "clojure.lang.Atom" #Nil) - #Nil])])])))) + (#Cons [## "lux;catching" + (#AppT List Text) + #Nil])])])])))) (_lux_declare-tags [#writer #loader #classes] Host) ## (deftype (DefData' m) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux index 4542b0519..99e15722d 100644 --- a/source/lux/host/io.lux +++ b/source/lux/host/io.lux @@ -30,11 +30,11 @@ (let [in (_jvm_getstatic "java.lang.System" "in") reader (_jvm_new "java.io.InputStreamReader" ["java.io.InputStream"] [in]) buff-reader (_jvm_new "java.io.BufferedReader" ["java.io.Reader"] [reader])] - (@io (let [output (: (Either Text ) (try ))] - (exec (_jvm_invokeinterface "java.io.Closeable" "close" [] buff-reader []) - (case output - (#;Left _) #;None - (#;Right input) (#;Some input)))))))] + (@io (let [output (: (Either Text ) (try )) + _close (: (Either Text (,)) (try (_jvm_invokeinterface "java.io.Closeable" "close" [] buff-reader [])))] + (case [output _close] + (\or [(#;Left _) _] [_ (#;Left _)]) #;None + [(#;Right input) (#;Right _)] (#;Some input))))))] [read-char Char (_jvm_i2c (_jvm_invokevirtual "java.io.BufferedReader" "read" [] buff-reader []))] [read-line Text (_jvm_invokevirtual "java.io.BufferedReader" "readLine" [] buff-reader [])] diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index e1c167ce6..03709b226 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -364,7 +364,7 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/T &/Nil$ &/None$) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] @@ -602,7 +602,7 @@ (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (analyse-variant+ analyse exo-type ?ident (&/|list)) + (analyse-variant+ analyse exo-type ?ident &/Nil$) (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index a0f07cdce..109ba7c41 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -39,7 +39,7 @@ ;; [Utils] (def ^:private unit - (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list)))) + (&/T (&/T "" -1 -1) (&/V &/$TupleS &/Nil$))) (defn ^:private resolve-type [type] (|case type @@ -118,7 +118,7 @@ (defn adjust-type [type] "(-> Type (Lux Type))" - (adjust-type* (&/|list) type)) + (adjust-type* &/Nil$ type)) (defn ^:private analyse-pattern [value-type pattern kont] (|let [[meta pattern*] pattern] @@ -170,7 +170,7 @@ (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] (return (&/T (&/Cons$ =test =tests) =kont))))) (|do [=kont kont] - (return (&/T (&/|list) =kont))) + (return (&/T &/Nil$ =kont))) (&/|reverse (&/zip2 ?member-types ?members)))] (return (&/T (&/V $TupleTestAC =tests) =kont))))) @@ -392,7 +392,7 @@ (|do [patterns (&/fold% (fn [patterns branch] (|let [[pattern body] branch] (analyse-branch analyse exo-type value-type pattern body patterns))) - (&/|list) + &/Nil$ branches) struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 0eb89b251..db04a60c0 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -23,6 +23,48 @@ _ (fail "[Analyser/Host Error] Can't extract text."))) +(defn ^:private ensure-catching [exceptions] + "(-> (List Text) (Lux (,)))" + (|do [class-loader &/loader] + (fn [state] + (let [exceptions (&/|map #(Class/forName % true class-loader) exceptions) + catching (->> state (&/get$ &/$host) (&/get$ &/$catching) + (&/|map #(Class/forName % true class-loader)))] + (if-let [missing-ex (&/fold (fn [prev now] + (or prev + (if (&/fold (fn [found? ex-catch] + (or found? + (.isAssignableFrom ex-catch now))) + false + catching) + nil + now))) + nil + exceptions)] + (assert false (str "[Analyser Error] Unhandled exception: " missing-ex)) + ;; (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex)) + (&/return* state nil))) + ))) + +(defn ^:private with-catches [catches body] + "(All [a] (-> (List Text) (Lux a) (Lux a)))" + (fn [state] + (let [;; _ (prn 'with-catches/_0 (&/->seq catches)) + old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) + ;; _ (prn 'with-catches/_1 (&/->seq (->> state (&/get$ &/$host) (&/get$ &/$catching)))) + state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %))) + ;; _ (prn 'with-catches/_2 (&/->seq (->> state* (&/get$ &/$host) (&/get$ &/$catching)))) + ] + (|case (&/run-state body state*) + (&/$Left msg) + (&/V &/$Left msg) + + (&/$Right state** output) + (do ;; (prn 'with-catches/_3 (&/->seq (->> state** (&/get$ &/$host) (&/get$ &/$catching)))) + (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output))))) + )) + (defn ^:private analyse-1+ [analyse token] (&type/with-var (fn [$var] @@ -74,8 +116,8 @@ ;; [Resources] (do-template [ ] - (let [input-type (&type/Data$ (&/|list)) - output-type (&type/Data$ (&/|list))] + (let [input-type (&type/Data$ &/Nil$) + output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type x y] (|do [=x (&&/analyse-1 analyse input-type x) =y (&&/analyse-1 analyse input-type y) @@ -157,12 +199,15 @@ (defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader - =return (&host/lookup-static-method class-loader class method classes) + =return+exceptions (&host/lookup-static-method class-loader class method classes) + :let [[=return exceptions] =return+exceptions] + ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))] + _ (ensure-catching exceptions) ;; :let [_ (matchv ::M/objects [=return] - ;; [[&/$DataT _return-class (&/|list)]] + ;; [[&/$DataT _return-class &/Nil$]] ;; (prn 'analyse-jvm-invokestatic class method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&type/Data$ _class (&/|list)) _arg)) + (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) classes args) :let [output-type =return] @@ -179,11 +224,16 @@ (do-template [ ] (defn [analyse exo-type class method classes object args] (|do [class-loader &/loader - =return (&host/lookup-virtual-method class-loader class method classes) - =object (&&/analyse-1 analyse (&type/Data$ class (&/|list)) object) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + =return+exceptions (&host/lookup-virtual-method class-loader class method classes) + ;; :let [_ (prn ' [class method] (&/adt->text =return+exceptions))] + :let [[=return exceptions] =return+exceptions] + _ (ensure-catching exceptions) + =object (&&/analyse-1 analyse (&type/Data$ class &/Nil$) object) + =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) :let [output-type =return] + ;; :let [_ (prn ' [class method] '=return (&type/show-type =return))] + ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] _ (&type/check exo-type (as-otype+ output-type))] (return (&/|list (&/T (&/V (&/T class method classes =object =args)) output-type))))) @@ -193,12 +243,15 @@ (defn analyse-jvm-invokespecial [analyse exo-type class method classes object args] (|do [class-loader &/loader - =return (if (= "" method) - (return &type/Unit) - (&host/lookup-virtual-method class-loader class method classes)) - =object (&&/analyse-1 analyse (&type/Data$ class (&/|list)) object) + =return+exceptions (if (= "" method) + (return (&/T &type/Unit &/Nil$)) + (&host/lookup-virtual-method class-loader class method classes)) + :let [[=return exceptions] =return+exceptions] + ;; :let [_ (prn 'analyse-jvm-invokespecial (&/adt->text =return+exceptions))] + _ (ensure-catching exceptions) + =object (&&/analyse-1 analyse (&type/Data$ class &/Nil$) object) =args (&/map2% (fn [c o] - (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] @@ -212,21 +265,21 @@ (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null" (&/|list))] + (|do [:let [output-type (&type/Data$ "null" &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader =return (&host/lookup-constructor class-loader class classes) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) - :let [output-type (&type/Data$ class (&/|list))] + :let [output-type (&type/Data$ class &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-new (&/T class classes =args)) output-type))))) (do-template [ ] - (let [elem-type (&type/Data$ (&/|list)) + (let [elem-type (&type/Data$ &/Nil$) array-type (&type/Data$ "Array" (&/|list elem-type))] (defn [analyse length] (return (&/|list (&/T (&/V length) array-type)))) @@ -252,24 +305,24 @@ ) (defn analyse-jvm-anewarray [analyse class length] - (let [elem-type (&type/Data$ class (&/|list)) + (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ "Array" (&/|list elem-type))] (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class length)) array-type))))) (defn analyse-jvm-aaload [analyse class array idx] - (let [elem-type (&type/Data$ class (&/|list)) + (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ "Array" (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array)] (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array idx)) elem-type)))))) (defn analyse-jvm-aastore [analyse class array idx elem] - (let [elem-type (&type/Data$ class (&/|list)) + (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ "Array" (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =elem (&&/analyse-1 analyse elem-type elem)] (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array idx =elem)) array-type)))))) -(let [length-type (&type/Data$ "java.lang.Long" (&/|list))] +(let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] (defn analyse-jvm-arraylength [analyse array] (&type/with-var (fn [$var] @@ -353,11 +406,11 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype) (&/|list)) + (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) (&/|list)) ?method-body)) + (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) &/Nil$) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs (&/Cons$ (&/T "this" ?super-class) @@ -396,7 +449,7 @@ _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) ;; :let [_ (prn 'analyse-jvm-class ?name ?super-class)] ] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-jvm-interface [analyse compile-token name supers methods] (|do [=methods (&/map% (fn [method] @@ -417,19 +470,21 @@ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) methods) _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] - =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class (&/|list)) + (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class &/Nil$) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) + :let [catched-exceptions (&/|map #(aget % 0) =catches)] + =body (with-catches catched-exceptions + (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally - (&/$None) (return (&/V &/$None nil)) + (&/$None) (return &/None$) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) @@ -437,7 +492,7 @@ (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable" (&/|list)) _type)] + _ (&type/check (&type/Data$ "java.lang.Throwable" &/Nil$) _type)] (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] @@ -453,9 +508,9 @@ ) (do-template [ ] - (let [output-type (&type/Data$ (&/|list))] + (let [output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ (&/|list)) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -480,9 +535,9 @@ ) (do-template [ ] - (let [output-type (&type/Data$ (&/|list))] + (let [output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ (&/|list)) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -501,9 +556,11 @@ analyse-jvm-lushr &&/$jvm-lushr "java.lang.Long" "java.lang.Integer" ) -(defn analyse-jvm-program [analyse compile-token ?args ?body] - (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V &&/$jvm-program =body))] - (return (&/|list)))) +(let [input-type (&type/App$ &type/List &type/Text) + output-type (&type/App$ &type/IO &type/Unit)] + (defn analyse-jvm-program [analyse compile-token ?args ?body] + (|do [=body (&/with-scope "" + (&&env/with-local ?args input-type + (&&/analyse-1 analyse output-type ?body))) + _ (compile-token (&/V &&/$jvm-program =body))] + (return &/Nil$)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6205adccb..4a03c4848 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -59,7 +59,7 @@ (|do [:let [=var* (next-bound-type tuple-type)] _ (&type/set-var iid =var*) tuple-type* (&type/clean $var tuple-type)] - (return (&type/Univ$ (&/|list) tuple-type*))) + (return (&type/Univ$ &/Nil$ tuple-type*))) _ (&type/clean $var tuple-type))] @@ -110,7 +110,7 @@ (|do [output (with-attempt (|case ?values (&/$Nil) - (analyse-tuple analyse (&/V &/$Right exo-type) (&/|list)) + (analyse-tuple analyse (&/V &/$Right exo-type) &/Nil$) (&/$Cons ?value (&/$Nil)) (analyse exo-type ?value) @@ -155,7 +155,7 @@ (|do [:let [=var* (next-bound-type variant-type)] _ (&type/set-var iid =var*) variant-type* (&type/clean $var variant-type)] - (return (&type/Univ$ (&/|list) variant-type*))) + (return (&type/Univ$ &/Nil$ variant-type*))) _ (&type/clean $var variant-type)) @@ -291,7 +291,7 @@ (&/T register* (&/Cons$ frame* new-inner)))) (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) - (&/|list)) + &/Nil$) (&/|reverse inner) scopes)] ((|do [_ (&type/check exo-type (&&/expr-type* =local))] (return (&/|list =local))) @@ -313,7 +313,7 @@ _ (&type/check exo-type fun-type) ;; :let [_ (prn 'analyse-apply*/_1 'SUCCESS (str "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))] ] - (return (&/T fun-type (&/|list)))) + (return (&/T fun-type &/Nil$))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -416,7 +416,7 @@ _ (&type/set-var iid =input*) =output* (&type/clean $input =output) =output** (&type/clean $output =output*)] - (return (&type/Univ$ (&/|list) (embed-inferred-input =input* =output**)))) + (return (&type/Univ$ &/Nil$ (embed-inferred-input =input* =output**)))) _ (|do [=output* (&type/clean $input =output) @@ -490,7 +490,7 @@ ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] ] - (return (&/|list))) + (return &/Nil$)) _ (do ;; (println 'DEF (str module-name ";" ?name)) @@ -505,7 +505,7 @@ [def-analysis def-type] =value _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) )]] - (return (&/|list))))) + (return &/Nil$)))) )))) (defn analyse-declare-macro [analyse compile-token ?name] @@ -515,7 +515,7 @@ _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) ;; :let [_ (prn 'analyse-declare-macro ?name "2")] ] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name @@ -524,7 +524,7 @@ ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-import [analyse compile-module compile-token path] ;; (prn 'analyse-import path) @@ -537,17 +537,17 @@ ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] _ (&&module/add-import path) _ (&/when% (not already-compiled?) (compile-module path))] - (return (&/|list)))))) + (return &/Nil$))))) (defn analyse-export [analyse compile-token name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-alias [analyse compile-token ex-alias ex-module] (|do [module-name &/get-module-name _ (&&module/alias module-name ex-alias ex-module)] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 97365ba08..deb6be69e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -27,7 +27,7 @@ ;; "lux;defs" (&/|table) ;; "lux;imports" - (&/|list) + &/Nil$ ;; "lux;tags" (&/|table) ;; "lux;types" diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 0f860888b..ddc9616fd 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -16,7 +16,7 @@ "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" (|do [[tag-group tag-type] (|case pairs (&/$Nil) - (return (&/T (&/|list) &type/Unit)) + (return (&/T &/Nil$ &type/Unit)) (&/$Cons [[_ (&/$TagS tag1)] _] _) (|do [[module name] (&&/resolved-ident tag1) diff --git a/src/lux/base.clj b/src/lux/base.clj index c0f28f519..aefa0cf4c 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -84,7 +84,8 @@ (deftags ["writer" "loader" - "classes"]) + "classes" + "catching"]) ;; Compiler (deftags @@ -179,13 +180,13 @@ (defmacro |list [& elems] (reduce (fn [tail head] `(V $Cons (T ~head ~tail))) - `(V $Nil nil) + `Nil$ (reverse elems))) (defmacro |table [& elems] (reduce (fn [table [k v]] `(|put ~k ~v ~table)) - `(|list) + `Nil$ (reverse (partition 2 elems)))) (defn |get [slot table] @@ -201,7 +202,7 @@ (defn |put [slot value table] (|case table ($Nil) - (V $Cons (T (T slot value) (V $Nil nil))) + (V $Cons (T (T slot value) Nil$)) ($Cons [k v] table*) (if (.equals ^Object k slot) @@ -344,7 +345,7 @@ (if (p x) (|let [[pre post] (|split-with p xs*)] (T (Cons$ x pre) post)) - (T (V $Nil nil) xs)))) + (T Nil$ xs)))) (defn |contains? [k table] (|case table @@ -355,6 +356,14 @@ (or (.equals ^Object k k*) (|contains? k table*)))) +(defn |member? [x xs] + (|case xs + ($Nil) + false + + ($Cons x* xs*) + (or (= x x*) (|member? x xs*)))) + (defn fold [f init xs] (|case xs ($Nil) @@ -386,7 +395,7 @@ (let [|range* (fn |range* [from to] (if (< from to) (V $Cons (T from (|range* (inc from) to))) - (V $Nil nil)))] + Nil$))] (defn |range [n] (|range* 0 n))) @@ -404,12 +413,12 @@ (V $Cons (T (T x y) (zip2 xs* ys*))) [_ _] - (V $Nil nil))) + Nil$)) (defn |keys [plist] (|case plist ($Nil) - (|list) + Nil$ ($Cons [k v] plist*) (Cons$ k (|keys plist*)))) @@ -417,7 +426,7 @@ (defn |vals [plist] (|case plist ($Nil) - (|list) + Nil$ ($Cons [k v] plist*) (Cons$ v (|vals plist*)))) @@ -448,7 +457,7 @@ flat-map% |++) (defn list-join [xss] - (fold |++ (V $Nil nil) xss)) + (fold |++ Nil$ xss)) (defn |as-pairs [xs] (|case xs @@ -456,12 +465,12 @@ (V $Cons (T (T x y) (|as-pairs xs*))) _ - (V $Nil nil))) + Nil$)) (defn |reverse [xs] (fold (fn [tail head] (Cons$ head tail)) - (|list) + Nil$ xs)) (defn assert! [test message] @@ -497,7 +506,7 @@ (try-all% (|list (|do [head monad tail (repeat% monad)] (return (Cons$ head tail))) - (return (|list))))) + (return Nil$)))) (defn exhaust% [step] (fn [state] @@ -580,6 +589,7 @@ (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) (catch java.lang.reflect.InvocationTargetException e (prn 'InvocationTargetException (.getCause e)) + (prn 'memory-class-loader/findClass class-name (get @store class-name)) (throw e))) (do (prn 'memory-class-loader/store class-name (keys @store)) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) @@ -591,7 +601,10 @@ ;; "lux;loader" (memory-class-loader store) ;; "lux;classes" - store))) + store + ;; "lux;catching" + Nil$ + ))) (defn init-state [_] (T ;; "lux;source" @@ -601,11 +614,11 @@ ;; "lux;modules" (|table) ;; "lux;envs" - (|list) + Nil$ ;; "lux;types" +init-bindings+ ;; "lux;expected" - (V $VariantT (|list)) + (V $VariantT Nil$) ;; "lux;seed" 0 ;; "lux;eval?" @@ -671,13 +684,13 @@ (defn ->list [seq] (if (empty? seq) - (|list) + Nil$ (Cons$ (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) (Cons$ x (|repeat (dec n) x)) - (|list))) + Nil$)) (def get-module-name (fn [state] @@ -830,7 +843,7 @@ (return (Cons$ z zs))) [($Nil) ($Nil)] - (return (V $Nil nil)) + (return Nil$) [_ _] (fail "Lists don't match in size."))) @@ -841,7 +854,7 @@ (Cons$ (f x y) (map2 f xs* ys*)) [_ _] - (V $Nil nil))) + Nil$)) (defn fold2 [f init xs ys] (|case [xs ys] diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index e47da2678..3532cf843 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -92,7 +92,7 @@ (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux"))] (load _import (hash content) compile-module))) (if (= [""] imports) - (&/|list) + &/Nil$ (&/->list imports)))] (if (->> loads &/->seq (every? true?)) (do (doseq [^File file (seq (.listFiles (File. module-path))) @@ -109,7 +109,7 @@ ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))) tag-groups (let [all-tags (get-field &/tags-field module-meta)] (if (= "" all-tags) - (&/|list) + &/Nil$ (-> all-tags (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) (->> (map (fn [_group] @@ -149,7 +149,7 @@ (return nil))) )) (if (= [""] defs) - (&/|list) + &/Nil$ (&/->list defs))) _ (&/map% (fn [group] (|let [[_type _tags] group] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 6c128df80..00e66410f 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -33,7 +33,7 @@ (def ^:private $Nil "Analysis" - (variant$ &/$Nil (tuple$ (&/|list)))) + (variant$ &/$Nil (tuple$ &/Nil$))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" diff --git a/src/lux/host.clj b/src/lux/host.clj index 8d6135d64..9137f3874 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -32,7 +32,7 @@ &type/Unit (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base) - (&/|list)) + &/Nil$) ))) (defn ^:private method->type [^Method method] @@ -115,7 +115,7 @@ args (&/|map #(.getName ^Class %) param-types)))))] =method))] - (return (method->type method)) + (return (&/T (method->type method) (->> method .getExceptionTypes &/->list (&/|map #(.getName %))))) (fail (str "[Host Error] Method does not exist: " target "." method-name)))) lookup-static-method true diff --git a/src/lux/parser.clj b/src/lux/parser.clj index dbd6ca2c5..516b6a947 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -17,7 +17,7 @@ token &lexer/lex] (|case token [meta [ _]] - (return (&/V (&/fold &/|++ (&/|list) elems))) + (return (&/V (&/fold &/|++ &/Nil$ elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) @@ -29,7 +29,7 @@ (defn ^:private parse-record [parse] (|do [elems* (&/repeat% parse) token &lexer/lex - :let [elems (&/fold &/|++ (&/|list) elems*)]] + :let [elems (&/fold &/|++ &/Nil$ elems*)]] (|case token [meta (&lexer/$Close_Brace _)] (if (even? (&/|length elems)) @@ -45,10 +45,10 @@ :let [[meta token*] token]] (|case token* (&lexer/$White_Space _) - (return (&/|list)) + (return &/Nil$) (&lexer/$Comment _) - (return (&/|list)) + (return &/Nil$) (&lexer/$Bool ?value) (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 0da579cf4..8a1e11bed 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -23,7 +23,7 @@ _ false)) -(def ^:private empty-env (&/V &/$Nil nil)) +(def ^:private empty-env &/Nil$) (defn Data$ [name params] (&/V &/$DataT (&/T name params))) (defn Bound$ [idx] @@ -46,13 +46,13 @@ (&/V &/$NamedT (&/T name type))) -(def Bool (Named$ (&/T "lux" "Bool") (Data$ "java.lang.Boolean" (&/|list)))) -(def Int (Named$ (&/T "lux" "Int") (Data$ "java.lang.Long" (&/|list)))) -(def Real (Named$ (&/T "lux" "Real") (Data$ "java.lang.Double" (&/|list)))) -(def Char (Named$ (&/T "lux" "Char") (Data$ "java.lang.Character" (&/|list)))) -(def Text (Named$ (&/T "lux" "Text") (Data$ "java.lang.String" (&/|list)))) -(def Unit (Named$ (&/T "lux" "Unit") (Tuple$ (&/|list)))) -(def $Void (Named$ (&/T "lux" "Void") (Variant$ (&/|list)))) +(def Bool (Named$ (&/T "lux" "Bool") (Data$ "java.lang.Boolean" &/Nil$))) +(def Int (Named$ (&/T "lux" "Int") (Data$ "java.lang.Long" &/Nil$))) +(def Real (Named$ (&/T "lux" "Real") (Data$ "java.lang.Double" &/Nil$))) +(def Char (Named$ (&/T "lux" "Char") (Data$ "java.lang.Character" &/Nil$))) +(def Text (Named$ (&/T "lux" "Text") (Data$ "java.lang.String" &/Nil$))) +(def Unit (Named$ (&/T "lux" "Unit") (Tuple$ &/Nil$))) +(def $Void (Named$ (&/T "lux" "Void") (Variant$ &/Nil$))) (def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO @@ -221,11 +221,14 @@ (Tuple$ (&/|list ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter" (&/|list)) + (Data$ "org.objectweb.asm.ClassWriter" &/Nil$) ;; "lux;loader" - (Data$ "java.lang.ClassLoader" (&/|list)) + (Data$ "java.lang.ClassLoader" &/Nil$) ;; "lux;classes" - (Data$ "clojure.lang.Atom" (&/|list)))))) + (Data$ "clojure.lang.Atom" &/Nil$) + ;; "lux;catching" + (App$ List Text) + )))) (def DefData* (Univ$ empty-env @@ -367,7 +370,7 @@ (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] (return* (&/update$ &/$type-vars #(->> % (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + (&/update$ &/$mappings (fn [ms] (&/|put id &/None$ ms)))) state) id)))) @@ -396,7 +399,7 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/T ?id (&/V &/$None nil))) + (return (&/T ?id &/None$)) (return binding)) _ @@ -465,7 +468,7 @@ (&/T ??out (&/Cons$ ?in ?args))) _ - (&/T type (&/|list)))) + (&/T type &/Nil$))) (defn ^:private unravel-app [fun-type] (|case fun-type @@ -474,7 +477,7 @@ (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) _ - (&/T fun-type (&/|list)))) + (&/T fun-type &/Nil$))) (defn show-type [^objects type] (|case type @@ -581,7 +584,7 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - (&/V &/$None nil) + &/None$ (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) @@ -674,7 +677,7 @@ (def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) -(def ^:private init-fixpoints (&/|list)) +(def ^:private init-fixpoints &/Nil$) (defn ^:private check* [class-loader fixpoints invariant?? expected actual] (if (clojure.lang.Util/identical expected actual) @@ -689,14 +692,14 @@ (return* state* (&/V &/$Some ebound)) (&/$Left _) - (return* state (&/V &/$None nil)))) + (return* state &/None$))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) (return* state* (&/V &/$Some abound)) (&/$Left _) - (return* state (&/V &/$None nil))))] + (return* state &/None$)))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] @@ -873,6 +876,10 @@ (return (&/T fixpoints nil))) (and (not invariant??) + ;; (do (println '[Data Data] [e!name a!name] + ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) + ;; true) (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) (return (&/T fixpoints nil)) -- cgit v1.2.3 From 2f2a37639e7933d97bd0dd4b790e92ff7e784dcf Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 13 Sep 2015 00:11:32 -0400 Subject: - Expanded the lux/host/jvm library. --- source/lux/host/jvm.lux | 122 ++++++++++++++++++++++++++++++++++++++++++++- source/lux/meta/syntax.lux | 40 +++++++-------- 2 files changed, 138 insertions(+), 24 deletions(-) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index ba29925a7..710bc9a20 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -6,14 +6,17 @@ (;import lux (lux (control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do))) + (monad #as M #refer (#only do seq%))) (data (list #refer #all #open ("" List/Functor List/Fold)) (number/int #refer #all #open ("i:" Int/Ord)) - maybe) + maybe + tuple) (meta lux ast syntax))) +(open List/Monad "list:") + ## [Utils] ## Parsers (def method-decl^ @@ -50,6 +53,11 @@ body id^] (wrap [modifiers name inputs output body])))) +(def opt-arg^ + (Parser (, Bool Text)) + (&^ (tag?^ ["" "?"]) + local-symbol^)) + ## [Syntax] (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) @@ -115,3 +123,113 @@ type (repeat dimensions [])))) (fail "Array must have positive dimension.")))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "") + g!_ (gensym "")] + (emit (@list (` (let [(~ g!lock) (~ lock) + (~ g!_) (;_jvm_monitorenter (~ g!lock)) + (~ g!body) (~ body) + (~ g!_) (;_jvm_monitorexit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (@list (` (;_jvm_null? (~ obj)))))) + +(def (prepare-args args) + (-> (List (, Bool Text)) (Lux (, (List AST) (List AST) (List AST) (List Text)))) + (do Lux/Monad + [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) + #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) + (lambda [[[opt? arg-class] var]] + (if opt? + [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) + (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) + (case (~ var) + (#;Some (~ var)) (~ var) + #;None ;_jvm_null))))] + [(` (^ (~ (symbol$ ["" arg-class])))) + (@list)]))) + (zip2 args vars)) + var-types (map first pairings) + var-rebinds (map second pairings) + arg-classes (map second args)]] + (wrap [vars var-types (list:join var-rebinds) arg-classes]))) + +(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ opt-arg^))]) + (do Lux/Monad + [[vars var-types var-rebinds arg-classes] (prepare-args args)] + (case vars + (\ (@list)) + (do Lux/Monad + [g!_ (gensym "")] + (wrap (@list (` (: (-> (,) (^ (~ (symbol$ ["" class])))) + (lambda [(~ g!_)] + (;_jvm_new (~ (text$ class)) [] []))))))) + + _ + (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) + (lambda [[(~@ vars)]] + (let [(~@ var-rebinds)] + (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))))))) + ))) + +(do-template [ ] + [(defsyntax #export ( [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] + [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) + (do Lux/Monad + [[vars var-types var-rebinds arg-classes] (prepare-args args) + g!self (gensym "self") + g!temp (gensym "temp") + #let [return-type (` (^ (~ (symbol$ ["" return])))) + body (` ( (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])) + [body return-type] (if opt? + [(` (let [(~ g!temp) (~ body)] + (if (;_jvm_null? (~ g!temp)) + #;None + (#;Some (~ g!temp))))) + (` (Maybe (~ return-type)))] + [body return-type]) + [body return-type] (if ex? + [(` (try (~ body))) + (` (Either Text (~ return-type)))] + [body return-type])]] + (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) + (lambda [[(~@ vars)] (~ g!self)] + (let [(~@ var-rebinds)] + (~ body))))))) + ))] + + [invoke-virtual$ ;_jvm_invokevirtual] + [invoke-interface$ ;_jvm_invokeinterface] + ) + +(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] + [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) + (do Lux/Monad + [[vars var-types var-rebinds arg-classes] (prepare-args args) + g!temp (gensym "temp") + #let [return-type (` (^ (~ (symbol$ ["" return])))) + body (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])) + [body return-type] (if opt? + [(` (let [(~ g!temp) (~ body)] + (if (;_jvm_null? (~ g!temp)) + #;None + (#;Some (~ g!temp))))) + (` (Maybe (~ return-type)))] + [body return-type]) + [body return-type] (if ex? + [(` (try (~ body))) + (` (Either Text (~ return-type)))] + [body return-type])]] + (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) + (lambda [[(~@ vars)]] + (let [(~@ var-rebinds)] + (~ body))))))) + )) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 5425a2d9c..a28fa6d27 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -107,15 +107,13 @@ (do-template [ ] [(def #export ( v tokens) - (-> (Parser (,))) + (-> (Parser Bool)) (case tokens (#;Cons [[_ ( x)] tokens']) - (if ( v x) - (#;Some [tokens' []]) - #;None) + (#;Some [tokens' ( v x)]) _ - #;None))] + (#;Some [tokens false])))] [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] [ int?^ Int #;IntS i=] @@ -220,24 +218,22 @@ (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] body)) (do Lux/Monad - [names+parsers (M;map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [arg] - (case arg - (\ [_ (#;TupleS (@list [_ (#;SymbolS var-name)] - parser))]) - (wrap [(symbol$ var-name) parser]) - - (\ [_ (#;SymbolS var-name)]) - (wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) + [vars+parsers (M;map% Lux/Monad + (: (-> AST (Lux (, AST AST))) + (lambda [arg] + (case arg + (\ [_ (#;TupleS (@list var parser))]) + (wrap [var parser]) + + (\ [_ (#;SymbolS var-name)]) + (wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) g!tokens (gensym "tokens") g!_ (gensym "_") - #let [names (:: List/Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) + #let [error-msg (text$ (text:++ "Wrong syntax for " name)) body' (foldL (: (-> AST (, AST AST) AST) (lambda [body name+parser] (let [[name parser] name+parser] @@ -248,7 +244,7 @@ (~ g!_) (l;fail (~ error-msg))))))) body - (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) + (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse vars+parsers)))) macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) (~ body')))]] (wrap (@list& macro-def -- cgit v1.2.3 From 12402b01ce04428fee46a9441a4d1f4cf16db179 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 13 Sep 2015 00:58:35 -0400 Subject: - Fixed bug wherein mutual recursion could occur between modules. - Fixed bug wherein recompiling a previously cached module didn't always trigger all the necessary recompilations from dependent modules. --- src/lux/analyser/lux.clj | 7 +++++-- src/lux/base.clj | 38 ++++++++++++++++++++++++++++++++++++-- src/lux/compiler.clj | 7 ++++--- src/lux/compiler/cache.clj | 6 ++++-- 4 files changed, 49 insertions(+), 9 deletions(-) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 4a03c4848..3de4db89f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -364,7 +364,7 @@ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] - ;; :let [_ (when (or (= "zip" (aget real-name 1)) + ;; :let [_ (when (or (= "invoke-interface$" (aget real-name 1)) ;; ;; (= "..?" (aget real-name 1)) ;; ;; (= "try$" (aget real-name 1)) ;; ) @@ -534,7 +534,10 @@ (return nil))] (&/save-module (|do [already-compiled? (&&module/exists? path) - ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] + ;; :let [_ (prn 'analyse-import module-name path + ;; already-compiled?)] + active? (&/active-module? path) + _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) _ (&&module/add-import path) _ (&/when% (not already-compiled?) (compile-module path))] (return &/Nil$))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index aefa0cf4c..4c5d8ae44 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -80,12 +80,19 @@ "locals" "closure"]) +;; ModuleState +(deftags + ["Active" + "Compiled" + "Cached"]) + ;; Host (deftags ["writer" "loader" "classes" - "catching"]) + "catching" + "module-states"]) ;; Compiler (deftags @@ -110,7 +117,6 @@ (def eval-field "_eval") (def tags-field "_tags") (def module-class-name "_") - (def +name-separator+ ";") (defn T [& elems] @@ -604,6 +610,8 @@ store ;; "lux;catching" Nil$ + ;; "lux;module-states" + (|table) ))) (defn init-state [_] @@ -937,3 +945,29 @@ ($None) (V $None nil) ($Some xs**) (V $Some (V $Cons (T x xs**)))) ))) + +(do-template [ ] + (do (defn [module] + "(-> Text (Lux (,)))" + (fn [state] + (let [state* (update$ $host (fn [host] + (update$ $module-states + (fn [module-states] + (|put module (V nil) module-states)) + host)) + state)] + (V $Right (T state* nil))))) + (defn [module] + "(-> Text (Lux Bool))" + (fn [state] + (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))] + (V $Right (T state (|case module-state + () true + _ false))) + (V $Right (T state false))) + ))) + + flag-active-module active-module? $Active + flag-compiled-module compiled-module? $Compiled + flag-cached-module cached-module? $Cached + ) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 759fc98fc..d6bbb17ae 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -483,8 +483,8 @@ (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&&cache/delete name) - _ (&a-module/enter-module name) + (|do [_ (&a-module/enter-module name) + _ (&/flag-active-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) @@ -529,7 +529,8 @@ .visitEnd) (.visitEnd)) ;; _ (prn 'CLOSED name =class) - ]] + ] + _ (&/flag-compiled-module name)] (&&/save-class! &/module-class-name (.toByteArray =class))) ?state) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 3532cf843..d4ce7516d 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -89,8 +89,9 @@ ;; _ (prn 'load/IMPORTS module imports) ] (|do [loads (&/map% (fn [_import] - (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux"))] - (load _import (hash content) compile-module))) + (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux")) + _ (load _import (hash content) compile-module)] + (&/cached-module? _import))) (if (= [""] imports) &/Nil$ (&/->list imports)))] @@ -120,6 +121,7 @@ &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) + _ (&/flag-cached-module module) _ (&a-module/set-imports imports) _ (&/map% (fn [_def] (let [[_exported? _name _ann] (string/split _def #" ") -- cgit v1.2.3 From 8a67a7e51b3875c3ebba4e8d0acbd275aaa2c356 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 14 Sep 2015 23:27:38 -0400 Subject: - Added the possibility to define anonymous classes. - Fixed some bugs. --- source/lux/codata/state.lux | 10 +- source/lux/control/enum.lux | 2 +- source/lux/data/io.lux | 5 + source/lux/data/number/int.lux | 2 +- source/lux/host/jvm.lux | 330 +++++++++++++++++++++++------------------ source/lux/meta/syntax.lux | 15 +- src/lux/analyser.clj | 62 ++++---- src/lux/analyser/host.clj | 307 ++++++++++++++++++++++---------------- src/lux/base.clj | 5 +- src/lux/compiler.clj | 24 +-- src/lux/compiler/host.clj | 166 +++++++++++++-------- src/lux/host.clj | 69 +++++++-- src/lux/type.clj | 6 +- 13 files changed, 607 insertions(+), 396 deletions(-) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index de7220a45..311fce320 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -23,11 +23,17 @@ (Monad (State s))) (def _functor State/Functor) - (def (wrap x) + (def (wrap a) (lambda [state] - [state x])) + [state a])) (def (join mma) (lambda [state] (let [[state' ma] (mma state)] (ma state'))))) + +## [Functions] +(def #export (run-state state action) + (All [s a] (-> s (State s a) a)) + (let [[state' output] (action state)] + output)) diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux index c54eab75b..4ce368e96 100644 --- a/source/lux/control/enum.lux +++ b/source/lux/control/enum.lux @@ -13,7 +13,7 @@ (: (-> e e) pred)) ## [Functions] -(def #export (range' <= succ from to) +(def (range' <= succ from to) (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) (if (<= from to) (#;Cons from (range' <= succ (succ from) to)) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index a0bfda3e0..973d37e38 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -35,3 +35,8 @@ (def (join mma) (mma []))) + +## [Functions] +(def #export (run-io io) + (All [a] (-> (IO a) a)) + (io [])) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index 20ea5fced..ea58cac17 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -58,7 +58,7 @@ [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) ## Enum -(defstruct Int/Enum (EN;Enum Int) +(defstruct #export Int/Enum (EN;Enum Int) (def _ord Int/Ord) (def succ (lambda [n] (:: Int/Number (N;+ n 1)))) (def pred (lambda [n] (:: Int/Number (N;- n 1))))) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 710bc9a20..1e903ad1d 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -6,98 +6,202 @@ (;import lux (lux (control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do seq%))) + (monad #as M #refer (#only do seq%)) + (enum #as E)) (data (list #refer #all #open ("" List/Functor List/Fold)) - (number/int #refer #all #open ("i:" Int/Ord)) + (number/int #refer #all #open ("i:" Int/Ord Int/Number)) maybe - tuple) + tuple + (text #open ("text:" Text/Monoid))) (meta lux ast syntax))) (open List/Monad "list:") +## [Types] +(defsyntax #export (Array [dimensions (?^ nat^)] type) + (emit (@list (foldL (lambda [inner _] (` (#;DataT "#Array" (@list (~ inner))))) + type + (repeat (? 1 dimensions) []))))) + ## [Utils] +## Types +(deftype StackFrame (^ java.lang.StackTraceElement)) +(deftype StackTrace (Array StackFrame)) + +(deftype Modifier Text) +(deftype JvmType Text) + +(deftype MemberDecl + (& #member-modifiers (List Modifier) + #member-name Text)) + +(deftype FieldDecl + JvmType) + +(deftype MethodDecl + (& #method-inputs (List JvmType) + #method-output JvmType)) + +(deftype ArgDecl + (& #arg-name Text + #arg-type JvmType)) + +(deftype MethodDef + (& #method-vars (List ArgDecl) + #return-type JvmType + #return-body AST)) + +(deftype ExpectedInput + (& #opt-input? Bool + #input-type JvmType)) + +(deftype ExpectedOutput + (& #ex-output? Bool + #opt-output? Bool + #output-type JvmType)) + +## Functions +(def (prepare-args args) + (-> (List ExpectedInput) (Lux (, (List AST) (List AST) (List AST) (List Text)))) + (do Lux/Monad + [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) + #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) + (lambda [[[opt? arg-class] var]] + (if opt? + [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) + (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) + (case (~ var) + (#;Some (~ var)) (~ var) + #;None ;_jvm_null))))] + [(` (^ (~ (symbol$ ["" arg-class])))) + (@list)]))) + (zip2 args vars)) + var-types (map first pairings) + var-rebinds (map second pairings) + arg-classes (map second args)]] + (wrap [vars var-types (list:join var-rebinds) arg-classes]))) + ## Parsers +(def member-decl^ + (Parser MemberDecl) + (&^ (*^ local-tag^) local-symbol^)) + (def method-decl^ - (Parser (, (List Text) Text (List Text) Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - inputs (tuple^ (*^ local-symbol^)) - output local-symbol^] - (wrap [modifiers name inputs output])))) + (Parser (, MemberDecl MethodDecl)) + (form^ (&^ member-decl^ + (&^ (tuple^ (*^ local-symbol^)) + local-symbol^)))) (def field-decl^ - (Parser (, (List Text) Text Text)) - (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ - class local-symbol^] - (wrap [modifiers name class])))) + (Parser (, MemberDecl FieldDecl)) + (form^ (&^ member-decl^ + local-symbol^))) (def arg-decl^ - (Parser (, Text Text)) - (form^ (do Parser/Monad - [arg-name local-symbol^ - arg-class local-symbol^] - (wrap [arg-name arg-class])))) + (Parser ArgDecl) + (form^ (&^ local-symbol^ local-symbol^))) (def method-def^ - (Parser (, (List Text) Text (List (, Text Text)) Text AST)) + (Parser (, MemberDecl MethodDef)) (form^ (do Parser/Monad - [modifiers (*^ local-tag^) - name local-symbol^ + [=member-decl member-decl^ inputs (tuple^ (*^ arg-decl^)) output local-symbol^ body id^] - (wrap [modifiers name inputs output body])))) + (wrap [=member-decl [inputs output body]])))) -(def opt-arg^ - (Parser (, Bool Text)) +(def exp-input^ + (Parser ExpectedInput) (&^ (tag?^ ["" "?"]) local-symbol^)) +(def exp-output^ + (Parser ExpectedOutput) + (do Parser/Monad + [ex? (tag?^ ["" "!"]) + opt? (tag?^ ["" "?"]) + return local-symbol^] + (wrap [ex? opt? return]))) + +## Generators +(def (gen-method-decl [[modifiers name] [inputs output]]) + (-> (, MemberDecl MethodDecl) AST) + (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))) + +(def (gen-field-decl [[modifiers name] class]) + (-> (, MemberDecl FieldDecl) AST) + (` ((~ (text$ name)) + (~ (text$ class)) + [(~@ (map text$ modifiers))]))) + +(def (gen-arg-decl [name type]) + (-> ArgDecl AST) + (form$ (@list (symbol$ ["" name]) (text$ type)))) + +(def (gen-method-def [[modifiers name] [inputs output body]]) + (-> (, MemberDecl MethodDef) AST) + (` ((~ (text$ name)) + [(~@ (map gen-arg-decl inputs))] + (~ (text$ output)) + [(~@ (map text$ modifiers))] + (~ body)))) + +(def (gen-expected-output [ex? opt? output] body) + (-> ExpectedOutput AST (, AST AST)) + (let [type (` (^ (~ (symbol$ ["" output])))) + [body type] (if opt? + [(` (;;??? (~ body))) + (` (Maybe (~ type)))] + [body type]) + [body type] (if ex? + [(` (;;try (~ body))) + (` (Either Text (~ type)))] + [body type])] + [body type])) + +## [Functions] +(def (stack-trace->text trace) + (-> StackTrace Text) + (let [size (_jvm_arraylength trace) + idxs (E;range Int/Enum 0 (i:+ -1 size))] + (|> idxs + (map (: (-> Int Text) + (lambda [idx] + (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload "java.lang.StackTraceElement" trace idx) [])))) + (interpose "\n") + (foldL text:++ "") + ))) + +(def (get-stack-trace t) + (-> (^ java.lang.Throwable) StackTrace) + (_jvm_invokevirtual "java.lang.Throwable" "getStackTrace" [] t [])) + +(def #export (throwable->text t) + ($ text:++ + (_jvm_invokevirtual "java.lang.Object" "toString" [] t []) + "\n" + (|> t get-stack-trace stack-trace->text))) + ## [Syntax] (defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (let [members' (map (: (-> (, (List Text) Text (List Text) Text) AST) - (lambda [member] - (let [[modifiers name inputs output] member] - (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))))) - members)] - (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ members'))))))) + (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + (~@ (map gen-method-decl members))))))) (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [fields (*^ field-decl^)] [methods (*^ method-def^)]) - (do Lux/Monad - [current-module get-module-name - #let [fields' (map (: (-> (, (List Text) Text Text) AST) - (lambda [field] - (let [[modifiers name class] field] - (` ((~ (text$ name)) - (~ (text$ class)) - [(~@ (map text$ modifiers))]))))) - fields) - methods' (map (: (-> (, (List Text) Text (List (, Text Text)) Text AST) AST) - (lambda [methods] - (let [[modifiers name inputs output body] methods] - (` ((~ (text$ name)) - [(~@ (map (: (-> (, Text Text) AST) - (lambda [in] - (let [[left right] in] - (form$ (@list (symbol$ ["" left]) - (text$ right)))))) - inputs))] - (~ (text$ output)) - [(~@ (map text$ modifiers))] - (~ body)))))) - methods)]] - (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) - [(~@ (map text$ interfaces))] - [(~@ fields')] - [(~@ methods')])))))) + (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ (map gen-field-decl fields))] + [(~@ (map gen-method-def methods))]))))) + +(defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [methods (*^ method-def^)]) + (emit (@list (` (;_jvm_anon-class (~ (text$ super)) + [(~@ (map text$ interfaces))] + [(~@ (map gen-method-def methods))]))))) (defsyntax #export (program [args symbol^] body) (emit (@list (` (;_jvm_program (~ (symbol$ args)) @@ -105,24 +209,16 @@ (defsyntax #export (??? expr) (do Lux/Monad - [g!val (gensym "")] - (emit (@list (` (let [(~ g!val) (~ expr)] - (if (;_jvm_null? (~ g!val)) + [g!temp (gensym "")] + (wrap (@list (` (let [(~ g!temp) (~ expr)] + (if (;_jvm_null? (~ g!temp)) #;None - (#;Some (~ g!val))))))))) + (#;Some (~ g!temp))))))))) (defsyntax #export (try expr) (emit (@list (` (;_jvm_try (#;Right (~ expr)) (~ (' (_jvm_catch "java.lang.Exception" e - (#;Left (_jvm_invokevirtual "java.lang.Throwable" "getMessage" [] e [])))))))))) - -(defsyntax #export (Array [dimensions (?^ int^)] type) - (let [dimensions (? 1 dimensions)] - (if (i:> dimensions 0) - (emit (@list (foldL (lambda [inner _] (` (#;DataT "Array" (@list (~ inner))))) - type - (repeat dimensions [])))) - (fail "Array must have positive dimension.")))) + (#;Left (throwable->text e)))))))))) (defsyntax #export (instance? [class local-symbol^] obj) (emit (@list (` (;_jvm_instanceof (~ (text$ class)) (~ obj)))))) @@ -142,64 +238,26 @@ (defsyntax #export (null? obj) (emit (@list (` (;_jvm_null? (~ obj)))))) -(def (prepare-args args) - (-> (List (, Bool Text)) (Lux (, (List AST) (List AST) (List AST) (List Text)))) +(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [ex? (tag?^ ["" "!"])]) (do Lux/Monad - [vars (seq% Lux/Monad (repeat (size args) (gensym ""))) - #let [pairings (map (: (-> (, (, Bool Text) AST) (, AST (List AST))) - (lambda [[[opt? arg-class] var]] - (if opt? - [(` (Maybe (^ (~ (symbol$ ["" arg-class]))))) - (@list var (` (: (^ (~ (symbol$ ["" arg-class]))) - (case (~ var) - (#;Some (~ var)) (~ var) - #;None ;_jvm_null))))] - [(` (^ (~ (symbol$ ["" arg-class])))) - (@list)]))) - (zip2 args vars)) - var-types (map first pairings) - var-rebinds (map second pairings) - arg-classes (map second args)]] - (wrap [vars var-types (list:join var-rebinds) arg-classes]))) - -(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ opt-arg^))]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args)] - (case vars - (\ (@list)) - (do Lux/Monad - [g!_ (gensym "")] - (wrap (@list (` (: (-> (,) (^ (~ (symbol$ ["" class])))) - (lambda [(~ g!_)] - (;_jvm_new (~ (text$ class)) [] []))))))) - - _ - (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) - (lambda [[(~@ vars)]] - (let [(~@ var-rebinds)] - (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)]))))))) - ))) + [[vars var-types var-rebinds arg-classes] (prepare-args args) + #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)])) + new-expr (if ex? + (` (try (~ new-expr))) + new-expr)]] + (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) + (lambda [[(~@ vars)]] + (let [(~@ var-rebinds)] + (~ new-expr))))))))) (do-template [ ] - [(defsyntax #export ( [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] - [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) + [(defsyntax #export ( [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] + [expected-output exp-output^]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) g!self (gensym "self") - g!temp (gensym "temp") - #let [return-type (` (^ (~ (symbol$ ["" return])))) - body (` ( (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])) - [body return-type] (if opt? - [(` (let [(~ g!temp) (~ body)] - (if (;_jvm_null? (~ g!temp)) - #;None - (#;Some (~ g!temp))))) - (` (Maybe (~ return-type)))] - [body return-type]) - [body return-type] (if ex? - [(` (try (~ body))) - (` (Either Text (~ return-type)))] - [body return-type])]] + #let [[body return-type] (gen-expected-output expected-output + (` ( (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])))]] (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) (lambda [[(~@ vars)] (~ g!self)] (let [(~@ var-rebinds)] @@ -210,24 +268,12 @@ [invoke-interface$ ;_jvm_invokeinterface] ) -(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ opt-arg^))] - [ex? (tag?^ ["" "!"])] [opt? (tag?^ ["" "?"])] [return local-symbol^]) +(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] + [expected-output exp-output^]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) - g!temp (gensym "temp") - #let [return-type (` (^ (~ (symbol$ ["" return])))) - body (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])) - [body return-type] (if opt? - [(` (let [(~ g!temp) (~ body)] - (if (;_jvm_null? (~ g!temp)) - #;None - (#;Some (~ g!temp))))) - (` (Maybe (~ return-type)))] - [body return-type]) - [body return-type] (if ex? - [(` (try (~ body))) - (` (Either Text (~ return-type)))] - [body return-type])]] + #let [[body return-type] (gen-expected-output expected-output + (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])))]] (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) (lambda [[(~@ vars)]] (let [(~@ var-rebinds)] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index a28fa6d27..d47780798 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -13,7 +13,7 @@ (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) (list #refer #all #open ("" List/Fold)) - (number (int #open ("i" Int/Eq)) + (number (int #open ("i" Int/Ord)) (real #open ("r" Real/Eq)))))) ## [Utils] @@ -84,6 +84,19 @@ [ tag^ Ident #;TagS] ) +(def #export (assert v tokens) + (-> Bool (Parser (,))) + (if v + (#;Some [tokens []]) + #;None)) + +(def #export nat^ + (Parser Int) + (do Parser/Monad + [n int^ + _ (assert (i>= n 0))] + (wrap n))) + (do-template [ ] [(def #export ( tokens) (Parser Text) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 03709b226..a412362d9 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -71,85 +71,85 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) (&&host/analyse-jvm-znewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-zastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-zaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-bnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-bastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-baload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-snewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-sastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-saload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-inewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-iastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-iaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-lnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-lastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-laload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-fnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-fastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-faload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-dnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-dastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-daload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-cnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-castore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-caload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-anewarray analyse ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil))))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))) (&&host/analyse-jvm-aastore analyse ?class ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))) (&&host/analyse-jvm-aaload analyse ?class ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) @@ -173,6 +173,14 @@ (|do [=supers (&/map% extract-text ?supers)] (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil)))))) + (|do [=interfaces (&/map% extract-text ?interfaces)] + (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces ?methods)) + ;; Programs (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] (&/$Cons [_ (&/$SymbolS "" ?args)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index db04a60c0..f6963d8bf 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -12,7 +12,9 @@ [type :as &type] [host :as &host]) (lux.analyser [base :as &&] - [env :as &&env]))) + [lambda :as &&lambda] + [env :as &&env]) + [lux.compiler.base :as &c!base])) ;; [Utils] (defn ^:private extract-text [ast] @@ -65,14 +67,6 @@ output))))) )) -(defn ^:private analyse-1+ [analyse token] - (&type/with-var - (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var token) - :let [[item type] =expr] - =type (&type/clean $var type)] - (return (&/T item =type)))))) - (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" (|case token @@ -215,7 +209,7 @@ (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T class method classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type class object] - (|do [=object (analyse-1+ analyse object) + (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] @@ -258,14 +252,14 @@ (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T class method classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type object] - (|do [=object (analyse-1+ analyse object) + (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null" &/Nil$)] + (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) @@ -280,18 +274,23 @@ (do-template [ ] (let [elem-type (&type/Data$ &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type)) + length-type &type/Int + idx-type &type/Int] (defn [analyse length] - (return (&/|list (&/T (&/V length) array-type)))) + (|do [=length (&&/analyse-1 analyse length-type length)] + (return (&/|list (&/T (&/V =length) array-type))))) (defn [analyse array idx] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V (&/T =array idx)) elem-type))))) + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx)] + (return (&/|list (&/T (&/V (&/T =array =idx)) elem-type))))) (defn [analyse array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V (&/T =array idx =elem)) array-type))))) + (return (&/|list (&/T (&/V (&/T =array =idx =elem)) array-type))))) ) "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore @@ -304,30 +303,35 @@ "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore ) -(defn analyse-jvm-anewarray [analyse class length] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class length)) array-type))))) - -(defn analyse-jvm-aaload [analyse class array idx] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array idx)) elem-type)))))) +(let [length-type &type/Int + idx-type &type/Int] + (defn analyse-jvm-anewarray [analyse class length] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=length (&&/analyse-1 analyse length-type length)] + (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class =length)) array-type)))))) + + (defn analyse-jvm-aaload [analyse class array idx] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx)] + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array =idx)) elem-type)))))) -(defn analyse-jvm-aastore [analyse class array idx elem] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array idx =elem)) array-type)))))) + (defn analyse-jvm-aastore [analyse class array idx elem] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem)] + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array =idx =elem)) array-type))))))) (let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] (defn analyse-jvm-arraylength [analyse array] (&type/with-var (fn [$var] (let [elem-type $var - array-type (&type/Data$ "Array" (&/|list elem-type))] + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array)] (return (&/|list (&/T (&/V &&/$jvm-arraylength =array) length-type))))))))) @@ -367,68 +371,85 @@ :concurrency nil} modifiers)) -(defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] - (|do [class-loader &/loader - abstract-methods (&/flat-map% (partial &host/abstract-methods class-loader) (&/Cons$ ?super-class ?interfaces)) - =fields (&/map% (fn [?field] - (|case ?field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Nil)))))] - (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] - (return {:name ?field-name - :modifiers =field-modifiers - :type ?field-type})) - - _ - (fail "[Analyser Error] Wrong syntax for field."))) - ?fields) - =methods (&/map% (fn [?method] - (|case ?method - [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?method-inputs)] - (&/$Cons [_ (&/$TextS ?method-output)] - (&/$Cons [_ (&/$TupleS ?method-modifiers)] - (&/$Cons ?method-body - (&/$Nil)))))))]] - (|do [=method-inputs (&/map% (fn [minput] - (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] - (&/$Cons [_ (&/$TextS ?input-type)] - (&/$Nil))))] - (return (&/T ?input-name ?input-type)) - - _ - (fail "[Analyser Error] Wrong syntax for method input."))) - ?method-inputs) - =method-modifiers (analyse-modifiers ?method-modifiers) - =method-body (&/with-scope (str ?name "_" ?idx) - (&/fold (fn [body* input*] - (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) - body*))) - (if (= "void" ?method-output) - (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) &/Nil$) ?method-body)) - (&/|reverse (if (:static? =method-modifiers) - =method-inputs - (&/Cons$ (&/T "this" ?super-class) - =method-inputs)))))] - (return {:name ?method-name - :modifiers =method-modifiers - :inputs (&/|map &/|second =method-inputs) - :output ?method-output - :body =method-body})) - - _ - (fail "[Analyser Error] Wrong syntax for method."))) - (&/enumerate ?methods)) - ;; Test for method completion +(defn ^:private analyse-field [field] + (|case field + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Nil)))))] + (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] + (return {:name ?field-name + :modifiers =field-modifiers + :type ?field-type})) + + _ + (fail "[Analyser Error] Wrong syntax for field."))) + +(defn ^:private analyse-method [analyse name owner-class method] + (|case method + [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons method-body + (&/$Nil)))))))]] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-inputs (&/map% (fn [minput] + (|case minput + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] + (&/$Cons [_ (&/$TextS input-type)] + (&/$Nil))))] + (return (&/T input-name input-type)) + + _ + (fail "[Analyser Error] Wrong syntax for method input."))) + method-inputs) + =method-body (&/fold (fn [body* input*] + (|let [[iname itype] input*] + (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) + body*))) + (if (= "void" method-output) + (&&/analyse-1+ analyse method-body) + (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body)) + (&/|reverse (&/Cons$ (&/T "this" owner-class) + =method-inputs)))] + (return {:name method-name + :modifiers =method-modifiers + :inputs (&/|map &/|second =method-inputs) + :output method-output + :body =method-body})) + + _ + (fail "[Analyser Error] Wrong syntax for method."))) + +(defn ^:private analyse-method-decl [method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Cons [_ (&/$TupleS modifiers)] + (&/$Nil))))))] + (|do [=inputs (&/map% extract-text inputs) + =modifiers (analyse-modifiers modifiers)] + (return {:name method-name + :modifiers =modifiers + :inputs =inputs + :output output})) + + _ + (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List ClassName) (List MethodDesc) (Lux (,)))" + (|do [abstract-methods (mandatory-methods supers) :let [methods-map (&/fold (fn [mmap mentry] (assoc mmap (:name mentry) mentry)) {} - =methods) + methods) missing-method (&/fold (fn [missing abs-meth] (|let [[am-name am-inputs] abs-meth] (or missing @@ -442,36 +463,74 @@ am-name)) am-name)))) nil - abstract-methods)] - _ (if (nil? missing-method) - (return nil) - (fail (str "[Analyser Error] Missing method: " missing-method))) - _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) - ;; :let [_ (prn 'analyse-jvm-class ?name ?super-class)] - ] - (return &/Nil$))) + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (fail (str "[Analyser Error] Missing method: " missing-method))))) + +(defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods] + (&/with-closure + (|do [module &/get-module-name + ;; :let [_ (prn 'analyse-jvm-class/_0)] + =fields (&/map% analyse-field fields) + ;; :let [_ (prn 'analyse-jvm-class/_1)] + =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + ;; :let [_ (prn 'analyse-jvm-class/_2)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-class/_3)] + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods nil))) + :let [_ (println 'DEF (str module "." name))]] + (return &/Nil$)))) (defn analyse-jvm-interface [analyse compile-token name supers methods] - (|do [=methods (&/map% (fn [method] - (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TextS output)] - (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Nil))))))] - (|do [=inputs (&/map% extract-text inputs) - =modifiers (analyse-modifiers modifiers)] - (return {:name method-name - :modifiers =modifiers - :inputs =inputs - :output output})) - - _ - (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - methods) - _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))] + (|do [module &/get-module-name + =methods (&/map% analyse-method-decl methods) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods))) + :let [_ (println 'DEF (str module "." name))]] (return &/Nil$))) +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [(&&/$captured _ _ source) _]] + source)) + +(let [captured-slot-modifier {:visibility "private" + :static? false + :final? false + :abstract? false + :concurrency nil} + captured-slot-type "java.lang.Object"] + (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods] + (&/with-closure + (|do [;; :let [_ (prn 'analyse-jvm-anon-class/_0 super-class)] + module &/get-module-name + scope &/get-scope-name + ;; :let [_ (prn 'analyse-jvm-anon-class/_1 super-class)] + :let [name (&host/location (&/|tail scope)) + anon-class (str module "." name)] + ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] + =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] + =captured &&env/captured-vars + :let [=fields (&/|map (fn [idx+capt] + {:name (str &c!base/closure-prefix (aget idx+capt 0)) + :modifiers captured-slot-modifier + :type captured-slot-type}) + (&/enumerate =captured)) + ;; _ (prn '=methods (&/adt->text (&/|map :body =methods))) + ;; =methods* (rename-captured-vars) + ] + :let [sources (&/|map captured-source =captured)] + ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] + ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured))) + :let [_ (println 'DEF anon-class)]] + (return (&/|list (&/T (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) (&type/Data$ anon-class (&/|list))))) + ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources) + )))) + (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] @@ -485,19 +544,17 @@ (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally (&/$None) (return &/None$) - (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] - (|do [=ex (analyse-1+ analyse ?ex) - :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable" &/Nil$) _type)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) + (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex)] + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) exo-type))))) (do-template [ ] (defn [analyse exo-type ?monitor] - (|do [=monitor (analyse-1+ analyse ?monitor) + (|do [=monitor (&&/analyse-1+ analyse ?monitor) _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 4c5d8ae44..0e164f5d2 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -749,10 +749,11 @@ (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + (let [old-writer (->> state (get$ $host) (get$ $writer)) + output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) + (return* (update$ $host #(set$ $writer old-writer %) ?state) ?value) _ diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index d6bbb17ae..048b9ee1d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -405,23 +405,6 @@ ) )) -(defn ^:private compile-statement [syntax] - (|case syntax - (&a/$def ?name ?body) - (&&lux/compile-def compile-expression ?name ?body) - - (&a/$declare-macro ?module ?name) - (&&lux/compile-declare-macro compile-expression ?module ?name) - - (&a/$jvm-program ?body) - (&&host/compile-jvm-program compile-expression ?body) - - (&a/$jvm-interface ?name ?supers ?methods) - (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) - (defn ^:private compile-token [syntax] (|case syntax (&a/$def ?name ?body) @@ -436,8 +419,8 @@ (&a/$jvm-interface ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) + (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods ??env) + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods ??env) _ (compile-expression syntax))) @@ -483,7 +466,8 @@ (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) + (|do [_ (&&cache/delete name) + _ (&a-module/enter-module name) _ (&/flag-active-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 83c769b4b..2ca613633 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -76,7 +76,7 @@ (&/$DataT "char" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - (&/$DataT _ (&/$Nil)) + (&/$DataT _ _) nil (&/$NamedT ?name ?type) @@ -290,16 +290,18 @@ (do-template [ ] (do (defn [compile *type* ?length] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitIntInsn Opcodes/NEWARRAY ))]] + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] (return nil))) (defn [compile *type* ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) (.visitInsn ) )]] (return nil))) @@ -307,9 +309,10 @@ (defn [compile *type* ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] _ (compile ?elem) :let [_ (doto *writer* @@ -329,25 +332,27 @@ (defn compile-jvm-anewarray [compile *type* ?class ?length] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] (return nil))) (defn compile-jvm-aaload [compile *type* ?class ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) - (.visitInsn Opcodes/AALOAD))]] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) (defn compile-jvm-aastore [compile *type* ?class ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] _ (compile ?elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) @@ -355,6 +360,7 @@ (defn compile-jvm-arraylength [compile *type* ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (doto *writer* (.visitInsn Opcodes/ARRAYLENGTH) (.visitInsn Opcodes/I2L) @@ -417,33 +423,75 @@ (&&/wrap-boolean))]] (return nil))) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] - (|do [module &/get-module-name] - (let [super-class* (&host/->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str module "/" ?name) nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) - (&host/->type-signature (:type field)) nil nil) - (.visitEnd))) - ?fields)] - (|do [_ (&/map% (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) - (:name method) - signature nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (.visitCode =method)] - _ (compile (:body method)) - :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ?methods)] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))))) +(defn ^:private compile-method [compile class-writer method] + ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) + ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) + ;; (prn 'compile-method/_2 (&/adt->text (:output method))) + ;; (prn 'compile-method/_3 (&/adt->text (:body method))) + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (&/with-writer (.visitMethod class-writer (modifiers->int (:modifiers method)) + (:name method) + signature nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (.visitCode =method)] + _ (compile (:body method)) + :let [_ (doto =method + (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + +(defn ^:private compile-method-decl [class-writer method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (.visitMethod class-writer (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + +(let [clo-field-sig (&host/->type-signature "java.lang.Object") + -return "V"] + (defn ^:private anon-class--signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + -return)) + + (defn ^:private add-anon-class- [class-writer class-name env] + (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "" (anon-class--signature env) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [(&a/$captured _ ?captured-id ?source) _]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ) + +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods env] + (|do [;; :let [_ (prn 'compile-jvm-class/_0)] + module &/get-module-name + ;; :let [_ (prn 'compile-jvm-class/_1)] + :let [full-name (str module "/" ?name) + super-class* (&host/->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil) + (.visitEnd))) + ?fields)] + ;; :let [_ (prn 'compile-jvm-class/_2)] + _ (&/map% (partial compile-method compile =class) ?methods) + ;; :let [_ (prn 'compile-jvm-class/_3)] + :let [_ (when env + (add-anon-class- =class full-name env))] + ;; :let [_ (prn 'compile-jvm-class/_4)] + ] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) (defn compile-jvm-interface [compile ?name ?supers ?methods] ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) @@ -451,11 +499,7 @@ (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) - _ (do (&/|map (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) - ?methods) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) @@ -467,14 +511,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -501,12 +545,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 9137f3874..eafd6a1ac 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -19,21 +19,45 @@ (def module-separator "/") (def class-name-separator ".") (def class-separator "/") +(def array-data-tag "#Array") +(def null-data-tag "#Null") ;; [Utils] +(def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") + +(comment + (let [class (class (to-array []))] + (str (if-let [pkg (.getPackage class)] + (str (.getName pkg) ".") + "") + (.getSimpleName class))) + + (.getName String) "java.lang.String" + + (.getName (class (to-array []))) "[Ljava.lang.Object;" + + (re-find class-name-re "java.lang.String") + ["java.lang.String" "java.lang.String" nil nil "java.lang.String"] + + (re-find class-name-re "[Ljava.lang.Object;") + ["[Ljava.lang.Object;" "[Ljava.lang.Object;" "[" "java.lang.Object" nil] + ) + (defn ^:private class->type [^Class class] "(-> Class Type)" - (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class)))] - (if (.equals "void" base) - &type/Unit - (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base) - &/Nil$) - ))) + (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + ;; (prn 'class->type/_1 class base arr-brackets) + (let [output-type (if (.equals "void" base) + &type/Unit + (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (&type/Data$ base &/Nil$) + (range (count (or arr-brackets "")))) + )] + ;; (prn 'class->type/_2 class (&type/show-type output-type)) + output-type) + )))) (defn ^:private method->type [^Method method] "(-> Method Type)" @@ -70,11 +94,31 @@ (str "L" class* ";"))) )) +(defn unfold-array [type] + "(-> Type (, Int Type))" + (|case type + (&/$DataT "#Array" (&/$Cons param (&/$Nil))) + (|let [[count inner] (unfold-array param)] + (&/T (inc count) inner)) + + _ + (&/T 0 type))) + (defn ->java-sig [^objects type] "(-> Type Text)" (|case type (&/$DataT ?name params) - (->type-signature ?name) + (cond (= array-data-tag ?name) (|let [[level base] (unfold-array type) + base-sig (|case base + (&/$DataT base-class _) + (->class base-class) + + _ + (->java-sig base))] + (str (->> (&/|repeat level "[") (&/fold str "")) + "L" base-sig ";")) + (= null-data-tag ?name) (->type-signature "java.lang.Object") + :else (->type-signature ?name)) (&/$LambdaT _ _) (->type-signature function-class) @@ -123,6 +167,7 @@ ) (defn lookup-constructor [class-loader target args] + ;; (prn 'lookup-constructor class-loader target (&type/as-obj target)) (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] (and (= (&/|length args) (&/|length param-types)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 8a1e11bed..baf834ee6 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -862,7 +862,7 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT "null" (&/$Nil))] + [(&/$DataT e!name e!params) (&/$DataT "#Null" (&/$Nil))] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) @@ -880,7 +880,9 @@ ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) ;; true) - (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) + (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) + (catch Exception e + (prn 'FAILED_HERE e!name a!name)))) (return (&/T fixpoints nil)) :else -- cgit v1.2.3 From d2a4aac2226b5cca59be236d3228fe5e5b17b8de Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 14 Sep 2015 23:37:10 -0400 Subject: - Renamed "this" to "_jvm_this". - Movied lux/data/io to lux/codata/io. --- source/lux/codata/io.lux | 42 ++++++++++++++++++++++++++++++++++++++++++ source/lux/data/io.lux | 42 ------------------------------------------ source/lux/host/io.lux | 4 ++-- src/lux/analyser/base.clj | 2 ++ src/lux/analyser/host.clj | 2 +- src/lux/analyser/lux.clj | 7 +++---- 6 files changed, 50 insertions(+), 49 deletions(-) create mode 100644 source/lux/codata/io.lux delete mode 100644 source/lux/data/io.lux diff --git a/source/lux/codata/io.lux b/source/lux/codata/io.lux new file mode 100644 index 000000000..195aef616 --- /dev/null +++ b/source/lux/codata/io.lux @@ -0,0 +1,42 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux (control (functor #as F) + (monad #as M)) + (data list))) + +## [Types] +(deftype #export (IO a) + (-> (,) a)) + +## [Syntax] +(defmacro #export (@io tokens state) + (case tokens + (\ (@list value)) + (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] + (#;Right [state (@list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for @io"))) + +## [Structures] +(defstruct #export IO/Functor (F;Functor IO) + (def (map f ma) + (@io (f (ma []))))) + +(defstruct #export IO/Monad (M;Monad IO) + (def _functor IO/Functor) + + (def (wrap x) + (@io x)) + + (def (join mma) + (mma []))) + +## [Functions] +(def #export (run-io io) + (All [a] (-> (IO a) a)) + (io [])) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux deleted file mode 100644 index 973d37e38..000000000 --- a/source/lux/data/io.lux +++ /dev/null @@ -1,42 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (functor #as F) - (monad #as M))) - (.. list)) - -## [Types] -(deftype #export (IO a) - (-> (,) a)) - -## [Syntax] -(defmacro #export (@io tokens state) - (case tokens - (\ (@list value)) - (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] - (#;Right [state (@list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) - - _ - (#;Left "Wrong syntax for @io"))) - -## [Structures] -(defstruct #export IO/Functor (F;Functor IO) - (def (map f ma) - (@io (f (ma []))))) - -(defstruct #export IO/Monad (M;Monad IO) - (def _functor IO/Functor) - - (def (wrap x) - (@io x)) - - (def (join mma) - (mma []))) - -## [Functions] -(def #export (run-io io) - (All [a] (-> (IO a) a)) - (io [])) diff --git a/source/lux/host/io.lux b/source/lux/host/io.lux index 99e15722d..220f089a2 100644 --- a/source/lux/host/io.lux +++ b/source/lux/host/io.lux @@ -4,8 +4,8 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (data io - (list #refer #all #open ("" List/Fold))) + (lux (data (list #refer #all #open ("" List/Fold))) + (codata io) (meta ast syntax lux) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 8df7f23b2..b12425ac7 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -155,6 +155,8 @@ (|let [[_ type] syntax+] type)) +(def jvm-this "_jvm_this") + (defn cap-1 [action] (|do [result action] (|case result diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index f6963d8bf..681f22168 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -411,7 +411,7 @@ (if (= "void" method-output) (&&/analyse-1+ analyse method-body) (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body)) - (&/|reverse (&/Cons$ (&/T "this" owner-class) + (&/|reverse (&/Cons$ (&/T &&/jvm-this owner-class) =method-inputs)))] (return {:name method-name :modifiers =method-modifiers diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 3de4db89f..6546990e6 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -275,10 +275,9 @@ endo-type)))) state) - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) - (fail* "_{_ analyse-symbol _}_"))) + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) + (fail* ""))) (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) -- cgit v1.2.3 From 5dafb9ad900f990a14e280db2e00fb668a6606b9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 00:31:35 -0400 Subject: - Compiler now takes into consideration exceptions that can be thrown by constructors. - Changed the order of parameters in UnivQ & ExQ (even params are now arguments & odd params are now the UnivQ/ExQ types). --- source/lux.lux | 86 +++++++++++++++++++++++------------------------ src/lux/analyser/case.clj | 2 +- src/lux/analyser/host.clj | 3 +- src/lux/host.clj | 2 +- src/lux/type.clj | 50 +++++++++++++-------------- 5 files changed, 72 insertions(+), 71 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index ee01c8bdf..4571529a0 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -49,8 +49,8 @@ (1 (1 ## "lux;Nil" (2 (0)) (1 ## "lux;Cons" - (2 (1 (4 1) - (1 (9 (4 0) (4 1)) + (2 (1 (4 0) + (1 (9 (4 1) (4 0)) (0)))) (0))))))) (_lux_export List) @@ -65,7 +65,7 @@ (1 (1 ## "lux;None" (2 (0)) (1 ## "lux;Some" - (4 1) + (4 0) (0))))))) (_lux_export Maybe) (_lux_declare-tags [#None #Some] Maybe) @@ -84,7 +84,7 @@ ## )) (_lux_def Type (10 ["lux" "Type"] - (_lux_case (9 (4 0) (4 1)) + (_lux_case (9 (4 1) (4 0)) Type (_lux_case (9 List Type) TypeList @@ -127,8 +127,8 @@ Int (#Cons ## "lux;mappings" (#AppT List - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) + (#TupleT (#Cons (#BoundT 2) + (#Cons (#BoundT 0) #Nil)))) #Nil))))))) (_lux_export Bindings) @@ -148,11 +148,11 @@ (#Cons ## "lux;inner-closures" Int (#Cons ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT 3)) - (#BoundT 1)) + (#AppT (#AppT Bindings (#BoundT 2)) + (#BoundT 0)) (#Cons ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT 3)) - (#BoundT 1)) + (#AppT (#AppT Bindings (#BoundT 2)) + (#BoundT 0)) #Nil))))))))) (_lux_export Env) (_lux_declare-tags [#name #inner-closures #locals #closure] Env) @@ -174,8 +174,8 @@ (#NamedT ["lux" "Meta"] (#UnivQ #Nil (#UnivQ #Nil - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) + (#TupleT (#Cons (#BoundT 2) + (#Cons (#BoundT 0) #Nil))))))) (_lux_export Meta) (_lux_declare-tags [#meta #datum] Meta) @@ -193,9 +193,9 @@ ## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) (_lux_def AST' (#NamedT ["lux" "AST'"] - (_lux_case (#AppT (#BoundT 1) - (#AppT (#BoundT 0) - (#BoundT 1))) + (_lux_case (#AppT (#BoundT 0) + (#AppT (#BoundT 1) + (#BoundT 0))) AST (_lux_case (#AppT [List AST]) ASTList @@ -245,9 +245,9 @@ (#UnivQ #Nil (#UnivQ #Nil (#VariantT (#Cons ## "lux;Left" - (#BoundT 3) + (#BoundT 2) (#Cons ## "lux;Right" - (#BoundT 1) + (#BoundT 0) #Nil))))))) (_lux_export Either) (_lux_declare-tags [#Left #Right] Either) @@ -257,10 +257,10 @@ (_lux_def StateE (#UnivQ #Nil (#UnivQ #Nil - (#LambdaT (#BoundT 3) + (#LambdaT (#BoundT 2) (#AppT (#AppT Either Text) - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) + (#TupleT (#Cons (#BoundT 2) + (#Cons (#BoundT 0) #Nil)))))))) ## (deftype Source @@ -303,7 +303,7 @@ (#Cons ## "lux;TypeD" Type (#Cons ## "lux;MacroD" - (#BoundT 1) + (#BoundT 0) (#Cons ## "lux;AliasD" Ident #Nil)))))))) @@ -337,7 +337,7 @@ (#Cons ## "lux;defs" (#AppT List (#TupleT (#Cons Text (#Cons (#TupleT (#Cons Bool (#Cons (#AppT DefData' (#LambdaT ASTList - (#AppT (#AppT StateE (#BoundT 1)) + (#AppT (#AppT StateE (#BoundT 0)) ASTList))) #Nil))) #Nil)))) @@ -382,7 +382,7 @@ Cursor (#Cons ## "lux;modules" (#AppT List (#TupleT (#Cons Text - (#Cons (#AppT Module (#AppT (#BoundT 0) (#BoundT 1))) + (#Cons (#AppT Module (#AppT (#BoundT 1) (#BoundT 0))) #Nil)))) (#Cons ## "lux;envs" (#AppT List (#AppT (#AppT Env Text) @@ -441,11 +441,11 @@ ## ...) (_lux_def return (_lux_: (#UnivQ #Nil - (#LambdaT (#BoundT 1) + (#LambdaT (#BoundT 0) (#LambdaT Compiler (#AppT (#AppT Either Text) (#TupleT (#Cons Compiler - (#Cons (#BoundT 1) + (#Cons (#BoundT 0) #Nil))))))) (_lux_lambda _ val (_lux_lambda _ state @@ -462,7 +462,7 @@ (#LambdaT Compiler (#AppT (#AppT Either Text) (#TupleT (#Cons Compiler - (#Cons (#BoundT 1) + (#Cons (#BoundT 0) #Nil))))))) (_lux_lambda _ msg (_lux_lambda _ state @@ -678,9 +678,9 @@ (def'' (map f xs) (#UnivQ #Nil (#UnivQ #Nil - (#LambdaT (#LambdaT (#BoundT 3) (#BoundT 1)) - (#LambdaT ($' List (#BoundT 3)) - ($' List (#BoundT 1)))))) + (#LambdaT (#LambdaT (#BoundT 2) (#BoundT 0)) + (#LambdaT ($' List (#BoundT 2)) + ($' List (#BoundT 0)))))) (_lux_case xs #Nil #Nil @@ -793,8 +793,8 @@ (def'' (parse-univq-args args next) ## (All [a] (-> (List AST) (-> (List Text) (Lux a)) (Lux a))) (#UnivQ #Nil (#LambdaT ($' List AST) - (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 1))) - (#AppT (#AppT StateE Compiler) (#BoundT 1))))) + (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 0))) + (#AppT (#AppT StateE Compiler) (#BoundT 0))))) (_lux_case args #Nil (next #Nil) @@ -811,12 +811,12 @@ (def'' (foldL f init xs) ## (All [a b] (-> (-> a b a) a (List b) a)) - (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 3) - (#LambdaT (#BoundT 1) - (#BoundT 3))) - (#LambdaT (#BoundT 3) - (#LambdaT ($' List (#BoundT 1)) - (#BoundT 3)))))) + (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 2) + (#LambdaT (#BoundT 0) + (#BoundT 2))) + (#LambdaT (#BoundT 2) + (#LambdaT ($' List (#BoundT 0)) + (#BoundT 2)))))) (_lux_case xs #Nil init @@ -839,9 +839,9 @@ (lambda'' [body' name'] (form$ (#Cons (tag$ ["lux" "UnivQ"]) (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) + (#Cons (replace-syntax (#Cons [name' (make-bound 0)] #Nil) (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) + (replace-syntax (#Cons [self-name (make-bound -1)] #Nil) body) names) (return (#Cons body' #Nil))))) @@ -865,9 +865,9 @@ (lambda'' [body' name'] (form$ (#Cons (tag$ ["lux" "ExQ"]) (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) + (#Cons (replace-syntax (#Cons [name' (make-bound 0)] #Nil) (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) + (replace-syntax (#Cons [self-name (make-bound -1)] #Nil) body) names) (return (#Cons body' #Nil))))) @@ -1799,7 +1799,7 @@ (defmacro' #export (Rec tokens) (_lux_case tokens (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) - (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)] + (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 1)) (~ (make-bound 0))))]) body)] (return (@list (` (#AppT (#UnivQ #Nil (~ body')) Void))))) _ @@ -2300,7 +2300,7 @@ (-> Type Type (Maybe Type)) (case type-fn (#UnivQ env body) - (#Some (beta-reduce (@list& type-fn param env) body)) + (#Some (beta-reduce (@list& param type-fn env) body)) (#AppT F A) (do Maybe/Monad diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 109ba7c41..c6806a627 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -68,7 +68,7 @@ (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/Cons$ (&/T _aenv 1 $var) (&/|map update-up-frame up)) =type)))) + (adjust-type* (&/Cons$ (&/T _aenv 0 $var) (&/|map update-up-frame up)) =type)))) (&/$TupleT ?members) (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 681f22168..f17be2a7c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -265,9 +265,10 @@ (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader - =return (&host/lookup-constructor class-loader class classes) + [=return exceptions] (&host/lookup-constructor class-loader class classes) =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) + _ (ensure-catching exceptions) :let [output-type (&type/Data$ class &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-new (&/T class classes =args)) output-type))))) diff --git a/src/lux/host.clj b/src/lux/host.clj index eafd6a1ac..6be162bf7 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -176,7 +176,7 @@ args (&/|map #(.getName ^Class %) param-types))))] =method))] - (return &type/Unit) + (return (&/T &type/Unit (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %))))) (fail (str "[Host Error] Constructor does not exist: " target)))) (defn abstract-methods [class-loader class] diff --git a/src/lux/type.clj b/src/lux/type.clj index baf834ee6..d6275651e 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -58,7 +58,7 @@ (def IO (Named$ (&/T "lux/data" "IO") (Univ$ empty-env - (Lambda$ Unit (Bound$ 1))))) + (Lambda$ Unit (Bound$ 0))))) (def List (Named$ (&/T "lux" "List") @@ -67,9 +67,9 @@ ;; lux;Nil Unit ;; lux;Cons - (Tuple$ (&/|list (Bound$ 1) - (App$ (Bound$ 0) - (Bound$ 1)))) + (Tuple$ (&/|list (Bound$ 0) + (App$ (Bound$ 1) + (Bound$ 0)))) ))))) (def Maybe @@ -79,12 +79,12 @@ ;; lux;None Unit ;; lux;Some - (Bound$ 1) + (Bound$ 0) ))))) (def Type (Named$ (&/T "lux" "Type") - (let [Type (App$ (Bound$ 0) (Bound$ 1)) + (let [Type (App$ (Bound$ 1) (Bound$ 0)) TypeList (App$ List Type) TypePair (Tuple$ (&/|list Type Type))] (App$ (Univ$ empty-env @@ -123,13 +123,13 @@ Int ;; "lux;mappings" (App$ List - (Tuple$ (&/|list (Bound$ 3) - (Bound$ 1)))))))))) + (Tuple$ (&/|list (Bound$ 2) + (Bound$ 0)))))))))) (def Env (Named$ (&/T "lux" "Env") - (let [bindings (App$ (App$ Bindings (Bound$ 3)) - (Bound$ 1))] + (let [bindings (App$ (App$ Bindings (Bound$ 2)) + (Bound$ 0))] (Univ$ empty-env (Univ$ empty-env (Tuple$ @@ -152,14 +152,14 @@ (Named$ (&/T "lux" "Meta") (Univ$ empty-env (Univ$ empty-env - (Tuple$ (&/|list (Bound$ 3) - (Bound$ 1))))))) + (Tuple$ (&/|list (Bound$ 2) + (Bound$ 0))))))) (def AST* (Named$ (&/T "lux" "AST'") - (let [AST* (App$ (Bound$ 1) - (App$ (Bound$ 0) - (Bound$ 1))) + (let [AST* (App$ (Bound$ 0) + (App$ (Bound$ 1) + (Bound$ 0))) AST*List (App$ List AST*)] (Univ$ empty-env (Variant$ (&/|list @@ -198,17 +198,17 @@ (Univ$ empty-env (Variant$ (&/|list ;; &/$Left - (Bound$ 3) + (Bound$ 2) ;; &/$Right - (Bound$ 1))))))) + (Bound$ 0))))))) (def StateE (Univ$ empty-env (Univ$ empty-env - (Lambda$ (Bound$ 3) + (Lambda$ (Bound$ 2) (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ 3) - (Bound$ 1)))))))) + (Tuple$ (&/|list (Bound$ 2) + (Bound$ 0)))))))) (def Source (Named$ (&/T "lux" "Source") @@ -238,7 +238,7 @@ ;; "lux;TypeD" Type ;; "lux;MacroD" - (Bound$ 1) + (Bound$ 0) ;; "lux;AliasD" Ident )))) @@ -263,7 +263,7 @@ (Tuple$ (&/|list Bool (App$ DefData* (Lambda$ ASTList - (App$ (App$ StateE (Bound$ 1)) + (App$ (App$ StateE (Bound$ 0)) ASTList)))))))) ;; "lux;imports" (App$ List Text) @@ -293,7 +293,7 @@ Cursor ;; "lux;modules" (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ 0) (Bound$ 1)))))) + (App$ $Module (App$ (Bound$ 1) (Bound$ 0)))))) ;; "lux;envs" (App$ List (App$ (App$ Env Text) @@ -645,8 +645,8 @@ (|case type-fn (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env - (&/Cons$ param) - (&/Cons$ type-fn)) + (&/Cons$ type-fn) + (&/Cons$ param)) local-def)) (&/$AppT F A) -- cgit v1.2.3 From 79f2b2d51b8210d0a2bc81344ea82b4e5cbc7429 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 00:59:45 -0400 Subject: - The Macro type now flows from lux.lux into the compiler, to achieve a perfect match without having the write the type in 2 places. - Made the "Host" type fully opaque to avoid letting users manipulate instances. --- source/lux.lux | 23 +---- src/lux/analyser/module.clj | 2 + src/lux/base.clj | 7 ++ src/lux/type.clj | 207 ++------------------------------------------ 4 files changed, 17 insertions(+), 222 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 4571529a0..e155af794 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -77,6 +77,7 @@ ## (#LambdaT Type Type) ## (#BoundT Int) ## (#VarT Int) +## (#ExT Int) ## (#UnivQ (List Type) Type) ## (#ExQ (List Type) Type) ## (#AppT Type Type) @@ -272,24 +273,6 @@ Text])]))) (_lux_export Source) -## (deftype Host -## (& #writer (^ org.objectweb.asm.ClassWriter) -## #loader (^ java.net.URLClassLoader) -## #classes (^ clojure.lang.Atom) -## #catching (List Text))) -(_lux_def Host - (#NamedT ["lux" "Host"] - (#TupleT (#Cons [## "lux;writer" - (#DataT "org.objectweb.asm.ClassWriter" #Nil) - (#Cons [## "lux;loader" - (#DataT "java.lang.ClassLoader" #Nil) - (#Cons [## "lux;classes" - (#DataT "clojure.lang.Atom" #Nil) - (#Cons [## "lux;catching" - (#AppT List Text) - #Nil])])])])))) -(_lux_declare-tags [#writer #loader #classes] Host) - ## (deftype (DefData' m) ## (| (#TypeD Type) ## (#ValueD (, Type Unit)) @@ -371,7 +354,7 @@ ## #expected Type ## #seed Int ## #eval? Bool -## #host Host +## #host Void ## )) (_lux_def Compiler (#NamedT ["lux" "Compiler"] @@ -396,7 +379,7 @@ (#Cons ## "lux;eval?" Bool (#Cons ## "lux;host" - Host + Void #Nil))))))))))) Void))) (_lux_export Compiler) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index deb6be69e..63ba9b741 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -62,6 +62,8 @@ (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] + (when (and (= "Macro" name) (= "lux" module)) + (&type/set-macro-type! (aget def-data 1))) (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state diff --git a/src/lux/base.clj b/src/lux/base.clj index 0e164f5d2..e57cb0957 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -600,6 +600,13 @@ (do (prn 'memory-class-loader/store class-name (keys @store)) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) + +;; (deftype Host +;; (& #writer (^ org.objectweb.asm.ClassWriter) +;; #loader (^ java.net.URLClassLoader) +;; #classes (^ clojure.lang.Atom) +;; #catching (List Text) +;; #module-states (List (, Text ModuleState)))) (defn host [_] (let [store (atom {})] (T ;; "lux;writer" diff --git a/src/lux/type.clj b/src/lux/type.clj index d6275651e..bc28dbde0 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -114,208 +114,11 @@ ))) $Void)))) -(def Bindings - (Named$ (&/T "lux" "Bindings") - (Univ$ empty-env - (Univ$ empty-env - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ 2) - (Bound$ 0)))))))))) - -(def Env - (Named$ (&/T "lux" "Env") - (let [bindings (App$ (App$ Bindings (Bound$ 2)) - (Bound$ 0))] - (Univ$ empty-env - (Univ$ empty-env - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - ))))))) - -(def Cursor - (Named$ (&/T "lux" "Cursor") - (Tuple$ (&/|list Text Int Int)))) - -(def Meta - (Named$ (&/T "lux" "Meta") - (Univ$ empty-env - (Univ$ empty-env - (Tuple$ (&/|list (Bound$ 2) - (Bound$ 0))))))) - -(def AST* - (Named$ (&/T "lux" "AST'") - (let [AST* (App$ (Bound$ 0) - (App$ (Bound$ 1) - (Bound$ 0))) - AST*List (App$ List AST*)] - (Univ$ empty-env - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - ))))) - -(def AST - (Named$ (&/T "lux" "AST") - (let [w (App$ Meta Cursor)] - (App$ w (App$ AST* w))))) - -(def ^:private ASTList (App$ List AST)) - -(def Either - (Named$ (&/T "lux" "Either") - (Univ$ empty-env - (Univ$ empty-env - (Variant$ (&/|list - ;; &/$Left - (Bound$ 2) - ;; &/$Right - (Bound$ 0))))))) - -(def StateE - (Univ$ empty-env - (Univ$ empty-env - (Lambda$ (Bound$ 2) - (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ 2) - (Bound$ 0)))))))) - -(def Source - (Named$ (&/T "lux" "Source") - (App$ List - (App$ (App$ Meta Cursor) - Text)))) - -(def Host - (Named$ (&/T "lux" "Host") - (Tuple$ - (&/|list - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter" &/Nil$) - ;; "lux;loader" - (Data$ "java.lang.ClassLoader" &/Nil$) - ;; "lux;classes" - (Data$ "clojure.lang.Atom" &/Nil$) - ;; "lux;catching" - (App$ List Text) - )))) - -(def DefData* - (Univ$ empty-env - (Variant$ (&/|list - ;; "lux;ValueD" - (Tuple$ (&/|list Type Unit)) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ 0) - ;; "lux;AliasD" - Ident - )))) - -(def LuxVar - (Named$ (&/T "lux" "LuxVar") - (Variant$ (&/|list - ;; "lux;Local" - Int - ;; "lux;Global" - Ident)))) - -(def $Module - (Univ$ empty-env - (Tuple$ - (&/|list - ;; "lux;module-aliases" - (App$ List (Tuple$ (&/|list Text Text))) - ;; "lux;defs" - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ 0)) - ASTList)))))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Int - (App$ List Ident) - Type))))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list (App$ List Ident) - Type))))) - )))) - -(def $Compiler - (Named$ (&/T "lux" "Compiler") - (App$ (Univ$ empty-env - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ 1) (Bound$ 0)))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) - $Void))) - -(def Macro - (Named$ (&/T "lux" "Macro") - (Lambda$ ASTList - (App$ (App$ StateE $Compiler) - ASTList)))) +(def Macro) + +(defn set-macro-type! [type] + (def Macro type) + nil) (defn bound? [id] (fn [state] -- cgit v1.2.3 From 0f358c4052cf766a74b0354124736cb3652cda1d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 02:18:07 -0400 Subject: - :: no longer demands prefixes for the struct members - Fixed both lux/control/comonad;be & lux/codata/stream;\stream --- source/lux.lux | 4 ++-- source/lux/codata/stream.lux | 31 ++++++++++++++++++++----------- source/lux/control/comonad.lux | 19 +++++++++++-------- source/lux/control/monad.lux | 5 ++--- source/lux/control/ord.lux | 8 ++++---- source/lux/data/list.lux | 4 ++-- source/lux/data/number/int.lux | 8 ++++---- source/lux/data/number/real.lux | 8 ++++---- source/lux/data/text.lux | 2 +- source/lux/data/writer.lux | 4 ++-- source/lux/meta/ast.lux | 10 +++++----- source/lux/meta/lux.lux | 20 ++++++++++---------- source/lux/meta/syntax.lux | 6 +++--- src/lux/analyser/case.clj | 2 +- 14 files changed, 71 insertions(+), 60 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index e155af794..7d00cd077 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -3049,10 +3049,10 @@ (lambda [so-far part] (case part [_ (#SymbolS slot)] - (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + (return (` (using (~ so-far) (~ (symbol$ slot))))) (\ [_ (#FormS (@list& [_ (#SymbolS slot)] args))]) - (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (return (` ((using (~ so-far) (~ (symbol$ slot))) (~@ args)))) _ diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 96de64fd4..1306e3d8b 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -9,11 +9,13 @@ (comonad #as CM #refer #all)) (meta lux syntax) - (data (list #as l #refer (#only @list @list& List/Monad)) + (data (list #as l #refer (#only @list @list& List/Monad) #open ("" List/Fold)) (number (int #open ("i" Int/Number Int/Ord))) bool) (codata (lazy #as L #refer #all)))) +(open List/Monad "list:") + ## [Types] (deftype #export (Stream a) (Lazy (, a (Stream a)))) @@ -117,15 +119,22 @@ (def _functor Stream/Functor) (def unwrap head) (def (split wa) - (:: Stream/Functor (F;map repeat wa)))) + (let [[head tail] (! wa)] + (... [wa (split tail)])))) ## [Pattern-matching] -(defsyntax #export (\stream body [patterns' (+^ id^)]) - (do Lux/Monad - [patterns (map% Lux/Monad macro-expand-1 patterns') - g!s (gensym "s") - #let [patterns+ (: (List AST) - (do List/Monad - [pattern (l;reverse patterns)] - (: (List AST) (@list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))))]] - (wrap (@list g!s (` (;let [(~@ patterns+)] (~ body))))))) +(defsyntax #export (\stream body [patterns (+^ id^)]) + (case (l;reverse patterns) + (\ (@list& last prevs)) + (do Lux/Monad + [prevs (map% Lux/Monad macro-expand-1 prevs) + g!s (gensym "s") + body+ (foldL (lambda [inner outer] + (` (let [[(~ outer) (~ g!s)] (! (~ g!s))] + (~ inner)))) + (` (let [(~ last) (~ g!s)] (~ body))) + prevs)] + (wrap (@list g!s body+))) + + _ + (fail "Wrong syntax for \\stream"))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux index 7ea3b58a9..2543f34da 100644 --- a/source/lux/control/comonad.lux +++ b/source/lux/control/comonad.lux @@ -28,22 +28,25 @@ ## [Syntax] (defmacro #export (be tokens state) (case tokens - (\ (@list comonad [_ (#;TupleS bindings)] body)) - (let [body' (foldL (: (-> AST (, AST AST) AST) + (#;Cons comonad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!split (: AST [["" -1 -1] (#;SymbolS ["" " split "])]) + body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] (case var [_ (#;TagS ["" "let"])] - (` (;let (~ value) (~ body'))) + (` (let (~ value) (~ body'))) _ - (` (extend (;lambda [(~ var)] (~ body')) - (~ value))))))) + (` (|> (~ value) (~ g!split) ((~ g!map) (lambda [(~ var)] (~ body'))))) + )))) body (reverse (as-pairs bindings)))] - (#;Right [state (@list (` (;case (~ comonad) - {#;return ;return #;bind ;bind} - (~ body'))))])) + (#;Right [state (#;Cons (` (case (~ comonad) + {#_functor {#F;map (~ g!map)} #unwrap (~ (' unwrap)) #split (~ g!split)} + (~ body'))) + #;Nil)])) _ (#;Left "Wrong syntax for be"))) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 0c7827c34..e5c5989cf 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -83,7 +83,7 @@ (-> (Monad M) (List (M a)) (M (List a)))) (case xs #;Nil - (:: monad (;;wrap #;Nil)) + (:: monad (wrap #;Nil)) (#;Cons x xs') (do monad @@ -95,10 +95,9 @@ (def #export (map% monad f xs) (All [M a b] (-> (Monad M) (-> a (M b)) (List a) (M (List b)))) - ## (seq% monad (:: monad ;;_functor (F;map f xs))) (case xs #;Nil - (:: monad (;;wrap #;Nil)) + (:: monad (wrap #;Nil)) (#;Cons x xs') (do monad diff --git a/source/lux/control/ord.lux b/source/lux/control/ord.lux index 987356d22..cb77e7042 100644 --- a/source/lux/control/ord.lux +++ b/source/lux/control/ord.lux @@ -24,11 +24,11 @@ (def < <) (def (<= x y) (or (< x y) - (:: eq (E;= x y)))) + (:: eq (= x y)))) (def > >) (def (>= x y) (or (> x y) - (:: eq (E;= x y)))))) + (:: eq (= x y)))))) ## [Functions] (do-template [ ] @@ -37,5 +37,5 @@ (-> (Ord a) a a a)) (if (:: ord ( x y)) x y))] - [max ;;>] - [min ;;<]) + [max >] + [min <]) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index e538007bf..7b9d4a60b 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -242,7 +242,7 @@ true [(#;Cons x xs') (#;Cons y ys')] - (and (:: eq (E;= x y)) + (and (:: eq (= x y)) (= xs' ys')) [_ _] @@ -284,7 +284,7 @@ (using ord (let [pre (filter (>= x) xs') post (filter (< x) xs') - ++ (:: List/Monoid m;++)] + ++ (:: List/Monoid ++)] ($ ++ (sort ord pre) (@list x) (sort ord post)))))) ## [Syntax] diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index ea58cac17..1e71b8a5a 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -60,8 +60,8 @@ ## Enum (defstruct #export Int/Enum (EN;Enum Int) (def _ord Int/Ord) - (def succ (lambda [n] (:: Int/Number (N;+ n 1)))) - (def pred (lambda [n] (:: Int/Number (N;- n 1))))) + (def succ (lambda [n] (:: Int/Number (+ n 1)))) + (def pred (lambda [n] (:: Int/Number (- n 1))))) ## Bounded (do-template [ ] @@ -79,8 +79,8 @@ [ IntAdd/Monoid Int 0 _jvm_ladd] [ IntMul/Monoid Int 1 _jvm_lmul] - [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] - [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] + [ IntMax/Monoid Int (:: Int/Bounded bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: Int/Bounded top) (O;min Int/Ord)] ) ## Show diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux index 7301f2932..7d5243385 100644 --- a/source/lux/data/number/real.lux +++ b/source/lux/data/number/real.lux @@ -60,8 +60,8 @@ ## Enum (defstruct Real/Enum (EN;Enum Real) (def _ord Real/Ord) - (def succ (lambda [n] (:: Real/Number (N;+ n 1.0)))) - (def pred (lambda [n] (:: Real/Number (N;- n 1.0))))) + (def succ (lambda [n] (:: Real/Number (+ n 1.0)))) + (def pred (lambda [n] (:: Real/Number (- n 1.0))))) ## Bounded (do-template [ ] @@ -79,8 +79,8 @@ [RealAdd/Monoid Real 0.0 _jvm_dadd] [RealMul/Monoid Real 1.0 _jvm_dmul] - [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] - [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] + [RealMax/Monoid Real (:: Real/Bounded bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: Real/Bounded top) (O;min Real/Ord)] ) ## Show diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index bbcb42d71..744a22f2e 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -174,7 +174,7 @@ (case tokens (#;Cons [_ (#;TextS template)] #;Nil) (let [++ (symbol$ ["" ""])] - (#;Right state (#;Cons (` (;let [(~ ++) (;:: Text/Monoid m;++)] + (#;Right state (#;Cons (` (;let [(~ ++) (get@ #m;++ Text/Monoid)] (;$ (~ ++) (~@ (unravel-template template))))) #;Nil))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux index bf26eac9a..3bf99c1ad 100644 --- a/source/lux/data/writer.lux +++ b/source/lux/data/writer.lux @@ -24,8 +24,8 @@ (def _functor Writer/Functor) (def (wrap x) - [(:: mon m;unit) x]) + [(:: mon unit) x]) (def (join mma) (let [[log1 [log2 a]] mma] - [(:: mon (m;++ log1 log2)) a]))) + [(:: mon (++ log1 log2)) a]))) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index 6d9271847..a9bc8b588 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -58,7 +58,7 @@ (case ast (\template [ ] [[_ ( value)] - (:: (S;show value))]) + (:: (show value))]) [[#;BoolS Bool/Show] [#;IntS Int/Show] [#;RealS Real/Show] @@ -67,7 +67,7 @@ (\template [ ] [[_ ( ident)] - (text:++ (:: Ident/Show (S;show ident)))]) + (text:++ (:: Ident/Show (show ident)))]) [[#;SymbolS ""] [#;TagS "#"]] (\template [ ] @@ -84,7 +84,7 @@ (case [x y] (\template [ ] [[[_ ( x')] [_ ( y')]] - (:: (E;= x' y'))]) + (:: (= x' y'))]) [[#;BoolS Bool/Eq] [#;IntS Int/Eq] [#;RealS Real/Eq] @@ -95,7 +95,7 @@ (\template [] [[[_ ( xs')] [_ ( ys')]] - (and (:: Int/Eq (E;= (size xs') (size ys'))) + (and (:: Int/Eq (= (size xs') (size ys'))) (foldL (lambda [old [x' y']] (and old (= x' y'))) true @@ -103,7 +103,7 @@ [[#;FormS] [#;TupleS]] [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] - (and (:: Int/Eq (E;= (size xs') (size ys'))) + (and (:: Int/Eq (= (size xs') (size ys'))) (foldL (lambda [old [[xl' xr'] [yl' yr']]] (and old (= xl' yl') (= xr' yr'))) true diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 66f1a554b..b9e07083f 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -113,7 +113,7 @@ (wrap [module-name name])) _ - (:: Lux/Monad (M;wrap ident)))) + (:: Lux/Monad (wrap ident)))) (def #export (macro-expand syntax) (-> AST (Lux (List AST))) @@ -127,13 +127,13 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand expansion)] - (wrap (:: List/Monad (M;join expansion')))) + (wrap (:: List/Monad (join expansion')))) #;None - (:: Lux/Monad (M;wrap (@list syntax))))) + (:: Lux/Monad (wrap (@list syntax))))) _ - (:: Lux/Monad (M;wrap (@list syntax))))) + (:: Lux/Monad (wrap (@list syntax))))) (def #export (macro-expand-all syntax) (-> AST (Lux (List AST))) @@ -147,31 +147,31 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand-all expansion)] - (wrap (:: List/Monad (M;join expansion')))) + (wrap (:: List/Monad (join expansion')))) #;None (do Lux/Monad [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] - (wrap (@list (form$ (:: List/Monad (M;join parts')))))))) + (wrap (@list (form$ (:: List/Monad (join parts')))))))) [_ (#;FormS (#;Cons [harg targs]))] (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (M;map% Lux/Monad macro-expand-all targs)] - (wrap (@list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List AST)) targs+)))))))) + (wrap (@list (form$ (list:++ harg+ (:: List/Monad (join (: (List (List AST)) targs+)))))))) [_ (#;TupleS members)] (do Lux/Monad [members' (M;map% Lux/Monad macro-expand-all members)] - (wrap (@list (tuple$ (:: List/Monad (M;join members')))))) + (wrap (@list (tuple$ (:: List/Monad (join members')))))) _ - (:: Lux/Monad (M;wrap (@list syntax))))) + (:: Lux/Monad (wrap (@list syntax))))) (def #export (gensym prefix state) (-> Text (Lux AST)) (#;Right [(update@ #;seed (i+ 1) state) - (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (S;show (get@ #;seed state))))])])) + (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (show (get@ #;seed state))))])])) (def #export (emit datum) (All [a] diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index d47780798..3b9149a74 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -128,11 +128,11 @@ _ (#;Some [tokens false])))] - [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] + [ bool?^ Bool #;BoolS (:: b;Bool/Eq =)] [ int?^ Int #;IntS i=] [ real?^ Real #;RealS r=] - [ char?^ Char #;CharS (:: c;Char/Eq E;=)] - [ text?^ Text #;TextS (:: t;Text/Eq E;=)] + [ char?^ Char #;CharS (:: c;Char/Eq =)] + [ text?^ Text #;TextS (:: t;Text/Eq =)] [symbol?^ Ident #;SymbolS ident:=] [ tag?^ Ident #;TagS ident:=] ) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index c6806a627..325b6cdd8 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -113,7 +113,7 @@ (adjust-type* up ?type) _ - (assert false (prn 'adjust-type* (&type/show-type type))) + (assert false (prn-str 'adjust-type* (&type/show-type type))) )) (defn adjust-type [type] -- cgit v1.2.3 From d531cab599d269eecd95f6a83285e933535e9c86 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 16 Sep 2015 00:17:55 -0400 Subject: - Changed the name of the \stream macro to \stream& --- source/lux/codata/stream.lux | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 1306e3d8b..86ce99761 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -123,18 +123,18 @@ (... [wa (split tail)])))) ## [Pattern-matching] -(defsyntax #export (\stream body [patterns (+^ id^)]) +(defsyntax #export (\stream& body [patterns (+^ id^)]) (case (l;reverse patterns) (\ (@list& last prevs)) (do Lux/Monad [prevs (map% Lux/Monad macro-expand-1 prevs) g!s (gensym "s") - body+ (foldL (lambda [inner outer] - (` (let [[(~ outer) (~ g!s)] (! (~ g!s))] - (~ inner)))) - (` (let [(~ last) (~ g!s)] (~ body))) - prevs)] + #let [body+ (foldL (lambda [inner outer] + (` (let [[(~ outer) (~ g!s)] (! (~ g!s))] + (~ inner)))) + (` (let [(~ last) (~ g!s)] (~ body))) + prevs)]] (wrap (@list g!s body+))) _ - (fail "Wrong syntax for \\stream"))) + (fail "Wrong syntax for \\stream&"))) -- cgit v1.2.3 From 6a84a06475463ffdaf3d6512696c7577afc8fed1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 16 Sep 2015 18:54:38 -0400 Subject: - Now the file-name & the line numbers are stored inside the .class files for debug info. --- source/lux.lux | 35 +-- source/lux/codata/lazy.lux | 7 +- source/lux/meta/lux.lux | 6 +- source/program.lux | 4 +- src/lux/analyser.clj | 43 +-- src/lux/analyser/base.clj | 19 +- src/lux/analyser/env.clj | 2 +- src/lux/analyser/host.clj | 152 +++++++---- src/lux/analyser/lambda.clj | 10 +- src/lux/analyser/lux.clj | 129 +++++---- src/lux/base.clj | 7 + src/lux/compiler.clj | 628 +++++++++++++++++++++++--------------------- src/lux/compiler/case.clj | 2 +- src/lux/compiler/host.clj | 90 ++++--- src/lux/compiler/lambda.clj | 10 +- src/lux/compiler/lux.clj | 28 +- src/lux/compiler/type.clj | 20 +- 17 files changed, 656 insertions(+), 536 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 7d00cd077..3ede6d75b 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -292,18 +292,10 @@ #Nil)))))))) (_lux_export DefData') -## (deftype LuxVar -## (| (#Local Int) -## (#Global Ident))) -(_lux_def LuxVar - (#NamedT ["lux" "LuxVar"] - (#VariantT (#Cons [## "lux;Local" - Int - (#Cons [## "lux;Global" - Ident - #Nil])])))) -(_lux_export LuxVar) -(_lux_declare-tags [#Local #Global] LuxVar) +(_lux_def Analysis + (#NamedT ["lux" "Analysis"] + Void)) +(_lux_export Analysis) ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) @@ -349,7 +341,7 @@ ## (& #source Source ## #cursor Cursor ## #modules (List (, Text (Module Compiler))) -## #envs (List (Env Text (, LuxVar Type))) +## #envs (List (Env Text (Meta (, Type Cursor) Analysis))) ## #type-vars (Bindings Int Type) ## #expected Type ## #seed Int @@ -369,7 +361,9 @@ #Nil)))) (#Cons ## "lux;envs" (#AppT List (#AppT (#AppT Env Text) - (#TupleT (#Cons LuxVar (#Cons Type #Nil))))) + (#AppT (#AppT Meta + (#TupleT (#Cons Type (#Cons Cursor #Nil)))) + Analysis))) (#Cons ## "lux;type-vars" (#AppT (#AppT Bindings Int) Type) (#Cons ## "lux;expected" @@ -2711,16 +2705,15 @@ #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) (lambda [env] (case env {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= name bname) - (#Some type) - #None))))) + (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) + (lambda [[bname [[type _] _]]] + (if (text:= name bname) + (#Some type) + #None)))) locals closure)))) envs))) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index 37fbbac64..c0c79fc1a 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -34,9 +34,14 @@ (def #export (call/cc f) (All [a b c] (Lazy (-> a (Lazy b c)) (Lazy a c))) (lambda [k] - (f (lambda [a _] (k a)) + (f (lambda [a _] + (k a)) k))) +(def #export (run-lazy l k) + (All [a z] (-> (Lazy a z) (-> a z) z)) + (l k)) + ## [Structs] (defstruct #export Lazy/Functor (Functor Lazy) (def (map f ma) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index b9e07083f..650e67133 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -236,13 +236,13 @@ #;envs envs #;type-vars types #;host host #;seed seed #;eval? eval? #;expected expected #;cursor cursor} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) (lambda [env] (case env {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) (lambda [binding] - (let [[bname [_ type]] binding] + (let [[bname [[type _] _]] binding] (if (text:= name bname) (#;Some type) #;None))))) diff --git a/source/program.lux b/source/program.lux index fa8b3a055..f013655bc 100644 --- a/source/program.lux +++ b/source/program.lux @@ -19,7 +19,6 @@ char (either #as e) id - io list maybe (number (int #refer (#only) #open ("i:" Int/Show)) @@ -32,7 +31,8 @@ (lazy #refer (#only)) (function #refer (#only)) (reader #as r) - (state #refer (#only))) + (state #refer (#only)) + io) (host jvm io) (meta ast diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index a412362d9..190b34b03 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -60,9 +60,9 @@ (if (or ? (&&/type-tag? module tag-name)) (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) (|do [wanted-type (&&module/tag-type module tag-name) - [variant-analysis variant-type] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) _ (&type/check exo-type variant-type)] - (return (&/|list (&/T variant-analysis exo-type)))))) + (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis)))))) _ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) @@ -324,10 +324,10 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons [_ (&/$TextS ?field)] - (&/$Cons ?object - (&/$Cons ?value + (&/$Cons ?value + (&/$Cons ?object (&/$Nil))))))) - (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) + (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?value ?object) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] (&/$Cons [_ (&/$TextS ?class)] @@ -584,24 +584,29 @@ (|case token ;; Standard special forms (&/$BoolS ?value) - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$bool ?value))))) (&/$IntS ?value) - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Int) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$int ?value))))) (&/$RealS ?value) - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$real ?value))))) (&/$CharS ?value) - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Char) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$char ?value))))) (&/$TextS ?value) - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$text ?value))))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems) @@ -657,16 +662,16 @@ (defn ^:private just-analyse [analyser syntax] (&type/with-var (fn [?var] - (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] + (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)] (|case [?var ?output-type] [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/T ?output-term ?output-type*))) - (return (&/T ?output-term ?output-type))) + (return (&&/|meta ?output-type* ?output-cursor ?output-term))) + (return (&&/|meta ?output-type ?output-cursor ?output-term))) [_ _] - (return (&/T ?output-term ?output-type))) + (return (&&/|meta ?output-type ?output-cursor ?output-term))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index b12425ac7..664ba4450 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -152,7 +152,7 @@ ;; [Exports] (defn expr-type* [syntax+] - (|let [[_ type] syntax+] + (|let [[[type _] _] syntax+] type)) (def jvm-this "_jvm_this") @@ -173,18 +173,21 @@ (&type/with-var (fn [$var] (|do [=expr (analyse-1 analyse $var ?token) - :let [[?item ?type] =expr] + :let [[[?type ?cursor] ?item] =expr] =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (return (&/T (&/T =type ?cursor) ?item)))))) (defn resolved-ident [ident] - (|let [[?module ?name] ident] - (|do [module* (if (.equals "" ?module) - &/get-module-name - (return ?module))] - (return (&/T module* ?name))))) + (|do [:let [[?module ?name] ident] + module* (if (.equals "" ?module) + &/get-module-name + (return ?module))] + (return (&/T module* ?name)))) (let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] (defn type-tag? [module name] (and (= "lux" module) (contains? tag-names name)))) + +(defn |meta [type cursor analysis] + (&/T (&/T type cursor) analysis)) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 66478eecc..a7ce52c1f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -24,7 +24,7 @@ (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] (&/Cons$ (&/update$ &/$locals #(->> % (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/update$ &/$mappings (fn [m] (&/|put name (&&/|meta type &/empty-cursor bound-unit) m)))) (&/|head stack)) (&/|tail stack)))) state))] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index f17be2a7c..292d3d4b1 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -115,8 +115,10 @@ (defn [analyse exo-type x y] (|do [=x (&&/analyse-1 analyse input-type x) =y (&&/analyse-1 analyse input-type y) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V (&/T =x =y)))))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -163,33 +165,41 @@ (|do [class-loader &/loader =type (&host/lookup-static-field class-loader class field) :let [output-type =type] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T class field)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-getstatic (&/T class field output-type))))))) (defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader =type (&host/lookup-static-field class-loader class field) =object (&&/analyse-1 analyse object) :let [output-type =type] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T class field =object)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-getfield (&/T class field =object output-type))))))) (defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader =type (&host/lookup-static-field class-loader class field) =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T class field =value)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-putstatic (&/T class field =value output-type))))))) -(defn analyse-jvm-putfield [analyse exo-type class field object value] +(defn analyse-jvm-putfield [analyse exo-type class field value object] (|do [class-loader &/loader =type (&host/lookup-static-field class-loader class field) =object (&&/analyse-1 analyse object) =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T class field =object =value)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-putfield (&/T class field =value =object (&&/expr-type* =object)))))))) (defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader @@ -205,15 +215,19 @@ classes args) :let [output-type =return] - _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T class method classes =args)) output-type))))) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type))))))) (defn analyse-jvm-instanceof [analyse exo-type class object] (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T class =object)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-instanceof (&/T class =object))))))) (do-template [ ] (defn [analyse exo-type class method classes object args] @@ -228,8 +242,10 @@ :let [output-type =return] ;; :let [_ (prn ' [class method] '=return (&type/show-type =return))] ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] - _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V (&/T class method classes =object =args)) output-type))))) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V (&/T class method classes =object =args output-type))))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface @@ -248,20 +264,26 @@ (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) :let [output-type =return] - _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T class method classes =object =args)) output-type))))) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-invokespecial (&/T class method classes =object =args output-type))))))) (defn analyse-jvm-null? [analyse exo-type object] (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-null? =object)))))) (defn analyse-jvm-null [analyse exo-type] (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-null nil)))))) (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader @@ -270,8 +292,10 @@ classes args) _ (ensure-catching exceptions) :let [output-type (&type/Data$ class &/Nil$)] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T class classes =args)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-new (&/T class classes =args))))))) (do-template [ ] (let [elem-type (&type/Data$ &/Nil$) @@ -279,19 +303,25 @@ length-type &type/Int idx-type &type/Int] (defn [analyse length] - (|do [=length (&&/analyse-1 analyse length-type length)] - (return (&/|list (&/T (&/V =length) array-type))))) + (|do [=length (&&/analyse-1 analyse length-type length) + _cursor &/cursor] + (return (&/|list (&&/|meta array-type _cursor + (&/V =length)))))) (defn [analyse array idx] (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx)] - (return (&/|list (&/T (&/V (&/T =array =idx)) elem-type))))) + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor] + (return (&/|list (&&/|meta elem-type _cursor + (&/V (&/T =array =idx))))))) (defn [analyse array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V (&/T =array =idx =elem)) array-type))))) + =elem (&&/analyse-1 analyse elem-type elem) + _cursor &/cursor] + (return (&/|list (&&/|meta array-type _cursor + (&/V (&/T =array =idx =elem))))))) ) "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore @@ -309,23 +339,29 @@ (defn analyse-jvm-anewarray [analyse class length] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] - (|do [=length (&&/analyse-1 analyse length-type length)] - (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class =length)) array-type)))))) + (|do [=length (&&/analyse-1 analyse length-type length) + _cursor &/cursor] + (return (&/|list (&&/|meta array-type _cursor + (&/V &&/$jvm-anewarray (&/T class =length)))))))) (defn analyse-jvm-aaload [analyse class array idx] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array =idx)) elem-type)))))) + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor] + (return (&/|list (&&/|meta elem-type _cursor + (&/V &&/$jvm-aaload (&/T class =array =idx)))))))) (defn analyse-jvm-aastore [analyse class array idx elem] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array =idx =elem)) array-type))))))) + =elem (&&/analyse-1 analyse elem-type elem) + _cursor &/cursor] + (return (&/|list (&&/|meta array-type _cursor + (&/V &&/$jvm-aastore (&/T class =array =idx =elem))))))))) (let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] (defn analyse-jvm-arraylength [analyse array] @@ -333,8 +369,11 @@ (fn [$var] (let [elem-type $var array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V &&/$jvm-arraylength =array) length-type))))))))) + (|do [=array (&&/analyse-1 analyse array-type array) + _cursor &/cursor] + (return (&/|list (&&/|meta length-type _cursor + (&/V &&/$jvm-arraylength =array) + ))))))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] @@ -492,7 +531,7 @@ (defn ^:private captured-source [env-entry] (|case env-entry - [name [(&&/$captured _ _ source) _]] + [name [_ (&&/$captured _ _ source)]] source)) (let [captured-slot-modifier {:visibility "private" @@ -527,8 +566,11 @@ ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured))) - :let [_ (println 'DEF anon-class)]] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) (&type/Data$ anon-class (&/|list))))) + :let [_ (println 'DEF anon-class)] + _cursor &/cursor] + (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor + (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) + ))) ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources) )))) @@ -546,20 +588,24 @@ =finally (|case ?finally (&/$None) (return &/None$) (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)] - (return (&/V &/$Some =finally))))] - (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) + (return (&/V &/$Some =finally)))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-try (&/T =body =catches =finally))))))) (defn analyse-jvm-throw [analyse exo-type ?ex] - (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) exo-type))))) + (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-throw =ex)))))) (do-template [ ] (defn [analyse exo-type ?monitor] (|do [=monitor (&&/analyse-1+ analyse ?monitor) _ (ensure-object =monitor) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =monitor) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V =monitor)))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit @@ -569,8 +615,9 @@ (let [output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type ?value] (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =value) output-type)))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V =value))))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -596,8 +643,9 @@ (let [output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type ?value] (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =value) output-type)))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V =value))))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 819f07583..bbb5d2dc7 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -22,11 +22,11 @@ (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] - (|let [[_ register-type] register - register* (&/T (&/V &&/$captured (&/T scope - (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) - register)) - register-type)] + (|let [[[register-type register-cursor] _] register + register* (&&/|meta register-type register-cursor + (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register)))] (&/T register* (&/update$ &/$closure #(->> % (&/update$ &/$counter inc) (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6546990e6..488b7ae4f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -52,7 +52,7 @@ (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) =var (&type/resolve-type $var) inferred-type (|case =var (&/$VarT iid) @@ -63,7 +63,8 @@ _ (&type/clean $var tuple-type))] - (return (&/|list (&/T tuple-analysis inferred-type)))))) + (return (&/|list (&&/|meta inferred-type tuple-cursor + tuple-analysis)))))) _ (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) @@ -74,23 +75,28 @@ (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] (return =analysis)) ?elems) - _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$tuple =elems) + )))) (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* (&/$TupleT ?members) (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) + ?members ?elems) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$tuple =elems) + )))) (&/$UnivQ _) (|do [$var &type/existential exo-type** (&type/apply-type exo-type* $var) - [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] - (return (&/|list (&/T tuple-analysis exo-type)))) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))) _ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) @@ -146,7 +152,7 @@ (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))] - [variant-analysis variant-type] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))] =var (&type/resolve-type $var) ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))] @@ -161,7 +167,8 @@ (&type/clean $var variant-type)) ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))] ] - (return (&/|list (&/T variant-analysis inferred-type)))))) + (return (&/|list (&&/|meta inferred-type variant-cursor + variant-analysis)))))) _ (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) @@ -188,9 +195,11 @@ (|do [_exo-type (&type/deref+ exo-type)] (fail (str err "\n" 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) - " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] - (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) - exo-type)))) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$variant (&/T idx =value)) + )))) (&/$None) (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) @@ -210,9 +219,10 @@ (|do [? (&type/bound? id)] (if ? (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) - (|do [[tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) + (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) _ (&type/check exo-type tuple-type)] - (return (&/|list (&/T tuple-analysis exo-type)))))) + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))))) _ (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) @@ -234,9 +244,11 @@ _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) - endo-type))))) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + ))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] @@ -270,9 +282,11 @@ _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) - endo-type)))) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + )))) state) _ @@ -354,7 +368,7 @@ (defn analyse-apply [analyse exo-type form-cursor =fn ?args] (|do [loader &/loader] - (|let [[=fn-form =fn-type] =fn] + (|let [[[=fn-type =fn-cursor] =fn-form] =fn] (|case =fn-form (&&/$var (&/$Global ?module ?name)) (|do [[real-name $def] (&&module/find-def ?module ?name)] @@ -363,7 +377,7 @@ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] - ;; :let [_ (when (or (= "invoke-interface$" (aget real-name 1)) + ;; :let [_ (when (or (= "do" (aget real-name 1)) ;; ;; (= "..?" (aget real-name 1)) ;; ;; (= "try$" (aget real-name 1)) ;; ) @@ -376,13 +390,15 @@ _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) - =output-t)))))) + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + )))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) - =output-t))))) + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + ))))) ))) (defn analyse-case [analyse exo-type ?value ?branches] @@ -390,9 +406,11 @@ _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") =value (&&/analyse-1+ analyse ?value) - =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))] - (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) - exo-type))))) + =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$case (&/T =value =match)) + ))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|case exo-type @@ -406,7 +424,7 @@ (fn [$input] (&type/with-var (fn [$output] - (|do [[lambda-analysis lambda-type] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body) + (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body) =input (&type/resolve-type $input) =output (&type/resolve-type $output) inferred-type (|case =input @@ -421,9 +439,9 @@ (|do [=output* (&type/clean $input =output) =output** (&type/clean $output =output*)] (return (embed-inferred-input =input =output**)))) - _ (&type/check exo-type inferred-type) - ] - (return (&/T lambda-analysis inferred-type))) + _ (&type/check exo-type inferred-type)] + (return (&&/|meta inferred-type lambda-cursor + lambda-analysis))) )))))) _ @@ -437,8 +455,10 @@ (&/$LambdaT ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) + (&&/analyse-1 analyse ?return-t ?body)) + _cursor &/cursor] + (return (&&/|meta exo-type* _cursor + (&/V &&/$lambda (&/T =scope =captured =body))))) @@ -452,9 +472,10 @@ (&/$UnivQ _) (|do [$var &type/existential exo-type* (&type/apply-type exo-type $var) - [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - (return (&/T _expr exo-type))) - + [_ _expr] (analyse-lambda** analyse exo-type* ?self ?arg ?body) + _cursor &/cursor] + (return (&&/|meta exo-type _cursor _expr))) + (&/$VarT id) (|do [? (&type/bound? id)] (if ? @@ -484,7 +505,7 @@ (|do [=value (&/with-scope ?name (&&/analyse-1+ analyse ?value))] (|case =value - [(&&/$var (&/$Global ?r-module ?r-name)) _] + [_ (&&/$var (&/$Global ?r-module ?r-name))] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] @@ -501,7 +522,7 @@ ;; (return nil)) ;; (return nil)) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - [def-analysis def-type] =value + [[def-type def-cursor] def-analysis] =value _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) )]] (return &/Nil$)))) @@ -533,8 +554,7 @@ (return nil))] (&/save-module (|do [already-compiled? (&&module/exists? path) - ;; :let [_ (prn 'analyse-import module-name path - ;; already-compiled?)] + ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] active? (&/active-module? path) _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) _ (&&module/add-import path) @@ -554,15 +574,22 @@ (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) + ;; :let [_ (prn 'analyse-check/_0 (&type/show-type ==type))] _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) - ==type))))) + =value (&&/analyse-1 analyse ==type ?value) + ;; :let [_ (prn 'analyse-check/_1 (&/adt->text =value))] + _cursor &/cursor + ] + (return (&/|list (&&/|meta ==type _cursor + (&/V &&/$ann (&/T =value =type)) + ))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (&&/analyse-1+ analyse ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) - ==type))))) + =value (&&/analyse-1+ analyse ?value) + _cursor &/cursor] + (return (&/|list (&&/|meta ==type _cursor + (&/V &&/$ann (&/T =value =type)) + ))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index e57cb0957..19f236ce1 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -132,6 +132,8 @@ (def Nil$ (V $Nil nil)) (defn Cons$ [h t] (V $Cons (T h t))) +(def empty-cursor (T "" -1 -1)) + (defn get$ [slot ^objects record] (aget record slot)) @@ -792,6 +794,11 @@ _ output))))) +(def cursor + ;; (Lux Cursor) + (fn [state] + (return* state (get$ $cursor state)))) + (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 048b9ee1d..d89684bcc 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -35,374 +35,388 @@ MethodVisitor))) ;; [Utils/Compilers] +(def ^:private !source->last-line (atom nil)) + (defn ^:private compile-expression [syntax] - (|let [[?form ?type] syntax] - (|case ?form - (&a/$bool ?value) - (&&lux/compile-bool compile-expression ?type ?value) - - (&a/$int ?value) - (&&lux/compile-int compile-expression ?type ?value) - - (&a/$real ?value) - (&&lux/compile-real compile-expression ?type ?value) - - (&a/$char ?value) - (&&lux/compile-char compile-expression ?type ?value) - - (&a/$text ?value) - (&&lux/compile-text compile-expression ?type ?value) - - (&a/$tuple ?elems) - (&&lux/compile-tuple compile-expression ?type ?elems) - - (&a/$var (&/$Local ?idx)) - (&&lux/compile-local compile-expression ?type ?idx) - - (&a/$captured ?scope ?captured-id ?source) - (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - - (&a/$var (&/$Global ?owner-class ?name)) - (&&lux/compile-global compile-expression ?type ?owner-class ?name) - - (&a/$apply ?fn ?args) - (&&lux/compile-apply compile-expression ?type ?fn ?args) - - (&a/$variant ?tag ?members) - (&&lux/compile-variant compile-expression ?type ?tag ?members) - - (&a/$case ?value ?match) - (&&case/compile-case compile-expression ?type ?value ?match) - - (&a/$lambda ?scope ?env ?body) - (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - - (&a/$ann ?value-ex ?type-ex) - (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) - - ;; Characters - (&a/$jvm-ceq ?x ?y) - (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - - (&a/$jvm-clt ?x ?y) - (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - - (&a/$jvm-cgt ?x ?y) - (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) - - ;; Integer arithmetic - (&a/$jvm-iadd ?x ?y) - (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - - (&a/$jvm-isub ?x ?y) - (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - - (&a/$jvm-imul ?x ?y) - (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - - (&a/$jvm-idiv ?x ?y) - (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - - (&a/$jvm-irem ?x ?y) - (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - - (&a/$jvm-ieq ?x ?y) - (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - - (&a/$jvm-ilt ?x ?y) - (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - - (&a/$jvm-igt ?x ?y) - (&&host/compile-jvm-igt compile-expression ?type ?x ?y) - - ;; Long arithmetic - (&a/$jvm-ladd ?x ?y) - (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - - (&a/$jvm-lsub ?x ?y) - (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - - (&a/$jvm-lmul ?x ?y) - (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - - (&a/$jvm-ldiv ?x ?y) - (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - - (&a/$jvm-lrem ?x ?y) - (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - - (&a/$jvm-leq ?x ?y) - (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - - (&a/$jvm-llt ?x ?y) - (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - - (&a/$jvm-lgt ?x ?y) - (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) - - ;; Float arithmetic - (&a/$jvm-fadd ?x ?y) - (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - - (&a/$jvm-fsub ?x ?y) - (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - - (&a/$jvm-fmul ?x ?y) - (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - - (&a/$jvm-fdiv ?x ?y) - (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - - (&a/$jvm-frem ?x ?y) - (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - - (&a/$jvm-feq ?x ?y) - (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - - (&a/$jvm-flt ?x ?y) - (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - - (&a/$jvm-fgt ?x ?y) - (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) - - ;; Double arithmetic - (&a/$jvm-dadd ?x ?y) - (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - - (&a/$jvm-dsub ?x ?y) - (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - - (&a/$jvm-dmul ?x ?y) - (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - - (&a/$jvm-ddiv ?x ?y) - (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - - (&a/$jvm-drem ?x ?y) - (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - - (&a/$jvm-deq ?x ?y) - (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - - (&a/$jvm-dlt ?x ?y) - (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - - (&a/$jvm-dgt ?x ?y) - (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - - (&a/$jvm-null _) - (&&host/compile-jvm-null compile-expression ?type) - - (&a/$jvm-null? ?object) - (&&host/compile-jvm-null? compile-expression ?type ?object) - - (&a/$jvm-new ?class ?classes ?args) - (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - - (&a/$jvm-getstatic ?class ?field) - (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) + ;; (prn 'compile-expression (&/adt->text syntax)) + (|let [[[?type [_file-name _line _column]] ?form] syntax] + (|do [^MethodVisitor *writer* &/get-writer + :let [debug-label (new Label) + _ (when (not= _line (get @!source->last-line _file-name)) + (doto *writer* + (.visitLabel debug-label) + (.visitLineNumber (int _line) debug-label)) + (swap! !source->last-line assoc _file-name _line))]] + (|case ?form + (&a/$bool ?value) + (&&lux/compile-bool compile-expression ?value) + + (&a/$int ?value) + (do ;; (prn 'compile-expression (&/adt->text syntax)) + (&&lux/compile-int compile-expression ?value)) + + (&a/$real ?value) + (&&lux/compile-real compile-expression ?value) + + (&a/$char ?value) + (&&lux/compile-char compile-expression ?value) + + (&a/$text ?value) + (&&lux/compile-text compile-expression ?value) + + (&a/$tuple ?elems) + (&&lux/compile-tuple compile-expression ?elems) + + (&a/$var (&/$Local ?idx)) + (&&lux/compile-local compile-expression ?idx) + + (&a/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) + + (&a/$var (&/$Global ?owner-class ?name)) + (&&lux/compile-global compile-expression ?owner-class ?name) + + (&a/$apply ?fn ?args) + (&&lux/compile-apply compile-expression ?fn ?args) + + (&a/$variant ?tag ?members) + (&&lux/compile-variant compile-expression ?tag ?members) + + (&a/$case ?value ?match) + (&&case/compile-case compile-expression ?value ?match) + + (&a/$lambda ?scope ?env ?body) + (&&lambda/compile-lambda compile-expression ?scope ?env ?body) + + (&a/$ann ?value-ex ?type-ex) + (&&lux/compile-ann compile-expression ?value-ex ?type-ex) + + ;; Characters + (&a/$jvm-ceq ?x ?y) + (&&host/compile-jvm-ceq compile-expression ?x ?y) + + (&a/$jvm-clt ?x ?y) + (&&host/compile-jvm-clt compile-expression ?x ?y) + + (&a/$jvm-cgt ?x ?y) + (&&host/compile-jvm-cgt compile-expression ?x ?y) + + ;; Integer arithmetic + (&a/$jvm-iadd ?x ?y) + (&&host/compile-jvm-iadd compile-expression ?x ?y) + + (&a/$jvm-isub ?x ?y) + (&&host/compile-jvm-isub compile-expression ?x ?y) + + (&a/$jvm-imul ?x ?y) + (&&host/compile-jvm-imul compile-expression ?x ?y) + + (&a/$jvm-idiv ?x ?y) + (&&host/compile-jvm-idiv compile-expression ?x ?y) + + (&a/$jvm-irem ?x ?y) + (&&host/compile-jvm-irem compile-expression ?x ?y) + + (&a/$jvm-ieq ?x ?y) + (&&host/compile-jvm-ieq compile-expression ?x ?y) + + (&a/$jvm-ilt ?x ?y) + (&&host/compile-jvm-ilt compile-expression ?x ?y) + + (&a/$jvm-igt ?x ?y) + (&&host/compile-jvm-igt compile-expression ?x ?y) + + ;; Long arithmetic + (&a/$jvm-ladd ?x ?y) + (&&host/compile-jvm-ladd compile-expression ?x ?y) + + (&a/$jvm-lsub ?x ?y) + (&&host/compile-jvm-lsub compile-expression ?x ?y) + + (&a/$jvm-lmul ?x ?y) + (&&host/compile-jvm-lmul compile-expression ?x ?y) + + (&a/$jvm-ldiv ?x ?y) + (&&host/compile-jvm-ldiv compile-expression ?x ?y) + + (&a/$jvm-lrem ?x ?y) + (&&host/compile-jvm-lrem compile-expression ?x ?y) + + (&a/$jvm-leq ?x ?y) + (&&host/compile-jvm-leq compile-expression ?x ?y) + + (&a/$jvm-llt ?x ?y) + (&&host/compile-jvm-llt compile-expression ?x ?y) + + (&a/$jvm-lgt ?x ?y) + (&&host/compile-jvm-lgt compile-expression ?x ?y) + + ;; Float arithmetic + (&a/$jvm-fadd ?x ?y) + (&&host/compile-jvm-fadd compile-expression ?x ?y) + + (&a/$jvm-fsub ?x ?y) + (&&host/compile-jvm-fsub compile-expression ?x ?y) + + (&a/$jvm-fmul ?x ?y) + (&&host/compile-jvm-fmul compile-expression ?x ?y) + + (&a/$jvm-fdiv ?x ?y) + (&&host/compile-jvm-fdiv compile-expression ?x ?y) + + (&a/$jvm-frem ?x ?y) + (&&host/compile-jvm-frem compile-expression ?x ?y) + + (&a/$jvm-feq ?x ?y) + (&&host/compile-jvm-feq compile-expression ?x ?y) + + (&a/$jvm-flt ?x ?y) + (&&host/compile-jvm-flt compile-expression ?x ?y) + + (&a/$jvm-fgt ?x ?y) + (&&host/compile-jvm-fgt compile-expression ?x ?y) + + ;; Double arithmetic + (&a/$jvm-dadd ?x ?y) + (&&host/compile-jvm-dadd compile-expression ?x ?y) + + (&a/$jvm-dsub ?x ?y) + (&&host/compile-jvm-dsub compile-expression ?x ?y) + + (&a/$jvm-dmul ?x ?y) + (&&host/compile-jvm-dmul compile-expression ?x ?y) + + (&a/$jvm-ddiv ?x ?y) + (&&host/compile-jvm-ddiv compile-expression ?x ?y) + + (&a/$jvm-drem ?x ?y) + (&&host/compile-jvm-drem compile-expression ?x ?y) + + (&a/$jvm-deq ?x ?y) + (&&host/compile-jvm-deq compile-expression ?x ?y) + + (&a/$jvm-dlt ?x ?y) + (&&host/compile-jvm-dlt compile-expression ?x ?y) + + (&a/$jvm-dgt ?x ?y) + (&&host/compile-jvm-dgt compile-expression ?x ?y) + + (&a/$jvm-null _) + (&&host/compile-jvm-null compile-expression) + + (&a/$jvm-null? ?object) + (&&host/compile-jvm-null? compile-expression ?object) + + (&a/$jvm-new ?class ?classes ?args) + (&&host/compile-jvm-new compile-expression ?class ?classes ?args) + + (&a/$jvm-getstatic ?class ?field ?output-type) + (&&host/compile-jvm-getstatic compile-expression ?class ?field ?output-type) + + (&a/$jvm-getfield ?class ?field ?object ?output-type) + (&&host/compile-jvm-getfield compile-expression ?class ?field ?object ?output-type) - (&a/$jvm-getfield ?class ?field ?object) - (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) + (&a/$jvm-putstatic ?class ?field ?value ?output-type) + (&&host/compile-jvm-putstatic compile-expression ?class ?field ?value) - (&a/$jvm-putstatic ?class ?field ?value) - (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) + (&a/$jvm-putfield ?class ?field ?value ?object ?output-type) + (&&host/compile-jvm-putfield compile-expression ?class ?field ?object ?value) - (&a/$jvm-putfield ?class ?field ?object ?value) - (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) + (&a/$jvm-invokestatic ?class ?method ?classes ?args ?output-type) + (&&host/compile-jvm-invokestatic compile-expression ?class ?method ?classes ?args ?output-type) - (&a/$jvm-invokestatic ?class ?method ?classes ?args) - (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) + (&a/$jvm-invokevirtual ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokevirtual compile-expression ?class ?method ?classes ?object ?args ?output-type) - (&a/$jvm-invokevirtual ?class ?method ?classes ?object ?args) - (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) + (&a/$jvm-invokeinterface ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokeinterface compile-expression ?class ?method ?classes ?object ?args ?output-type) - (&a/$jvm-invokeinterface ?class ?method ?classes ?object ?args) - (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) + (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokespecial compile-expression ?class ?method ?classes ?object ?args ?output-type) + + (&a/$jvm-znewarray ?length) + (&&host/compile-jvm-znewarray compile-expression ?length) - (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args) - (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - - (&a/$jvm-znewarray ?length) - (&&host/compile-jvm-znewarray compile-expression ?type ?length) + (&a/$jvm-zastore ?array ?idx ?elem) + (&&host/compile-jvm-zastore compile-expression ?array ?idx ?elem) - (&a/$jvm-zastore ?array ?idx ?elem) - (&&host/compile-jvm-zastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-zaload ?array ?idx) + (&&host/compile-jvm-zaload compile-expression ?array ?idx) - (&a/$jvm-zaload ?array ?idx) - (&&host/compile-jvm-zaload compile-expression ?type ?array ?idx) + (&a/$jvm-bnewarray ?length) + (&&host/compile-jvm-bnewarray compile-expression ?length) - (&a/$jvm-bnewarray ?length) - (&&host/compile-jvm-bnewarray compile-expression ?type ?length) + (&a/$jvm-bastore ?array ?idx ?elem) + (&&host/compile-jvm-bastore compile-expression ?array ?idx ?elem) - (&a/$jvm-bastore ?array ?idx ?elem) - (&&host/compile-jvm-bastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-baload ?array ?idx) + (&&host/compile-jvm-baload compile-expression ?array ?idx) - (&a/$jvm-baload ?array ?idx) - (&&host/compile-jvm-baload compile-expression ?type ?array ?idx) + (&a/$jvm-snewarray ?length) + (&&host/compile-jvm-snewarray compile-expression ?length) - (&a/$jvm-snewarray ?length) - (&&host/compile-jvm-snewarray compile-expression ?type ?length) + (&a/$jvm-sastore ?array ?idx ?elem) + (&&host/compile-jvm-sastore compile-expression ?array ?idx ?elem) - (&a/$jvm-sastore ?array ?idx ?elem) - (&&host/compile-jvm-sastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-saload ?array ?idx) + (&&host/compile-jvm-saload compile-expression ?array ?idx) - (&a/$jvm-saload ?array ?idx) - (&&host/compile-jvm-saload compile-expression ?type ?array ?idx) + (&a/$jvm-inewarray ?length) + (&&host/compile-jvm-inewarray compile-expression ?length) - (&a/$jvm-inewarray ?length) - (&&host/compile-jvm-inewarray compile-expression ?type ?length) + (&a/$jvm-iastore ?array ?idx ?elem) + (&&host/compile-jvm-iastore compile-expression ?array ?idx ?elem) - (&a/$jvm-iastore ?array ?idx ?elem) - (&&host/compile-jvm-iastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-iaload ?array ?idx) + (&&host/compile-jvm-iaload compile-expression ?array ?idx) - (&a/$jvm-iaload ?array ?idx) - (&&host/compile-jvm-iaload compile-expression ?type ?array ?idx) + (&a/$jvm-lnewarray ?length) + (&&host/compile-jvm-lnewarray compile-expression ?length) - (&a/$jvm-lnewarray ?length) - (&&host/compile-jvm-lnewarray compile-expression ?type ?length) + (&a/$jvm-lastore ?array ?idx ?elem) + (&&host/compile-jvm-lastore compile-expression ?array ?idx ?elem) - (&a/$jvm-lastore ?array ?idx ?elem) - (&&host/compile-jvm-lastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-laload ?array ?idx) + (&&host/compile-jvm-laload compile-expression ?array ?idx) - (&a/$jvm-laload ?array ?idx) - (&&host/compile-jvm-laload compile-expression ?type ?array ?idx) + (&a/$jvm-fnewarray ?length) + (&&host/compile-jvm-fnewarray compile-expression ?length) - (&a/$jvm-fnewarray ?length) - (&&host/compile-jvm-fnewarray compile-expression ?type ?length) + (&a/$jvm-fastore ?array ?idx ?elem) + (&&host/compile-jvm-fastore compile-expression ?array ?idx ?elem) - (&a/$jvm-fastore ?array ?idx ?elem) - (&&host/compile-jvm-fastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-faload ?array ?idx) + (&&host/compile-jvm-faload compile-expression ?array ?idx) - (&a/$jvm-faload ?array ?idx) - (&&host/compile-jvm-faload compile-expression ?type ?array ?idx) + (&a/$jvm-dnewarray ?length) + (&&host/compile-jvm-dnewarray compile-expression ?length) - (&a/$jvm-dnewarray ?length) - (&&host/compile-jvm-dnewarray compile-expression ?type ?length) + (&a/$jvm-dastore ?array ?idx ?elem) + (&&host/compile-jvm-dastore compile-expression ?array ?idx ?elem) - (&a/$jvm-dastore ?array ?idx ?elem) - (&&host/compile-jvm-dastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-daload ?array ?idx) + (&&host/compile-jvm-daload compile-expression ?array ?idx) - (&a/$jvm-daload ?array ?idx) - (&&host/compile-jvm-daload compile-expression ?type ?array ?idx) + (&a/$jvm-cnewarray ?length) + (&&host/compile-jvm-cnewarray compile-expression ?length) - (&a/$jvm-cnewarray ?length) - (&&host/compile-jvm-cnewarray compile-expression ?type ?length) + (&a/$jvm-castore ?array ?idx ?elem) + (&&host/compile-jvm-castore compile-expression ?array ?idx ?elem) - (&a/$jvm-castore ?array ?idx ?elem) - (&&host/compile-jvm-castore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-caload ?array ?idx) + (&&host/compile-jvm-caload compile-expression ?array ?idx) - (&a/$jvm-caload ?array ?idx) - (&&host/compile-jvm-caload compile-expression ?type ?array ?idx) + (&a/$jvm-anewarray ?class ?length) + (&&host/compile-jvm-anewarray compile-expression ?class ?length) - (&a/$jvm-anewarray ?class ?length) - (&&host/compile-jvm-anewarray compile-expression ?type ?class ?length) + (&a/$jvm-aastore ?class ?array ?idx ?elem) + (&&host/compile-jvm-aastore compile-expression ?class ?array ?idx ?elem) - (&a/$jvm-aastore ?class ?array ?idx ?elem) - (&&host/compile-jvm-aastore compile-expression ?type ?class ?array ?idx ?elem) + (&a/$jvm-aaload ?class ?array ?idx) + (&&host/compile-jvm-aaload compile-expression ?class ?array ?idx) - (&a/$jvm-aaload ?class ?array ?idx) - (&&host/compile-jvm-aaload compile-expression ?type ?class ?array ?idx) + (&a/$jvm-arraylength ?array) + (&&host/compile-jvm-arraylength compile-expression ?array) - (&a/$jvm-arraylength ?array) - (&&host/compile-jvm-arraylength compile-expression ?type ?array) + (&a/$jvm-try ?body ?catches ?finally) + (&&host/compile-jvm-try compile-expression ?body ?catches ?finally) - (&a/$jvm-try ?body ?catches ?finally) - (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) + (&a/$jvm-throw ?ex) + (&&host/compile-jvm-throw compile-expression ?ex) - (&a/$jvm-throw ?ex) - (&&host/compile-jvm-throw compile-expression ?type ?ex) + (&a/$jvm-monitorenter ?monitor) + (&&host/compile-jvm-monitorenter compile-expression ?monitor) - (&a/$jvm-monitorenter ?monitor) - (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) + (&a/$jvm-monitorexit ?monitor) + (&&host/compile-jvm-monitorexit compile-expression ?monitor) - (&a/$jvm-monitorexit ?monitor) - (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) + (&a/$jvm-d2f ?value) + (&&host/compile-jvm-d2f compile-expression ?value) - (&a/$jvm-d2f ?value) - (&&host/compile-jvm-d2f compile-expression ?type ?value) + (&a/$jvm-d2i ?value) + (&&host/compile-jvm-d2i compile-expression ?value) - (&a/$jvm-d2i ?value) - (&&host/compile-jvm-d2i compile-expression ?type ?value) + (&a/$jvm-d2l ?value) + (&&host/compile-jvm-d2l compile-expression ?value) + + (&a/$jvm-f2d ?value) + (&&host/compile-jvm-f2d compile-expression ?value) - (&a/$jvm-d2l ?value) - (&&host/compile-jvm-d2l compile-expression ?type ?value) - - (&a/$jvm-f2d ?value) - (&&host/compile-jvm-f2d compile-expression ?type ?value) + (&a/$jvm-f2i ?value) + (&&host/compile-jvm-f2i compile-expression ?value) - (&a/$jvm-f2i ?value) - (&&host/compile-jvm-f2i compile-expression ?type ?value) + (&a/$jvm-f2l ?value) + (&&host/compile-jvm-f2l compile-expression ?value) + + (&a/$jvm-i2b ?value) + (&&host/compile-jvm-i2b compile-expression ?value) - (&a/$jvm-f2l ?value) - (&&host/compile-jvm-f2l compile-expression ?type ?value) - - (&a/$jvm-i2b ?value) - (&&host/compile-jvm-i2b compile-expression ?type ?value) + (&a/$jvm-i2c ?value) + (&&host/compile-jvm-i2c compile-expression ?value) - (&a/$jvm-i2c ?value) - (&&host/compile-jvm-i2c compile-expression ?type ?value) + (&a/$jvm-i2d ?value) + (&&host/compile-jvm-i2d compile-expression ?value) - (&a/$jvm-i2d ?value) - (&&host/compile-jvm-i2d compile-expression ?type ?value) + (&a/$jvm-i2f ?value) + (&&host/compile-jvm-i2f compile-expression ?value) - (&a/$jvm-i2f ?value) - (&&host/compile-jvm-i2f compile-expression ?type ?value) + (&a/$jvm-i2l ?value) + (&&host/compile-jvm-i2l compile-expression ?value) - (&a/$jvm-i2l ?value) - (&&host/compile-jvm-i2l compile-expression ?type ?value) + (&a/$jvm-i2s ?value) + (&&host/compile-jvm-i2s compile-expression ?value) - (&a/$jvm-i2s ?value) - (&&host/compile-jvm-i2s compile-expression ?type ?value) + (&a/$jvm-l2d ?value) + (&&host/compile-jvm-l2d compile-expression ?value) - (&a/$jvm-l2d ?value) - (&&host/compile-jvm-l2d compile-expression ?type ?value) + (&a/$jvm-l2f ?value) + (&&host/compile-jvm-l2f compile-expression ?value) - (&a/$jvm-l2f ?value) - (&&host/compile-jvm-l2f compile-expression ?type ?value) + (&a/$jvm-l2i ?value) + (&&host/compile-jvm-l2i compile-expression ?value) - (&a/$jvm-l2i ?value) - (&&host/compile-jvm-l2i compile-expression ?type ?value) + (&a/$jvm-iand ?x ?y) + (&&host/compile-jvm-iand compile-expression ?x ?y) - (&a/$jvm-iand ?x ?y) - (&&host/compile-jvm-iand compile-expression ?type ?x ?y) + (&a/$jvm-ior ?x ?y) + (&&host/compile-jvm-ior compile-expression ?x ?y) - (&a/$jvm-ior ?x ?y) - (&&host/compile-jvm-ior compile-expression ?type ?x ?y) + (&a/$jvm-ixor ?x ?y) + (&&host/compile-jvm-ixor compile-expression ?x ?y) - (&a/$jvm-ixor ?x ?y) - (&&host/compile-jvm-ixor compile-expression ?type ?x ?y) + (&a/$jvm-ishl ?x ?y) + (&&host/compile-jvm-ishl compile-expression ?x ?y) - (&a/$jvm-ishl ?x ?y) - (&&host/compile-jvm-ishl compile-expression ?type ?x ?y) + (&a/$jvm-ishr ?x ?y) + (&&host/compile-jvm-ishr compile-expression ?x ?y) - (&a/$jvm-ishr ?x ?y) - (&&host/compile-jvm-ishr compile-expression ?type ?x ?y) + (&a/$jvm-iushr ?x ?y) + (&&host/compile-jvm-iushr compile-expression ?x ?y) - (&a/$jvm-iushr ?x ?y) - (&&host/compile-jvm-iushr compile-expression ?type ?x ?y) + (&a/$jvm-land ?x ?y) + (&&host/compile-jvm-land compile-expression ?x ?y) - (&a/$jvm-land ?x ?y) - (&&host/compile-jvm-land compile-expression ?type ?x ?y) + (&a/$jvm-lor ?x ?y) + (&&host/compile-jvm-lor compile-expression ?x ?y) - (&a/$jvm-lor ?x ?y) - (&&host/compile-jvm-lor compile-expression ?type ?x ?y) + (&a/$jvm-lxor ?x ?y) + (&&host/compile-jvm-lxor compile-expression ?x ?y) - (&a/$jvm-lxor ?x ?y) - (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) + (&a/$jvm-lshl ?x ?y) + (&&host/compile-jvm-lshl compile-expression ?x ?y) - (&a/$jvm-lshl ?x ?y) - (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) + (&a/$jvm-lshr ?x ?y) + (&&host/compile-jvm-lshr compile-expression ?x ?y) - (&a/$jvm-lshr ?x ?y) - (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) + (&a/$jvm-lushr ?x ?y) + (&&host/compile-jvm-lushr compile-expression ?x ?y) - (&a/$jvm-lushr ?x ?y) - (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) + (&a/$jvm-instanceof ?class ?object) + (&&host/compile-jvm-instanceof compile-expression ?class ?object) - (&a/$jvm-instanceof ?class ?object) - (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) - ) + _ + (assert false (prn-str 'compile-expression (&/adt->text syntax))) + )) )) (defn ^:private compile-token [syntax] @@ -429,13 +443,15 @@ (&/with-eval (|do [module &/get-module-name id &/gen-id + [file-name _ _] &/cursor :let [class-name (str (&host/->module-class module) "/" id) ;; _ (prn 'eval! id class-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))))] + (doto (.visitEnd))) + (.visitSource file-name nil))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitCode *writer*)] @@ -475,7 +491,8 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/hash-field "I" nil file-hash) .visitEnd) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version) - .visitEnd)) + .visitEnd) + (.visitSource file-name nil)) ;; _ (prn 'compile-module name =class) ]] (fn [state] @@ -524,6 +541,7 @@ )) (defn ^:private init! [] + (reset! !source->last-line {}) (.mkdirs (java.io.File. &&/output-dir))) ;; [Resources] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 5f9d6cd2d..64237f3db 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -161,7 +161,7 @@ )) ;; [Resources] -(defn compile-case [compile *type* ?value ?matches] +(defn compile-case [compile ?value ?matches] (|do [^MethodVisitor *writer* &/get-writer :let [$end (new Label)] _ (compile ?value) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 2ca613633..179b5423c 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -88,7 +88,7 @@ ;; [Resources] (do-template [ ] - (defn [compile *type* ?x ?y] + (defn [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer _ (compile ?x) @@ -130,7 +130,7 @@ ) (do-template [ ] - (defn [compile *type* ?x ?y] + (defn [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer _ (compile ?y) @@ -162,7 +162,7 @@ ) (do-template [ ] - (defn [compile *type* ?x ?y] + (defn [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer _ (compile ?y) @@ -199,9 +199,9 @@ compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()D" ) -(defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] +(defn compile-jvm-invokestatic [compile ?class ?method ?classes ?args ?output-type] (|do [^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] @@ -209,14 +209,14 @@ ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) - (prepare-return! *type*))]] + (prepare-return! ?output-type))]] (return nil))) (do-template [ ] - (defn [compile *type* ?class ?method ?classes ?object ?args] + (defn [compile ?class ?method ?classes ?object ?args ?output-type] (|do [:let [?class* (&host/->class (&type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] _ (&/map2% (fn [class-name arg] @@ -226,7 +226,7 @@ ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn ?class* ?method method-sig) - (prepare-return! *type*))]] + (prepare-return! ?output-type))]] (return nil))) compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL @@ -234,10 +234,10 @@ ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL ) -(defn compile-jvm-invokespecial [compile *type* ?class ?method ?classes ?object ?args] +(defn compile-jvm-invokespecial [compile ?class ?method ?classes ?object ?args ?output-type] (|do [:let [?class* (&host/->class (&type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] :let [_ (when (not= "" ?method) @@ -249,15 +249,15 @@ ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig) - (prepare-return! *type*))]] + (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-null [compile *type*] +(defn compile-jvm-null [compile] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) -(defn compile-jvm-null? [compile *type* ?object] +(defn compile-jvm-null? [compile ?object] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [$then (new Label) @@ -271,7 +271,7 @@ (.visitLabel $end))]] (return nil))) -(defn compile-jvm-new [compile *type* ?class ?classes ?args] +(defn compile-jvm-new [compile ?class ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer :let [init-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")V") class* (&host/->class ?class) @@ -288,14 +288,14 @@ (return nil))) (do-template [ ] - (do (defn [compile *type* ?length] + (do (defn [compile ?length] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?length) :let [_ (.visitInsn *writer* Opcodes/L2I)] :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] (return nil))) - (defn [compile *type* ?array ?idx] + (defn [compile ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -306,7 +306,7 @@ )]] (return nil))) - (defn [compile *type* ?array ?idx ?elem] + (defn [compile ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -330,14 +330,14 @@ Opcodes/T_CHAR compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char ) -(defn compile-jvm-anewarray [compile *type* ?class ?length] +(defn compile-jvm-anewarray [compile ?class ?length] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?length) :let [_ (.visitInsn *writer* Opcodes/L2I)] :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] (return nil))) -(defn compile-jvm-aaload [compile *type* ?class ?array ?idx] +(defn compile-jvm-aaload [compile ?class ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -346,7 +346,7 @@ :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) -(defn compile-jvm-aastore [compile *type* ?class ?array ?idx ?elem] +(defn compile-jvm-aastore [compile ?class ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -357,7 +357,7 @@ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn compile-jvm-arraylength [compile *type* ?array] +(defn compile-jvm-arraylength [compile ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -367,36 +367,38 @@ &&/wrap-long)]] (return nil))) -(defn compile-jvm-getstatic [compile *type* ?class ?field] +(defn compile-jvm-getstatic [compile ?class ?field ?output-type] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*)) - (prepare-return! *type*))]] + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) + (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-getfield [compile *type* ?class ?field ?object] +(defn compile-jvm-getfield [compile ?class ?field ?object ?output-type] (|do [:let [class* (&host/->class (&type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST class*) - (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig *type*)) - (prepare-return! *type*))]] + (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig ?output-type)) + (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-putstatic [compile *type* ?class ?field ?value] +(defn compile-jvm-putstatic [compile ?class ?field ?value ?output-type] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) -(defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value] +(defn compile-jvm-putfield [compile ?class ?field ?object ?value ?output-type] (|do [:let [class* (&host/->class (&type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) + :let [_ (.visitInsn *writer* Opcodes/DUP)] _ (compile ?value) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig ?output-type))]] (return nil))) (defn ^:private modifiers->int [mods] @@ -414,7 +416,7 @@ ;; else 0))) -(defn compile-jvm-instanceof [compile *type* class object] +(defn compile-jvm-instanceof [compile class object] (|do [:let [class* (&host/->class class)] ^MethodVisitor *writer* &/get-writer _ (compile object) @@ -463,7 +465,7 @@ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) + [?name [_ (&a/$captured _ ?captured-id ?source)]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -474,11 +476,13 @@ (|do [;; :let [_ (prn 'compile-jvm-class/_0)] module &/get-module-name ;; :let [_ (prn 'compile-jvm-class/_1)] + [file-name _ _] &/cursor :let [full-name (str module "/" ?name) super-class* (&host/->class ?super-class) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))) + (.visitSource file-name nil)) _ (&/|map (fn [field] (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) (&host/->type-signature (:type field)) nil nil) @@ -495,15 +499,17 @@ (defn compile-jvm-interface [compile ?name ?supers ?methods] ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) - (|do [module &/get-module-name] + (|do [module &/get-module-name + [file-name _ _] &/cursor] (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) - (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) + (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String))) + (.visitSource file-name nil)) _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) -(defn compile-jvm-try [compile *type* ?body ?catches ?finally] +(defn compile-jvm-try [compile ?body ?catches ?finally] (|do [^MethodVisitor *writer* &/get-writer :let [$from (new Label) $to (new Label) @@ -555,14 +561,14 @@ :let [_ (.visitLabel *writer* $end)]] (return nil))) -(defn compile-jvm-throw [compile *type* ?ex] +(defn compile-jvm-throw [compile ?ex] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?ex) :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil))) (do-template [ ] - (defn [compile *type* ?monitor] + (defn [compile ?monitor] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?monitor) :let [_ (doto *writer* @@ -575,7 +581,7 @@ ) (do-template [ ] - (defn [compile *type* ?value] + (defn [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW (&host/->class )) @@ -609,7 +615,7 @@ ) (do-template [ ] - (defn [compile *type* ?x ?y] + (defn [compile ?x ?y] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW (&host/->class )) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 86bc08534..77dc316b8 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -44,7 +44,7 @@ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) + [?name [_ (&a/$captured _ ?captured-id ?source)]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -82,7 +82,7 @@ (.visitInsn Opcodes/DUP))] _ (&/map% (fn [?name+?captured] (|case ?name+?captured - [?name [(&a/$captured _ _ ?source) _]] + [?name [_ (&a/$captured _ _ ?source)]] (compile ?source))) closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] @@ -93,7 +93,8 @@ datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] (defn compile-lambda [compile ?scope ?env ?body] ;; (prn 'compile-lambda (->> ?scope &/->seq)) - (|do [:let [name (&host/location (&/|tail ?scope)) + (|do [[file-name _ _] &/cursor + :let [name (&host/location (&/|tail ?scope)) class-name (str (&host/->module-class (&/|head ?scope)) "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 lambda-flags @@ -102,8 +103,9 @@ (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) + [?name [_ (&a/$captured _ ?captured-id ?source)]]) (doseq [?name+?captured (&/->seq ?env)]))) + (.visitSource file-name nil) (add-lambda-apply class-name ?env) (add-lambda- class-name ?env) )] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index e85af8b0d..f7cd905e8 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -26,13 +26,13 @@ MethodVisitor))) ;; [Exports] -(defn compile-bool [compile *type* ?value] +(defn compile-bool [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) (do-template [ ] - (defn [compile *type* value] + (defn [compile value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW ) @@ -46,12 +46,12 @@ compile-char "java/lang/Character" "(C)V" char ) -(defn compile-text [compile *type* ?value] +(defn compile-text [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-tuple [compile *type* ?elems] +(defn compile-tuple [compile ?elems] (|do [^MethodVisitor *writer* &/get-writer :let [num-elems (&/|length ?elems) _ (doto *writer* @@ -67,7 +67,7 @@ (&/|range num-elems) ?elems)] (return nil))) -(defn compile-variant [compile *type* ?tag ?value] +(defn compile-variant [compile ?tag ?value] ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -84,12 +84,12 @@ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn compile-local [compile *type* ?idx] +(defn compile-local [compile ?idx] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] (return nil))) -(defn compile-captured [compile *type* ?scope ?captured-id ?source] +(defn compile-captured [compile ?scope ?captured-id ?source] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) @@ -99,12 +99,12 @@ "Ljava/lang/Object;"))]] (return nil))) -(defn compile-global [compile *type* ?owner-class ?name] +(defn compile-global [compile ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) &/datum-field "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile *type* ?fn ?args] +(defn compile-apply [compile ?fn ?args] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) _ (&/map% (fn [?arg] @@ -142,10 +142,10 @@ "value" (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) ?def-type (|case ?body - [(&a/$ann ?def-value ?type-expr) ?def-type] + [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr)] ?type-expr - [?def-value ?def-type] + [[?def-type ?def-cursor] ?def-value] (&&type/->analysis ?def-type))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S @@ -186,6 +186,7 @@ "value")] ^ClassWriter *writer* &/get-writer module-name &/get-module-name + [file-name _ _] &/cursor :let [datum-sig "Ljava/lang/Object;" def-name (&/normalize-name ?name) current-class (str (&host/->module-class module-name) "/" def-name) @@ -197,7 +198,8 @@ (-> (.visitField field-flags &/datum-field datum-sig nil nil) (doto (.visitEnd))) (-> (.visitField field-flags &/meta-field datum-sig nil nil) - (doto (.visitEnd))))] + (doto (.visitEnd))) + (.visitSource file-name nil))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] @@ -217,7 +219,7 @@ _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] (return nil)))) -(defn compile-ann [compile *type* ?value-ex ?type-ex] +(defn compile-ann [compile ?value-ex ?type-ex] (compile ?value-ex)) (defn compile-declare-macro [compile module name] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 00e66410f..c1615f9b6 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -13,23 +13,27 @@ ;; [Utils] (defn ^:private variant$ [tag body] "(-> Text Analysis Analysis)" - (&/T (&/V &a/$variant (&/T tag body)) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$variant (&/T tag body)) + )) (defn ^:private tuple$ [members] "(-> (List Analysis) Analysis)" - (&/T (&/V &a/$tuple members) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$tuple members) + )) (defn ^:private int$ [value] "(-> Int Analysis)" - (&/T (&/V &a/$int value) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$int value) + )) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/T (&/V &a/$text text) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$text text) + )) (def ^:private $Nil "Analysis" -- cgit v1.2.3 From ceff2a8a5fc4cb701a114071f75367c8b1004887 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 16 Sep 2015 21:10:41 -0400 Subject: - Did a trick to make sure "this" always had the type of the class being defined, instead of the type of the super-class. --- src/lux/analyser/host.clj | 9 ++++--- src/lux/compiler/host.clj | 21 +++------------- src/lux/host.clj | 64 +++++++++++++++++++++++++++++++++++++---------- src/lux/type.clj | 2 -- 4 files changed, 60 insertions(+), 36 deletions(-) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 292d3d4b1..6c15c8bbc 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -425,7 +425,7 @@ _ (fail "[Analyser Error] Wrong syntax for field."))) -(defn ^:private analyse-method [analyse name owner-class method] +(defn ^:private analyse-method [analyse owner-class method] (|case method [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS method-inputs)] @@ -511,10 +511,12 @@ (defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods] (&/with-closure (|do [module &/get-module-name + :let [full-name (str module "." name)] ;; :let [_ (prn 'analyse-jvm-class/_0)] =fields (&/map% analyse-field fields) ;; :let [_ (prn 'analyse-jvm-class/_1)] - =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + _ (&host/use-dummy-class name super-class interfaces =fields) + =methods (&/map% (partial analyse-method analyse full-name) (&/enumerate methods)) ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-class/_3)] @@ -549,7 +551,8 @@ :let [name (&host/location (&/|tail scope)) anon-class (str module "." name)] ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] - =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + _ (&host/use-dummy-class name super-class interfaces (&/|list)) + =methods (&/map% (partial analyse-method analyse anon-class) (&/enumerate methods)) ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 179b5423c..89f830561 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -401,21 +401,6 @@ :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig ?output-type))]] (return nil))) -(defn ^:private modifiers->int [mods] - (+ (case (:visibility mods) - "default" 0 - "public" Opcodes/ACC_PUBLIC - "private" Opcodes/ACC_PRIVATE - "protected" Opcodes/ACC_PROTECTED) - (if (:static? mods) Opcodes/ACC_STATIC 0) - (if (:final? mods) Opcodes/ACC_FINAL 0) - (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0) - (case (:concurrency mods) - "synchronized" Opcodes/ACC_SYNCHRONIZED - "volatile" Opcodes/ACC_VOLATILE - ;; else - 0))) - (defn compile-jvm-instanceof [compile class object] (|do [:let [class* (&host/->class class)] ^MethodVisitor *writer* &/get-writer @@ -432,7 +417,7 @@ ;; (prn 'compile-method/_3 (&/adt->text (:body method))) (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod class-writer (modifiers->int (:modifiers method)) + (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil nil) (|do [^MethodVisitor =method &/get-writer @@ -447,7 +432,7 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil nil))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] @@ -484,7 +469,7 @@ full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))) (.visitSource file-name nil)) _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (doto (.visitField =class (&host/modifiers->int (:modifiers field)) (:name field) (&host/->type-signature (:type field)) nil nil) (.visitEnd))) ?fields)] diff --git a/src/lux/host.clj b/src/lux/host.clj index 6be162bf7..d2ade63c7 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -11,7 +11,11 @@ (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) (:import (java.lang.reflect Field Method Constructor Modifier) - java.util.regex.Pattern)) + java.util.regex.Pattern + (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) ;; [Constants] (def prefix "lux.") @@ -46,18 +50,18 @@ (defn ^:private class->type [^Class class] "(-> Class Type)" (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) - (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] - (let [base (or arr-base simple-base)] - ;; (prn 'class->type/_1 class base arr-brackets) - (let [output-type (if (.equals "void" base) - &type/Unit - (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) - (&type/Data$ base &/Nil$) - (range (count (or arr-brackets "")))) - )] - ;; (prn 'class->type/_2 class (&type/show-type output-type)) - output-type) - )))) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + ;; (prn 'class->type/_1 class base arr-brackets) + (let [output-type (if (.equals "void" base) + &type/Unit + (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (&type/Data$ base &/Nil$) + (range (count (or arr-brackets "")))) + )] + ;; (prn 'class->type/_2 class (&type/show-type output-type)) + output-type) + )))) (defn ^:private method->type [^Method method] "(-> Method Type)" @@ -186,3 +190,37 @@ (defn location [scope] (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) + +(defn modifiers->int [mods] + (+ (case (:visibility mods) + "default" 0 + "public" Opcodes/ACC_PUBLIC + "private" Opcodes/ACC_PRIVATE + "protected" Opcodes/ACC_PROTECTED) + (if (:static? mods) Opcodes/ACC_STATIC 0) + (if (:final? mods) Opcodes/ACC_FINAL 0) + (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0) + (case (:concurrency mods) + "synchronized" Opcodes/ACC_SYNCHRONIZED + "volatile" Opcodes/ACC_VOLATILE + ;; else + 0))) + +(defn use-dummy-class [name super-class interfaces fields] + (|do [module &/get-module-name + :let [full-name (str module "/" name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil (->class super-class) (->> interfaces (&/|map ->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (->type-signature (:type field)) nil nil) + (.visitEnd))) + fields) + bytecode (.toByteArray (doto =class .visitEnd))] + loader &/loader + !classes &/classes + :let [real-name (str (->class-name module) "." name) + _ (swap! !classes assoc real-name bytecode) + _ (.loadClass loader real-name)]] + (return nil))) diff --git a/src/lux/type.clj b/src/lux/type.clj index bc28dbde0..24486c85a 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -404,8 +404,6 @@ "\n\nActual: " (show-type actual) "\n")) -;; (def !flag (atom false)) - (defn beta-reduce [env type] ;; (when @!flag ;; (prn 'beta-reduce (show-type type))) -- cgit v1.2.3 From 03bf7b58e6cf45b76b317369aa476443236658f9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 09:22:21 -0400 Subject: - Both method declarations & method definitions in classes can now include declarations of which exceptions they throw. --- source/lux.lux | 2 +- source/lux/host/jvm.lux | 62 +++++++++++++++++++++++++++++++++++----------- source/lux/meta/syntax.lux | 21 ++++++++++++++++ src/lux/analyser/host.clj | 30 +++++++++++++--------- src/lux/compiler/host.clj | 6 +++-- 5 files changed, 91 insertions(+), 30 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index 3ede6d75b..fbdd71904 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -5,7 +5,7 @@ ## First things first, must define functions (_jvm_interface "Function" [] - ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + ("apply" ["public" "abstract"] [] ["java.lang.Object"] "java.lang.Object")) ## Basic types (_lux_def Bool (10 ["lux" "Bool"] diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 1e903ad1d..4892ba333 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -42,7 +42,8 @@ (deftype MethodDecl (& #method-inputs (List JvmType) - #method-output JvmType)) + #method-output JvmType + #method-exs (List JvmType))) (deftype ArgDecl (& #arg-name Text @@ -51,7 +52,8 @@ (deftype MethodDef (& #method-vars (List ArgDecl) #return-type JvmType - #return-body AST)) + #return-body AST + #throws-exs (List JvmType))) (deftype ExpectedInput (& #opt-input? Bool @@ -88,11 +90,30 @@ (Parser MemberDecl) (&^ (*^ local-tag^) local-symbol^)) +(def throws-decl'^ + (Parser (List JvmType)) + (do Parser/Monad + [_ (tag!^ ["" "throws"])] + (tuple^ (*^ local-symbol^)))) + +(def throws-decl^ + (Parser (List JvmType)) + (do Parser/Monad + [exs? (?^ throws-decl'^)] + (wrap (? (@list) exs?)))) + +(def method-decl'^ + (Parser MethodDecl) + (do Parser/Monad + [inputs (tuple^ (*^ local-symbol^)) + outputs local-symbol^ + exs throws-decl^] + (wrap [inputs outputs exs]))) + (def method-decl^ (Parser (, MemberDecl MethodDecl)) (form^ (&^ member-decl^ - (&^ (tuple^ (*^ local-symbol^)) - local-symbol^)))) + method-decl'^))) (def field-decl^ (Parser (, MemberDecl FieldDecl)) @@ -103,14 +124,19 @@ (Parser ArgDecl) (form^ (&^ local-symbol^ local-symbol^))) +(def method-def'^ + (Parser MethodDef) + (do Parser/Monad + [inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + exs throws-decl^ + body id^] + (wrap [inputs output body exs]))) + (def method-def^ (Parser (, MemberDecl MethodDef)) - (form^ (do Parser/Monad - [=member-decl member-decl^ - inputs (tuple^ (*^ arg-decl^)) - output local-symbol^ - body id^] - (wrap [=member-decl [inputs output body]])))) + (form^ (&^ member-decl^ + method-def'^))) (def exp-input^ (Parser ExpectedInput) @@ -126,26 +152,32 @@ (wrap [ex? opt? return]))) ## Generators -(def (gen-method-decl [[modifiers name] [inputs output]]) +(def (gen-method-decl [[modifiers name] [inputs output exs]]) (-> (, MemberDecl MethodDecl) AST) - (` ((~ (text$ name)) [(~@ (map text$ inputs))] (~ (text$ output)) [(~@ (map text$ modifiers))]))) + (` ((~ (text$ name)) + [(~@ (map text$ modifiers))] + [(~@ (map text$ exs))] + [(~@ (map text$ inputs))] + (~ (text$ output))))) (def (gen-field-decl [[modifiers name] class]) (-> (, MemberDecl FieldDecl) AST) (` ((~ (text$ name)) + [(~@ (map text$ modifiers))] (~ (text$ class)) - [(~@ (map text$ modifiers))]))) + ))) (def (gen-arg-decl [name type]) (-> ArgDecl AST) (form$ (@list (symbol$ ["" name]) (text$ type)))) -(def (gen-method-def [[modifiers name] [inputs output body]]) +(def (gen-method-def [[modifiers name] [inputs output body exs]]) (-> (, MemberDecl MethodDef) AST) (` ((~ (text$ name)) + [(~@ (map text$ modifiers))] + [(~@ (map text$ exs))] [(~@ (map gen-arg-decl inputs))] (~ (text$ output)) - [(~@ (map text$ modifiers))] (~ body)))) (def (gen-expected-output [ex? opt? output] body) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 3b9149a74..d9f3c6dc3 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -137,6 +137,27 @@ [ tag?^ Ident #;TagS ident:=] ) +(do-template [ ] + [(def #export ( v tokens) + (-> (Parser Unit)) + (case tokens + (#;Cons [[_ ( x)] tokens']) + (if ( v x) + (#;Some [tokens' []]) + #;None) + + _ + #;None))] + + [ bool!^ Bool #;BoolS (:: b;Bool/Eq =)] + [ int!^ Int #;IntS i=] + [ real!^ Real #;RealS r=] + [ char!^ Char #;CharS (:: c;Char/Eq =)] + [ text!^ Text #;TextS (:: t;Text/Eq =)] + [symbol!^ Ident #;SymbolS ident:=] + [ tag!^ Ident #;TagS ident:=] + ) + (do-template [ ] [(def #export ( p tokens) (All [a] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 6c15c8bbc..9d295edda 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -414,8 +414,8 @@ (defn ^:private analyse-field [field] (|case field [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Cons [_ (&/$TextS ?field-type)] (&/$Nil)))))] (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name @@ -428,12 +428,14 @@ (defn ^:private analyse-method [analyse owner-class method] (|case method [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons method-body - (&/$Nil)))))))]] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil))))))))]] (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] (|case minput [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] @@ -455,6 +457,7 @@ =method-inputs)))] (return {:name method-name :modifiers =method-modifiers + :exceptions =method-exs :inputs (&/|map &/|second =method-inputs) :output method-output :body =method-body})) @@ -465,14 +468,17 @@ (defn ^:private analyse-method-decl [method] (|case method [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TextS output)] - (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Nil))))))] + (&/$Cons [_ (&/$TupleS modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Nil)))))))] (|do [=inputs (&/map% extract-text inputs) - =modifiers (analyse-modifiers modifiers)] + =modifiers (analyse-modifiers modifiers) + =method-exs (&/map% extract-text method-exs)] (return {:name method-name :modifiers =modifiers + :exceptions =method-exs :inputs =inputs :output output})) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 89f830561..b4858d789 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -419,7 +419,9 @@ (&host/->type-signature (:output method)))] (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) - signature nil nil) + signature + nil + (->> (:exceptions method) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (.visitCode =method)] _ (compile (:body method)) @@ -432,7 +434,7 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil nil))) + (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) &/->seq (into-array java.lang.String))))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] -- cgit v1.2.3 From 0fbbced7029ae8dc05b63c618bc6dd30aeef8b09 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 16:17:03 -0400 Subject: - Finished some missing bits of class definition analysis. --- src/lux/analyser/host.clj | 54 ++++++++++++++++++++++++++++-------- src/lux/compiler/host.clj | 36 ++++++++++++++++++++++-- src/lux/host.clj | 70 +++++++++++++++++++++++++++++++++++++++++------ src/lux/type.clj | 50 ++++++++++++++++++--------------- 4 files changed, 165 insertions(+), 45 deletions(-) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9d295edda..53ab1de5b 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -425,15 +425,45 @@ _ (fail "[Analyser Error] Wrong syntax for field."))) +(defn ^:private dummy-method-desc [method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil))))))))] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-exs (&/map% extract-text method-exs) + =method-inputs (&/map% (fn [minput] + (|case minput + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] + (&/$Cons [_ (&/$TextS input-type)] + (&/$Nil))))] + (return (&/T input-name input-type)) + + _ + (fail "[Analyser Error] Wrong syntax for method input."))) + method-inputs)] + (return {:name method-name + :modifiers =method-modifiers + :exceptions =method-exs + :inputs (&/|map &/|second =method-inputs) + :output method-output})) + + _ + (fail "[Analyser Error] Wrong syntax for method."))) + (defn ^:private analyse-method [analyse owner-class method] (|case method - [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil))))))))]] + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil))))))))] (|do [=method-modifiers (analyse-modifiers method-modifiers) =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] @@ -521,8 +551,9 @@ ;; :let [_ (prn 'analyse-jvm-class/_0)] =fields (&/map% analyse-field fields) ;; :let [_ (prn 'analyse-jvm-class/_1)] - _ (&host/use-dummy-class name super-class interfaces =fields) - =methods (&/map% (partial analyse-method analyse full-name) (&/enumerate methods)) + =method-descs (&/map% dummy-method-desc methods) + _ (&host/use-dummy-class name super-class interfaces =fields =method-descs) + =methods (&/map% (partial analyse-method analyse full-name) methods) ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-class/_3)] @@ -557,8 +588,9 @@ :let [name (&host/location (&/|tail scope)) anon-class (str module "." name)] ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] - _ (&host/use-dummy-class name super-class interfaces (&/|list)) - =methods (&/map% (partial analyse-method analyse anon-class) (&/enumerate methods)) + =method-descs (&/map% dummy-method-desc methods) + _ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs) + =methods (&/map% (partial analyse-method analyse anon-class) methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index b4858d789..95d63b0fb 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -410,6 +410,36 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-method-return [writer output] + (case output + "void" (.visitInsn writer Opcodes/RETURN) + "boolean" (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + "byte" (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + "short" (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + "int" (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + "long" (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + "float" (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + "double" (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + "char" (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + ;; else + (.visitInsn writer Opcodes/ARETURN))) + (defn ^:private compile-method [compile class-writer method] ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) @@ -421,12 +451,12 @@ (:name method) signature nil - (->> (:exceptions method) &/->seq (into-array java.lang.String))) + (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (.visitCode =method)] _ (compile (:body method)) :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (compile-method-return (:output method)) (.visitMaxs 0 0) (.visitEnd))]] (return nil))))) @@ -434,7 +464,7 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) &/->seq (into-array java.lang.String))))) + (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] diff --git a/src/lux/host.clj b/src/lux/host.clj index d2ade63c7..b05c30ad3 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -68,14 +68,15 @@ (class->type (.getReturnType method))) ;; [Resources] -(defn ^String ->class [class] - (string/replace class (-> class-name-separator Pattern/quote re-pattern) class-separator)) - -(defn ^String ->class-name [module] - (string/replace module (-> module-separator Pattern/quote re-pattern) class-name-separator)) - -(defn ^String ->module-class [module-name] - (string/replace module-name (-> module-separator Pattern/quote re-pattern) class-separator)) +(do-template [ ] + (let [regex (-> Pattern/quote re-pattern)] + (defn [old] + (string/replace old regex ))) + + ^String ->class class-name-separator class-separator + ^String ->class-name module-separator class-name-separator + ^String ->module-class module-separator class-separator + ) (def ->package ->module-class) @@ -206,7 +207,45 @@ ;; else 0))) -(defn use-dummy-class [name super-class interfaces fields] +(let [object-real-class (->class "java.lang.Object")] + (defn ^:private dummy-return [writer name output] + (case output + "void" (if (= "" name) + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL object-real-class "" "()V") + (.visitInsn Opcodes/RETURN)) + (.visitInsn writer Opcodes/RETURN)) + "boolean" (doto writer + (.visitLdcInsn false) + (.visitInsn Opcodes/IRETURN)) + "byte" (doto writer + (.visitLdcInsn (byte 0)) + (.visitInsn Opcodes/IRETURN)) + "short" (doto writer + (.visitLdcInsn (short 0)) + (.visitInsn Opcodes/IRETURN)) + "int" (doto writer + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/IRETURN)) + "long" (doto writer + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN)) + "float" (doto writer + (.visitLdcInsn (float 0.0)) + (.visitInsn Opcodes/FRETURN)) + "double" (doto writer + (.visitLdcInsn (double 0.0)) + (.visitInsn Opcodes/DRETURN)) + "char" (doto writer + (.visitLdcInsn (char 0)) + (.visitInsn Opcodes/IRETURN)) + ;; else + (doto writer + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN))))) + +(defn use-dummy-class [name super-class interfaces fields methods] (|do [module &/get-module-name :let [full-name (str module "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -217,6 +256,19 @@ (->type-signature (:type field)) nil nil) (.visitEnd))) fields) + _ (&/|map (fn [method] + (|let [signature (str "(" (&/fold str "" (&/|map ->type-signature (:inputs method))) ")" + (->type-signature (:output method)))] + (doto (.visitMethod =class (modifiers->int (:modifiers method)) + (:name method) + signature + nil + (->> (:exceptions method) (&/|map ->class) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return (:name method) (:output method)) + (.visitMaxs 0 0) + (.visitEnd)))) + methods) bytecode (.toByteArray (doto =class .visitEnd))] loader &/loader !classes &/classes diff --git a/src/lux/type.clj b/src/lux/type.clj index 24486c85a..0495e6b02 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -663,31 +663,37 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT "#Null" (&/$Nil))] - (if (contains? primitive-types e!name) - (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/T fixpoints nil))) - [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] - (cond (and (.equals ^Object e!name a!name) - (= (&/|length e!params) (&/|length a!params))) - (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] - (return (&/T fixpoints nil))) - - (and (not invariant??) - ;; (do (println '[Data Data] [e!name a!name] - ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) - ;; true) - (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) - (catch Exception e - (prn 'FAILED_HERE e!name a!name)))) + (cond (= "#Null" a!name) + (if (not (contains? primitive-types e!name)) (return (&/T fixpoints nil)) + (fail (check-error expected actual))) - :else - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) + (= "#Null" e!name) + (if (= "#Null" a!name) + (return (&/T fixpoints nil)) + (fail (check-error expected actual))) + + :else + (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (cond (and (.equals ^Object e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] + (return (&/T fixpoints nil))) + + (and (not invariant??) + ;; (do (println '[Data Data] [e!name a!name] + ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) + ;; true) + (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) + (catch Exception e + (prn 'FAILED_HERE e!name a!name)))) + (return (&/T fixpoints nil)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] -- cgit v1.2.3 From 506ec627005cca8a2e6f7c4fcf374634be3653de Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 18:10:00 -0400 Subject: - Added support for Java annotations. --- source/lux.lux | 4 +- source/lux/host/jvm.lux | 70 +++++++++++++++++++++++++++++----- source/lux/meta/syntax.lux | 22 +++++++++-- src/lux/analyser.clj | 14 ++++--- src/lux/analyser/host.clj | 93 +++++++++++++++++++++++++++++++++------------- src/lux/compiler.clj | 8 ++-- src/lux/compiler/host.clj | 37 ++++++++++++++---- 7 files changed, 189 insertions(+), 59 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index fbdd71904..dddf5c80d 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -4,8 +4,8 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. ## First things first, must define functions -(_jvm_interface "Function" [] - ("apply" ["public" "abstract"] [] ["java.lang.Object"] "java.lang.Object")) +(_jvm_interface "Function" [] [] + ("apply" ["public" "abstract"] [] [] ["java.lang.Object"] "java.lang.Object")) ## Basic types (_lux_def Bool (10 ["lux" "Bool"] diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 4892ba333..bbb396874 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -33,9 +33,17 @@ (deftype Modifier Text) (deftype JvmType Text) +(deftype AnnotationParam + (, Text AST)) + +(deftype Annotation + (& #ann-name Text + #ann-params (List AnnotationParam))) + (deftype MemberDecl - (& #member-modifiers (List Modifier) - #member-name Text)) + (& #member-name Text + #member-modifiers (List Modifier) + #member-anns (List Annotation))) (deftype FieldDecl JvmType) @@ -86,9 +94,34 @@ (wrap [vars var-types (list:join var-rebinds) arg-classes]))) ## Parsers +(def annotation-params^ + (Parser (List AnnotationParam)) + (record^ (*^ (tuple^ (&^ local-tag^ id^))))) + +(def annotation^ + (Parser Annotation) + (form^ (&^ local-symbol^ + annotation-params^))) + +(def annotations^' + (Parser (List Annotation)) + (do Parser/Monad + [_ (tag!^ ["" "ann"])] + (tuple^ (*^ annotation^)))) + +(def annotations^ + (Parser (List Annotation)) + (do Parser/Monad + [anns?? (?^ annotations^')] + (wrap (? (@list) anns??)))) + (def member-decl^ (Parser MemberDecl) - (&^ (*^ local-tag^) local-symbol^)) + (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + anns annotations^] + (wrap [name modifiers anns]))) (def throws-decl'^ (Parser (List JvmType)) @@ -152,18 +185,29 @@ (wrap [ex? opt? return]))) ## Generators -(def (gen-method-decl [[modifiers name] [inputs output exs]]) +(def (gen-annotation-param [name value]) + (-> AnnotationParam (, AST AST)) + [(text$ name) value]) + +(def (gen-annotation [name params]) + (-> Annotation AST) + (` ((~ (text$ name)) + (~ (record$ (map gen-annotation-param params)))))) + +(def (gen-method-decl [[name modifiers anns] [inputs output exs]]) (-> (, MemberDecl MethodDecl) AST) (` ((~ (text$ name)) [(~@ (map text$ modifiers))] + [(~@ (map gen-annotation anns))] [(~@ (map text$ exs))] [(~@ (map text$ inputs))] (~ (text$ output))))) -(def (gen-field-decl [[modifiers name] class]) +(def (gen-field-decl [[name modifiers anns] class]) (-> (, MemberDecl FieldDecl) AST) (` ((~ (text$ name)) [(~@ (map text$ modifiers))] + [(~@ (map gen-annotation anns))] (~ (text$ class)) ))) @@ -171,10 +215,11 @@ (-> ArgDecl AST) (form$ (@list (symbol$ ["" name]) (text$ type)))) -(def (gen-method-def [[modifiers name] [inputs output body exs]]) +(def (gen-method-def [[name modifiers anns] [inputs output body exs]]) (-> (, MemberDecl MethodDef) AST) (` ((~ (text$ name)) [(~@ (map text$ modifiers))] + [(~@ (map gen-annotation anns))] [(~@ (map text$ exs))] [(~@ (map gen-arg-decl inputs))] (~ (text$ output)) @@ -217,18 +262,23 @@ (|> t get-stack-trace stack-trace->text))) ## [Syntax] -(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) - (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] - (~@ (map gen-method-decl members))))))) - (defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [annotations annotations^] [fields (*^ field-decl^)] [methods (*^ method-def^)]) (emit (@list (` (;_jvm_class (~ (text$ name)) (~ (text$ super)) [(~@ (map text$ interfaces))] + [(~@ (map gen-annotation annotations))] [(~@ (map gen-field-decl fields))] [(~@ (map gen-method-def methods))]))))) +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] + [annotations annotations^] + [members (*^ method-decl^)]) + (emit (@list (` (;_jvm_interface (~ (text$ name)) [(~@ (map text$ supers))] + [(~@ (map gen-annotation annotations))] + (~@ (map gen-method-decl members))))))) + (defsyntax #export (object [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] [methods (*^ method-def^)]) (emit (@list (` (;_jvm_anon-class (~ (text$ super)) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index d9f3c6dc3..641dfba0d 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -12,7 +12,7 @@ (data (bool #as b) (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) - (list #refer #all #open ("" List/Fold)) + (list #refer #all #open ("" List/Functor List/Fold)) (number (int #open ("i" Int/Ord)) (real #open ("r" Real/Eq)))))) @@ -28,6 +28,10 @@ #;Nil #;Nil (#;Cons [[x y] pairs']) (@list& x y (join-pairs pairs')))) +(def (pair->tuple [left right]) + (-> (, AST AST) AST) + (tuple$ (@list left right))) + ## [Types] (deftype #export (Parser a) (-> (List AST) (Maybe (, (List AST) a)))) @@ -163,8 +167,8 @@ (All [a] (-> (Parser a) (Parser a))) (case tokens - (#;Cons [[_ ( form)] tokens']) - (case (p form) + (#;Cons [[_ ( members)] tokens']) + (case (p members) (#;Some [#;Nil x]) (#;Some [tokens' x]) _ #;None) @@ -175,6 +179,18 @@ [tuple^ #;TupleS] ) +(def #export (record^ p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [[_ (#;RecordS pairs)] tokens']) + (case (p (map pair->tuple pairs)) + (#;Some [#;Nil x]) (#;Some [tokens' x]) + _ #;None) + + _ + #;None)) + (def #export (?^ p tokens) (All [a] (-> (Parser a) (Parser (Maybe a)))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 190b34b03..5659a066e 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -160,18 +160,20 @@ (&/$Cons [_ (&/$TextS ?name)] (&/$Cons [_ (&/$TextS ?super-class)] (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons [_ (&/$TupleS ?fields)] - (&/$Cons [_ (&/$TupleS ?methods)] - (&/$Nil)))))))) + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TupleS ?fields)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil))))))))) (|do [=interfaces (&/map% extract-text ?interfaces)] - (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?fields ?methods)) + (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?anns ?fields ?methods)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] (&/$Cons [_ (&/$TextS ?name)] (&/$Cons [_ (&/$TupleS ?supers)] - ?methods)))) + (&/$Cons [_ (&/$TupleS ?anns)] + ?methods))))) (|do [=supers (&/map% extract-text ?supers)] - (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods)) + (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?anns ?methods)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] (&/$Cons [_ (&/$TextS ?super-class)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 53ab1de5b..5208b2883 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -411,15 +411,45 @@ :concurrency nil} modifiers)) +(let [failure (fail (str "[Analyser Error] Invalid annotation parameter."))] + (defn ^:private extract-ann-param [param] + (|case param + [[_ (&/$TextS param-name)] param-value] + (|case param-value + [_ (&/$BoolS param-value*)] (return (&/T param-name (boolean param-value*))) + [_ (&/$IntS param-value*)] (return (&/T param-name (int param-value*))) + [_ (&/$RealS param-value*)] (return (&/T param-name (float param-value*))) + [_ (&/$CharS param-value*)] (return (&/T param-name (char param-value*))) + [_ (&/$TextS param-value*)] (return (&/T param-name param-value*)) + + _ + failure) + + _ + failure))) + +(defn ^:private analyse-ann [ann] + (|case ann + [_ (&/$FormS (&/$Cons [_ (&/$TextS ann-name)] (&/$Cons [_ (&/$RecordS ann-params)] (&/$Nil))))] + (|do [=ann-params (&/map% extract-ann-param ann-params)] + (return {:name ann-name + :params ann-params})) + + _ + (fail (str "[Analyser Error] Invalid annotation: " (&/show-ast ann))))) + (defn ^:private analyse-field [field] (|case field [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Nil)))))] - (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Nil))))))] + (|do [=field-modifiers (analyse-modifiers ?field-modifiers) + =anns (&/map% analyse-ann ?anns)] (return {:name ?field-name :modifiers =field-modifiers + :anns =anns :type ?field-type})) _ @@ -429,11 +459,12 @@ (|case method [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil))))))))] + (&/$Cons [_ (&/$TupleS method-anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil)))))))))] (|do [=method-modifiers (analyse-modifiers method-modifiers) =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] @@ -448,23 +479,26 @@ method-inputs)] (return {:name method-name :modifiers =method-modifiers + :anns (&/|list) :exceptions =method-exs :inputs (&/|map &/|second =method-inputs) :output method-output})) _ - (fail "[Analyser Error] Wrong syntax for method."))) + (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method))))) (defn ^:private analyse-method [analyse owner-class method] (|case method [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil))))))))] + (&/$Cons [_ (&/$TupleS method-anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil)))))))))] (|do [=method-modifiers (analyse-modifiers method-modifiers) + =anns (&/map% analyse-ann method-anns) =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] (|case minput @@ -487,27 +521,31 @@ =method-inputs)))] (return {:name method-name :modifiers =method-modifiers + :anns =anns :exceptions =method-exs :inputs (&/|map &/|second =method-inputs) :output method-output :body =method-body})) _ - (fail "[Analyser Error] Wrong syntax for method."))) + (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method))))) (defn ^:private analyse-method-decl [method] (|case method [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TextS output)] - (&/$Nil)))))))] - (|do [=inputs (&/map% extract-text inputs) - =modifiers (analyse-modifiers modifiers) + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Nil))))))))] + (|do [=modifiers (analyse-modifiers modifiers) + =anns (&/map% analyse-ann ?anns) + =inputs (&/map% extract-text inputs) =method-exs (&/map% extract-text method-exs)] (return {:name method-name :modifiers =modifiers + :anns =anns :exceptions =method-exs :inputs =inputs :output output})) @@ -544,11 +582,12 @@ (return nil) (fail (str "[Analyser Error] Missing method: " missing-method))))) -(defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods] +(defn analyse-jvm-class [analyse compile-token name super-class interfaces anns fields methods] (&/with-closure (|do [module &/get-module-name :let [full-name (str module "." name)] ;; :let [_ (prn 'analyse-jvm-class/_0)] + =anns (&/map% analyse-ann anns) =fields (&/map% analyse-field fields) ;; :let [_ (prn 'analyse-jvm-class/_1)] =method-descs (&/map% dummy-method-desc methods) @@ -557,14 +596,15 @@ ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-class/_3)] - _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods nil))) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =anns =fields =methods nil))) :let [_ (println 'DEF (str module "." name))]] (return &/Nil$)))) -(defn analyse-jvm-interface [analyse compile-token name supers methods] +(defn analyse-jvm-interface [analyse compile-token name supers anns methods] (|do [module &/get-module-name + =anns (&/map% analyse-ann anns) =methods (&/map% analyse-method-decl methods) - _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods))) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =anns =methods))) :let [_ (println 'DEF (str module "." name))]] (return &/Nil$))) @@ -598,6 +638,7 @@ :let [=fields (&/|map (fn [idx+capt] {:name (str &c!base/closure-prefix (aget idx+capt 0)) :modifiers captured-slot-modifier + :anns (&/|list) :type captured-slot-type}) (&/enumerate =captured)) ;; _ (prn '=methods (&/adt->text (&/|map :body =methods))) @@ -606,7 +647,7 @@ :let [sources (&/|map captured-source =captured)] ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) - _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured))) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured))) :let [_ (println 'DEF anon-class)] _cursor &/cursor] (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index d89684bcc..90b8bcc05 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -430,11 +430,11 @@ (&a/$jvm-program ?body) (&&host/compile-jvm-program compile-expression ?body) - (&a/$jvm-interface ?name ?supers ?methods) - (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) + (&a/$jvm-interface ?name ?supers ?anns ?methods) + (&&host/compile-jvm-interface compile-expression ?name ?supers ?anns ?methods) - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods ??env) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods ??env) + (&a/$jvm-class ?name ?super-class ?interfaces ?anns ?fields ?methods ??env) + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?anns ?fields ?methods ??env) _ (compile-expression syntax))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 95d63b0fb..2322b0e32 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -410,6 +410,25 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-annotation [writer ann] + (doto (.visitAnnotation writer (&host/->class (:name ann)) true) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) + nil) + +(defn ^:private compile-field [writer field] + (let [=field (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil)] + (&/|map (partial compile-annotation =field) (:anns field)) + (.visitEnd =field) + nil) + ;; (doto (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) + ;; (&host/->type-signature (:type field)) nil nil) + ;; (.visitEnd)) + ) + (defn ^:private compile-method-return [writer output] (case output "void" (.visitInsn writer Opcodes/RETURN) @@ -453,7 +472,8 @@ nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer - :let [_ (.visitCode =method)] + :let [_ (&/|map (partial compile-annotation =method) (:anns method)) + _ (.visitCode =method)] _ (compile (:body method)) :let [_ (doto =method (compile-method-return (:output method)) @@ -464,7 +484,9 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))))) + (let [=method (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))] + (&/|map (partial compile-annotation =method) (:anns method)) + nil))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] @@ -489,7 +511,7 @@ (.visitEnd))) ) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods env] +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env] (|do [;; :let [_ (prn 'compile-jvm-class/_0)] module &/get-module-name ;; :let [_ (prn 'compile-jvm-class/_1)] @@ -500,10 +522,8 @@ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))) (.visitSource file-name nil)) - _ (&/|map (fn [field] - (doto (.visitField =class (&host/modifiers->int (:modifiers field)) (:name field) - (&host/->type-signature (:type field)) nil nil) - (.visitEnd))) + _ (&/|map (partial compile-annotation =class) ?anns) + _ (&/|map (partial compile-field =class) ?fields)] ;; :let [_ (prn 'compile-jvm-class/_2)] _ (&/map% (partial compile-method compile =class) ?methods) @@ -514,7 +534,7 @@ ] (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) -(defn compile-jvm-interface [compile ?name ?supers ?methods] +(defn compile-jvm-interface [compile ?name ?supers ?anns ?methods] ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) (|do [module &/get-module-name [file-name _ _] &/cursor] @@ -522,6 +542,7 @@ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String))) (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =interface) ?anns) _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) -- cgit v1.2.3 From aa3b52309f2e920688d56b0b00ba12040bf0e841 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 27 Sep 2015 01:07:18 -0400 Subject: - Lux programs can now use libraries for both the JVM (.jar files) and pure Lux code (.tar.gz files). - Fixed a bug regarding indices and loading/storing from/to arrays. --- project.clj | 3 +- src/lux.clj | 28 ++++++++---- src/lux/analyser/lux.clj | 4 +- src/lux/base.clj | 1 + src/lux/compiler.clj | 8 ++-- src/lux/compiler/cache.clj | 2 +- src/lux/compiler/host.clj | 16 +++++-- src/lux/compiler/io.clj | 23 ++++++++-- src/lux/compiler/package.clj | 66 --------------------------- src/lux/lib/loader.clj | 55 +++++++++++++++++++++++ src/lux/packager/lib.clj | 40 +++++++++++++++++ src/lux/packager/program.clj | 103 +++++++++++++++++++++++++++++++++++++++++++ 12 files changed, 260 insertions(+), 89 deletions(-) delete mode 100644 src/lux/compiler/package.clj create mode 100644 src/lux/lib/loader.clj create mode 100644 src/lux/packager/lib.clj create mode 100644 src/lux/packager/program.clj diff --git a/project.clj b/project.clj index 88191109a..9d09c53fc 100644 --- a/project.clj +++ b/project.clj @@ -5,6 +5,7 @@ :url "http://www.eclipse.org/legal/epl-v10.html"} :dependencies [[org.clojure/clojure "1.6.0"] [org.clojure/core.match "0.2.1"] - [org.ow2.asm/asm-all "5.0.3"]] + [org.ow2.asm/asm-all "5.0.3"] + [org.apache.commons/commons-compress "1.10"]] :warn-on-reflection true :main lux) diff --git a/src/lux.clj b/src/lux.clj index 03d09ebba..8cd2c4b80 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -5,17 +5,29 @@ (ns lux (:gen-class) - (:require [lux.base :as &] + (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]] + [lux.compiler.base :as &compiler-base] [lux.compiler :as &compiler] - :reload-all)) + [lux.packager.lib :as &lib] + :reload-all) + (:import (java.io File))) -(defn -main [& [program-module & _]] - (if program-module - (time (&compiler/compile-program program-module)) - (println "Please provide a module name to compile.")) - (System/exit 0) +(defn -main [& args] + (|case (&/->list args) + (&/$Cons "compile" (&/$Cons program-module (&/$Nil))) + (if program-module + (time (&compiler/compile-program program-module)) + (println "Please provide a module name to compile.")) + + (&/$Cons "lib" (&/$Cons lib-module (&/$Nil))) + (&lib/package lib-module (new File &compiler-base/input-dir)) + + _ + (println "Can't understand command.")) + ;; (System/exit 0) ) (comment - (-main "program") + (-main "compile" "program") + (-main "lib" "lux") ) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 488b7ae4f..9dd8cecdc 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -558,7 +558,9 @@ active? (&/active-module? path) _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) _ (&&module/add-import path) - _ (&/when% (not already-compiled?) (compile-module path))] + _ (if (not already-compiled?) + (compile-module path) + (return nil))] (return &/Nil$))))) (defn analyse-export [analyse compile-token name] diff --git a/src/lux/base.clj b/src/lux/base.clj index 19f236ce1..d8bce5f87 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -118,6 +118,7 @@ (def tags-field "_tags") (def module-class-name "_") (def +name-separator+ ";") +(def lib-dir "lib") (defn T [& elems] (to-array elems)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 90b8bcc05..9e399205f 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -26,9 +26,9 @@ [host :as &&host] [case :as &&case] [lambda :as &&lambda] - [package :as &&package] [module :as &&module] - [io :as &&io])) + [io :as &&io]) + [lux.packager.program :as &packager-program]) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -473,7 +473,7 @@ (defn ^:private compile-module [name] ;; (prn 'compile-module name (&&cache/cached? name)) - (let [file-name (str &&/input-dir "/" name ".lux")] + (let [file-name (str name ".lux")] (|do [file-content (&&io/read-file file-name) :let [file-hash (hash file-content)]] (if (&&cache/cached? name) @@ -551,7 +551,7 @@ (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) - (&&package/package program-module)) + (&packager-program/package program-module)) (&/$Left ?message) (assert false ?message))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index d4ce7516d..4f37e8b62 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -89,7 +89,7 @@ ;; _ (prn 'load/IMPORTS module imports) ] (|do [loads (&/map% (fn [_import] - (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux")) + (|do [content (&&io/read-file (str _import ".lux")) _ (load _import (hash content) compile-module)] (&/cached-module? _import))) (if (= [""] imports) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 2322b0e32..afb3c9a49 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -300,7 +300,9 @@ _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] _ (compile ?idx) - :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] :let [_ (doto *writer* (.visitInsn ) )]] @@ -312,7 +314,9 @@ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (.visitInsn *writer* Opcodes/DUP)] _ (compile ?idx) - :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] _ (compile ?elem) :let [_ (doto *writer* @@ -342,7 +346,9 @@ _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] _ (compile ?idx) - :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) @@ -352,7 +358,9 @@ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (.visitInsn *writer* Opcodes/DUP)] _ (compile ?idx) - :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] _ (compile ?elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index 93be57f17..d83ec1404 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -5,11 +5,26 @@ (ns lux.compiler.io (:require (lux [base :as & :refer [|let |do return* return fail fail*]]) - )) + (lux.compiler [base :as &&]) + [lux.lib.loader :as &lib])) + +;; [Utils] +(def ^:private !libs (atom nil)) + +(defn ^:private libs-imported? [] + (not (nil? @!libs))) + +(defn ^:private init-libs! [] + (reset! !libs (&lib/load &/lib-dir))) ;; [Resources] -(defn read-file [^String path] - (let [file (new java.io.File path)] +(defn read-file [^String file-name] + ;; (prn 'read-file file-name) + (let [file (new java.io.File (str &&/input-dir "/" file-name))] (if (.exists file) (return (slurp file)) - (fail (str "[I/O Error] File doesn't exist: " path))))) + (do (when (not (libs-imported?)) + (init-libs!)) + (if-let [code (get @!libs file-name)] + (return code) + (fail (str "[I/O Error] File doesn't exist: " file-name))))))) diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj deleted file mode 100644 index 4f703f5d1..000000000 --- a/src/lux/compiler/package.clj +++ /dev/null @@ -1,66 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.package - (:require [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail*]] - [host :as &host]) - (lux.compiler [base :as &&])) - (:import (java.io File - FileInputStream - FileOutputStream - BufferedInputStream) - (java.util.jar Manifest - Attributes$Name - JarEntry - JarOutputStream - ))) - -;; [Utils] -(def ^:private kilobyte 1024) - -(defn ^:private manifest [^String module] - "(-> Text Manifest)" - (doto (new Manifest) - (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) - (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) - -(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] - "(-> Text File JarOutputStream Unit)" - ;; (prn 'write-class! path file) - (with-open [in (new BufferedInputStream (new FileInputStream file))] - (let [buffer (byte-array (* 10 kilobyte))] - (doto out - (.putNextEntry (new JarEntry (str path "/" (.getName file)))) - (-> (.write buffer 0 bytes-read) - (->> (when (not= -1 bytes-read)) - (loop [bytes-read (.read in buffer)]))) - (.flush) - (.closeEntry) - )) - )) - -(let [output-dir-size (.length &&/output-dir)] - (defn ^:private write-module! [^File file ^JarOutputStream out] - "(-> File JarOutputStream Unit)" - (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file) - ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size)) - inner-files (.listFiles file) - inner-modules (filter #(.isDirectory %) inner-files) - inner-classes (filter #(not (.isDirectory %)) inner-files)] - (doseq [$class inner-classes] - (write-class! module-name $class out)) - (doseq [$module inner-modules] - (write-module! $module out))))) - -;; [Resources] -(defn package [module] - "(-> Text (,))" - ;; (prn 'package module) - (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] - (doseq [$group (.listFiles (new File &&/output-dir))] - (write-module! $group out)) - )) diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj new file mode 100644 index 000000000..6326fb835 --- /dev/null +++ b/src/lux/lib/loader.clj @@ -0,0 +1,55 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.lib.loader + (:refer-clojure :exclude [load]) + (:require (lux [base :as & :refer [|let |do return fail return* fail* |case]])) + (:import (java.io InputStream + File + FileInputStream + ByteArrayInputStream + ByteArrayOutputStream) + java.util.zip.GZIPInputStream + (org.apache.commons.compress.archivers.tar TarArchiveEntry + TarArchiveInputStream))) + +;; [Utils] +(defn ^:private fetch-libs [from] + (seq (.listFiles (new File from)))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private unpackage [^File lib-file] + (let [is (->> lib-file + (new FileInputStream) + (new GZIPInputStream) + (new TarArchiveInputStream))] + (loop [lib-data {} + entry (.getNextTarEntry is)] + (if entry + (recur (assoc lib-data (.getName entry) (new String (read-stream is))) + (.getNextTarEntry is)) + lib-data)))) + +;; [Exports] +(def lib-ext ".tar.gz") + +(defn load [from] + (reduce merge {} + (for [lib (fetch-libs from)] + (unpackage lib)))) + +(comment + (->> &/lib-dir load keys) + ) diff --git a/src/lux/packager/lib.clj b/src/lux/packager/lib.clj new file mode 100644 index 000000000..41f3143a0 --- /dev/null +++ b/src/lux/packager/lib.clj @@ -0,0 +1,40 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.packager.lib + (:require [lux.lib.loader :as &lib]) + (:import (java.io File + FileOutputStream) + java.util.zip.GZIPOutputStream + (org.apache.commons.compress.archivers.tar TarArchiveEntry + TarArchiveOutputStream) + )) + +;; [Utils] +(defn ^:private read-file [file] + (with-open [is (java.io.FileInputStream. file)] + (let [data (byte-array (.length file))] + (.read is data) + data))) + +(defn ^:private add-to-tar! [prefix ^File file os] + "(-> Text File TarArchiveOutputStream Unit)" + (let [file-name (str prefix "/" (.getName file))] + (if (.isDirectory file) + (doseq [file (seq (.listFiles file))] + (add-to-tar! file-name file os)) + (doto os + (.putArchiveEntry (doto (new TarArchiveEntry file-name) + (.setSize (.length file)))) + (.write (read-file file)) + (.closeArchiveEntry))))) + +;; [Exports] +(defn package [output-lib-name ^File source-dir] + "(-> Text File Unit)" + (with-open [out (->> (str output-lib-name &lib/lib-ext) (new FileOutputStream) (new GZIPOutputStream) (new TarArchiveOutputStream))] + (doseq [file (seq (.listFiles source-dir))] + (add-to-tar! "" file out)) + )) diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj new file mode 100644 index 000000000..7337bcb02 --- /dev/null +++ b/src/lux/packager/program.clj @@ -0,0 +1,103 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.packager.program + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail*]] + [host :as &host]) + (lux.compiler [base :as &&])) + (:import (java.io InputStream + File + FileInputStream + FileOutputStream + BufferedInputStream + ByteArrayOutputStream) + (java.util.jar Manifest + Attributes$Name + JarEntry + JarInputStream + JarOutputStream + ))) + +;; [Utils] +(def ^:private kilobyte 1024) + +(defn ^:private manifest [^String module] + "(-> Text Manifest)" + (doto (new Manifest) + (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) + (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) + +(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] + "(-> Text File JarOutputStream Unit)" + ;; (prn 'write-class! path file) + (with-open [in (new BufferedInputStream (new FileInputStream file))] + (let [buffer (byte-array (* 10 kilobyte))] + (doto out + (.putNextEntry (new JarEntry (str path "/" (.getName file)))) + (-> (.write buffer 0 bytes-read) + (->> (when (not= -1 bytes-read)) + (loop [bytes-read (.read in buffer)]))) + (.flush) + (.closeEntry) + )) + )) + +(let [output-dir-size (.length &&/output-dir)] + (defn ^:private write-module! [^File file ^JarOutputStream out] + "(-> File JarOutputStream Unit)" + (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file) + ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size)) + inner-files (.listFiles file) + inner-modules (filter #(.isDirectory ^File %) inner-files) + inner-classes (filter #(not (.isDirectory ^File %)) inner-files)] + (doseq [$class inner-classes] + (write-class! module-name $class out)) + (doseq [$module inner-modules] + (write-module! $module out))))) + +(defn ^:private fetch-available-jars [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".jar")))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private add-jar! [^File jar-file ^JarOutputStream out] + (with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))] + (loop [^JarEntry entry (.getNextJarEntry is)] + (when entry + ;; (prn 'add-jar! (.getName entry) (.isDirectory entry)) + (when (and (not (.isDirectory entry)) + (not (.startsWith (.getName entry) "META-INF/"))) + (let [entry-data (read-stream is)] + (doto out + (.putNextEntry entry) + (.write entry-data 0 (alength entry-data)) + (.flush) + (.closeEntry)))) + (recur (.getNextJarEntry is)))))) + +;; [Resources] +(defn package [module] + "(-> Text (,))" + ;; (prn 'package module) + (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] + (doseq [$group (.listFiles (new File &&/output-dir))] + (write-module! $group out)) + (doseq [^String jar-file (fetch-available-jars)] + (add-jar! (new File jar-file) out)) + )) -- cgit v1.2.3 From f829e62d2102a60244b9f0950240dc71f74cccff Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 27 Sep 2015 18:59:38 -0400 Subject: - Added support for type-checking generic classes. - Added support for instancing generic objects. --- source/lux/host/jvm.lux | 35 +++++----- src/lux/analyser.clj | 10 ++- src/lux/analyser/host.clj | 75 +++++++++++++++++---- src/lux/base.clj | 12 ++++ src/lux/compiler/host.clj | 15 +++-- src/lux/compiler/io.clj | 2 +- src/lux/host.clj | 77 +++++++++------------- src/lux/lib/loader.clj | 17 +++-- src/lux/type.clj | 38 +++-------- src/lux/type/host.clj | 162 ++++++++++++++++++++++++++++++++++++++++++++++ 10 files changed, 321 insertions(+), 122 deletions(-) create mode 100644 src/lux/type/host.clj diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index bbb396874..57d0e9c5d 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -332,32 +332,29 @@ (let [(~@ var-rebinds)] (~ new-expr))))))))) -(do-template [ ] +(do-template [ ] [(defsyntax #export ( [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] - [expected-output exp-output^]) + [expected-output exp-output^] [unsafe? (tag?^ ["" "unsafe"])]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) g!self (gensym "self") - #let [[body return-type] (gen-expected-output expected-output - (` ( (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~ g!self) [(~@ vars)])))]] + #let [included-self (: (List AST) + (if + (@list g!self) + (@list))) + [body return-type] (gen-expected-output expected-output + (` ( (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] (~@ included-self) [(~@ vars)]))) + [body return-type] (if unsafe? + [(` (try (~ body))) (` (Either Text (~ return-type)))] + [body return-type])]] (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class]))) (~ return-type)) - (lambda [[(~@ vars)] (~ g!self)] + (lambda [[(~@ vars)] (~@ included-self)] (let [(~@ var-rebinds)] (~ body))))))) ))] - [invoke-virtual$ ;_jvm_invokevirtual] - [invoke-interface$ ;_jvm_invokeinterface] + [invoke-virtual$ ;_jvm_invokevirtual true] + [invoke-interface$ ;_jvm_invokeinterface true] + [invoke-special$ ;_jvm_invokespecial true] + [invoke-static$ ;_jvm_invokestatic false] ) - -(defsyntax #export (invoke-static$ [class local-symbol^] [method local-symbol^] [args (tuple^ (*^ exp-input^))] - [expected-output exp-output^]) - (do Lux/Monad - [[vars var-types var-rebinds arg-classes] (prepare-args args) - #let [[body return-type] (gen-expected-output expected-output - (` (;_jvm_invokestatic (~ (text$ class)) (~ (text$ method)) [(~@ (map text$ arg-classes))] [(~@ vars)])))]] - (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) - (lambda [[(~@ vars)]] - (let [(~@ var-rebinds)] - (~ body))))))) - )) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 5659a066e..0aa883c23 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -68,7 +68,7 @@ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) ))) -(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] +(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) @@ -155,6 +155,12 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) (&&host/analyse-jvm-arraylength analyse ?array) + _ + (do (prn 'aba8 (&/adt->text token)) + (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token)))))))) + +(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Classes & interfaces (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] (&/$Cons [_ (&/$TextS ?name)] @@ -191,7 +197,7 @@ (&&host/analyse-jvm-program analyse compile-token ?args ?body) _ - (fail ""))) + (aba8 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 5208b2883..9490c37c8 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -11,10 +11,12 @@ [parser :as &parser] [type :as &type] [host :as &host]) + [lux.type.host :as &host-type] (lux.analyser [base :as &&] [lambda :as &&lambda] [env :as &&env]) - [lux.compiler.base :as &c!base])) + [lux.compiler.base :as &c!base]) + (:import (java.lang.reflect TypeVariable))) ;; [Utils] (defn ^:private extract-text [ast] @@ -80,7 +82,7 @@ "(-> Type Type)" (|case type (&/$DataT class params) - (&type/Data$ (&type/as-obj class) params) + (&type/Data$ (&host-type/as-obj class) params) _ type)) @@ -279,19 +281,68 @@ (&/V &&/$jvm-null? =object)))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] + (|do [:let [output-type (&type/Data$ &host-type/null-data-tag &/Nil$)] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-null nil)))))) +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T idx real-type))) + (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T idx* (&/Cons$ real-type types))))) + (&/T 0 (&/|list)) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&type/Univ$ &type/empty-env base-type) + + _ + base-type)) + (&type/Data$ class-name type-args) + type-args)) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + ;; :let [_ (prn 'analyse-jvm-new-helper/_0 gtype) + ;; _ (prn 'analyse-jvm-new-helper/_1 gtype (->> arg-types (&/|map &type/show-type) &/->seq)) + ;; _ (prn 'analyse-jvm-new-helper/_2 gtype (->> args (&/|map &/show-ast) &/->seq))] + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T (make-gtype gtype gtype-vars*) + =args))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + ;; (prn 'analyse-jvm-new-helper gtype gtv $var (&/|length gtype-vars) (&/|length gtype-args)) + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] + (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args)))) + )) + (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader - [=return exceptions] (&host/lookup-constructor class-loader class classes) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) - classes args) + [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) + ;; :let [_ (prn 'analyse-jvm-new class (&/->seq gvars) (&/->seq gargs))] _ (ensure-catching exceptions) - :let [output-type (&type/Data$ class &/Nil$)] + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + ;; :let [_ (prn 'analyse-jvm-new/POST class (->> classes &/->seq vec) (&type/show-type output-type))] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor @@ -299,7 +350,7 @@ (do-template [ ] (let [elem-type (&type/Data$ &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type)) + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type)) length-type &type/Int idx-type &type/Int] (defn [analyse length] @@ -338,7 +389,7 @@ idx-type &type/Int] (defn analyse-jvm-anewarray [analyse class length] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=length (&&/analyse-1 analyse length-type length) _cursor &/cursor] (return (&/|list (&&/|meta array-type _cursor @@ -346,7 +397,7 @@ (defn analyse-jvm-aaload [analyse class array idx] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) _cursor &/cursor] @@ -355,7 +406,7 @@ (defn analyse-jvm-aastore [analyse class array idx elem] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem) @@ -368,7 +419,7 @@ (&type/with-var (fn [$var] (let [elem-type $var - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) _cursor &/cursor] (return (&/|list (&&/|meta length-type _cursor diff --git a/src/lux/base.clj b/src/lux/base.clj index d8bce5f87..d76348b9a 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -987,3 +987,15 @@ flag-compiled-module compiled-module? $Compiled flag-cached-module cached-module? $Cached ) + +(do-template [ ] + (defn [p xs] + (|case xs + ($Nil) + + + ($Cons x xs*) + ( (p x) (|every? p xs*)))) + + |every? true and + |any? false or) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index afb3c9a49..7f7509998 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -15,6 +15,7 @@ [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.type.host :as &host-type] [lux.analyser.base :as &a] [lux.compiler.base :as &&] :reload) @@ -208,13 +209,13 @@ (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) + (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&host-type/as-obj ?class)) ?method method-sig) (prepare-return! ?output-type))]] (return nil))) (do-template [ ] (defn [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) @@ -235,7 +236,7 @@ ) (defn compile-jvm-invokespecial [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) @@ -378,12 +379,12 @@ (defn compile-jvm-getstatic [compile ?class ?field ?output-type] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) (prepare-return! ?output-type))]] (return nil))) (defn compile-jvm-getfield [compile ?class ?field ?object ?output-type] - (|do [:let [class* (&host/->class (&type/as-obj ?class))] + (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (doto *writer* @@ -395,12 +396,12 @@ (defn compile-jvm-putstatic [compile ?class ?field ?value ?output-type] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) (defn compile-jvm-putfield [compile ?class ?field ?object ?value ?output-type] - (|do [:let [class* (&host/->class (&type/as-obj ?class))] + (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (.visitInsn *writer* Opcodes/DUP)] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index d83ec1404..4cd6284b7 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -15,7 +15,7 @@ (not (nil? @!libs))) (defn ^:private init-libs! [] - (reset! !libs (&lib/load &/lib-dir))) + (reset! !libs (&lib/load))) ;; [Resources] (defn read-file [^String file-name] diff --git a/src/lux/host.clj b/src/lux/host.clj index b05c30ad3..74a8af66a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -9,7 +9,8 @@ clojure.core.match clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type])) + [type :as &type]) + [lux.type.host :as &host-type]) (:import (java.lang.reflect Field Method Constructor Modifier) java.util.regex.Pattern (org.objectweb.asm Opcodes @@ -23,30 +24,10 @@ (def module-separator "/") (def class-name-separator ".") (def class-separator "/") -(def array-data-tag "#Array") -(def null-data-tag "#Null") ;; [Utils] (def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") -(comment - (let [class (class (to-array []))] - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class))) - - (.getName String) "java.lang.String" - - (.getName (class (to-array []))) "[Ljava.lang.Object;" - - (re-find class-name-re "java.lang.String") - ["java.lang.String" "java.lang.String" nil nil "java.lang.String"] - - (re-find class-name-re "[Ljava.lang.Object;") - ["[Ljava.lang.Object;" "[Ljava.lang.Object;" "[" "java.lang.Object" nil] - ) - (defn ^:private class->type [^Class class] "(-> Class Type)" (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) @@ -55,7 +36,7 @@ ;; (prn 'class->type/_1 class base arr-brackets) (let [output-type (if (.equals "void" base) &type/Unit - (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (reduce (fn [inner _] (&type/Data$ &host-type/array-data-tag (&/|list inner))) (&type/Data$ base &/Nil$) (range (count (or arr-brackets "")))) )] @@ -113,16 +94,16 @@ "(-> Type Text)" (|case type (&/$DataT ?name params) - (cond (= array-data-tag ?name) (|let [[level base] (unfold-array type) - base-sig (|case base - (&/$DataT base-class _) - (->class base-class) - - _ - (->java-sig base))] - (str (->> (&/|repeat level "[") (&/fold str "")) - "L" base-sig ";")) - (= null-data-tag ?name) (->type-signature "java.lang.Object") + (cond (= &host-type/array-data-tag ?name) (|let [[level base] (unfold-array type) + base-sig (|case base + (&/$DataT base-class _) + (->class base-class) + + _ + (->java-sig base))] + (str (->> (&/|repeat level "[") (&/fold str "")) + "L" base-sig ";")) + (= &host-type/null-data-tag ?name) (->type-signature "java.lang.Object") :else (->type-signature ?name)) (&/$LambdaT _ _) @@ -140,7 +121,7 @@ (do-template [ ] (defn [class-loader target field] - (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&type/as-obj target) true class-loader)) + (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&host-type/as-obj target) true class-loader)) :when (and (.equals ^Object field (.getName =field)) (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] @@ -154,7 +135,7 @@ (do-template [ ] (defn [class-loader target method-name args] ;; (prn ' target method-name) - (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) + (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object (Modifier/isStatic (.getModifiers =method))) (let [param-types (&/->list (seq (.getParameterTypes =method)))] @@ -172,20 +153,24 @@ ) (defn lookup-constructor [class-loader target args] - ;; (prn 'lookup-constructor class-loader target (&type/as-obj target)) - (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) - :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types))))] - =method))] - (return (&/T &type/Unit (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %))))) - (fail (str "[Host Error] Constructor does not exist: " target)))) + ;; (prn 'lookup-constructor class-loader target (&host-type/as-obj target)) + (let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list) + gargs (->> ctor .getGenericParameterTypes seq &/->list) + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %)))] + (return (&/T exs gvars gargs))) + (fail (str "[Host Error] Constructor does not exist: " target))))) (defn abstract-methods [class-loader class] - (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj class) true class-loader)) + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj class) true class-loader)) :when (.equals true (Modifier/isAbstract (.getModifiers =method)))] (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj index 6326fb835..13810238a 100644 --- a/src/lux/lib/loader.clj +++ b/src/lux/lib/loader.clj @@ -16,8 +16,13 @@ TarArchiveInputStream))) ;; [Utils] -(defn ^:private fetch-libs [from] - (seq (.listFiles (new File from)))) +(defn ^:private fetch-libs [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + seq + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".tar.gz")) + (map #(new File ^String %)))) (let [init-capacity (* 100 1024) buffer-size 1024] @@ -45,10 +50,10 @@ ;; [Exports] (def lib-ext ".tar.gz") -(defn load [from] - (reduce merge {} - (for [lib (fetch-libs from)] - (unpackage lib)))) +(defn load [] + (->> (fetch-libs) + (map unpackage) + (reduce merge {}))) (comment (->> &/lib-dir load keys) diff --git a/src/lux/type.clj b/src/lux/type.clj index 0495e6b02..723e169c4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -7,7 +7,8 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.type.host :as &&host])) (declare show-type) @@ -23,7 +24,7 @@ _ false)) -(def ^:private empty-env &/Nil$) +(def empty-env &/Nil$) (defn Data$ [name params] (&/V &/$DataT (&/T name params))) (defn Bound$ [idx] @@ -463,21 +464,6 @@ _ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) -(defn as-obj [class] - (case class - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - class)) - -(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) - (def ^:private init-fixpoints &/Nil$) (defn ^:private check* [class-loader fixpoints invariant?? expected actual] @@ -665,7 +651,7 @@ [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] (cond (= "#Null" a!name) - (if (not (contains? primitive-types e!name)) + (if (not (&&host/primitive-type? e!name)) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -675,22 +661,16 @@ (fail (check-error expected actual))) :else - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] + (let [e!name (&&host/as-obj e!name) + a!name (&&host/as-obj a!name)] (cond (and (.equals ^Object e!name a!name) (= (&/|length e!params) (&/|length a!params))) (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] (return (&/T fixpoints nil))) - (and (not invariant??) - ;; (do (println '[Data Data] [e!name a!name] - ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) - ;; true) - (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) - (catch Exception e - (prn 'FAILED_HERE e!name a!name)))) - (return (&/T fixpoints nil)) + (not invariant??) + (|do [actual& (&&host/->super-type existential class-loader e!name a!name a!params)] + (check* class-loader fixpoints invariant?? expected actual&)) :else (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj new file mode 100644 index 000000000..486205494 --- /dev/null +++ b/src/lux/type/host.clj @@ -0,0 +1,162 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.type.host + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]])) + (:import (java.lang.reflect GenericArrayType + ParameterizedType + TypeVariable + WildcardType))) + +;; [Exports] +(def array-data-tag "#Array") +(def null-data-tag "#Null") + +;; [Utils] +(defn ^:private Data$ [name params] + (&/V &/$DataT (&/T name params))) + +(defn ^:private trace-lineage* [^Class super-class ^Class sub-class] + "(-> Class Class (List Class))" + ;; Either they're both interfaces, of they're both classes + (cond (.isInterface sub-class) + (let [interface<=interface? #(if (or (= super-class %) + (.isAssignableFrom super-class %)) + % + nil)] + (loop [sub-class sub-class + stack (&/|list)] + (let [super-interface (some interface<=interface? + (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/Cons$ super-interface stack) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/Cons$ super* stack))))))) + + (.isInterface super-class) + (let [class<=interface? #(if (= super-class %) % nil)] + (loop [sub-class sub-class + stack (&/|list)] + (if-let [super-interface (some class<=interface? (.getInterfaces sub-class))] + (&/Cons$ super-interface stack) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/Cons$ super* stack)))))) + + :else + (loop [sub-class sub-class + stack (&/|list)] + (let [super* (.getSuperclass sub-class)] + (if (= super* super-class) + (&/Cons$ super* stack) + (recur super* (&/Cons$ super* stack))))))) + +(defn ^:private trace-lineage [^Class sub-class ^Class super-class] + "(-> Class Class (List Class))" + (&/|reverse (trace-lineage* super-class sub-class))) + +(let [matcher (fn [m ^TypeVariable jt lt] (&/Cons$ (&/T (.getName jt) lt) m))] + (defn ^:private match-params [sub-type-params params] + (assert (and (= (&/|length sub-type-params) (&/|length params)) + (&/|every? (partial instance? TypeVariable) sub-type-params))) + (&/fold2 matcher (&/|table) sub-type-params params))) + +;; [Exports] +(defn instance-param [existential matchings refl-type] + "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" + ;; (prn 'instance-param refl-type (class refl-type)) + (cond (instance? Class refl-type) + (return (Data$ (.getName ^Class refl-type) (&/|list))) + + (instance? GenericArrayType refl-type) + (let [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] + (return (Data$ array-data-tag (&/|list inner-type)))) + + (instance? ParameterizedType refl-type) + (|do [:let [refl-type* ^ParameterizedType refl-type] + params* (->> refl-type* + .getActualTypeArguments + seq &/->list + (&/map% (partial instance-param existential matchings)))] + (return (Data$ (->> refl-type* ^Class (.getRawType) .getName) + params*))) + + (instance? TypeVariable refl-type) + (let [gvar (.getName ^TypeVariable refl-type)] + (if-let [m-type (&/|get gvar matchings)] + (return m-type) + (fail (str "[Type Error] Unknown generic type variable: " gvar)))) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (instance-param existential matchings bound) + existential))) + +;; [Utils] +(defn ^:private translate-params [existential super-type-params sub-type-params params] + "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" + (|let [matchings (match-params sub-type-params params)] + (&/map% (partial instance-param existential matchings) super-type-params))) + +(defn ^:private raise* [existential sub+params super] + "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" + (|let [[^Class sub params] sub+params] + (if (.isInterface super) + (|do [:let [super-params (->> sub + .getGenericInterfaces + (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) + (if (instance? Class %) (&/|list) (->> % .getActualTypeArguments seq &/->list)) + nil)))] + params* (translate-params existential + super-params + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T super params*))) + (let [super* (.getGenericSuperclass sub)] + (cond (instance? Class super*) + (return (&/T super* (&/|list))) + + (instance? ParameterizedType super*) + (|do [params* (translate-params existential + (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T super params*))) + + :else + (assert false (prn-str super* (class super*) [sub super]))))))) + +(defn ^:private raise [existential lineage class params] + "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" + (&/fold% (partial raise* existential) (&/T class params) lineage)) + +;; [Exports] +(defn ->super-type [existential class-loader super-class sub-class sub-params] + "(-> Text Text (List Type) (Lux Type))" + (let [super-class+ (Class/forName super-class true class-loader) + sub-class+ (Class/forName sub-class true class-loader)] + (if (.isAssignableFrom super-class+ sub-class+) + (let [lineage (trace-lineage sub-class+ super-class+)] + (|do [[sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (Data$ (.getName sub-class*) sub-params*)))) + (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " text t) + (-> (^ java.lang.Throwable) Text) ($ text:++ (_jvm_invokevirtual "java.lang.Object" "toString" [] t []) "\n" diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0aa883c23..4e1093cec 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -72,88 +72,88 @@ (|case token ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) - (&&host/analyse-jvm-znewarray analyse ?length) + (&&host/analyse-jvm-znewarray analyse exo-type ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) - (&&host/analyse-jvm-zastore analyse ?array ?idx ?elem) + (&&host/analyse-jvm-zastore analyse exo-type ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) - (&&host/analyse-jvm-zaload analyse ?array ?idx) + (&&host/analyse-jvm-zaload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) - (&&host/analyse-jvm-bnewarray analyse ?length) + (&&host/analyse-jvm-bnewarray analyse exo-type ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) - (&&host/analyse-jvm-bastore analyse ?array ?idx ?elem) + (&&host/analyse-jvm-bastore analyse exo-type ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) - (&&host/analyse-jvm-baload analyse ?array ?idx) + (&&host/analyse-jvm-baload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) - (&&host/analyse-jvm-snewarray analyse ?length) + (&&host/analyse-jvm-snewarray analyse exo-type ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) - (&&host/analyse-jvm-sastore analyse ?array ?idx ?elem) + (&&host/analyse-jvm-sastore analyse exo-type ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) - (&&host/analyse-jvm-saload analyse ?array ?idx) + (&&host/analyse-jvm-saload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) - (&&host/analyse-jvm-inewarray analyse ?length) + (&&host/analyse-jvm-inewarray analyse exo-type ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) - (&&host/analyse-jvm-iastore analyse ?array ?idx ?elem) + (&&host/analyse-jvm-iastore analyse exo-type ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) - (&&host/analyse-jvm-iaload analyse ?array ?idx) + (&&host/analyse-jvm-iaload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) - (&&host/analyse-jvm-lnewarray analyse ?length) + (&&host/analyse-jvm-lnewarray analyse exo-type ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) - (&&host/analyse-jvm-lastore analyse ?array ?idx ?elem) + (&&host/analyse-jvm-lastore analyse exo-type ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) - (&&host/analyse-jvm-laload analyse ?array ?idx) + (&&host/analyse-jvm-laload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) - (&&host/analyse-jvm-fnewarray analyse ?length) + (&&host/analyse-jvm-fnewarray analyse exo-type ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) - (&&host/analyse-jvm-fastore analyse ?array ?idx ?elem) + (&&host/analyse-jvm-fastore analyse exo-type ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) - (&&host/analyse-jvm-faload analyse ?array ?idx) + (&&host/analyse-jvm-faload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) - (&&host/analyse-jvm-dnewarray analyse ?length) + (&&host/analyse-jvm-dnewarray analyse exo-type ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) - (&&host/analyse-jvm-dastore analyse ?array ?idx ?elem) + (&&host/analyse-jvm-dastore analyse exo-type ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) - (&&host/analyse-jvm-daload analyse ?array ?idx) + (&&host/analyse-jvm-daload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) - (&&host/analyse-jvm-cnewarray analyse ?length) + (&&host/analyse-jvm-cnewarray analyse exo-type ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) - (&&host/analyse-jvm-castore analyse ?array ?idx ?elem) + (&&host/analyse-jvm-castore analyse exo-type ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) - (&&host/analyse-jvm-caload analyse ?array ?idx) + (&&host/analyse-jvm-caload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) - (&&host/analyse-jvm-anewarray analyse ?class ?length) + (&&host/analyse-jvm-anewarray analyse exo-type ?class ?length) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))) - (&&host/analyse-jvm-aastore analyse ?class ?array ?idx ?elem) + (&&host/analyse-jvm-aastore analyse exo-type ?class ?array ?idx ?elem) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))) - (&&host/analyse-jvm-aaload analyse ?class ?array ?idx) + (&&host/analyse-jvm-aaload analyse exo-type ?class ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) - (&&host/analyse-jvm-arraylength analyse ?array) + (&&host/analyse-jvm-arraylength analyse exo-type ?array) _ (do (prn 'aba8 (&/adt->text token)) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9490c37c8..cf361da22 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -69,14 +69,23 @@ output))))) )) -(defn ^:private ensure-object [token] - "(-> Analysis (Lux (,)))" - (|case token - [_ (&/$DataT _ _)] - (return nil) +(defn ^:private ensure-object [type] + "(-> Type (Lux (, Text (List Type))))" + (|case type + (&/$DataT payload) + (return payload) + + (&/$NamedT _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) _ - (fail "[Analyser Error] Expecting object"))) + (fail (str "[Analyser Error] Expecting object: " (&type/show-type type))))) (defn ^:private as-object [type] "(-> Type Type)" @@ -110,6 +119,35 @@ _ type)) +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T idx real-type))) + (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T idx* (&/Cons$ real-type types))))) + (&/T 0 (&/|list)) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&type/Univ$ &type/empty-env base-type) + + _ + base-type)) + (&type/Data$ class-name type-args) + type-args)) + ;; [Resources] (do-template [ ] (let [input-type (&type/Data$ &/Nil$) @@ -163,117 +201,142 @@ analyse-jvm-dgt &&/$jvm-dgt "java.lang.Double" "java.lang.Boolean" ) +(defn ^:private analyse-field-access-helper [obj-type gvars gtype] + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + (|case obj-type + (&/$DataT class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m g t] (&/Cons$ (&/T (.getName g) t) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (fail (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + + _ + (fail (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + (defn analyse-jvm-getstatic [analyse exo-type class field] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader class field) + [gvars gtype] (&host/lookup-static-field class-loader class field) + ;; :let [_ (prn 'analyse-jvm-getstatic class field (&/->seq gvars) gtype)] + :let [=type (&host-type/class->type (cast Class gtype))] :let [output-type =type] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-getstatic (&/T class field output-type))))))) (defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader class field) =object (&&/analyse-1 analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader class field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) :let [output-type =type] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-getfield (&/T class field =object output-type))))))) (defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader class field) + [gvars gtype] (&host/lookup-static-field class-loader class field) + :let [=type (&host-type/class->type (cast Class gtype))] =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-putstatic (&/T class field =value output-type))))))) (defn analyse-jvm-putfield [analyse exo-type class field value object] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader class field) =object (&&/analyse-1 analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader class field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-putfield (&/T class field =value =object (&&/expr-type* =object)))))))) -(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] - (|do [class-loader &/loader - =return+exceptions (&host/lookup-static-method class-loader class method classes) - :let [[=return exceptions] =return+exceptions] - ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))] - _ (ensure-catching exceptions) - ;; :let [_ (matchv ::M/objects [=return] - ;; [[&/$DataT _return-class &/Nil$]] - ;; (prn 'analyse-jvm-invokestatic class method _return-class))] - =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) - classes - args) - :let [output-type =return] - _ (&type/check exo-type (as-otype+ output-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type))))))) - (defn analyse-jvm-instanceof [analyse exo-type class object] (|do [=object (&&/analyse-1+ analyse object) - _ (ensure-object =object) + _ (ensure-object (&&/expr-type* =object)) :let [output-type &type/Bool] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-instanceof (&/T class =object))))))) -(do-template [ ] - (defn [analyse exo-type class method classes object args] - (|do [class-loader &/loader - =return+exceptions (&host/lookup-virtual-method class-loader class method classes) - ;; :let [_ (prn ' [class method] (&/adt->text =return+exceptions))] - :let [[=return exceptions] =return+exceptions] - _ (ensure-catching exceptions) - =object (&&/analyse-1 analyse (&type/Data$ class &/Nil$) object) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) - classes args) - :let [output-type =return] - ;; :let [_ (prn ' [class method] '=return (&type/show-type =return))] - ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] - _ (&type/check exo-type (as-otype+ output-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&/V (&/T class method classes =object =args output-type))))))) +(defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret)] + (return (&/T =gret =args))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] + (analyse-method-call-helper analyse gret gtype-env* gtype-vars* gtype-args args)))) + )) - analyse-jvm-invokevirtual &&/$jvm-invokevirtual - analyse-jvm-invokeinterface &&/$jvm-invokeinterface - ) +(let [dummy-type-param (&type/Data$ "java.lang.Object" (&/|list))] + (do-template [ ] + (defn [analyse exo-type class method classes object args] + (|do [class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (if (= "" method) + (return (&/T Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$)) + (&host/lookup-virtual-method class-loader class method classes)) + ;; :let [_ (prn ' [class method] (&/adt->text =return+exceptions))] + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params) + :let [gtype-env (&/fold2 (fn [m g t] (&/Cons$ (&/T g t) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) + ;; :let [_ (prn ' [class method] (&type/show-type exo-type) (&type/show-type output-type))] + ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V (&/T class method classes =object =args output-type))))))) + + analyse-jvm-invokevirtual &&/$jvm-invokevirtual + analyse-jvm-invokeinterface &&/$jvm-invokeinterface + analyse-jvm-invokespecial &&/$jvm-invokespecial + )) -(defn analyse-jvm-invokespecial [analyse exo-type class method classes object args] +(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader - =return+exceptions (if (= "" method) - (return (&/T &type/Unit &/Nil$)) - (&host/lookup-virtual-method class-loader class method classes)) - :let [[=return exceptions] =return+exceptions] - ;; :let [_ (prn 'analyse-jvm-invokespecial (&/adt->text =return+exceptions))] + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) + ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))] _ (ensure-catching exceptions) - =object (&&/analyse-1 analyse (&type/Data$ class &/Nil$) object) - =args (&/map2% (fn [c o] - (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) - classes args) - :let [output-type =return] + ;; :let [_ (matchv ::M/objects [=return] + ;; [[&/$DataT _return-class &/Nil$]] + ;; (prn 'analyse-jvm-invokestatic class method _return-class))] + =args (&/map2% (fn [_class _arg] + (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) + classes + args) + :let [output-type (&host-type/class->type (cast Class gret))] _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&/V &&/$jvm-invokespecial (&/T class method classes =object =args output-type))))))) + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type))))))) (defn analyse-jvm-null? [analyse exo-type object] (|do [=object (&&/analyse-1+ analyse object) - _ (ensure-object =object) + _ (ensure-object (&&/expr-type* =object)) :let [output-type &type/Bool] _ (&type/check exo-type output-type) _cursor &/cursor] @@ -287,35 +350,6 @@ (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-null nil)))))) -(defn ^:private clean-gtype-var [idx gtype-var] - (|let [(&/$VarT id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T idx real-type))) - (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) - -(defn ^:private clean-gtype-vars [gtype-vars] - (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] - (|do [:let [[idx types] idx+types] - [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T idx* (&/Cons$ real-type types))))) - (&/T 0 (&/|list)) - gtype-vars)] - (return clean-types))) - -(defn ^:private make-gtype [class-name type-args] - "(-> Text (List Type) Type)" - (&/fold (fn [base-type type-arg] - (|case type-arg - (&/$BoundT _) - (&type/Univ$ &type/empty-env base-type) - - _ - base-type)) - (&type/Data$ class-name type-args) - type-args)) - (defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] (|case gtype-vars (&/$Nil) @@ -345,7 +379,7 @@ ;; :let [_ (prn 'analyse-jvm-new/POST class (->> classes &/->seq vec) (&type/show-type output-type))] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-new (&/T class classes =args))))))) (do-template [ ] @@ -353,25 +387,28 @@ array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type)) length-type &type/Int idx-type &type/Int] - (defn [analyse length] + (defn [analyse exo-type length] (|do [=length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) _cursor &/cursor] - (return (&/|list (&&/|meta array-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V =length)))))) - (defn [analyse array idx] + (defn [analyse exo-type array idx] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) _cursor &/cursor] - (return (&/|list (&&/|meta elem-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V (&/T =array =idx))))))) - (defn [analyse array idx elem] + (defn [analyse exo-type array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) _cursor &/cursor] - (return (&/|list (&&/|meta array-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V (&/T =array =idx =elem))))))) ) @@ -387,44 +424,46 @@ (let [length-type &type/Int idx-type &type/Int] - (defn analyse-jvm-anewarray [analyse class length] + (defn analyse-jvm-anewarray [analyse exo-type class length] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) _cursor &/cursor] - (return (&/|list (&&/|meta array-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-anewarray (&/T class =length)))))))) - (defn analyse-jvm-aaload [analyse class array idx] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _cursor &/cursor] - (return (&/|list (&&/|meta elem-type _cursor - (&/V &&/$jvm-aaload (&/T class =array =idx)))))))) + (defn analyse-jvm-aaload [analyse exo-type class array idx] + (|do [=array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-aaload (&/T class =array =idx))))))) - (defn analyse-jvm-aastore [analyse class array idx elem] + (defn analyse-jvm-aastore [analyse exo-type class array idx elem] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) _cursor &/cursor] - (return (&/|list (&&/|meta array-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-aastore (&/T class =array =idx =elem))))))))) -(let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] - (defn analyse-jvm-arraylength [analyse array] - (&type/with-var - (fn [$var] - (let [elem-type $var - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - _cursor &/cursor] - (return (&/|list (&&/|meta length-type _cursor - (&/V &&/$jvm-arraylength =array) - ))))))))) +(defn analyse-jvm-arraylength [analyse exo-type array] + (|do [=array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Int) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-arraylength =array) + ))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] @@ -734,7 +773,7 @@ (do-template [ ] (defn [analyse exo-type ?monitor] (|do [=monitor (&&/analyse-1+ analyse ?monitor) - _ (ensure-object =monitor) + _ (ensure-object (&&/expr-type* =monitor)) :let [output-type &type/Unit] _ (&type/check exo-type output-type) _cursor &/cursor] diff --git a/src/lux/host.clj b/src/lux/host.clj index 74a8af66a..00f1307ad 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -11,7 +11,7 @@ (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]) [lux.type.host :as &host-type]) - (:import (java.lang.reflect Field Method Constructor Modifier) + (:import (java.lang.reflect Field Method Constructor Modifier Type) java.util.regex.Pattern (org.objectweb.asm Opcodes Label @@ -25,29 +25,6 @@ (def class-name-separator ".") (def class-separator "/") -;; [Utils] -(def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") - -(defn ^:private class->type [^Class class] - "(-> Class Type)" - (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) - (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] - (let [base (or arr-base simple-base)] - ;; (prn 'class->type/_1 class base arr-brackets) - (let [output-type (if (.equals "void" base) - &type/Unit - (reduce (fn [inner _] (&type/Data$ &host-type/array-data-tag (&/|list inner))) - (&type/Data$ base &/Nil$) - (range (count (or arr-brackets "")))) - )] - ;; (prn 'class->type/_2 class (&type/show-type output-type)) - output-type) - )))) - -(defn ^:private method->type [^Method method] - "(-> Method Type)" - (class->type (.getReturnType method))) - ;; [Resources] (do-template [ ] (let [regex (-> Pattern/quote re-pattern)] @@ -121,12 +98,14 @@ (do-template [ ] (defn [class-loader target field] - (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&host-type/as-obj target) true class-loader)) - :when (and (.equals ^Object field (.getName =field)) - (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] - (.getType =field)))] - (return (class->type type*)) - (fail (str "[Host Error] Field does not exist: " target "." field)))) + (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Type gtype (first (for [^Field =field (.getDeclaredFields target-class) + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] + (.getGenericType =field)))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list)] + (return (&/T gvars gtype))) + (fail (str "[Host Error] Field does not exist: " target "." field))))) lookup-static-field true lookup-field false @@ -135,18 +114,26 @@ (do-template [ ] (defn [class-loader target method-name args] ;; (prn ' target method-name) - (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) - :when (and (.equals ^Object method-name (.getName =method)) - (.equals ^Object (Modifier/isStatic (.getModifiers =method))) - (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types)))))] - =method))] - (return (&/T (method->type method) (->> method .getExceptionTypes &/->list (&/|map #(.getName %))))) - (fail (str "[Host Error] Method does not exist: " target "." method-name)))) + (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object (Modifier/isStatic (.getModifiers =method))) + (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types)))))] + =method))] + (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list) + gvars (->> method .getTypeParameters seq &/->list) + gargs (->> method .getGenericParameterTypes seq &/->list)] + (return (&/T (.getGenericReturnType method) + (->> method .getExceptionTypes &/->list (&/|map #(.getName %))) + parent-gvars + gvars + gargs))) + (fail (str "[Host Error] Method does not exist: " target "." method-name))))) lookup-static-method true lookup-virtual-method false @@ -255,7 +242,7 @@ (.visitEnd)))) methods) bytecode (.toByteArray (doto =class .visitEnd))] - loader &/loader + ^ClassLoader loader &/loader !classes &/classes :let [real-name (str (->class-name module) "." name) _ (swap! !classes assoc real-name bytecode) diff --git a/src/lux/type.clj b/src/lux/type.clj index 723e169c4..7eae7e181 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -649,31 +649,40 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] - (cond (= "#Null" a!name) - (if (not (&&host/primitive-type? e!name)) - (return (&/T fixpoints nil)) - (fail (check-error expected actual))) - - (= "#Null" e!name) - (if (= "#Null" a!name) - (return (&/T fixpoints nil)) - (fail (check-error expected actual))) - - :else - (let [e!name (&&host/as-obj e!name) - a!name (&&host/as-obj a!name)] - (cond (and (.equals ^Object e!name a!name) - (= (&/|length e!params) (&/|length a!params))) - (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] - (return (&/T fixpoints nil))) - - (not invariant??) - (|do [actual& (&&host/->super-type existential class-loader e!name a!name a!params)] - (check* class-loader fixpoints invariant?? expected actual&)) - - :else - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) + [(&/$DataT e!data) (&/$DataT a!data)] + (&&host/check-host-types (partial check* class-loader fixpoints true) + check-error + fixpoints + existential + class-loader + invariant?? + e!data + a!data) + ;; [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] + ;; (cond (= "#Null" a!name) + ;; (if (not (&&host/primitive-type? e!name)) + ;; (return (&/T fixpoints nil)) + ;; (fail (check-error expected actual))) + + ;; (= "#Null" e!name) + ;; (if (= "#Null" a!name) + ;; (return (&/T fixpoints nil)) + ;; (fail (check-error expected actual))) + + ;; :else + ;; (let [e!name (&&host/as-obj e!name) + ;; a!name (&&host/as-obj a!name)] + ;; (cond (and (.equals ^Object e!name a!name) + ;; (= (&/|length e!params) (&/|length a!params))) + ;; (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] + ;; (return (&/T fixpoints nil))) + + ;; (not invariant??) + ;; (|do [actual* (&&host/->super-type existential class-loader e!name a!name a!params)] + ;; (check* class-loader fixpoints invariant?? expected actual*)) + + ;; :else + ;; (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index 486205494..3121a2213 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -17,9 +17,6 @@ (def null-data-tag "#Null") ;; [Utils] -(defn ^:private Data$ [name params] - (&/V &/$DataT (&/T name params))) - (defn ^:private trace-lineage* [^Class super-class ^Class sub-class] "(-> Class Class (List Class))" ;; Either they're both interfaces, of they're both classes @@ -56,7 +53,9 @@ (defn ^:private trace-lineage [^Class sub-class ^Class super-class] "(-> Class Class (List Class))" - (&/|reverse (trace-lineage* super-class sub-class))) + (if (= sub-class super-class) + (&/|list) + (&/|reverse (trace-lineage* super-class sub-class)))) (let [matcher (fn [m ^TypeVariable jt lt] (&/Cons$ (&/T (.getName jt) lt) m))] (defn ^:private match-params [sub-type-params params] @@ -65,15 +64,30 @@ (&/fold2 matcher (&/|table) sub-type-params params))) ;; [Exports] +(let [class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))" + Unit (&/V &/$TupleT (&/|list))] + (defn class->type [^Class class] + "(-> Class Type)" + (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + ;; (prn 'class->type/_1 class base arr-brackets) + (if (.equals "void" base) + Unit + (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner)))) + (&/V &/$DataT (&/T base &/Nil$)) + (range (count (or arr-brackets ""))))) + ))))) + (defn instance-param [existential matchings refl-type] "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" ;; (prn 'instance-param refl-type (class refl-type)) (cond (instance? Class refl-type) - (return (Data$ (.getName ^Class refl-type) (&/|list))) + (return (class->type refl-type)) (instance? GenericArrayType refl-type) (let [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] - (return (Data$ array-data-tag (&/|list inner-type)))) + (return (&/V &/$DataT (&/T array-data-tag (&/|list inner-type))))) (instance? ParameterizedType refl-type) (|do [:let [refl-type* ^ParameterizedType refl-type] @@ -81,8 +95,8 @@ .getActualTypeArguments seq &/->list (&/map% (partial instance-param existential matchings)))] - (return (Data$ (->> refl-type* ^Class (.getRawType) .getName) - params*))) + (return (&/V &/$DataT (&/T (->> refl-type* ^Class (.getRawType) .getName) + params*)))) (instance? TypeVariable refl-type) (let [gvar (.getName ^TypeVariable refl-type)] @@ -140,8 +154,8 @@ sub-class+ (Class/forName sub-class true class-loader)] (if (.isAssignableFrom super-class+ sub-class+) (let [lineage (trace-lineage sub-class+ super-class+)] - (|do [[sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] - (return (Data$ (.getName sub-class*) sub-params*)))) + (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (&/V &/$DataT (&/T (.getName sub-class*) sub-params*))))) (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " super-type existential class-loader e!name a!name a!params)] + (check (&/V &/$DataT expected) actual*)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))))) -- cgit v1.2.3 From 968eb87adef6d62803543adf2ec51049527ccb33 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 28 Sep 2015 21:22:42 -0400 Subject: - Added a rule that Void is a subtype of every other type. - Added the type-checking rules for existential quantification (ExQ). - Fixed one of the rules for type-checking universal quantification (UnivQ). --- source/lux/data/list.lux | 2 +- src/lux/analyser.clj | 17 ++++++++++++--- src/lux/type.clj | 56 +++++++++++++++++++++++------------------------- 3 files changed, 42 insertions(+), 33 deletions(-) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 7b9d4a60b..563282f32 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -190,7 +190,7 @@ (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) (def #export (size list) - (-> List Int) + (All [a] (-> (List a) Int)) (foldL (lambda [acc _] (i:+ 1 acc)) 0 list)) (do-template [ ] diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 4e1093cec..c02ba03d0 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -68,7 +68,7 @@ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) ))) -(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token] +(defn ^:private aba10 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) @@ -116,6 +116,12 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-laload analyse exo-type ?array ?idx) + _ + (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token))))))) + +(defn ^:private aba9 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-fnewarray analyse exo-type ?length) @@ -143,6 +149,12 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-caload analyse exo-type ?array ?idx) + _ + (aba10 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-anewarray analyse exo-type ?class ?length) @@ -156,8 +168,7 @@ (&&host/analyse-jvm-arraylength analyse exo-type ?array) _ - (do (prn 'aba8 (&/adt->text token)) - (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token)))))))) + (aba9 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token diff --git a/src/lux/type.clj b/src/lux/type.clj index 7eae7e181..ed0dd8898 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -638,10 +638,13 @@ (check* class-loader fixpoints invariant?? expected actual*)) [(&/$UnivQ _) _] - (with-var - (fn [$arg] - (|do [expected* (apply-type expected $arg)] - (check* class-loader fixpoints invariant?? expected* actual)))) + (|do [$arg existential + expected* (apply-type expected $arg)] + (check* class-loader fixpoints invariant?? expected* actual)) + ;; (with-var + ;; (fn [$arg] + ;; (|do [expected* (apply-type expected $arg)] + ;; (check* class-loader fixpoints invariant?? expected* actual)))) [_ (&/$UnivQ _)] (with-var @@ -649,6 +652,23 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) + [(&/$ExQ e!env e!def) _] + (with-var + (fn [$arg] + (|let [expected* (beta-reduce (->> e!env + (&/Cons$ expected) + (&/Cons$ $arg)) + e!def)] + (check* class-loader fixpoints invariant?? expected* actual)))) + + [_ (&/$ExQ a!env a!def)] + (|do [$arg existential] + (|let [actual* (beta-reduce (->> a!env + (&/Cons$ expected) + (&/Cons$ $arg)) + a!def)] + (check* class-loader fixpoints invariant?? expected actual*))) + [(&/$DataT e!data) (&/$DataT a!data)] (&&host/check-host-types (partial check* class-loader fixpoints true) check-error @@ -658,31 +678,6 @@ invariant?? e!data a!data) - ;; [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] - ;; (cond (= "#Null" a!name) - ;; (if (not (&&host/primitive-type? e!name)) - ;; (return (&/T fixpoints nil)) - ;; (fail (check-error expected actual))) - - ;; (= "#Null" e!name) - ;; (if (= "#Null" a!name) - ;; (return (&/T fixpoints nil)) - ;; (fail (check-error expected actual))) - - ;; :else - ;; (let [e!name (&&host/as-obj e!name) - ;; a!name (&&host/as-obj a!name)] - ;; (cond (and (.equals ^Object e!name a!name) - ;; (= (&/|length e!params) (&/|length a!params))) - ;; (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] - ;; (return (&/T fixpoints nil))) - - ;; (not invariant??) - ;; (|do [actual* (&&host/->super-type existential class-loader e!name a!name a!params)] - ;; (check* class-loader fixpoints invariant?? expected actual*)) - - ;; :else - ;; (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] @@ -696,6 +691,9 @@ e!members a!members)] (return (&/T fixpoints* nil))) + [_ (&/$VariantT (&/$Nil))] + (return (&/T fixpoints nil)) + [(&/$VariantT e!cases) (&/$VariantT a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp invariant?? e a)] -- cgit v1.2.3 From f5c046279de3c28e3d83dda116f2b3742766a93b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 28 Sep 2015 22:25:32 -0400 Subject: - Removed reflection warnings. - Made some improvements to working with object arrays. --- source/lux/host/jvm.lux | 2 +- src/lux/analyser.clj | 10 ++-- src/lux/analyser/host.clj | 130 ++++++++++++++++++++++---------------------- src/lux/analyser/module.clj | 2 +- src/lux/compiler.clj | 8 +-- src/lux/compiler/cache.clj | 2 +- src/lux/compiler/host.clj | 27 ++++----- src/lux/host.clj | 8 +-- src/lux/packager/lib.clj | 15 ++--- src/lux/type/host.clj | 16 +++++- 10 files changed, 116 insertions(+), 104 deletions(-) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index cb818eb2b..573e181b5 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -246,7 +246,7 @@ (|> idxs (map (: (-> Int Text) (lambda [idx] - (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload "java.lang.StackTraceElement" trace idx) [])))) + (_jvm_invokevirtual "java.lang.Object" "toString" [] (_jvm_aaload trace idx) [])))) (interpose "\n") (foldL text:++ "") ))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index c02ba03d0..0b911f9ed 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -117,7 +117,7 @@ (&&host/analyse-jvm-laload analyse exo-type ?array ?idx) _ - (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token))))))) + (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&/T (&/T "" -1 -1) token))))))) (defn ^:private aba9 [analyse eval! compile-module compile-token exo-type token] (|case token @@ -158,11 +158,11 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-anewarray analyse exo-type ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))) - (&&host/analyse-jvm-aastore analyse exo-type ?class ?array ?idx ?elem) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-aastore analyse exo-type ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))) - (&&host/analyse-jvm-aaload analyse exo-type ?class ?array ?idx) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-aaload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) (&&host/analyse-jvm-arraylength analyse exo-type ?array) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index cf361da22..9a38022d8 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -34,9 +34,9 @@ (let [exceptions (&/|map #(Class/forName % true class-loader) exceptions) catching (->> state (&/get$ &/$host) (&/get$ &/$catching) (&/|map #(Class/forName % true class-loader)))] - (if-let [missing-ex (&/fold (fn [prev now] + (if-let [missing-ex (&/fold (fn [prev ^Class now] (or prev - (if (&/fold (fn [found? ex-catch] + (if (&/fold (fn [found? ^Class ex-catch] (or found? (.isAssignableFrom ex-catch now))) false @@ -206,7 +206,7 @@ (|case obj-type (&/$DataT class targs) (if (= (&/|length targs) (&/|length gvars)) - (|let [gtype-env (&/fold2 (fn [m g t] (&/Cons$ (&/T (.getName g) t) m)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/Cons$ (&/T (.getName g) t) m)) (&/|table) gvars targs)] @@ -382,58 +382,58 @@ (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-new (&/T class classes =args))))))) -(do-template [ ] - (let [elem-type (&type/Data$ &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type)) - length-type &type/Int - idx-type &type/Int] - (defn [analyse exo-type length] - (|do [=length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V =length)))))) - - (defn [analyse exo-type array idx] - (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type elem-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V (&/T =array =idx))))))) - - (defn [analyse exo-type array idx elem] - (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V (&/T =array =idx =elem))))))) - ) - - "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore - "java.lang.Byte" analyse-jvm-bnewarray &&/$jvm-bnewarray analyse-jvm-baload &&/$jvm-baload analyse-jvm-bastore &&/$jvm-bastore - "java.lang.Short" analyse-jvm-snewarray &&/$jvm-snewarray analyse-jvm-saload &&/$jvm-saload analyse-jvm-sastore &&/$jvm-sastore - "java.lang.Integer" analyse-jvm-inewarray &&/$jvm-inewarray analyse-jvm-iaload &&/$jvm-iaload analyse-jvm-iastore &&/$jvm-iastore - "java.lang.Long" analyse-jvm-lnewarray &&/$jvm-lnewarray analyse-jvm-laload &&/$jvm-laload analyse-jvm-lastore &&/$jvm-lastore - "java.lang.Float" analyse-jvm-fnewarray &&/$jvm-fnewarray analyse-jvm-faload &&/$jvm-faload analyse-jvm-fastore &&/$jvm-fastore - "java.lang.Double" analyse-jvm-dnewarray &&/$jvm-dnewarray analyse-jvm-daload &&/$jvm-daload analyse-jvm-dastore &&/$jvm-dastore - "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore - ) +(let [length-type &type/Int + idx-type &type/Int] + (do-template [ ] + (let [elem-type (&type/Data$ &/Nil$) + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] + (defn [analyse exo-type length] + (|do [=length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V =length)))))) + + (defn [analyse exo-type array idx] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V (&/T =array =idx))))))) + + (defn [analyse exo-type array idx elem] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V (&/T =array =idx =elem))))))) + ) + + "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore + "java.lang.Byte" analyse-jvm-bnewarray &&/$jvm-bnewarray analyse-jvm-baload &&/$jvm-baload analyse-jvm-bastore &&/$jvm-bastore + "java.lang.Short" analyse-jvm-snewarray &&/$jvm-snewarray analyse-jvm-saload &&/$jvm-saload analyse-jvm-sastore &&/$jvm-sastore + "java.lang.Integer" analyse-jvm-inewarray &&/$jvm-inewarray analyse-jvm-iaload &&/$jvm-iaload analyse-jvm-iastore &&/$jvm-iastore + "java.lang.Long" analyse-jvm-lnewarray &&/$jvm-lnewarray analyse-jvm-laload &&/$jvm-laload analyse-jvm-lastore &&/$jvm-lastore + "java.lang.Float" analyse-jvm-fnewarray &&/$jvm-fnewarray analyse-jvm-faload &&/$jvm-faload analyse-jvm-fastore &&/$jvm-fastore + "java.lang.Double" analyse-jvm-dnewarray &&/$jvm-dnewarray analyse-jvm-daload &&/$jvm-daload analyse-jvm-dastore &&/$jvm-dastore + "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore + )) (let [length-type &type/Int idx-type &type/Int] (defn analyse-jvm-anewarray [analyse exo-type class length] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] - (|do [=length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-anewarray (&/T class =length)))))))) + (|do [elem-type (&host-type/dummy-gtype class) + :let [array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-anewarray (&/T class =length))))))) - (defn analyse-jvm-aaload [analyse exo-type class array idx] + (defn analyse-jvm-aaload [analyse exo-type array idx] (|do [=array (&&/analyse-1+ analyse array) [arr-class arr-params] (ensure-object (&&/expr-type* =array)) _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) @@ -442,18 +442,20 @@ _ (&type/check exo-type inner-arr-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-aaload (&/T class =array =idx))))))) + (&/V &&/$jvm-aaload (&/T =array =idx))))))) - (defn analyse-jvm-aastore [analyse exo-type class array idx elem] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-aastore (&/T class =array =idx =elem))))))))) + (defn analyse-jvm-aastore [analyse exo-type array idx elem] + (|do [=array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-aastore (&/T =array =idx =elem)))))))) (defn analyse-jvm-arraylength [analyse exo-type array] (|do [=array (&&/analyse-1+ analyse array) @@ -725,7 +727,7 @@ _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] =captured &&env/captured-vars - :let [=fields (&/|map (fn [idx+capt] + :let [=fields (&/|map (fn [^objects idx+capt] {:name (str &c!base/closure-prefix (aget idx+capt 0)) :modifiers captured-slot-modifier :anns (&/|list) @@ -738,7 +740,7 @@ ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured))) - :let [_ (println 'DEF anon-class)] + ;; :let [_ (println 'DEF anon-class)] _cursor &/cursor] (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) @@ -754,7 +756,7 @@ idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - :let [catched-exceptions (&/|map #(aget % 0) =catches)] + :let [catched-exceptions (&/|map #(aget ^objects % 0) =catches)] =body (with-catches catched-exceptions (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 63ba9b741..c645a9566 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -59,7 +59,7 @@ state) nil)))) -(defn define [module name def-data type] +(defn define [module name ^objects def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] (when (and (= "Macro" name) (= "lux" module)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 9e399205f..76d3a1eb2 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -309,11 +309,11 @@ (&a/$jvm-anewarray ?class ?length) (&&host/compile-jvm-anewarray compile-expression ?class ?length) - (&a/$jvm-aastore ?class ?array ?idx ?elem) - (&&host/compile-jvm-aastore compile-expression ?class ?array ?idx ?elem) + (&a/$jvm-aastore ?array ?idx ?elem) + (&&host/compile-jvm-aastore compile-expression ?array ?idx ?elem) - (&a/$jvm-aaload ?class ?array ?idx) - (&&host/compile-jvm-aaload compile-expression ?class ?array ?idx) + (&a/$jvm-aaload ?array ?idx) + (&&host/compile-jvm-aaload compile-expression ?array ?idx) (&a/$jvm-arraylength ?array) (&&host/compile-jvm-arraylength compile-expression ?array) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 4f37e8b62..f1b21f6fd 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -32,7 +32,7 @@ (defn ^:private clean-file [^File file] "(-> File (,))" - (doseq [f (seq (.listFiles file)) + (doseq [^File f (seq (.listFiles file)) :when (not (.isDirectory f))] (.delete f))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 7f7509998..6d926e6da 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -22,7 +22,8 @@ (:import (org.objectweb.asm Opcodes Label ClassWriter - MethodVisitor))) + MethodVisitor + AnnotationVisitor))) ;; [Utils] (let [class+method+sig {"boolean" [(&host/->class "java.lang.Boolean") "booleanValue" "()Z"] @@ -342,7 +343,7 @@ :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] (return nil))) -(defn compile-jvm-aaload [compile ?class ?array ?idx] +(defn compile-jvm-aaload [compile ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -353,7 +354,7 @@ :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) -(defn compile-jvm-aastore [compile ?class ?array ?idx ?elem] +(defn compile-jvm-aastore [compile ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -420,25 +421,21 @@ (return nil))) (defn ^:private compile-annotation [writer ann] - (doto (.visitAnnotation writer (&host/->class (:name ann)) true) + (doto ^AnnotationVisitor (.visitAnnotation writer (&host/->class (:name ann)) true) (-> (.visit param-name param-value) (->> (|let [[param-name param-value] param]) (doseq [param (&/->seq (:params ann))]))) (.visitEnd)) nil) -(defn ^:private compile-field [writer field] +(defn ^:private compile-field [^ClassWriter writer field] (let [=field (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) (&host/->type-signature (:type field)) nil nil)] (&/|map (partial compile-annotation =field) (:anns field)) (.visitEnd =field) - nil) - ;; (doto (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) - ;; (&host/->type-signature (:type field)) nil nil) - ;; (.visitEnd)) - ) + nil)) -(defn ^:private compile-method-return [writer output] +(defn ^:private compile-method-return [^MethodVisitor writer output] (case output "void" (.visitInsn writer Opcodes/RETURN) "boolean" (doto writer @@ -468,7 +465,7 @@ ;; else (.visitInsn writer Opcodes/ARETURN))) -(defn ^:private compile-method [compile class-writer method] +(defn ^:private compile-method [compile ^ClassWriter class-writer method] ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) ;; (prn 'compile-method/_2 (&/adt->text (:output method))) @@ -490,7 +487,7 @@ (.visitEnd))]] (return nil))))) -(defn ^:private compile-method-decl [class-writer method] +(defn ^:private compile-method-decl [^ClassWriter class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] (let [=method (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))] @@ -503,8 +500,8 @@ (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" -return)) - (defn ^:private add-anon-class- [class-writer class-name env] - (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "" (anon-class--signature env) nil nil) + (defn ^:private add-anon-class- [^ClassWriter class-writer class-name env] + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "" (anon-class--signature env) nil nil) (.visitCode) (.visitVarInsn Opcodes/ALOAD 0) (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") diff --git a/src/lux/host.clj b/src/lux/host.clj index 00f1307ad..133c50e9b 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -129,7 +129,7 @@ gvars (->> method .getTypeParameters seq &/->list) gargs (->> method .getGenericParameterTypes seq &/->list)] (return (&/T (.getGenericReturnType method) - (->> method .getExceptionTypes &/->list (&/|map #(.getName %))) + (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) parent-gvars gvars gargs))) @@ -152,13 +152,13 @@ =method))] (|let [gvars (->> target-class .getTypeParameters seq &/->list) gargs (->> ctor .getGenericParameterTypes seq &/->list) - exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %)))] + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))] (return (&/T exs gvars gargs))) (fail (str "[Host Error] Constructor does not exist: " target))))) (defn abstract-methods [class-loader class] (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj class) true class-loader)) - :when (.equals true (Modifier/isAbstract (.getModifiers =method)))] + :when (Modifier/isAbstract (.getModifiers =method))] (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) (defn location [scope] @@ -180,7 +180,7 @@ 0))) (let [object-real-class (->class "java.lang.Object")] - (defn ^:private dummy-return [writer name output] + (defn ^:private dummy-return [^MethodVisitor writer name output] (case output "void" (if (= "" name) (doto writer diff --git a/src/lux/packager/lib.clj b/src/lux/packager/lib.clj index 41f3143a0..af48e31eb 100644 --- a/src/lux/packager/lib.clj +++ b/src/lux/packager/lib.clj @@ -13,23 +13,24 @@ )) ;; [Utils] -(defn ^:private read-file [file] +(defn ^:private read-file ^objects [^File file] (with-open [is (java.io.FileInputStream. file)] (let [data (byte-array (.length file))] (.read is data) data))) -(defn ^:private add-to-tar! [prefix ^File file os] +(defn ^:private add-to-tar! [prefix ^File file ^TarArchiveOutputStream os] "(-> Text File TarArchiveOutputStream Unit)" (let [file-name (str prefix "/" (.getName file))] (if (.isDirectory file) (doseq [file (seq (.listFiles file))] (add-to-tar! file-name file os)) - (doto os - (.putArchiveEntry (doto (new TarArchiveEntry file-name) - (.setSize (.length file)))) - (.write (read-file file)) - (.closeArchiveEntry))))) + (let [data (read-file file)] + (doto os + (.putArchiveEntry (doto (new TarArchiveEntry file-name) + (.setSize (.length file)))) + (.write data 0 (alength data)) + (.closeArchiveEntry)))))) ;; [Exports] (defn package [output-lib-name ^File source-dir] diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index 3121a2213..e121cee86 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -115,14 +115,16 @@ (|let [matchings (match-params sub-type-params params)] (&/map% (partial instance-param existential matchings) super-type-params))) -(defn ^:private raise* [existential sub+params super] +(defn ^:private raise* [existential sub+params ^Class super] "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" (|let [[^Class sub params] sub+params] (if (.isInterface super) (|do [:let [super-params (->> sub .getGenericInterfaces (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) - (if (instance? Class %) (&/|list) (->> % .getActualTypeArguments seq &/->list)) + (if (instance? Class %) + (&/|list) + (->> ^ParameterizedType % .getActualTypeArguments seq &/->list)) nil)))] params* (translate-params existential super-params @@ -209,3 +211,13 @@ :else (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))))) + +(let [Void$ (&/V &/$VariantT (&/|list)) + gen-type (constantly Void$)] + (defn dummy-gtype [class] + (|do [class-loader &/loader] + (try (|let [=class (Class/forName class true class-loader) + params (->> =class .getTypeParameters seq &/->list (&/|map gen-type))] + (return (&/V &/$DataT (&/T class params)))) + (catch Exception e + (fail (str "[Type Error] Unknown type: " class))))))) -- cgit v1.2.3 From 8760f9bc9399cdc0d862f4d841bf920818d4c7bb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 29 Sep 2015 07:21:11 -0400 Subject: - Cleaned-up the comments from the codebase. --- src/lux/analyser.clj | 4 +- src/lux/analyser/case.clj | 65 +++++------------ src/lux/analyser/env.clj | 2 - src/lux/analyser/host.clj | 46 ++---------- src/lux/analyser/lux.clj | 165 ++++++++++++++---------------------------- src/lux/analyser/module.clj | 33 ++++----- src/lux/base.clj | 4 -- src/lux/compiler.clj | 11 +-- src/lux/compiler/cache.clj | 166 +++++++++++++++++++------------------------ src/lux/compiler/host.clj | 69 ++++-------------- src/lux/compiler/io.clj | 1 - src/lux/compiler/lambda.clj | 1 - src/lux/compiler/lux.clj | 13 +--- src/lux/host.clj | 1 - src/lux/lexer.clj | 6 +- src/lux/packager/program.clj | 6 +- src/lux/type.clj | 65 +---------------- src/lux/type/host.clj | 19 +++-- 18 files changed, 199 insertions(+), 478 deletions(-) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0b911f9ed..4ead47916 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -694,7 +694,6 @@ )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] - ;; (prn 'analyse-ast (&/show-ast token)) (|let [[cursor _] token] (&/with-cursor cursor (&/with-expected-type exo-type @@ -709,8 +708,7 @@ (fn [state] (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*) _ ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 325b6cdd8..9640cf88a 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -62,7 +62,6 @@ (defn adjust-type* [up type] "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" - ;; (prn 'adjust-type* (&type/show-type type)) (|case type (&/$UnivQ _aenv _abody) (&type/with-var @@ -159,63 +158,47 @@ (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] - (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (|case value-type* - (&/$TupleT ?member-types) - (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/Cons$ =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T &/Nil$ =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont))))) + (|case value-type* + (&/$TupleT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/Cons$ =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T &/Nil$ =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) - _ - (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*))))) (&/$RecordS pairs) (|do [[rec-members rec-type] (&&record/order-record pairs)] (analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont)) (&/$TagS ?ident) - (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] - [=module =name] (&&/resolved-ident ?ident) - ;; :let [_ (println "#01")] + (|do [[=module =name] (&&/resolved-ident ?ident) value-type* (adjust-type value-type) - ;; :let [_ (println "#02")] idx (&module/tag-index =module =name) group (&module/tag-group =module =name) - ;; :let [_ (println "#03")] case-type (&type/variant-case idx value-type*) - ;; :let [_ (println "#04")] - [=test =kont] (analyse-pattern case-type unit kont) - ;; :let [_ (println "#05")] - ] + [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] - [=module =name] (&&/resolved-ident ?ident) - ;; :let [_ (println "#11")] + (|do [[=module =name] (&&/resolved-ident ?ident) value-type* (adjust-type value-type) - ;; :let [_ (println "#12" (&type/show-type value-type*))] idx (&module/tag-index =module =name) group (&module/tag-group =module =name) - ;; :let [_ (println "#13")] case-type (&type/variant-case idx value-type*) - ;; :let [_ (println "#14" (&type/show-type case-type))] [=test =kont] (case (int (&/|length ?values)) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont)) - ;; :let [_ (println "#15")] - ] + (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont))] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) _ @@ -319,7 +302,6 @@ (return (&/T =output =type))))))) (defn ^:private check-totality [value-type struct] - ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct ($DefaultTotal ?total) (return ?total) @@ -371,20 +353,11 @@ (|do [value-type* (resolve-type value-type)] (|case value-type* (&/$VariantT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - ;; (prn '$VariantTotal - ;; (&/adt->text sub-struct) - ;; (&type/show-type ?member)) - (check-totality ?member sub-struct)) - ?structs ?members)] + (|do [totals (&/map2% check-totality ?members ?structs)] (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Variant is not total.")))) - - ;; _ - ;; (assert false (prn-str 'check-totality (&type/show-type value-type) - ;; (&/adt->text struct))) )) ;; [Exports] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index a7ce52c1f..81397a3f6 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,9 +15,7 @@ (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] - ;; (prn 'with-local name) (fn [state] - ;; (prn 'with-local name) (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) =return (body (&/update$ &/$envs (fn [stack] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9a38022d8..33553985b 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -45,28 +45,22 @@ now))) nil exceptions)] - (assert false (str "[Analyser Error] Unhandled exception: " missing-ex)) - ;; (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex)) + (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex)) (&/return* state nil))) ))) (defn ^:private with-catches [catches body] "(All [a] (-> (List Text) (Lux a) (Lux a)))" (fn [state] - (let [;; _ (prn 'with-catches/_0 (&/->seq catches)) - old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) - ;; _ (prn 'with-catches/_1 (&/->seq (->> state (&/get$ &/$host) (&/get$ &/$catching)))) - state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %))) - ;; _ (prn 'with-catches/_2 (&/->seq (->> state* (&/get$ &/$host) (&/get$ &/$catching)))) - ] + (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) + state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] (|case (&/run-state body state*) (&/$Left msg) (&/V &/$Left msg) (&/$Right state** output) - (do ;; (prn 'with-catches/_3 (&/->seq (->> state** (&/get$ &/$host) (&/get$ &/$catching)))) - (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) - output))))) + (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output)))) )) (defn ^:private ensure-object [type] @@ -219,7 +213,6 @@ (defn analyse-jvm-getstatic [analyse exo-type class field] (|do [class-loader &/loader [gvars gtype] (&host/lookup-static-field class-loader class field) - ;; :let [_ (prn 'analyse-jvm-getstatic class field (&/->seq gvars) gtype)] :let [=type (&host-type/class->type (cast Class gtype))] :let [output-type =type] _ (&type/check exo-type output-type) @@ -294,7 +287,6 @@ [gret exceptions parent-gvars gvars gargs] (if (= "" method) (return (&/T Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$)) (&host/lookup-virtual-method class-loader class method classes)) - ;; :let [_ (prn ' [class method] (&/adt->text =return+exceptions))] _ (ensure-catching exceptions) =object (&&/analyse-1+ analyse object) [sub-class sub-params] (ensure-object (&&/expr-type* =object)) @@ -304,8 +296,6 @@ parent-gvars super-params*)] [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) - ;; :let [_ (prn ' [class method] (&type/show-type exo-type) (&type/show-type output-type))] - ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor @@ -319,11 +309,7 @@ (defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) - ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))] _ (ensure-catching exceptions) - ;; :let [_ (matchv ::M/objects [=return] - ;; [[&/$DataT _return-class &/Nil$]] - ;; (prn 'analyse-jvm-invokestatic class method _return-class))] =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) classes @@ -354,9 +340,6 @@ (|case gtype-vars (&/$Nil) (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - ;; :let [_ (prn 'analyse-jvm-new-helper/_0 gtype) - ;; _ (prn 'analyse-jvm-new-helper/_1 gtype (->> arg-types (&/|map &type/show-type) &/->seq)) - ;; _ (prn 'analyse-jvm-new-helper/_2 gtype (->> args (&/|map &/show-ast) &/->seq))] =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] (return (&/T (make-gtype gtype gtype-vars*) @@ -365,7 +348,6 @@ (&/$Cons ^TypeVariable gtv gtype-vars*) (&type/with-var (fn [$var] - ;; (prn 'analyse-jvm-new-helper gtype gtv $var (&/|length gtype-vars) (&/|length gtype-args)) (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args)))) )) @@ -373,10 +355,8 @@ (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) - ;; :let [_ (prn 'analyse-jvm-new class (&/->seq gvars) (&/->seq gargs))] _ (ensure-catching exceptions) [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - ;; :let [_ (prn 'analyse-jvm-new/POST class (->> classes &/->seq vec) (&type/show-type output-type))] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor @@ -713,39 +693,27 @@ captured-slot-type "java.lang.Object"] (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods] (&/with-closure - (|do [;; :let [_ (prn 'analyse-jvm-anon-class/_0 super-class)] - module &/get-module-name + (|do [module &/get-module-name scope &/get-scope-name - ;; :let [_ (prn 'analyse-jvm-anon-class/_1 super-class)] :let [name (&host/location (&/|tail scope)) anon-class (str module "." name)] - ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] =method-descs (&/map% dummy-method-desc methods) _ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs) =methods (&/map% (partial analyse-method analyse anon-class) methods) - ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) - ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] =captured &&env/captured-vars :let [=fields (&/|map (fn [^objects idx+capt] {:name (str &c!base/closure-prefix (aget idx+capt 0)) :modifiers captured-slot-modifier :anns (&/|list) :type captured-slot-type}) - (&/enumerate =captured)) - ;; _ (prn '=methods (&/adt->text (&/|map :body =methods))) - ;; =methods* (rename-captured-vars) - ] + (&/enumerate =captured))] :let [sources (&/|map captured-source =captured)] - ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] - ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured))) - ;; :let [_ (println 'DEF anon-class)] _cursor &/cursor] (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) ))) - ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources) )))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 9dd8cecdc..e938fa343 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -45,8 +45,7 @@ (defn analyse-tuple [analyse ?exo-type ?elems] (|case ?exo-type (&/$Left exo-type) - (|do [;; :let [_ (println 'analyse-tuple/$Left (&type/show-type exo-type))] - exo-type* (&type/actual-type exo-type)] + (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* (&/$UnivQ _) (&type/with-var @@ -100,7 +99,6 @@ _ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) - ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) )))))) (defn with-attempt [m-value on-error] @@ -127,10 +125,6 @@ (fail (str err "\n" 'analyse-variant-body " " (&type/show-type exo-type) " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) - ;; (assert false - ;; (str err "\n" - ;; 'analyse-variant-body " " (&type/show-type exo-type) - ;; " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) ))] (|case output (&/$Cons x (&/$Nil)) @@ -142,20 +136,14 @@ (defn analyse-variant [analyse ?exo-type idx ?values] (|case ?exo-type (&/$Left exo-type) - (|do [;; :let [_ (println 'analyse-variant/Left 0 (&type/show-type exo-type))] - exo-type* (&type/actual-type exo-type) - ;; :let [_ (println 'analyse-variant/Left 1 (&type/show-type exo-type*))] - ] + (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))] [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) - ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))] =var (&type/resolve-type $var) - ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))] inferred-type (|case =var (&/$VarT iid) (|do [:let [=var* (next-bound-type variant-type)] @@ -164,9 +152,7 @@ (return (&type/Univ$ &/Nil$ variant-type*))) _ - (&type/clean $var variant-type)) - ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))] - ] + (&type/clean $var variant-type))] (return (&/|list (&&/|meta inferred-type variant-cursor variant-analysis)))))) @@ -174,9 +160,7 @@ (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) (&/$Right exo-type) - ;; [_ exo-type] - (|do [;; :let [_ (println 'analyse-variant/Right 0 (&type/show-type exo-type))] - exo-type* (|case exo-type + (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) @@ -230,8 +214,6 @@ (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) - ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - ;; :let [_ (prn 'analyse-global/$def (aget $def 0))] endo-type (|case $def (&/$ValueD ?type _) (return ?type) @@ -263,52 +245,48 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] - (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) - (|case global - [(&/$Global ?module* name*) _] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) - ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (|case $def - (&/$ValueD ?type _) - (return ?type) - - (&/$MacroD _) - (return &type/Macro) - - (&/$TypeD _) - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta endo-type _cursor - (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) - )))) - state) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] + (|case global + [(&/$Global ?module* name*) _] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) + endo-type (|case $def + (&/$ValueD ?type _) + (return ?type) + + (&/$MacroD _) + (return &type/Macro) + + (&/$TypeD _) + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + )))) + state) - _ - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) - (fail* ""))) + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) + (fail* "")) (&/$Cons top-outer _) - (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1) - (&/|map #(&/get$ &/$name %) outer) - (&/|reverse inner))) - [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] - (|let [[register new-inner] register+new-inner - [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/T register* (&/Cons$ frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) - (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) - &/Nil$) - (&/|reverse inner) scopes)] - ((|do [_ (&type/check exo-type (&&/expr-type* =local))] - (return (&/|list =local))) - (&/set$ &/$envs (&/|++ inner* outer) state)))) + (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] + (&/T register* (&/Cons$ frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) + &/Nil$) + (&/|reverse inner) scopes)] + ((|do [_ (&type/check exo-type (&&/expr-type* =local))] + (return (&/|list =local))) + (&/set$ &/$envs (&/|++ inner* outer) state))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -319,22 +297,15 @@ )) (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] - ;; (prn 'analyse-apply* (aget fun-type 0)) (|case ?args (&/$Nil) - (|do [;; :let [_ (prn 'analyse-apply*/_0 (&type/show-type exo-type) (&type/show-type fun-type))] - _ (&type/check exo-type fun-type) - ;; :let [_ (prn 'analyse-apply*/_1 'SUCCESS (str "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))] - ] + (|do [_ (&type/check exo-type fun-type)] (return (&/T fun-type &/Nil$))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* (&/$UnivQ _) - ;; (|do [$var &type/existential - ;; type* (&type/apply-type ?fun-type* $var)] - ;; (analyse-apply* analyse exo-type type* ?args)) (&type/with-var (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) @@ -359,9 +330,6 @@ " " "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))))] (return (&/T =output-t (&/Cons$ =arg =args)))) - ;; [[&/$VarT ?id-t]] - ;; (|do [ (&type/deref ?id-t)]) - _ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) @@ -374,9 +342,7 @@ (|do [[real-name $def] (&&module/find-def ?module ?name)] (|case $def (&/$MacroD macro) - (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] - macro-expansion #(-> macro (.apply ?args) (.apply %)) - ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] + (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (when (or (= "do" (aget real-name 1)) ;; ;; (= "..?" (aget real-name 1)) ;; ;; (= "try$" (aget real-name 1)) @@ -494,11 +460,7 @@ (return (&/|list output)))) (defn analyse-def [analyse compile-token ?name ?value] - ;; (prn 'analyse-def/BEGIN ?name) - ;; (when (= "monoid$" ?name) - ;; (reset! &type/!flag true)) (|do [module-name &/get-module-name - ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))] ? (&&module/defined? module-name ?name)] (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) @@ -506,55 +468,36 @@ (&&/analyse-1+ analyse ?value))] (|case =value [_ (&&/$var (&/$Global ?r-module ?r-name))] - (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) - ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) - ;; _ (println)] - ] + (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))] (return &/Nil$)) _ - (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) - ;; _ (if (and (= "lux" module-name) - ;; (= "Type" ?name)) - ;; (|do [newly-defined-Type - ;; :let [_ (&type/redefine-type! newly-defined-Type)]] - ;; (return nil)) - ;; (return nil)) - :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - [[def-type def-cursor] def-analysis] =value - _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) - )]] - (return &/Nil$)))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [[[def-type def-cursor] def-analysis] =value + _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) + )]] + (return &/Nil$))) )))) (defn analyse-declare-macro [analyse compile-token ?name] - (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] - module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) - ;; :let [_ (prn 'analyse-declare-macro ?name "2")] - ] + (|do [module-name &/get-module-name + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] (return &/Nil$))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] (return &/Nil$))) (defn analyse-import [analyse compile-module compile-token path] - ;; (prn 'analyse-import path) (|do [module-name &/get-module-name _ (if (= module-name path) (fail (str "[Analyser Error] Module can't import itself: " path)) (return nil))] (&/save-module (|do [already-compiled? (&&module/exists? path) - ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] active? (&/active-module? path) _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) _ (&&module/add-import path) @@ -576,10 +519,8 @@ (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) - ;; :let [_ (prn 'analyse-check/_0 (&type/show-type ==type))] _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value) - ;; :let [_ (prn 'analyse-check/_1 (&/adt->text =value))] _cursor &/cursor ] (return (&/|list (&&/|meta ==type _cursor diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index c645a9566..192e80153 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -60,7 +60,6 @@ nil)))) (defn define [module name ^objects def-data type] - ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] (when (and (= "Macro" name) (= "lux" module)) (&type/set-macro-type! (aget def-data 1))) @@ -116,7 +115,6 @@ (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] - ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) @@ -165,23 +163,19 @@ (defn find-def [module name] (|do [current-module &/get-module-name] (fn [state] - ;; (prn 'find-def/_0 module name 'current-module current-module) (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|let [[exported? $$def] $def] - (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) - (if (or exported? (.equals ^Object current-module module)) - (|case $$def - (&/$AliasD ?r-module ?r-name) - (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) - ((find-def ?r-module ?r-name) - state)) - - _ - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) - (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[exported? $$def] $def] + (if (or exported? (.equals ^Object current-module module)) + (|case $$def + (&/$AliasD ?r-module ?r-name) + ((find-def ?r-module ?r-name) + state) + + _ + (return* state (&/T (&/T module name) $$def))) + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) (defn ensure-type-def [def-data] @@ -321,8 +315,7 @@ (defn declare-tags [module tag-names type] "(-> Text (List Text) Type (Lux (,)))" - (|do [;; :let [_ (prn 'declare-tags module (&/->seq tag-names) (&type/show-type type))] - _ (ensure-undeclared-tags module tag-names) + (|do [_ (ensure-undeclared-tags module tag-names) type-name (&type/type-name type) :let [[_module _name] type-name] _ (&/assert! (= module _module) diff --git a/src/lux/base.clj b/src/lux/base.clj index d76348b9a..7357bd483 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -217,9 +217,6 @@ (if (.equals ^Object k slot) (V $Cons (T (T slot value) table*)) (V $Cons (T (T k v) (|put slot value table*)))) - - ;; _ - ;; (assert false (prn-str '|put (aget table 0))) )) (defn |remove [slot table] @@ -801,7 +798,6 @@ (return* state (get$ $cursor state)))) (defn show-ast [ast] - ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast [_ ($BoolS ?value)] (pr-str ?value) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 76d3a1eb2..3052ead09 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -38,7 +38,6 @@ (def ^:private !source->last-line (atom nil)) (defn ^:private compile-expression [syntax] - ;; (prn 'compile-expression (&/adt->text syntax)) (|let [[[?type [_file-name _line _column]] ?form] syntax] (|do [^MethodVisitor *writer* &/get-writer :let [debug-label (new Label) @@ -52,8 +51,7 @@ (&&lux/compile-bool compile-expression ?value) (&a/$int ?value) - (do ;; (prn 'compile-expression (&/adt->text syntax)) - (&&lux/compile-int compile-expression ?value)) + (&&lux/compile-int compile-expression ?value) (&a/$real ?value) (&&lux/compile-real compile-expression ?value) @@ -445,7 +443,6 @@ id &/gen-id [file-name _ _] &/cursor :let [class-name (str (&host/->module-class module) "/" id) - ;; _ (prn 'eval! id class-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) @@ -472,7 +469,6 @@ return)))) (defn ^:private compile-module [name] - ;; (prn 'compile-module name (&&cache/cached? name)) (let [file-name (str name ".lux")] (|do [file-content (&&io/read-file file-name) :let [file-hash (hash file-content)]] @@ -492,9 +488,7 @@ .visitEnd) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version) .visitEnd) - (.visitSource file-name nil)) - ;; _ (prn 'compile-module name =class) - ]] + (.visitSource file-name nil))]] (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) @@ -529,7 +523,6 @@ (&/fold str ""))) .visitEnd) (.visitEnd)) - ;; _ (prn 'CLOSED name =class) ] _ (&/flag-compiled-module name)] (&&/save-class! &/module-class-name (.toByteArray =class))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index f1b21f6fd..a35225acf 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -72,94 +72,78 @@ :let [redo-cache (|do [_ (delete module) _ (compile-module module)] (return false))]] - (do ;; (prn 'load module 'sources already-loaded? - ;; (&/->seq _modules)) - (if already-loaded? - (return true) - (if (cached? module) - (do ;; (prn 'load/HASH module module-hash) - (let [module* (&host/->class-name module) - module-path (str &&/output-dir module) - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field &/hash-field module-meta)) - (= &&/version (get-field &/compiler-field module-meta))) - (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator))) - ;; _ (prn 'load/IMPORTS module imports) - ] - (|do [loads (&/map% (fn [_import] - (|do [content (&&io/read-file (str _import ".lux")) - _ (load _import (hash content) compile-module)] - (&/cached-module? _import))) - (if (= [""] imports) - &/Nil$ - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load module real-name) - ] - (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator))) - ;; _ (prn module '(get-field &/tags-field module-meta) - ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))) - tag-groups (let [all-tags (get-field &/tags-field module-meta)] - (if (= "" all-tags) - &/Nil$ - (-> all-tags - (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) - (->> (map (fn [_group] - ;; (prn '_group _group) - (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] - ;; (prn '[_type _tags] [_type _tags]) - (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) - &/->list)))] - ;; (prn 'load module defs) - (|do [_ (&a-module/enter-module module) - _ (&/flag-cached-module module) - _ (&a-module/set-imports imports) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) - "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] - (&a-module/declare-macro module _name))) - "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-meta (get-field &/meta-field def-class)] - (|case def-meta - (&/$ValueD def-type _) - (&a-module/define module _name def-meta def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= &&/exported-true _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) - &/Nil$ - (&/->list defs))) - _ (&/map% (fn [group] - (|let [[_type _tags] group] - (|do [=type (&a-module/type-def module _type)] - (&a-module/declare-tags module _tags =type)))) - tag-groups)] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache))))) + (if already-loaded? + (return true) + (if (cached? module) + (let [module* (&host/->class-name module) + module-path (str &&/output-dir module) + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name))] + (if (and (= module-hash (get-field &/hash-field module-meta)) + (= &&/version (get-field &/compiler-field module-meta))) + (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator)))] + (|do [loads (&/map% (fn [_import] + (|do [content (&&io/read-file (str _import ".lux")) + _ (load _import (hash content) compile-module)] + (&/cached-module? _import))) + (if (= [""] imports) + &/Nil$ + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file)] + (swap! !classes assoc (str module* "." real-name) bytecode))) + (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator))) + tag-groups (let [all-tags (get-field &/tags-field module-meta)] + (if (= "" all-tags) + &/Nil$ + (-> all-tags + (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) + (->> (map (fn [_group] + (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + &/->list)))] + (|do [_ (&a-module/enter-module module) + _ (&/flag-cached-module module) + _ (&a-module/set-imports imports) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ")] + (|do [_ (case _ann + "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field &/datum-field def-class)] + (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) + "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field &/datum-field def-class)] + (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] + (&a-module/declare-macro module _name))) + "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-meta (get-field &/meta-field def-class)] + (|case def-meta + (&/$ValueD def-type _) + (&a-module/define module _name def-meta def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (&a-module/def-alias module _name __module __name __type))))] + (if (= &&/exported-true _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + &/Nil$ + (&/->list defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [=type (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags =type)))) + tag-groups)] + (return true)))) + redo-cache))) + redo-cache) + ) + redo-cache)))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 6d926e6da..c364091ba 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -220,7 +220,8 @@ ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] + :let [_ (when (not= "" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] @@ -233,27 +234,9 @@ compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL + compile-jvm-invokespecial Opcodes/INVOKESPECIAL ) -(defn compile-jvm-invokespecial [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] - _ (compile ?object) - ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] - :let [_ (when (not= "" ?method) - (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - (defn compile-jvm-null [compile] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] @@ -422,10 +405,10 @@ (defn ^:private compile-annotation [writer ann] (doto ^AnnotationVisitor (.visitAnnotation writer (&host/->class (:name ann)) true) - (-> (.visit param-name param-value) - (->> (|let [[param-name param-value] param]) - (doseq [param (&/->seq (:params ann))]))) - (.visitEnd)) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) nil) (defn ^:private compile-field [^ClassWriter writer field] @@ -466,10 +449,6 @@ (.visitInsn writer Opcodes/ARETURN))) (defn ^:private compile-method [compile ^ClassWriter class-writer method] - ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) - ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) - ;; (prn 'compile-method/_2 (&/adt->text (:output method))) - ;; (prn 'compile-method/_3 (&/adt->text (:body method))) (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) @@ -518,9 +497,7 @@ ) (defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env] - (|do [;; :let [_ (prn 'compile-jvm-class/_0)] - module &/get-module-name - ;; :let [_ (prn 'compile-jvm-class/_1)] + (|do [module &/get-module-name [file-name _ _] &/cursor :let [full-name (str module "/" ?name) super-class* (&host/->class ?super-class) @@ -531,17 +508,12 @@ _ (&/|map (partial compile-annotation =class) ?anns) _ (&/|map (partial compile-field =class) ?fields)] - ;; :let [_ (prn 'compile-jvm-class/_2)] _ (&/map% (partial compile-method compile =class) ?methods) - ;; :let [_ (prn 'compile-jvm-class/_3)] :let [_ (when env - (add-anon-class- =class full-name env))] - ;; :let [_ (prn 'compile-jvm-class/_4)] - ] + (add-anon-class- =class full-name env))]] (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) (defn compile-jvm-interface [compile ?name ?supers ?anns ?methods] - ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) (|do [module &/get-module-name [file-name _ _] &/cursor] (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -571,9 +543,7 @@ (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) - _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) - ;; :let [_ (prn 'HANDLER ?ex-class (&host/->class ?ex-class) $handler-start $handler-end $from $to $catch-finally)] - ] + _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)] (doto *writer* (.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class)) (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))) @@ -591,7 +561,6 @@ compile-finally)) ?catches catch-boundaries) - ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) @@ -694,16 +663,12 @@ (defn compile-jvm-program [compile ?body] (|do [module-name &/get-module-name - ;; :let [_ (prn 'compile-jvm-program module-name)] ^ClassWriter *writer* &/get-writer] (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) (.visitCode)) (|do [^MethodVisitor main-writer &/get-writer - :let [;; _ (prn "#1" module-name *writer*) - $loop (new Label) - ;; _ (prn "#2") + :let [$loop (new Label) $end (new Label) - ;; _ (prn "#3") _ (doto main-writer ;; Tail: Begin (.visitLdcInsn (int 2)) ;; S @@ -772,20 +737,14 @@ (.visitInsn Opcodes/POP) ;; V (.visitVarInsn Opcodes/ASTORE (int 0)) ;; ) - ;; _ (prn "#4") ] _ (compile ?body) - :let [;; _ (prn "#5") - _ (doto main-writer + :let [_ (doto main-writer (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)) - ;; _ (prn "#6") - ] + (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))] :let [_ (doto main-writer (.visitInsn Opcodes/POP) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) - (.visitEnd)) - ;; _ (prn "#7") - ]] + (.visitEnd))]] (return nil))))) diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index 4cd6284b7..bc6fa854d 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -19,7 +19,6 @@ ;; [Resources] (defn read-file [^String file-name] - ;; (prn 'read-file file-name) (let [file (new java.io.File (str &&/input-dir "/" file-name))] (if (.exists file) (return (slurp file)) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 77dc316b8..cb8ad0037 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -92,7 +92,6 @@ (let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] (defn compile-lambda [compile ?scope ?env ?body] - ;; (prn 'compile-lambda (->> ?scope &/->seq)) (|do [[file-name _ _] &/cursor :let [name (&host/location (&/|tail ?scope)) class-name (str (&host/->module-class (&/|head ?scope)) "/" name) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index f7cd905e8..01e4ffd5b 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -68,7 +68,6 @@ (return nil))) (defn compile-variant [compile ?tag ?value] - ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) @@ -118,8 +117,7 @@ (|do [^MethodVisitor **writer** &/get-writer] (|case def-type "type" - (|do [:let [;; ?type* (&&type/->analysis ?type) - _ (doto **writer** + (|do [:let [_ (doto **writer** ;; Tail: Begin (.visitLdcInsn (int 2)) ;; S (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V @@ -131,17 +129,12 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") - ;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN (.visitInsn Opcodes/AASTORE) ;; V - )] - ;; _ (compile ?type*) - ;; :let [_ (.visitInsn **writer** Opcodes/AASTORE)] - ] + )]] (return nil)) "value" - (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) - ?def-type (|case ?body + (|let [?def-type (|case ?body [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr)] ?type-expr diff --git a/src/lux/host.clj b/src/lux/host.clj index 133c50e9b..916f94419 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -113,7 +113,6 @@ (do-template [ ] (defn [class-loader target method-name args] - ;; (prn ' target method-name) (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index fd694c51c..651f9ecce 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -109,10 +109,8 @@ ? (&module/exists? token)] (if ? (return (&/T meta (&/T token local-token))) - (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] - (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/T meta (&/T unaliased local-token))))))) + (|do [unaliased (&module/dealias token)] + (return (&/T meta (&/T unaliased local-token)))))) (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj index 7337bcb02..83927ba0d 100644 --- a/src/lux/packager/program.clj +++ b/src/lux/packager/program.clj @@ -33,7 +33,6 @@ (defn ^:private write-class! [^String path ^File file ^JarOutputStream out] "(-> Text File JarOutputStream Unit)" - ;; (prn 'write-class! path file) (with-open [in (new BufferedInputStream (new FileInputStream file))] (let [buffer (byte-array (* 10 kilobyte))] (doto out @@ -49,8 +48,7 @@ (let [output-dir-size (.length &&/output-dir)] (defn ^:private write-module! [^File file ^JarOutputStream out] "(-> File JarOutputStream Unit)" - (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file) - ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size)) + (let [module-name (.substring (.getPath file) output-dir-size) inner-files (.listFiles file) inner-modules (filter #(.isDirectory ^File %) inner-files) inner-classes (filter #(not (.isDirectory ^File %)) inner-files)] @@ -80,7 +78,6 @@ (with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))] (loop [^JarEntry entry (.getNextJarEntry is)] (when entry - ;; (prn 'add-jar! (.getName entry) (.isDirectory entry)) (when (and (not (.isDirectory entry)) (not (.startsWith (.getName entry) "META-INF/"))) (let [entry-data (read-stream is)] @@ -94,7 +91,6 @@ ;; [Resources] (defn package [module] "(-> Text (,))" - ;; (prn 'package module) (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] (doseq [$group (.listFiles (new File &&/output-dir))] (write-module! $group out)) diff --git a/src/lux/type.clj b/src/lux/type.clj index ed0dd8898..fb9c63783 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -36,10 +36,8 @@ (defn App$ [fun arg] (&/V &/$AppT (&/T fun arg))) (defn Tuple$ [members] - ;; (assert (|list? members)) (&/V &/$TupleT members)) (defn Variant$ [members] - ;; (assert (|list? members)) (&/V &/$VariantT members)) (defn Univ$ [env body] (&/V &/$UnivQ (&/T env body))) @@ -149,7 +147,6 @@ (deref id) _ - ;; (assert false (str "[Type Error] Type is not a variable: " (show-type type))) (fail (str "[Type Error] Type is not a variable: " (show-type type))) )) @@ -406,8 +403,6 @@ "\n")) (defn beta-reduce [env type] - ;; (when @!flag - ;; (prn 'beta-reduce (show-type type))) (|case type (&/$VariantT ?members) (Variant$ (&/|map (partial beta-reduce env) ?members)) @@ -442,8 +437,6 @@ )) (defn apply-type [type-fn param] - ;; (when @!flag - ;; (prn 'apply-type (show-type type-fn) (show-type param))) (|case type-fn (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env @@ -528,40 +521,6 @@ (check* class-loader fixpoints invariant?? eA aA) (fail (check-error expected actual))) - ;; [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] - ;; (fn [state] - ;; (|case ((|do [F1 (deref ?eid)] - ;; (fn [state] - ;; (|case ((|do [F2 (deref ?aid)] - ;; (check* class-loader fixpoints invariant?? (App$ F1 A1) (App$ F2 A2))) - ;; state) - ;; (&/$Right state* output) - ;; (return* state* output) - - ;; (&/$Left _) - ;; ((check* class-loader fixpoints invariant?? (App$ F1 A1) actual) - ;; state)))) - ;; state) - ;; (&/$Right state* output) - ;; (return* state* output) - - ;; (&/$Left _) - ;; (|case ((|do [F2 (deref ?aid)] - ;; (check* class-loader fixpoints invariant?? expected (App$ F2 A2))) - ;; state) - ;; (&/$Right state* output) - ;; (return* state* output) - - ;; (&/$Left _) - ;; ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid)) - ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? A1 A2)] - ;; (return (&/T fixpoints** nil))) - ;; state)))) - - ;; (|do [_ (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid)) - ;; _ (check* class-loader fixpoints invariant?? A1 A2)] - ;; (return (&/T fixpoints nil))) - [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] @@ -578,13 +537,6 @@ (return (&/T fixpoints** nil))) state))) - ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2) - ;; e* (apply-type F2 A1) - ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] - ;; (return (&/T fixpoints** nil))) - [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] @@ -601,17 +553,6 @@ (return (&/T fixpoints** nil))) state))) - ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id)) - ;; e* (apply-type F1 A1) - ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] - ;; (return (&/T fixpoints** nil))) - - ;; [(&/$AppT eF eA) (&/$AppT aF aA)] - ;; (|do [_ (check* class-loader fixpoints invariant?? eF aF)] - ;; (check* class-loader fixpoints invariant?? eA aA)) - [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) @@ -641,11 +582,7 @@ (|do [$arg existential expected* (apply-type expected $arg)] (check* class-loader fixpoints invariant?? expected* actual)) - ;; (with-var - ;; (fn [$arg] - ;; (|do [expected* (apply-type expected $arg)] - ;; (check* class-loader fixpoints invariant?? expected* actual)))) - + [_ (&/$UnivQ _)] (with-var (fn [$arg] diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index e121cee86..989c0d665 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -68,20 +68,17 @@ Unit (&/V &/$TupleT (&/|list))] (defn class->type [^Class class] "(-> Class Type)" - (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) - (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] - (let [base (or arr-base simple-base)] - ;; (prn 'class->type/_1 class base arr-brackets) - (if (.equals "void" base) - Unit - (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner)))) - (&/V &/$DataT (&/T base &/Nil$)) - (range (count (or arr-brackets ""))))) - ))))) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + (if (.equals "void" base) + Unit + (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner)))) + (&/V &/$DataT (&/T base &/Nil$)) + (range (count (or arr-brackets ""))))) + )))) (defn instance-param [existential matchings refl-type] "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" - ;; (prn 'instance-param refl-type (class refl-type)) (cond (instance? Class refl-type) (return (class->type refl-type)) -- cgit v1.2.3 From 57ed0ef20db8f6ae926c1f7580f5bfa26928612b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 29 Sep 2015 07:40:29 -0400 Subject: - Returned to old format of type-environments where odds are arguments & evens are quantifiers. --- source/lux.lux | 86 +++++++++++++++++++++++------------------------ src/lux/analyser/case.clj | 2 +- src/lux/analyser/host.clj | 2 +- src/lux/type.clj | 24 ++++++------- 4 files changed, 57 insertions(+), 57 deletions(-) diff --git a/source/lux.lux b/source/lux.lux index dddf5c80d..ddb3384cc 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -49,8 +49,8 @@ (1 (1 ## "lux;Nil" (2 (0)) (1 ## "lux;Cons" - (2 (1 (4 0) - (1 (9 (4 1) (4 0)) + (2 (1 (4 1) + (1 (9 (4 0) (4 1)) (0)))) (0))))))) (_lux_export List) @@ -65,7 +65,7 @@ (1 (1 ## "lux;None" (2 (0)) (1 ## "lux;Some" - (4 0) + (4 1) (0))))))) (_lux_export Maybe) (_lux_declare-tags [#None #Some] Maybe) @@ -85,7 +85,7 @@ ## )) (_lux_def Type (10 ["lux" "Type"] - (_lux_case (9 (4 1) (4 0)) + (_lux_case (9 (4 0) (4 1)) Type (_lux_case (9 List Type) TypeList @@ -128,8 +128,8 @@ Int (#Cons ## "lux;mappings" (#AppT List - (#TupleT (#Cons (#BoundT 2) - (#Cons (#BoundT 0) + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) #Nil)))) #Nil))))))) (_lux_export Bindings) @@ -149,11 +149,11 @@ (#Cons ## "lux;inner-closures" Int (#Cons ## "lux;locals" - (#AppT (#AppT Bindings (#BoundT 2)) - (#BoundT 0)) + (#AppT (#AppT Bindings (#BoundT 3)) + (#BoundT 1)) (#Cons ## "lux;closure" - (#AppT (#AppT Bindings (#BoundT 2)) - (#BoundT 0)) + (#AppT (#AppT Bindings (#BoundT 3)) + (#BoundT 1)) #Nil))))))))) (_lux_export Env) (_lux_declare-tags [#name #inner-closures #locals #closure] Env) @@ -175,8 +175,8 @@ (#NamedT ["lux" "Meta"] (#UnivQ #Nil (#UnivQ #Nil - (#TupleT (#Cons (#BoundT 2) - (#Cons (#BoundT 0) + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) #Nil))))))) (_lux_export Meta) (_lux_declare-tags [#meta #datum] Meta) @@ -194,9 +194,9 @@ ## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) (_lux_def AST' (#NamedT ["lux" "AST'"] - (_lux_case (#AppT (#BoundT 0) - (#AppT (#BoundT 1) - (#BoundT 0))) + (_lux_case (#AppT (#BoundT 1) + (#AppT (#BoundT 0) + (#BoundT 1))) AST (_lux_case (#AppT [List AST]) ASTList @@ -246,9 +246,9 @@ (#UnivQ #Nil (#UnivQ #Nil (#VariantT (#Cons ## "lux;Left" - (#BoundT 2) + (#BoundT 3) (#Cons ## "lux;Right" - (#BoundT 0) + (#BoundT 1) #Nil))))))) (_lux_export Either) (_lux_declare-tags [#Left #Right] Either) @@ -258,10 +258,10 @@ (_lux_def StateE (#UnivQ #Nil (#UnivQ #Nil - (#LambdaT (#BoundT 2) + (#LambdaT (#BoundT 3) (#AppT (#AppT Either Text) - (#TupleT (#Cons (#BoundT 2) - (#Cons (#BoundT 0) + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) #Nil)))))))) ## (deftype Source @@ -286,7 +286,7 @@ (#Cons ## "lux;TypeD" Type (#Cons ## "lux;MacroD" - (#BoundT 0) + (#BoundT 1) (#Cons ## "lux;AliasD" Ident #Nil)))))))) @@ -312,7 +312,7 @@ (#Cons ## "lux;defs" (#AppT List (#TupleT (#Cons Text (#Cons (#TupleT (#Cons Bool (#Cons (#AppT DefData' (#LambdaT ASTList - (#AppT (#AppT StateE (#BoundT 0)) + (#AppT (#AppT StateE (#BoundT 1)) ASTList))) #Nil))) #Nil)))) @@ -357,7 +357,7 @@ Cursor (#Cons ## "lux;modules" (#AppT List (#TupleT (#Cons Text - (#Cons (#AppT Module (#AppT (#BoundT 1) (#BoundT 0))) + (#Cons (#AppT Module (#AppT (#BoundT 0) (#BoundT 1))) #Nil)))) (#Cons ## "lux;envs" (#AppT List (#AppT (#AppT Env Text) @@ -418,11 +418,11 @@ ## ...) (_lux_def return (_lux_: (#UnivQ #Nil - (#LambdaT (#BoundT 0) + (#LambdaT (#BoundT 1) (#LambdaT Compiler (#AppT (#AppT Either Text) (#TupleT (#Cons Compiler - (#Cons (#BoundT 0) + (#Cons (#BoundT 1) #Nil))))))) (_lux_lambda _ val (_lux_lambda _ state @@ -439,7 +439,7 @@ (#LambdaT Compiler (#AppT (#AppT Either Text) (#TupleT (#Cons Compiler - (#Cons (#BoundT 0) + (#Cons (#BoundT 1) #Nil))))))) (_lux_lambda _ msg (_lux_lambda _ state @@ -655,9 +655,9 @@ (def'' (map f xs) (#UnivQ #Nil (#UnivQ #Nil - (#LambdaT (#LambdaT (#BoundT 2) (#BoundT 0)) - (#LambdaT ($' List (#BoundT 2)) - ($' List (#BoundT 0)))))) + (#LambdaT (#LambdaT (#BoundT 3) (#BoundT 1)) + (#LambdaT ($' List (#BoundT 3)) + ($' List (#BoundT 1)))))) (_lux_case xs #Nil #Nil @@ -770,8 +770,8 @@ (def'' (parse-univq-args args next) ## (All [a] (-> (List AST) (-> (List Text) (Lux a)) (Lux a))) (#UnivQ #Nil (#LambdaT ($' List AST) - (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 0))) - (#AppT (#AppT StateE Compiler) (#BoundT 0))))) + (#LambdaT (#LambdaT ($' List Text) (#AppT (#AppT StateE Compiler) (#BoundT 1))) + (#AppT (#AppT StateE Compiler) (#BoundT 1))))) (_lux_case args #Nil (next #Nil) @@ -788,12 +788,12 @@ (def'' (foldL f init xs) ## (All [a b] (-> (-> a b a) a (List b) a)) - (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 2) - (#LambdaT (#BoundT 0) - (#BoundT 2))) - (#LambdaT (#BoundT 2) - (#LambdaT ($' List (#BoundT 0)) - (#BoundT 2)))))) + (#UnivQ #Nil (#UnivQ #Nil (#LambdaT (#LambdaT (#BoundT 3) + (#LambdaT (#BoundT 1) + (#BoundT 3))) + (#LambdaT (#BoundT 3) + (#LambdaT ($' List (#BoundT 1)) + (#BoundT 3)))))) (_lux_case xs #Nil init @@ -816,9 +816,9 @@ (lambda'' [body' name'] (form$ (#Cons (tag$ ["lux" "UnivQ"]) (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 0)] #Nil) + (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -1)] #Nil) + (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) body) names) (return (#Cons body' #Nil))))) @@ -842,9 +842,9 @@ (lambda'' [body' name'] (form$ (#Cons (tag$ ["lux" "ExQ"]) (#Cons (tag$ ["lux" "Nil"]) - (#Cons (replace-syntax (#Cons [name' (make-bound 0)] #Nil) + (#Cons (replace-syntax (#Cons [name' (make-bound 1)] #Nil) (update-bounds body')) #Nil)))))) - (replace-syntax (#Cons [self-name (make-bound -1)] #Nil) + (replace-syntax (#Cons [self-name (make-bound -2)] #Nil) body) names) (return (#Cons body' #Nil))))) @@ -1776,7 +1776,7 @@ (defmacro' #export (Rec tokens) (_lux_case tokens (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) - (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 1)) (~ (make-bound 0))))]) body)] + (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)] (return (@list (` (#AppT (#UnivQ #Nil (~ body')) Void))))) _ @@ -2277,7 +2277,7 @@ (-> Type Type (Maybe Type)) (case type-fn (#UnivQ env body) - (#Some (beta-reduce (@list& param type-fn env) body)) + (#Some (beta-reduce (@list& type-fn param env) body)) (#AppT F A) (do Maybe/Monad diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 9640cf88a..ca4e0edeb 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -67,7 +67,7 @@ (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/Cons$ (&/T _aenv 0 $var) (&/|map update-up-frame up)) =type)))) + (adjust-type* (&/Cons$ (&/T _aenv 1 $var) (&/|map update-up-frame up)) =type)))) (&/$TupleT ?members) (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 33553985b..7e1f92d19 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -126,7 +126,7 @@ (|do [:let [[idx types] idx+types] [idx* real-type] (clean-gtype-var idx gtype-var)] (return (&/T idx* (&/Cons$ real-type types))))) - (&/T 0 (&/|list)) + (&/T 1 (&/|list)) gtype-vars)] (return clean-types))) diff --git a/src/lux/type.clj b/src/lux/type.clj index fb9c63783..6ae542b68 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -57,7 +57,7 @@ (def IO (Named$ (&/T "lux/data" "IO") (Univ$ empty-env - (Lambda$ Unit (Bound$ 0))))) + (Lambda$ Unit (Bound$ 1))))) (def List (Named$ (&/T "lux" "List") @@ -66,9 +66,9 @@ ;; lux;Nil Unit ;; lux;Cons - (Tuple$ (&/|list (Bound$ 0) - (App$ (Bound$ 1) - (Bound$ 0)))) + (Tuple$ (&/|list (Bound$ 1) + (App$ (Bound$ 0) + (Bound$ 1)))) ))))) (def Maybe @@ -78,12 +78,12 @@ ;; lux;None Unit ;; lux;Some - (Bound$ 0) + (Bound$ 1) ))))) (def Type (Named$ (&/T "lux" "Type") - (let [Type (App$ (Bound$ 1) (Bound$ 0)) + (let [Type (App$ (Bound$ 0) (Bound$ 1)) TypeList (App$ List Type) TypePair (Tuple$ (&/|list Type Type))] (App$ (Univ$ empty-env @@ -440,8 +440,8 @@ (|case type-fn (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env - (&/Cons$ type-fn) - (&/Cons$ param)) + (&/Cons$ param) + (&/Cons$ type-fn)) local-def)) (&/$AppT F A) @@ -593,16 +593,16 @@ (with-var (fn [$arg] (|let [expected* (beta-reduce (->> e!env - (&/Cons$ expected) - (&/Cons$ $arg)) + (&/Cons$ $arg) + (&/Cons$ expected)) e!def)] (check* class-loader fixpoints invariant?? expected* actual)))) [_ (&/$ExQ a!env a!def)] (|do [$arg existential] (|let [actual* (beta-reduce (->> a!env - (&/Cons$ expected) - (&/Cons$ $arg)) + (&/Cons$ $arg) + (&/Cons$ expected)) a!def)] (check* class-loader fixpoints invariant?? expected actual*))) -- cgit v1.2.3 From 1ff2c6ced65171a68ef761275a75ba4dc56caf7b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 30 Sep 2015 16:44:42 -0400 Subject: - Changed the license in the project.clj file (had forgotten until now). - Some minor updates to the standard library. - Some minor bug fixes & improvements. - program.lux has been removed. --- project.clj | 4 +- source/lux.lux | 41 ++++++++++++++++----- source/lux/codata/function.lux | 2 +- source/lux/data/char.lux | 4 ++ source/lux/data/list.lux | 6 +++ source/lux/data/text.lux | 13 +++++++ source/lux/host/jvm.lux | 28 +++++++++++--- source/lux/meta/lux.lux | 67 ++++++++++++++++++++++++++++------ source/lux/meta/type.lux | 34 ++++++++++++++--- source/program.lux | 56 ---------------------------- src/lux.clj | 2 +- src/lux/analyser.clj | 83 ++++++++++++++++++++++-------------------- src/lux/base.clj | 2 +- src/lux/type/host.clj | 2 +- 14 files changed, 211 insertions(+), 133 deletions(-) delete mode 100644 source/program.lux diff --git a/project.clj b/project.clj index 9d09c53fc..64b4141c2 100644 --- a/project.clj +++ b/project.clj @@ -1,8 +1,8 @@ (defproject lux-jvm "0.3.0" :description "The JVM compiler for the Lux programming language." :url "https://github.com/LuxLang/lux" - :license {:name "Eclipse Public License" - :url "http://www.eclipse.org/legal/epl-v10.html"} + :license {:name "Mozilla Public License (Version 2.0)" + :url "https://www.mozilla.org/en-US/MPL/2.0/"} :dependencies [[org.clojure/clojure "1.6.0"] [org.clojure/core.match "0.2.1"] [org.ow2.asm/asm-all "5.0.3"] diff --git a/source/lux.lux b/source/lux.lux index ddb3384cc..4d1c3fdef 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -5,7 +5,7 @@ ## First things first, must define functions (_jvm_interface "Function" [] [] - ("apply" ["public" "abstract"] [] [] ["java.lang.Object"] "java.lang.Object")) + ("apply" ["public" "abstract"] [] [] ["java.lang.Object"] "java.lang.Object")) ## Basic types (_lux_def Bool (10 ["lux" "Bool"] @@ -394,6 +394,11 @@ (_lux_export DefData) (_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData) +(_lux_def Definition + (#NamedT ["lux" "Definition"] + (#AppT (#AppT Meta Bool) DefData))) +(_lux_export Definition) + ## Base functions & macros ## (def _cursor ## Cursor @@ -1060,8 +1065,9 @@ ## (-> Compiler (Either Text (, Compiler a)))) (def''' #export Lux Type - (All [a] - (-> Compiler ($' Either Text (, Compiler a))))) + (#NamedT ["lux" "Lux"] + (All [a] + (-> Compiler ($' Either Text (, Compiler a)))))) ## (defsig (Monad m) ## (: (All [a] (-> a (m a))) @@ -1405,6 +1411,15 @@ _ #None)) +(def''' (get-tag x) + (-> AST ($' Maybe Ident)) + (_lux_case x + [_ (#TagS sname)] + (#Some sname) + + _ + #None)) + (def''' (get-name x) (-> AST ($' Maybe Text)) (_lux_case x @@ -1535,7 +1550,7 @@ [$module (get module modules) gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} (_lux_: ($' Module Compiler) $module)] (get name bindings))] - (_lux_case (_lux_: (, Bool DefData) gdef) + (_lux_case (_lux_: Definition gdef) [exported? (#MacroD macro')] (if exported? (#Some macro') @@ -2023,7 +2038,7 @@ (if (symbol? arg) (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) (` (;_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) + (case (~ g!blank) (~ arg) (~ body'))))))) body (reverse tail))] (return (@list (if (symbol? head) @@ -2616,7 +2631,7 @@ #cursor cursor} (case (get module modules) (#Some =module) - (let [to-alias (map (: (-> (, Text (, Bool DefData)) + (let [to-alias (map (: (-> (, Text Definition) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] @@ -3226,7 +3241,7 @@ (return (@list (` ((: (-> (~@ (map type->ast init-types)) (~ (type->ast expected))) (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] - (~ body))) + (~ body))) (~@ inits)))))) (do Lux/Monad [aliases (map% Lux/Monad @@ -3250,8 +3265,8 @@ [slots (: (Lux (, Ident (List Ident))) (case (: (Maybe (, Ident (List Ident))) (do Maybe/Monad - [hslot (get-ident hslot') - tslots (map% Maybe/Monad get-ident tslots')] + [hslot (get-tag hslot') + tslots (map% Maybe/Monad get-tag tslots')] (wrap [hslot tslots]))) (#Some slots) (return slots) @@ -3278,3 +3293,11 @@ _ (fail "Wrong syntax for \\slots"))) + +(do-template [ ] + [(def #export + (-> Int Int) + (i+ ))] + + [inc 1] + [dec -1]) diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux index a23e969b3..1b7336049 100644 --- a/source/lux/codata/function.lux +++ b/source/lux/codata/function.lux @@ -14,7 +14,7 @@ (def #export (flip f) (All [a b c] (-> (-> a b c) (-> b a c))) - (lambda [y x] (f x y))) + (lambda [x y] (f y x))) (def #export (. f g) (All [a b c] diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 4e0d41b22..b7b4c6bda 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -16,3 +16,7 @@ (defstruct #export Char/Show (S;Show Char) (def (show x) ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) + +(def #export (->text c) + (-> Char Text) + (_jvm_invokevirtual "java.lang.Object" "toString" [] c [])) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 563282f32..6bf050228 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -336,3 +336,9 @@ (def #export zip2 (zip 2)) (def #export zip3 (zip 3)) + +(def #export (empty? xs) + (All [a] (-> (List a) Bool)) + (case xs + #;Nil true + _ false)) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 744a22f2e..af2de51ff 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -180,3 +180,16 @@ _ (#;Left "Wrong syntax for <>"))) + +(def #export (split-lines text) + (-> Text (List Text)) + (case (: (Maybe (List Text)) + (do Maybe/Monad + [idx (index-of "\n" text) + [head post] (split (inc idx) text)] + (wrap (#;Cons head (split-lines post))))) + #;None + (#;Cons text #;Nil) + + (#;Some xs) + xs)) diff --git a/source/lux/host/jvm.lux b/source/lux/host/jvm.lux index 573e181b5..737c1731d 100644 --- a/source/lux/host/jvm.lux +++ b/source/lux/host/jvm.lux @@ -93,6 +93,21 @@ arg-classes (map second args)]] (wrap [vars var-types (list:join var-rebinds) arg-classes]))) +(def (class->type class) + (-> JvmType AST) + (case class + "boolean" (' (;^ java.lang.Boolean)) + "byte" (' (;^ java.lang.Byte)) + "short" (' (;^ java.lang.Short)) + "int" (' (;^ java.lang.Integer)) + "long" (' (;^ java.lang.Long)) + "float" (' (;^ java.lang.Float)) + "double" (' (;^ java.lang.Double)) + "char" (' (;^ java.lang.Character)) + "void" (` ;Unit) + _ + (` (^ (~ (symbol$ ["" class])))))) + ## Parsers (def annotation-params^ (Parser (List AnnotationParam)) @@ -227,7 +242,7 @@ (def (gen-expected-output [ex? opt? output] body) (-> ExpectedOutput AST (, AST AST)) - (let [type (` (^ (~ (symbol$ ["" output])))) + (let [type (class->type output) [body type] (if opt? [(` (;;??? (~ body))) (` (Maybe (~ type)))] @@ -321,14 +336,15 @@ (defsyntax #export (null? obj) (emit (@list (` (;_jvm_null? (~ obj)))))) -(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [ex? (tag?^ ["" "!"])]) +(defsyntax #export (new$ [class local-symbol^] [args (tuple^ (*^ exp-input^))] [unsafe? (tag?^ ["" "unsafe"])]) (do Lux/Monad [[vars var-types var-rebinds arg-classes] (prepare-args args) #let [new-expr (` (;_jvm_new (~ (text$ class)) [(~@ (map text$ arg-classes))] [(~@ vars)])) - new-expr (if ex? - (` (try (~ new-expr))) - new-expr)]] - (wrap (@list (` (: (-> (, (~@ var-types)) (^ (~ (symbol$ ["" class])))) + return-type (class->type class) + [new-expr return-type] (if unsafe? + [(` (try (~ new-expr))) (` (Either Text (~ return-type)))] + [new-expr return-type])]] + (wrap (@list (` (: (-> (, (~@ var-types)) (~ return-type)) (lambda [[(~@ vars)]] (let [(~@ var-rebinds)] (~ new-expr))))))))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 650e67133..b6ff09f59 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -9,9 +9,11 @@ (functor #as F) (monad #as M #refer (#only do)) (show #as S)) - (lux/data (list #refer #all #open ("list:" List/Monoid)) + (lux/data (list #refer #all #open ("list:" List/Monoid List/Functor)) (text #as T #open ("text:" Text/Monoid Text/Eq)) - (number/int #as I #open ("i" Int/Number)))) + (number/int #as I #open ("i" Int/Number)) + (tuple #as t) + ident)) ## [Types] ## (deftype (Lux a) @@ -77,7 +79,7 @@ (#;Some $module) (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name)) (#;Some gdef) - (case (: (, Bool DefData) gdef) + (case (: Definition gdef) [exported? (#;MacroD macro')] (if (or exported? (text:= module current-module)) (#;Some macro') @@ -210,7 +212,7 @@ (case (get module (get@ #;modules state)) (#;Some =module) (using List/Monad - (#;Right [state (join (map (: (-> (, Text (, Bool DefData)) + (#;Right [state (join (map (: (-> (, Text Definition) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] @@ -251,7 +253,7 @@ envs))) (def (find-in-defs' name state) - (-> Ident Compiler (Maybe DefData)) + (-> Ident Compiler (Maybe Definition)) (let [[v-prefix v-name] name {#;source source #;modules modules #;envs envs #;type-vars types #;host host @@ -266,17 +268,17 @@ #;None #;None - (#;Some [_ def-data]) - (case def-data - (#;AliasD name') (find-in-defs' name' state) - _ (#;Some def-data) + (#;Some def) + (case def + [_ (#;AliasD name')] (find-in-defs' name' state) + _ (#;Some def) ))) )) (def #export (find-in-defs name state) (-> Ident Compiler (Maybe Type)) (case (find-in-defs' name state) - (#;Some def-data) + (#;Some [_ def-data]) (case def-data (#;ValueD [type value]) (#;Some type) (#;MacroD _) (#;Some Macro) @@ -315,9 +317,50 @@ (case (find-in-defs' name' state) (#;Some def-data) (case def-data - (#;TypeD type) (#;Right [state type]) - _ (#;Left ($ text:++ "Definition is not a type: " (ident->text name)))) + [_ (#;TypeD type)] (#;Right [state type]) + _ (#;Left ($ text:++ "Definition is not a type: " (ident->text name)))) _ (#;Left ($ text:++ "Unknown var: " (ident->text name)))))) )) + +(def #export (defs module-name state) + (-> Text (Lux (List (, Text Definition)))) + (case (get module-name (get@ #;modules state)) + #;None (#;Left ($ text:++ "Unknown module: " module-name)) + (#;Some module) (#;Right [state (get@ #;defs module)]) + )) + +(def #export (exports module-name) + (-> Text (Lux (List (, Text Definition)))) + (do Lux/Monad + [defs (defs module-name)] + (wrap (filter (lambda [[name [exported? data]]] exported?) + defs)))) + +(def #export (modules state) + (Lux (List Text)) + (|> state + (get@ #;modules) + (list:map t;first) + (#;Right state))) + +(def #export (find-module name state) + (-> Text (Lux (Module Compiler))) + (case (get name (get@ #;modules state)) + (#;Some module) + (#;Right state module) + + _ + (#;Left ($ text:++ "Unknown module: " name)))) + +(def #export (tags-for [module name]) + (-> Ident (Lux (Maybe (List Ident)))) + (do Lux/Monad + [module (find-module module)] + (case (get name (get@ #;types module)) + (#;Some [tags _]) + (wrap (#;Some tags)) + + _ + (wrap #;None)))) diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux index a1c34b1ac..0938d104d 100644 --- a/source/lux/meta/type.lux +++ b/source/lux/meta/type.lux @@ -7,14 +7,36 @@ (lux (control show eq monad) - (data (text #open ("text:" Text/Monoid Text/Eq)) - (number/int #open ("int:" Int/Eq Int/Show)) + (data (char #as c) + (text #as t #open ("text:" Text/Monoid Text/Eq)) + (number/int #open ("int:" Int/Number Int/Ord Int/Show)) maybe - (list #refer #all #open ("list:" List/Monad List/Fold))) + (list #refer #all #open ("list:" List/Monad List/Monoid List/Fold))) )) (open List/Fold) +## [Utils] +(def (unravel-fun type) + (-> Type (, Type (List Type))) + (case type + (#;LambdaT in out') + (let [[out ins] (unravel-fun out')] + [out (@list& in ins)]) + + _ + [type (@list)])) + +(def (unravel-app type) + (-> Type (, Type (List Type))) + (case type + (#;AppT left' right) + (let [[left rights] (unravel-app left')] + [left (list:++ rights (@list right))]) + + _ + [type (@list)])) + ## [Structures] (defstruct #export Type/Show (Show Type) (def (show type) @@ -44,7 +66,8 @@ ($ text:++ "(| " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) (#;LambdaT input output) - ($ text:++ "(-> " (show input) " " (show output) ")") + (let [[out ins] (unravel-fun type)] + ($ text:++ "(-> " (|> ins (list:map show) (interpose " ") (foldL text:++ "")) " " (show out) ")")) (#;VarT id) ($ text:++ "⌈" (int:show id) "⌋") @@ -56,7 +79,8 @@ ($ text:++ "⟨" (int:show id) "⟩") (#;AppT fun param) - ($ text:++ "(" (show fun) " " (show param) ")") + (let [[type-fun type-args] (unravel-app type)] + ($ text:++ "(" (show type-fun) " " (|> type-args (list:map show) (interpose " ") (foldL text:++ "")) ")")) (#;UnivQ env body) ($ text:++ "(All " (show body) ")") diff --git a/source/program.lux b/source/program.lux deleted file mode 100644 index f013655bc..000000000 --- a/source/program.lux +++ /dev/null @@ -1,56 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;import lux - (lux (control (monoid #as m) - functor - monad - comonad - bounded - eq - hash - (ord #as O) - (show #as S) - number - enum) - (data bool - char - (either #as e) - id - list - maybe - (number (int #refer (#only) #open ("i:" Int/Show)) - (real #refer (#only))) - (text #refer (#only <>) #open ("text:" Text/Monoid)) - (writer #refer (#only)) - (tuple #refer (#only)) - ) - (codata (stream #as s) - (lazy #refer (#only)) - (function #refer (#only)) - (reader #as r) - (state #refer (#only)) - io) - (host jvm - io) - (meta ast - lux - syntax - type) - math - )) - -(program args - (case args - (\ (@list name)) - (write-line (<> "Hello, #{name}!")) - - _ - (do IO/Monad - [_ (write "Please, tell me your name: ") - name' read-line - #let [name (? "???" name')]] - (write-line (<> "Hello, #{name}!"))) - )) diff --git a/src/lux.clj b/src/lux.clj index 8cd2c4b80..4b1c15ef7 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -24,7 +24,7 @@ _ (println "Can't understand command.")) - ;; (System/exit 0) + (System/exit 0) ) (comment diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 4ead47916..70a4a6ee9 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -211,6 +211,48 @@ (aba8 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Bitwise operators + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-iand analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ior analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-land analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) + + _ + (aba7 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba5_5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) @@ -258,45 +300,8 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) - ;; Bitwise operators - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-land analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) - _ - (aba7 analyse eval! compile-module compile-token exo-type token))) + (aba6 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token @@ -411,7 +416,7 @@ (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) _ - (aba6 analyse eval! compile-module compile-token exo-type token))) + (aba5_5 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token diff --git a/src/lux/base.clj b/src/lux/base.clj index 7357bd483..e9b8896bf 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -376,7 +376,7 @@ init ($Cons x xs*) - (fold f (f init x) xs*))) + (recur f (f init x) xs*))) (defn fold% [f init xs] (|case xs diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index 989c0d665..d4627b273 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -155,7 +155,7 @@ (let [lineage (trace-lineage sub-class+ super-class+)] (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] (return (&/V &/$DataT (&/T (.getName sub-class*) sub-params*))))) - (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class "