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. --- 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 +- 35 files changed, 1342 insertions(+), 973 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 (limited to 'source') 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 -- cgit v1.3.1 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 (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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 (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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(-) (limited to 'source') 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.3.1 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 (limited to 'source') 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 "