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 +++++++++++++++++++++++++++++++------------------------- 1 file changed, 611 insertions(+), 504 deletions(-) (limited to 'source/lux.lux') 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.") -- cgit v1.2.3 From bcf0cb737e348dc9e183b1608abbebc5a40ba847 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 2 Aug 2015 22:38:43 -0400 Subject: - Added a module for hashing. - Refactored the standard library a bit. - Implemented the "loop" macro. - Added the expected type of expressions as a field in the compiler state. - Added syntactic sugar for using tuples with variants, in order to minimize the usage of brackets to delimit the contents of data-structures. - Fixed a bug wherein "macro-expand" was behaving like "macro-expand-all", and added a separate implementation for "macro-expand-all". - Fixed a few bugs. --- source/lux.lux | 561 ++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 340 insertions(+), 221 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index dc186fb3d..3670a9e52 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -32,29 +32,29 @@ (_lux_def Void (#VariantT #Nil)) (_lux_export Void) -(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_def Ident (#TupleT (#Cons Text (#Cons Text #Nil)))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil -## (#Cons (, a (List a))))) +## (#Cons a (List a)))) (_lux_def List - (#AllT [(#Some #Nil) "lux;List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) + (#AllT (#Some #Nil) "lux;List" "a" + (#VariantT (#Cons ["lux;Nil" (#TupleT #Nil)] + (#Cons ["lux;Cons" (#TupleT (#Cons (#BoundT "a") + (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a")) + #Nil)))] + #Nil))))) (_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT [(#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) + (#AllT (#Some #Nil) "lux;Maybe" "a" + (#VariantT (#Cons ["lux;None" (#TupleT #Nil)] + (#Cons ["lux;Some" (#BoundT "a")] + #Nil))))) (_lux_export Maybe) ## (deftype #rec Type @@ -62,29 +62,29 @@ ## (#TupleT (List Type)) ## (#VariantT (List (, Text Type))) ## (#RecordT (List (, Text Type))) -## (#LambdaT (, Type Type)) +## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) -## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) -## (#AppT (, Type Type)))) +## (#AllT (Maybe (List (, Text Type))) Text Text Type) +## (#AppT Type Type))) (_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + (_lux_case (#AppT (#BoundT "Type") (#BoundT "_")) Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil)))) TypeEnv - (#AppT [(#AllT [(#Some #Nil) "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) + (#AppT (#AllT (#Some #Nil) "Type" "_" + (#VariantT (#Cons ["lux;DataT" Text] + (#Cons ["lux;TupleT" (#AppT List Type)] + (#Cons ["lux;VariantT" TypeEnv] + (#Cons ["lux;RecordT" TypeEnv] + (#Cons ["lux;LambdaT" (#TupleT (#Cons Type (#Cons Type #Nil)))] + (#Cons ["lux;BoundT" Text] + (#Cons ["lux;VarT" Int] + (#Cons ["lux;AllT" (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil)))))] + (#Cons ["lux;AppT" (#TupleT (#Cons Type (#Cons Type #Nil)))] + (#Cons ["lux;ExT" Int] + #Nil)))))))))))) + Void)))) (_lux_export Type) ## (deftype (Bindings k v) @@ -125,7 +125,7 @@ (_lux_export Cursor) ## (deftype (Meta m v) -## (| (#Meta (, m v)))) +## (| (#Meta m v))) (_lux_def Meta (#AllT [(#Some #Nil) "lux;Meta" "m" (#AllT [#None "" "v" @@ -141,8 +141,8 @@ ## (#RealS Real) ## (#CharS Char) ## (#TextS Text) -## (#SymbolS (, Text Text)) -## (#TagS (, Text Text)) +## (#SymbolS Text Text) +## (#TagS Text Text) ## (#FormS (List (w (Syntax' w)))) ## (#TupleS (List (w (Syntax' w)))) ## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) @@ -267,7 +267,8 @@ ## #types (Bindings Int Type) ## #host HostState ## #seed Int -## #eval? Bool)) +## #eval? Bool +## #expected Type)) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] @@ -280,7 +281,8 @@ (#Cons [["lux;host" HostState] (#Cons [["lux;seed" Int] (#Cons [["lux;eval?" Bool] - #Nil])])])])])])]))]) + (#Cons [["lux;expected" Type] + #Nil])])])])])])])]))]) Void])) (_lux_export Compiler) @@ -348,6 +350,11 @@ (_lux_lambda _ text (_meta (#TextS text))))) +(_lux_def int$ + (_lux_: (#LambdaT [Int Syntax]) + (_lux_lambda _ value + (_meta (#IntS value))))) + (_lux_def symbol$ (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident @@ -1039,6 +1046,15 @@ (f (g x)))) (def''' (get-ident x) + (-> Syntax ($' Maybe Ident)) + (_lux_case x + (#Meta [_ (#SymbolS sname)]) + (#Some sname) + + _ + #None)) + +(def''' (get-name x) (-> Syntax ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) @@ -1127,7 +1143,7 @@ (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe/Monad get-ident bindings) + [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] (let' [apply (_lux_: (-> RepEnv ($' List Syntax)) @@ -1245,7 +1261,7 @@ ["" tokens]))] (_lux_case tokens' (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-ident args) + (_lux_case (map% Maybe/Monad get-name args) (#Some idents) (_lux_case idents #Nil @@ -1297,8 +1313,8 @@ ($' Lux Text) (_lux_case state {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected} (_lux_case (reverse envs) #Nil (#Left "Can't get the module name without a module!") @@ -1337,7 +1353,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (#Right [state (find-macro' modules current-module module name)])))))) (def''' (list:join xs) @@ -1367,11 +1383,16 @@ [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - + [ident (normalize ident) + #let [case-body (_lux_: Syntax + (_lux_case values + #Nil (`' Unit) + (#Cons value #Nil) value + _ (`' (, (~@ values)))))]] + (;return (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) + _ (fail "Wrong syntax for |")))) tokens)] @@ -1412,9 +1433,9 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def''' (macro-expand syntax) +(def''' (macro-expand token) (-> Syntax ($' Lux ($' List Syntax))) - (_lux_case syntax + (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad [macro-name' (normalize macro-name) @@ -1427,19 +1448,39 @@ (;return (list:join expansion'))) #None + (return (list token)))) + + _ + (return (list token)))) + +(def''' (macro-expand-all syntax) + (-> Syntax ($' Lux ($' List Syntax))) + (_lux_case syntax + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) (do Lux/Monad - [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + [expansion (macro args) + expansion' (map% Lux/Monad macro-expand-all expansion)] + (;return (list:join expansion'))) + + #None + (do Lux/Monad + [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (;return (list (form$ (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (map% Lux/Monad macro-expand targs)] + [harg+ (macro-expand-all harg) + targs+ (map% Lux/Monad macro-expand-all targs)] (;return (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) (do Lux/Monad - [members' (map% Lux/Monad macro-expand members)] + [members' (map% Lux/Monad macro-expand-all members)] (;return (list (tuple$ (list:join members'))))) _ @@ -1464,11 +1505,11 @@ (defmacro #export (type tokens) (_lux_case tokens - (#Cons [type #Nil]) + (#Cons type #Nil) (do Lux/Monad - [type+ (macro-expand type)] + [type+ (macro-expand-all type)] (_lux_case type+ - (#Cons [type' #Nil]) + (#Cons type' #Nil) (;return (list (walk-type type'))) _ @@ -1479,7 +1520,7 @@ (defmacro #export (: tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) + (#Cons type (#Cons value #Nil)) (return (list (`' (_lux_: (;type (~ type)) (~ value))))) _ @@ -1487,7 +1528,7 @@ (defmacro #export (:! tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) + (#Cons type (#Cons value #Nil)) (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) _ @@ -1502,30 +1543,30 @@ (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) [rec? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "rec")) tokens') [true tokens'] _ [false tokens'])) parts (: (Maybe (, Text (List Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) - (#Some [name #Nil type]) + (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) + (#Some name #Nil type) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) - (#Some [name args type]) + (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil)) + (#Some name args type) _ #None))] (_lux_case parts - (#Some [name args type]) + (#Some name args type) (let' [with-export (: (List Syntax) (if export? (list (`' (_lux_export (~ (symbol$ ["" name]))))) @@ -1570,12 +1611,12 @@ ## (#Some [(symbol$ name) #Nil type]) ## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) args type]) +## (#Some (symbol$ name) args type) ## _ ## #None))] ## (_lux_case parts -## (#Some [name args type]) +## (#Some name args type]) ## (let' [with-export (: (List Syntax) ## (if export? ## (list (`' (_lux_export (~ name)))) @@ -1596,7 +1637,7 @@ (defmacro #export (exec tokens) (_lux_case (reverse tokens) - (#Cons [value actions]) + (#Cons value actions) (let' [dummy (symbol$ ["" ""])] (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) value @@ -1608,29 +1649,29 @@ (defmacro (def' tokens) (let' [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) + (#Some name args (#Some type) body) - (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (#Some [name #Nil (#Some type) body]) + (#Cons name (#Cons type (#Cons body #Nil))) + (#Some name #Nil (#Some type) body) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil)) + (#Some name args #None body) - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) + (#Cons name (#Cons body #Nil)) + (#Some name #Nil #None body) _ #None))] (_lux_case parts - (#Some [name args ?type body]) + (#Some name args ?type body) (let' [body' (: Syntax (_lux_case args #Nil @@ -1660,16 +1701,16 @@ (defmacro #export (case tokens) (_lux_case tokens - (#Cons [value branches]) + (#Cons value branches) (do Lux/Monad [expansions (map% Lux/Monad (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) (do Lux/Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + [expansion (macro-expand-all (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] (;return (list:join expansions))) @@ -1684,11 +1725,11 @@ (defmacro #export (\ tokens) (case tokens - (#Cons [body (#Cons [pattern #Nil])]) + (#Cons body (#Cons pattern #Nil)) (do Lux/Monad - [pattern+ (macro-expand pattern)] + [pattern+ (macro-expand-all pattern)] (case pattern+ - (#Cons [pattern' #Nil]) + (#Cons pattern' #Nil) (;return (list pattern' body)) _ @@ -1699,14 +1740,14 @@ (defmacro #export (\or tokens) (case tokens - (#Cons [body patterns]) + (#Cons body patterns) (case patterns #Nil (fail "\\or can't have 0 patterns") _ (do Lux/Monad - [patterns' (map% Lux/Monad macro-expand patterns)] + [patterns' (map% Lux/Monad macro-expand-all patterns)] (;return (list:join (map (lambda' [pattern] (list pattern body)) (list:join patterns')))))) @@ -1726,7 +1767,7 @@ (def' (symbol? ast) (-> Syntax Bool) (case ast - (#Meta [_ (#SymbolS _)]) + (#Meta _ (#SymbolS _)) true _ @@ -1734,7 +1775,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list (#Meta [_ (#TupleS bindings)]) body)) + (\ (list (#Meta _ (#TupleS bindings)) body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> Syntax (, Syntax Syntax) Syntax) @@ -1754,7 +1795,7 @@ (def' (ast:show ast) (-> Syntax Text) (case ast - (#Meta [_ ast]) + (#Meta _ ast) (case ast (\or (#BoolS val) (#IntS val) (#RealS val)) (->text val) @@ -1771,10 +1812,10 @@ (#TupleS parts) ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]") - (#SymbolS [prefix name]) + (#SymbolS prefix name) ($ text:++ prefix ";" name) - (#TagS [prefix name]) + (#TagS prefix name) ($ text:++ "#" prefix ";" name) (#RecordS kvs) @@ -1790,15 +1831,15 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident Syntax (List Syntax) Syntax)) (case tokens - (\ (list (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) - (#Some [["" ""] head tail body]) + (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) + (#Some ["" ""] head tail body) - (\ (list (#Meta [_ (#SymbolS ident)]) (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) - (#Some [ident head tail body]) + (\ (list (#Meta _ (#SymbolS ident)) (#Meta _ (#TupleS (#Cons head tail))) body)) + (#Some ident head tail body) _ #None)) - (#Some [ident head tail body]) + (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) body+ (: Syntax (foldL (: (-> Syntax Syntax Syntax) @@ -1819,29 +1860,29 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (case tokens' - (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) type body)) - (#Some [name args (#Some type) body]) + (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) + (#Some name args (#Some type) body) (\ (list name type body)) - (#Some [name #Nil (#Some type) body]) + (#Some name #Nil (#Some type) body) - (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) body)) - (#Some [name args #None body]) + (\ (list (#Meta _ (#FormS (#Cons name args))) body)) + (#Some name args #None body) (\ (list name body)) - (#Some [name #Nil #None body]) + (#Some name #Nil #None body) _ #None))] (case parts - (#Some [name args ?type body]) + (#Some name args ?type body) (let [body (: Syntax (case args #Nil @@ -1869,22 +1910,11 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [{#source source #modules modules - #envs envs #types types #host host - #seed (i+ 1 seed) #eval? eval?} - (symbol$ ["__gensym__" (->text seed)])]))) - -(def (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (list token')) - (;return token') - - _ - (fail "Macro expanded to more than 1 element.")))) + #seed seed #eval? eval? #expected expected} + (#Right {#source source #modules modules + #envs envs #types types #host host + #seed (i+ 1 seed) #eval? eval? #expected expected} + (symbol$ ["__gensym__" (->text seed)])))) (defmacro #export (sig tokens) (do Lux/Monad @@ -1893,7 +1923,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) (do Lux/Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1911,23 +1941,23 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) - (#Some [name args sigs]) + (\ (list& (#Meta _ (#FormS (list& name args))) sigs)) + (#Some name args sigs) (\ (list& name sigs)) - (#Some [name #Nil sigs]) + (#Some name #Nil sigs) _ #None))] (case ?parts - (#Some [name args sigs]) + (#Some name args sigs) (let [sigs' (: Syntax (case args #Nil @@ -1950,7 +1980,7 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS name)) value)))) (do Lux/Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [(tag$ name') value]))) @@ -1963,23 +1993,23 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) - (#Some [name args type defs]) + (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) + (#Some name args type defs) (\ (list& name type defs)) - (#Some [name #Nil type defs]) + (#Some name #Nil type defs) _ #None))] (case ?parts - (#Some [name args type defs]) + (#Some name args type defs) (let [defs' (: Syntax (case args #Nil @@ -2031,7 +2061,7 @@ (: (-> Syntax (Lux Text)) (lambda [def] (case def - (#Meta [_ (#SymbolS ["" name])]) + (#Meta _ (#SymbolS "" name)) (return name) _ @@ -2041,7 +2071,7 @@ (def (parse-alias tokens) (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) _ @@ -2050,17 +2080,17 @@ (def (parse-referrals tokens) (-> (List Syntax) (Lux (, Referrals (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) + (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) (case referral - (#Meta [_ (#TagS ["" "all"])]) + (#Meta _ (#TagS "" "all")) (return (: (, Referrals (List Syntax)) [#All tokens'])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) @@ -2074,7 +2104,7 @@ (def (extract-symbol syntax) (-> Syntax (Lux Ident)) (case syntax - (#Meta [_ (#SymbolS ident)]) + (#Meta _ (#SymbolS ident)) (return ident) _ @@ -2083,10 +2113,10 @@ (def (parse-openings tokens) (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) + (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] - (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) + (return (: (, (Maybe Openings) (List Syntax)) [(#Some prefix structs') tokens']))) _ (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) @@ -2097,10 +2127,10 @@ (: (-> Syntax (Lux Syntax)) (lambda [token] (case token - (#Meta [_ (#SymbolS ["" sub-name])]) + (#Meta _ (#SymbolS "" sub-name)) (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts)))) (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ @@ -2114,10 +2144,10 @@ (: (-> Syntax (Lux (List Import))) (lambda [token] (case token - (#Meta [_ (#SymbolS ["" m-name])]) + (#Meta _ (#SymbolS "" m-name)) (;return (list [m-name #None #All #None])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2141,13 +2171,13 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (case (get module modules) (#Some =module) - (#Right [state true]) + (#Right state true) #None - (#Right [state false])) + (#Right state false)) )) (def (exported-defs module state) @@ -2155,7 +2185,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (case (get module modules) (#Some =module) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) @@ -2167,7 +2197,7 @@ (list))))) (let [{#module-aliases _ #defs defs #imports _} =module] defs))] - (#Right [state (list:join to-alias)])) + (#Right state (list:join to-alias))) #None (#Left ($ text:++ "Unknown module: " module))) @@ -2195,18 +2225,18 @@ (def (split-module-contexts module) (-> Text (List Text)) - (#Cons [module (let [idx (last-index-of "/" module)] - (if (i< idx 0) - #Nil - (split-module-contexts (substring2 0 idx module))))])) + (#Cons module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module)))))) (def (split-module module) (-> Text (List Text)) (let [idx (index-of "/" module)] (if (i< idx 0) - (#Cons [module #Nil]) - (#Cons [(substring2 0 idx module) - (split-module (substring1 (i+ 1 idx) module))])))) + (#Cons module #Nil) + (#Cons (substring2 0 idx module) + (split-module (substring1 (i+ 1 idx) module)))))) (def (@ idx xs) (All [a] @@ -2215,7 +2245,7 @@ #Nil #None - (#Cons [x xs']) + (#Cons x xs') (if (i= idx 0) (#Some x) (@ (i- idx 1) xs') @@ -2228,7 +2258,7 @@ #Nil [ys xs] - (#Cons [x xs']) + (#Cons x xs') (if (p x) (split-with' p (list& x ys) xs') [ys xs]))) @@ -2267,9 +2297,9 @@ #;Nil (list) - (#;Cons [x xs']) + (#;Cons x xs') (if (p x) - (#;Cons [x (filter p xs')]) + (#;Cons x (filter p xs')) (filter p xs')))) (def (is-member? cases name) @@ -2335,7 +2365,7 @@ #None (list) - (#Some [prefix structs]) + (#Some prefix structs) (map (: (-> Ident Syntax) (lambda [struct] (let [[_ name] struct] @@ -2367,7 +2397,7 @@ #Nil #None - (#Cons [x xs']) + (#Cons x xs') (case (f x) #None (some f xs') @@ -2433,7 +2463,7 @@ (foldL text:++ "")) ")")) - (#LambdaT [input output]) + (#LambdaT input output) ($ text:++ "(-> " (type:show input) " " (type:show output) ")") (#VarT id) @@ -2445,10 +2475,10 @@ (#ExT ?id) ($ text:++ "⟨" (->text ?id) "⟩") - (#AppT [?lambda ?param]) + (#AppT ?lambda ?param) ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - (#AllT [?env ?name ?arg ?body]) + (#AllT ?env ?name ?arg ?body) ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") )) @@ -2472,19 +2502,19 @@ (#TupleT ?members) (#TupleT (map (beta-reduce env) ?members)) - (#AppT [?type-fn ?type-arg]) - (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)]) + (#AppT ?type-fn ?type-arg) + (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - (#AllT [?local-env ?local-name ?local-arg ?local-def]) + (#AllT ?local-env ?local-name ?local-arg ?local-def) (case ?local-env #None - (#AllT [(#Some env) ?local-name ?local-arg ?local-def]) + (#AllT (#Some env) ?local-name ?local-arg ?local-def) (#Some _) type) - (#LambdaT [?input ?output]) - (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)]) + (#LambdaT ?input ?output) + (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) (#BoundT ?name) (case (get ?name env) @@ -2501,7 +2531,7 @@ (def (apply-type type-fn param) (-> Type Type (Maybe Type)) (case type-fn - (#AllT [env name arg body]) + (#AllT env name arg body) (#Some (beta-reduce (|> (case env (#Some env) env _ (list)) @@ -2509,7 +2539,7 @@ (put arg param)) body)) - (#AppT [F A]) + (#AppT F A) (do Maybe/Monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -2523,10 +2553,10 @@ (#RecordT slots) (#Some type) - (#AppT [fun arg]) + (#AppT fun arg) (apply-type fun arg) - (#AllT [_ _ _ body]) + (#AllT _ _ _ body) (resolve-struct-type body) _ @@ -2545,7 +2575,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -2579,7 +2609,7 @@ (let [[v-prefix v-name] name {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} state] + #seed seed #eval? eval? #expected expected} state] (case (get v-prefix modules) #None #None @@ -2589,7 +2619,7 @@ #None #None - (#Some [_ def-data]) + (#Some _ def-data) (case def-data #TypeD (#Some Type) (#ValueD type) (#Some type) @@ -2602,7 +2632,7 @@ ## (let [[v-prefix v-name] name ## {#source source #modules modules ## #envs envs #types types #host host -## #seed seed #eval? eval?} state] +## #seed seed #eval? eval? #expected expected} state] ## (do Maybe/Monad ## [module (get v-prefix modules) ## #let [{#defs defs #module-aliases _ #imports _} module] @@ -2621,24 +2651,32 @@ (lambda [state] (case (find-in-env name state) (#Some struct-type) - (#Right [state struct-type]) + (#Right state struct-type) _ (case (find-in-defs name' state) (#Some struct-type) - (#Right [state struct-type]) + (#Right state struct-type) _ (let [{#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} state] + #seed seed #eval? eval? #expected expected} state] (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) +(def expected-type + (Lux Type) + (lambda [state] + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected} state] + (#Right state expected)))) + (defmacro #export (using tokens) (case tokens (\ (list struct body)) (case struct - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [struct-type (find-var-type name)] (case (resolve-struct-type struct-type) @@ -2687,9 +2725,9 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) record)) + (\ (list (#Meta _ (#TagS slot')) record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name) g!blank (gensym "") @@ -2724,10 +2762,10 @@ (defmacro #export (open tokens) (case tokens - (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens')) + (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) (do Lux/Monad [#let [prefix (case tokens' - (\ (list (#Meta [_ (#TextS prefix)]))) + (\ (list (#Meta _ (#TextS prefix)))) prefix _ @@ -2754,7 +2792,7 @@ (-> (Monad m) (-> a b (m a)) a (List b) (m a))) (case ys - (#Cons [y ys']) + (#Cons y ys') (do M [x' (f x y)] (foldL% M f x' ys')) @@ -2770,10 +2808,10 @@ (: (-> Syntax Syntax (Lux Syntax)) (lambda [so-far part] (case part - (#Meta [_ (#SymbolS slot)]) + (#Meta _ (#SymbolS slot)) (return (` (get@ (~ (tag$ slot)) (~ so-far)))) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args)))) (return (` ((get@ (~ (tag$ slot)) (~ so-far)) (~@ args)))) @@ -2787,9 +2825,9 @@ (defmacro #export (set@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) value record)) + (\ (list (#Meta _ (#TagS slot')) value record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) @@ -2835,9 +2873,9 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) fun record)) + (\ (list (#Meta _ (#TagS slot')) fun record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) @@ -2883,12 +2921,12 @@ (defmacro #export (\template tokens) (case tokens - (\ (list (#Meta [_ (#TupleS data)]) - (#Meta [_ (#TupleS bindings)]) - (#Meta [_ (#TupleS templates)]))) + (\ (list (#Meta _ (#TupleS data)) + (#Meta _ (#TupleS bindings)) + (#Meta _ (#TupleS templates)))) (case (: (Maybe (List Syntax)) (do Maybe/Monad - [bindings' (map% Maybe/Monad get-ident bindings) + [bindings' (map% Maybe/Monad get-name bindings) data' (map% Maybe/Monad tuple->list data)] (let [apply (: (-> RepEnv (List Syntax)) (lambda [env] (map (apply-template env) templates)))] @@ -2904,28 +2942,109 @@ _ (fail "Wrong syntax for \\template"))) -(def #export complement - (All [a] (-> (-> a Bool) (-> a Bool))) - (. not)) - -## (defmacro #export (loop tokens) -## (case tokens -## (\ (list bindings body)) -## (let [pairs (as-pairs bindings) -## vars (map first pairs) -## inits (map second pairs)] -## (if (every? symbol? inits) -## (do Lux/Monad -## [inits' (map% Maybe/Monad get-ident inits) -## init-types (map% Maybe/Monad find-var-type inits')] -## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] -## (~ body)) -## (~@ inits)))))) -## (do Lux/Monad -## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] -## (return (list (` (let [(~@ (interleave aliases inits))] -## (loop [(~@ (interleave vars aliases))] -## (~ body))))))))) - -## _ -## (fail "Wrong syntax for loop"))) +(do-template [ ] + [(def ( [x y]) + (All [a b] (-> (, a b) )) + )] + + [first a x] + [second b y]) + +(def (interleave xs ys) + (All [a] (-> (List a) (List a) (List a))) + (case xs + #Nil + #Nil + + (#Cons x xs') + (case ys + #Nil + #Nil + + (#Cons y ys') + (list& x y (interleave xs' ys'))))) + +(do-template [ ] + [(def ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] ( _1 (p _2))) xs))] + + [every? true and]) + +(def (type->syntax type) + (-> Type Syntax) + (case type + (#DataT name) + (` (#DataT (~ (text$ name)))) + + (#TupleT parts) + (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) + + (#VariantT cases) + (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + cases))))) + + (#RecordT fields) + (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + fields))))) + + (#LambdaT in out) + (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) + + (#BoundT name) + (` (#BoundT (~ (text$ name)))) + + (#VarT id) + (` (#VarT (~ (int$ id)))) + + (#ExT id) + (` (#ExT (~ (int$ id)))) + + (#AllT env name arg type) + (let [env' (: Syntax + (case env + #None (` #None) + (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + _env)))))))] + (` (#AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) + + (#AppT fun arg) + (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))))) + +(defmacro #export (loop tokens) + (case tokens + (\ (list (#Meta _ (#TupleS bindings)) body)) + (let [pairs (as-pairs bindings) + vars (map first pairs) + inits (map second pairs)] + (if (every? symbol? inits) + (do Lux/Monad + [inits' (: (Lux (List Ident)) + (case (map% Maybe/Monad get-ident inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init-types (map% Lux/Monad find-var-type inits') + expected expected-type] + (return (list (` ((: (-> (~@ (map type->syntax init-types)) + (~ (type->syntax expected))) + (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] + (~ body))) + (~@ inits)))))) + (do Lux/Monad + [aliases (map% Lux/Monad + (: (-> Syntax (Lux Syntax)) + (lambda [_] (gensym ""))) + inits)] + (return (list (` (let [(~@ (interleave aliases inits))] + (loop [(~@ (interleave vars aliases))] + (~ body))))))))) + + _ + (fail "Wrong syntax for loop"))) -- cgit v1.2.3 From ddc471806fba8fe179d52b4781f0a66d871b5e99 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 3 Aug 2015 19:54:53 -0400 Subject: - Type definitions inside the compiler data now hold the type itself. - Value definitions inside the compiler data now hold the value itself. - Fixed a few bugs. --- source/lux.lux | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) (limited to 'source/lux.lux') 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"))) -- cgit v1.2.3 From 8a78830404234dc6e766ed6b653905bd7c89fac2 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Aug 2015 00:22:28 -0400 Subject: - Added a macro for exporting definitions (to not depend on the #export tag on definitions). - The "open" and "using" macros now work recursively on records. --- source/lux.lux | 54 +++++++++++++++++++++++++++++++++++------------------- 1 file changed, 35 insertions(+), 19 deletions(-) (limited to 'source/lux.lux') 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))) -- cgit v1.2.3 From a8ac885a008f519816d747eca0f894ec9794e938 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Aug 2015 19:40:58 -0400 Subject: - Renamed the Syntax type to AST. - Created the lux/meta/ast module. --- source/lux.lux | 316 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 158 insertions(+), 158 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index 798742e6f..deb6025ad 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -135,7 +135,7 @@ #Nil]))])])) (_lux_export Meta) -## (deftype (Syntax' w) +## (deftype (AST' w) ## (| (#BoolS Bool) ## (#IntS Int) ## (#RealS Real) @@ -143,17 +143,17 @@ ## (#TextS Text) ## (#SymbolS Text Text) ## (#TagS Text Text) -## (#FormS (List (w (Syntax' w)))) -## (#TupleS (List (w (Syntax' w)))) -## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) -(_lux_def Syntax' +## (#FormS (List (w (AST' w)))) +## (#TupleS (List (w (AST' w)))) +## (#RecordS (List (, (w (AST' w)) (w (AST' w))))))) +(_lux_def AST' (_lux_case (#AppT [(#BoundT "w") - (#AppT [(#BoundT "lux;Syntax'") + (#AppT [(#BoundT "lux;AST'") (#BoundT "w")])]) - Syntax - (_lux_case (#AppT [List Syntax]) - SyntaxList - (#AllT [(#Some #Nil) "lux;Syntax'" "w" + AST + (_lux_case (#AppT [List AST]) + ASTList + (#AllT [(#Some #Nil) "lux;AST'" "w" (#VariantT (#Cons [["lux;BoolS" Bool] (#Cons [["lux;IntS" Int] (#Cons [["lux;RealS" Real] @@ -161,23 +161,23 @@ (#Cons [["lux;TextS" Text] (#Cons [["lux;SymbolS" Ident] (#Cons [["lux;TagS" Ident] - (#Cons [["lux;FormS" SyntaxList] - (#Cons [["lux;TupleS" SyntaxList] - (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + (#Cons [["lux;FormS" ASTList] + (#Cons [["lux;TupleS" ASTList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))])] #Nil]) ])])])])])])])])]) )])))) -(_lux_export Syntax') +(_lux_export AST') -## (deftype Syntax -## (Meta Cursor (Syntax' (Meta Cursor)))) -(_lux_def Syntax +## (deftype AST +## (Meta Cursor (AST' (Meta Cursor)))) +(_lux_def AST (_lux_case (#AppT [Meta Cursor]) w - (#AppT [w (#AppT [Syntax' w])]))) -(_lux_export Syntax) + (#AppT [w (#AppT [AST' w])]))) +(_lux_export AST) -(_lux_def SyntaxList (#AppT [List Syntax])) +(_lux_def ASTList (#AppT [List AST])) ## (deftype (Either l r) ## (| (#Left l) @@ -246,16 +246,16 @@ ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) -## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) ## #imports (List Text) ## )) (_lux_def Module (#AllT [(#Some #Nil) "lux;Module" "Compiler" (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - SyntaxList])])]) + ASTList])])]) #Nil])])) #Nil])]))])] (#Cons [["lux;imports" (#AppT [List Text])] @@ -289,11 +289,11 @@ (_lux_export Compiler) ## (deftype Macro -## (-> (List Syntax) (StateE Compiler (List Syntax)))) +## (-> (List AST) (StateE Compiler (List AST)))) (_lux_def Macro - (#LambdaT [SyntaxList + (#LambdaT [ASTList (#AppT [(#AppT [StateE Compiler]) - SyntaxList])])) + ASTList])])) (_lux_export Macro) ## Base functions & macros @@ -304,12 +304,12 @@ (_lux_: Cursor ["" -1 -1])) ## (def (_meta data) -## (-> (Syntax' (Meta Cursor)) Syntax) +## (-> (AST' (Meta Cursor)) AST) ## (#Meta [["" -1 -1] data])) (_lux_def _meta - (_lux_: (#LambdaT [(#AppT [Syntax' + (_lux_: (#LambdaT [(#AppT [AST' (#AppT [Meta Cursor])]) - Syntax]) + AST]) (_lux_lambda _ data (#Meta [_cursor data])))) @@ -348,37 +348,37 @@ (#Left msg))))) (_lux_def text$ - (_lux_: (#LambdaT [Text Syntax]) + (_lux_: (#LambdaT [Text AST]) (_lux_lambda _ text (_meta (#TextS text))))) (_lux_def int$ - (_lux_: (#LambdaT [Int Syntax]) + (_lux_: (#LambdaT [Int AST]) (_lux_lambda _ value (_meta (#IntS value))))) (_lux_def symbol$ - (_lux_: (#LambdaT [Ident Syntax]) + (_lux_: (#LambdaT [Ident AST]) (_lux_lambda _ ident (_meta (#SymbolS ident))))) (_lux_def tag$ - (_lux_: (#LambdaT [Ident Syntax]) + (_lux_: (#LambdaT [Ident AST]) (_lux_lambda _ ident (_meta (#TagS ident))))) (_lux_def form$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_: (#LambdaT [(#AppT [List AST]) AST]) (_lux_lambda _ tokens (_meta (#FormS tokens))))) (_lux_def tuple$ - (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_: (#LambdaT [(#AppT [List AST]) AST]) (_lux_lambda _ tokens (_meta (#TupleS tokens))))) (_lux_def record$ - (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [AST (#Cons [AST #Nil])]))]) AST]) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) @@ -638,7 +638,7 @@ (fail "Wrong syntax for list&"))) (defmacro (lambda' tokens) - (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) (_lux_case tokens (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) [name tokens'] @@ -722,8 +722,8 @@ (defmacro (let' tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) - (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) - Syntax) + (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) + AST) (lambda' [body binding] (_lux_case binding [label value] @@ -757,7 +757,7 @@ false (any? p xs')))) (def''' (spliced? token) - (->' Syntax Bool) + (->' AST Bool) (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) true @@ -766,13 +766,13 @@ false)) (def''' (wrap-meta content) - (->' Syntax Syntax) + (->' AST AST) (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) content))))))) (def''' (untemplate-list tokens) - (->' ($' List Syntax) Syntax) + (->' ($' List AST) AST) (_lux_case tokens #Nil (_meta (#TagS ["lux" "Nil"])) @@ -801,7 +801,7 @@ (fail "Wrong syntax for $"))) (def''' (splice replace? untemplate tag elems) - (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) + (->' Bool (->' AST AST) AST ($' List AST) AST) (_lux_case replace? true (_lux_case (any? spliced? elems) @@ -813,7 +813,7 @@ _ (form$ (list (symbol$ ["" "_lux_:"]) - (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "AST"]))))) (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) (tag$ ["lux" "Nil"]))))))))) elems)] @@ -828,8 +828,8 @@ (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) (def''' (untemplate replace? subst token) - (->' Bool Text Syntax Syntax) - (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) + (->' Bool Text AST AST) + (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) [_ (#Meta [_ (#BoolS value)])] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) @@ -875,7 +875,7 @@ [_ (#Meta [_ (#RecordS fields)])] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) - (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) + (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) (lambda' [kv] (let' [[k v] kv] (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) @@ -1000,7 +1000,7 @@ (defmacro (do tokens) (_lux_case tokens (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) - (let' [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var @@ -1048,7 +1048,7 @@ (f (g x)))) (def''' (get-ident x) - (-> Syntax ($' Maybe Ident)) + (-> AST ($' Maybe Ident)) (_lux_case x (#Meta [_ (#SymbolS sname)]) (#Some sname) @@ -1057,7 +1057,7 @@ #None)) (def''' (get-name x) - (-> Syntax ($' Maybe Text)) + (-> AST ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) (#Some sname) @@ -1066,7 +1066,7 @@ #None)) (def''' (tuple->list tuple) - (-> Syntax ($' Maybe ($' List Syntax))) + (-> AST ($' Maybe ($' List AST))) (_lux_case tuple (#Meta [_ (#TupleS members)]) (#Some members) @@ -1076,11 +1076,11 @@ (def''' RepEnv Type - ($' List (, Text Syntax))) + ($' List (, Text AST))) (def''' (make-env xs ys) - (-> ($' List Text) ($' List Syntax) RepEnv) - (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + (-> ($' List Text) ($' List AST) RepEnv) + (_lux_case (_lux_: (, ($' List Text) ($' List AST)) [xs ys]) [(#Cons [x xs']) (#Cons [y ys'])] (#Cons [[x y] (make-env xs' ys')]) @@ -1094,7 +1094,7 @@ x [y])) (def''' (get-rep key env) - (-> Text RepEnv ($' Maybe Syntax)) + (-> Text RepEnv ($' Maybe AST)) (_lux_case env #Nil #None @@ -1105,7 +1105,7 @@ (get-rep key env')))) (def''' (apply-template env template) - (-> RepEnv Syntax Syntax) + (-> RepEnv AST AST) (_lux_case template (#Meta [_ (#SymbolS ["" sname])]) (_lux_case (get-rep sname env) @@ -1122,7 +1122,7 @@ (form$ (map (apply-template env) elems)) (#Meta [_ (#RecordS members)]) - (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] [(apply-template env slot) (apply-template env value)]))) @@ -1144,11 +1144,11 @@ (defmacro #export (do-template tokens) (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) - (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] - (let' [apply (_lux_: (-> RepEnv ($' List Syntax)) + (let' [apply (_lux_: (-> RepEnv ($' List AST)) (lambda' [env] (map (apply-template env) templates)))] (|> data' (join-map (. apply (make-env bindings'))) @@ -1226,7 +1226,7 @@ ($ text:++ module ";" name))) (def''' (replace-syntax reps syntax) - (-> RepEnv Syntax Syntax) + (-> RepEnv AST AST) (_lux_case syntax (#Meta [_ (#SymbolS ["" name])]) (_lux_case (get-rep name reps) @@ -1243,7 +1243,7 @@ (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) (#Meta [_ (#RecordS slots)]) - (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (#Meta [_ (#RecordS (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [slot] (let' [[k v] slot] [(replace-syntax reps k) (replace-syntax reps v)]))) @@ -1254,7 +1254,7 @@ ) (defmacro #export (All tokens) - (let' [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (let' [[self-ident tokens'] (_lux_: (, Text ASTList) (_lux_case tokens (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) [self-ident tokens'] @@ -1270,7 +1270,7 @@ (return (list body)) (#Cons [harg targs]) - (let' [replacements (map (_lux_: (-> Text (, Text Syntax)) + (let' [replacements (map (_lux_: (-> Text (, Text AST)) (lambda' [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) (list& self-ident idents)) body' (foldL (lambda' [body' arg'] @@ -1377,7 +1377,7 @@ (defmacro #export (| tokens) (do Lux/Monad [pairs (map% Lux/Monad - (_lux_: (-> Syntax ($' Lux Syntax)) + (_lux_: (-> AST ($' Lux AST)) (lambda' [token] (_lux_case token (#Meta [_ (#TagS ident)]) @@ -1388,7 +1388,7 @@ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) (do Lux/Monad [ident (normalize ident) - #let [case-body (_lux_: Syntax + #let [case-body (_lux_: AST (_lux_case values #Nil (`' Unit) (#Cons value #Nil) value @@ -1405,7 +1405,7 @@ (fail "& expects an even number of arguments.") (do Lux/Monad [pairs (map% Lux/Monad - (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) + (_lux_: (-> (, AST AST) ($' Lux AST)) (lambda' [pair] (_lux_case pair [(#Meta [_ (#TagS ident)]) value] @@ -1436,7 +1436,7 @@ (list& x sep (interpose sep xs')))) (def''' (macro-expand token) - (-> Syntax ($' Lux ($' List Syntax))) + (-> AST ($' Lux ($' List AST))) (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad @@ -1456,7 +1456,7 @@ (return (list token)))) (def''' (macro-expand-all syntax) - (-> Syntax ($' Lux ($' List Syntax))) + (-> AST ($' Lux ($' List AST))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad @@ -1489,7 +1489,7 @@ (return (list syntax)))) (def''' (walk-type type) - (-> Syntax Syntax) + (-> AST AST) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) (form$ (#Cons [(tag$ tag) (map walk-type parts)])) @@ -1543,21 +1543,21 @@ _ false)) (defmacro #export (deftype tokens) - (let' [[export? tokens'] (: (, Bool (List Syntax)) + (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) - [rec? tokens'] (: (, Bool (List Syntax)) + [rec? tokens'] (: (, Bool (List AST)) (_lux_case tokens' (#Cons (#Meta _ (#TagS "" "rec")) tokens') [true tokens'] _ [false tokens'])) - parts (: (Maybe (, Text (List Syntax) Syntax)) + parts (: (Maybe (, Text (List AST) AST)) (_lux_case tokens' (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) (#Some name #Nil type) @@ -1569,11 +1569,11 @@ #None))] (_lux_case parts (#Some name args type) - (let' [with-export (: (List Syntax) + (let' [with-export (: (List AST) (if export? (list (`' (_lux_export (~ (symbol$ ["" name]))))) #Nil)) - type' (: (Maybe Syntax) + type' (: (Maybe AST) (if rec? (if (empty? args) (let' [g!param (symbol$ ["" ""]) @@ -1600,14 +1600,14 @@ (fail "Wrong syntax for deftype")) )) ## (defmacro #export (deftype tokens) -## (let' [[export? tokens'] (: (, Bool (List Syntax)) -## (_lux_case (:! (List Syntax) tokens) +## (let' [[export? tokens'] (: (, Bool (List AST)) +## (_lux_case (:! (List AST) tokens) ## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) -## [true (:! (List Syntax) tokens')] +## [true (:! (List AST) tokens')] ## _ -## [false (:! (List Syntax) tokens)])) -## parts (: (Maybe (, Syntax (List Syntax) Syntax)) +## [false (:! (List AST) tokens)])) +## parts (: (Maybe (, AST (List AST) AST)) ## (_lux_case tokens' ## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) ## (#Some [(symbol$ name) #Nil type]) @@ -1619,11 +1619,11 @@ ## #None))] ## (_lux_case parts ## (#Some name args type]) -## (let' [with-export (: (List Syntax) +## (let' [with-export (: (List AST) ## (if export? ## (list (`' (_lux_export (~ name)))) ## #Nil)) -## type' (: Syntax +## type' (: AST ## (_lux_case args ## #Nil ## type @@ -1649,14 +1649,14 @@ (fail "Wrong syntax for exec"))) (defmacro (def' tokens) - (let' [[export? tokens'] (: (, Bool (List Syntax)) + (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (_lux_case tokens' (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) (#Some name args (#Some type) body) @@ -1674,14 +1674,14 @@ #None))] (_lux_case parts (#Some name args ?type body) - (let' [body' (: Syntax + (let' [body' (: AST (_lux_case args #Nil body _ (`' (;lambda' (~ name) [(~@ args)] (~ body))))) - body'' (: Syntax + body'' (: AST (_lux_case ?type (#Some type) (`' (: (~ type) (~ body'))) @@ -1697,7 +1697,7 @@ (fail "Wrong syntax for def'")))) (def' (rejoin-pair pair) - (-> (, Syntax Syntax) (List Syntax)) + (-> (, AST AST) (List AST)) (let' [[left right] pair] (list left right))) @@ -1706,7 +1706,7 @@ (#Cons value branches) (do Lux/Monad [expansions (map% Lux/Monad - (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (: (-> (, AST AST) (Lux (List (, AST AST)))) (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern @@ -1767,7 +1767,7 @@ (fail "Wrong syntax for `")))) (def' (symbol? ast) - (-> Syntax Bool) + (-> AST Bool) (case ast (#Meta _ (#SymbolS _)) true @@ -1780,7 +1780,7 @@ (\ (list (#Meta _ (#TupleS bindings)) body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse - (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (foldL (: (-> AST (, AST AST) AST) (lambda' [body' lr] (let' [[l r] lr] (if (symbol? l) @@ -1795,7 +1795,7 @@ (fail "Wrong syntax for let"))) (def' (ast:show ast) - (-> Syntax Text) + (-> AST Text) (case ast (#Meta _ ast) (case ast @@ -1823,7 +1823,7 @@ (#RecordS kvs) ($ text:++ "{" (|> kvs - (map (: (-> (, Syntax Syntax) Text) + (map (: (-> (, AST AST) Text) (lambda' [kv] (let [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v)))))) (interpose " ") (foldL text:++ "")) @@ -1831,7 +1831,7 @@ ))) (defmacro #export (lambda tokens) - (case (: (Maybe (, Ident Syntax (List Syntax) Syntax)) + (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) (#Some ["" ""] head tail body) @@ -1844,7 +1844,7 @@ (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) - body+ (: Syntax (foldL (: (-> Syntax Syntax Syntax) + body+ (: AST (foldL (: (-> AST AST AST) (lambda' [body' arg] (if (symbol? arg) (` (_lux_lambda (~ g!blank) (~ arg) (~ body'))) @@ -1860,14 +1860,14 @@ (fail "Wrong syntax for lambda"))) (defmacro #export (def tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) + (let [[export? tokens'] (: (, Bool (List AST)) (case tokens (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) - parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) (#Some name args (#Some type) body) @@ -1885,14 +1885,14 @@ #None))] (case parts (#Some name args ?type body) - (let [body (: Syntax + (let [body (: AST (case args #Nil body _ (` (;lambda (~ name) [(~@ args)] (~ body))))) - body (: Syntax + body (: AST (case ?type (#Some type) (` (: (~ type) (~ body))) @@ -1908,7 +1908,7 @@ (fail "Wrong syntax for def")))) (def (gensym prefix state) - (-> Text (Lux Syntax)) + (-> Text (Lux AST)) (case state {#source source #modules modules #envs envs #types types #host host @@ -1922,18 +1922,18 @@ (do Lux/Monad [tokens' (map% Lux/Monad macro-expand tokens) members (map% Lux/Monad - (: (-> Syntax (Lux (, Ident Syntax))) + (: (-> AST (Lux (, Ident AST))) (lambda [token] (case token (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) (do Lux/Monad [name' (normalize name)] - (;return (: (, Ident Syntax) [name' type]))) + (;return (: (, Ident AST) [name' type]))) _ (fail "Signatures require typed members!")))) (list:join tokens'))] - (;return (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) + (;return (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident AST) AST) (lambda [pair] (let [[name type] pair] (` [(~ (|> name ident->text text$)) @@ -1941,14 +1941,14 @@ members))))))))) (defmacro #export (defsig tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) + (let [[export? tokens'] (: (, Bool (List AST)) (case tokens (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) + ?parts (: (Maybe (, AST (List AST) (List AST))) (case tokens' (\ (list& (#Meta _ (#FormS (list& name args))) sigs)) (#Some name args sigs) @@ -1960,7 +1960,7 @@ #None))] (case ?parts (#Some name args sigs) - (let [sigs' (: Syntax + (let [sigs' (: AST (case args #Nil (` (;sig (~@ sigs))) @@ -1979,13 +1979,13 @@ (do Lux/Monad [tokens' (map% Lux/Monad macro-expand tokens) members (map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) + (: (-> AST (Lux (, AST AST))) (lambda [token] (case token (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS name)) value)))) (do Lux/Monad [name' (normalize name)] - (;return (: (, Syntax Syntax) [(tag$ name') value]))) + (;return (: (, AST AST) [(tag$ name') value]))) _ (fail "Structures require defined members")))) @@ -1993,14 +1993,14 @@ (;return (list (record$ members))))) (defmacro #export (defstruct tokens) - (let [[export? tokens'] (: (, Bool (List Syntax)) + (let [[export? tokens'] (: (, Bool (List AST)) (case tokens (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) - ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) + ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) (#Some name args type defs) @@ -2012,7 +2012,7 @@ #None))] (case ?parts (#Some name args type defs) - (let [defs' (: Syntax + (let [defs' (: AST (case args #Nil (` (;struct (~@ defs))) @@ -2058,9 +2058,9 @@ (, Text (Maybe Text) Referrals (Maybe Openings))) (def (extract-defs defs) - (-> (List Syntax) (Lux (List Text))) + (-> (List AST) (Lux (List Text))) (map% Lux/Monad - (: (-> Syntax (Lux Text)) + (: (-> AST (Lux Text)) (lambda [def] (case def (#Meta _ (#SymbolS "" name)) @@ -2071,40 +2071,40 @@ defs)) (def (parse-alias tokens) - (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) + (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) - (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) + (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) _ - (return (: (, (Maybe Text) (List Syntax)) [#None tokens])))) + (return (: (, (Maybe Text) (List AST)) [#None tokens])))) (def (parse-referrals tokens) - (-> (List Syntax) (Lux (, Referrals (List Syntax)))) + (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) (case referral (#Meta _ (#TagS "" "all")) - (return (: (, Referrals (List Syntax)) [#All tokens'])) + (return (: (, Referrals (List AST)) [#All tokens'])) (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) + (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] - (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) + (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) _ (fail "Incorrect syntax for referral.")) _ - (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) + (return (: (, Referrals (List AST)) [#Nothing tokens])))) (def (extract-symbol syntax) - (-> Syntax (Lux Ident)) + (-> AST (Lux Ident)) (case syntax (#Meta _ (#SymbolS ident)) (return ident) @@ -2113,20 +2113,20 @@ (fail "Not a symbol."))) (def (parse-openings tokens) - (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) + (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] - (return (: (, (Maybe Openings) (List Syntax)) [(#Some prefix structs') tokens']))) + (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) _ - (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) + (return (: (, (Maybe Openings) (List AST)) [#None tokens])))) (def (decorate-imports super-name tokens) - (-> Text (List Syntax) (Lux (List Syntax))) + (-> Text (List AST) (Lux (List AST))) (map% Lux/Monad - (: (-> Syntax (Lux Syntax)) + (: (-> AST (Lux AST)) (lambda [token] (case token (#Meta _ (#SymbolS "" sub-name)) @@ -2140,10 +2140,10 @@ tokens)) (def (parse-imports imports) - (-> (List Syntax) (Lux (List Import))) + (-> (List AST) (Lux (List Import))) (do Lux/Monad [imports' (map% Lux/Monad - (: (-> Syntax (Lux (List Import))) + (: (-> AST (Lux (List Import))) (lambda [token] (case token (#Meta _ (#SymbolS "" m-name)) @@ -2190,7 +2190,7 @@ #seed seed #eval? eval? #expected expected} (case (get module modules) (#Some =module) - (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) + (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST)))))) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] @@ -2341,7 +2341,7 @@ #Nil (do Lux/Monad [output' (map% Lux/Monad - (: (-> Import (Lux (List Syntax))) + (: (-> Import (Lux (List AST))) (lambda [import] (case import [m-name m-alias m-referrals m-openings] @@ -2362,13 +2362,13 @@ #Nothing (;return (list))) - #let [openings (: (List Syntax) + #let [openings (: (List AST) (case m-openings #None (list) (#Some prefix structs) - (map (: (-> Ident Syntax) + (map (: (-> Ident AST) (lambda [struct] (let [[_ name] struct] (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) @@ -2378,7 +2378,7 @@ (case m-alias #None (list) (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) - (map (: (-> Text Syntax) + (map (: (-> Text AST) (lambda [def] (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) defs) @@ -2387,7 +2387,7 @@ (;return (list:join output'))) _ - (;return (: (List Syntax) + (;return (: (List AST) (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) unknowns) (list (` (import (~@ tokens)))))))))) @@ -2675,12 +2675,12 @@ (#Right state expected)))) (def (use-field field-name type) - (-> Text Type (, Syntax Syntax)) + (-> Text Type (, AST AST)) (let [[module name] (split-slot field-name) - pattern (: Syntax + pattern (: AST (case (resolve-struct-type type) (#Some (#RecordT slots)) - (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (record$ (map (: (-> (, Text Type) (, AST AST)) (lambda [[sname stype]] (use-field sname stype))) slots)) @@ -2697,7 +2697,7 @@ [struct-type (find-var-type name)] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) - (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (let [pattern (record$ (map (: (-> (, Text Type) (, AST AST)) (lambda [[sname stype]] (use-field sname stype))) slots))] (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) @@ -2726,7 +2726,7 @@ (fail "cond requires an even number of arguments.") (case (reverse tokens) (\ (list& else branches')) - (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (return (list (foldL (: (-> AST (, AST AST) AST) (lambda [else branch] (let [[right left] branch] (` (if (~ left) (~ right) (~ else)))))) @@ -2750,7 +2750,7 @@ (do Lux/Monad [slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + pattern (record$ (map (: (-> (, Text Type) (, AST AST)) (lambda [slot] (let [[r-slot-name r-type] slot [r-prefix r-name] (split-slot r-slot-name)] @@ -2774,12 +2774,12 @@ (fail "Wrong syntax for get@"))) (def (open-field prefix field-name source type) - (-> Text Text Syntax Type (List Syntax)) + (-> Text Text AST Type (List AST)) (let [[module name] (split-slot field-name) - source+ (: Syntax (` (get@ (~ (tag$ [module name])) (~ source))))] + source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))] (case (resolve-struct-type type) (#Some (#RecordT slots)) - (list:join (map (: (-> (, Text Type) (List Syntax)) + (list:join (map (: (-> (, Text Type) (List AST)) (lambda [[sname stype]] (open-field prefix sname source+ stype))) slots)) @@ -2800,7 +2800,7 @@ #let [source (symbol$ struct-name)]] (case (resolve-struct-type struct-type) (#Some (#RecordT slots)) - (return (list:join (map (: (-> (, Text Type) (List Syntax)) + (return (list:join (map (: (-> (, Text Type) (List AST)) (lambda [[sname stype]] (open-field prefix sname source stype))) slots))) @@ -2828,7 +2828,7 @@ (\ (list& start parts)) (do Lux/Monad [output (foldL% Lux/Monad - (: (-> Syntax Syntax (Lux Syntax)) + (: (-> AST AST (Lux AST)) (lambda [so-far part] (case part (#Meta _ (#SymbolS slot)) @@ -2857,7 +2857,7 @@ (#Some (#RecordT slots)) (do Lux/Monad [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) + (: (-> (, Text Type) (Lux (, Text AST))) (lambda [slot] (let [[r-slot-name r-type] slot] (do Lux/Monad @@ -2866,12 +2866,12 @@ slots) slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + pattern (record$ (map (: (-> (, Text AST) (, AST AST)) (lambda [slot] (let [[r-slot-name r-var] slot] [(tag$ (split-slot r-slot-name)) r-var]))) pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + output (record$ (map (: (-> (, Text AST) (, AST AST)) (lambda [slot] (let [[r-slot-name r-var] slot [r-prefix r-name] (split-slot r-slot-name)] @@ -2905,7 +2905,7 @@ (#Some (#RecordT slots)) (do Lux/Monad [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text Syntax))) + (: (-> (, Text Type) (Lux (, Text AST))) (lambda [slot] (let [[r-slot-name r-type] slot] (do Lux/Monad @@ -2914,12 +2914,12 @@ slots) slot (normalize slot')] (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + pattern (record$ (map (: (-> (, Text AST) (, AST AST)) (lambda [slot] (let [[r-slot-name r-var] slot] [(tag$ (split-slot r-slot-name)) r-var]))) pattern')) - output (record$ (map (: (-> (, Text Syntax) (, Syntax Syntax)) + output (record$ (map (: (-> (, Text AST) (, AST AST)) (lambda [slot] (let [[r-slot-name r-var] slot [r-prefix r-name] (split-slot r-slot-name)] @@ -2947,11 +2947,11 @@ (\ (list (#Meta _ (#TupleS data)) (#Meta _ (#TupleS bindings)) (#Meta _ (#TupleS templates)))) - (case (: (Maybe (List Syntax)) + (case (: (Maybe (List AST)) (do Maybe/Monad [bindings' (map% Maybe/Monad get-name bindings) data' (map% Maybe/Monad tuple->list data)] - (let [apply (: (-> RepEnv (List Syntax)) + (let [apply (: (-> RepEnv (List AST)) (lambda [env] (map (apply-template env) templates)))] (|> data' (join-map (. apply (make-env bindings'))) @@ -2996,7 +2996,7 @@ [every? true and]) (def (type->syntax type) - (-> Type Syntax) + (-> Type AST) (case type (#DataT name) (` (#DataT (~ (text$ name)))) @@ -3005,13 +3005,13 @@ (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) (#VariantT cases) - (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) AST) (lambda [[label type]] (tuple$ (list (text$ label) (type->syntax type))))) cases))))) (#RecordT fields) - (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) AST) (lambda [[label type]] (tuple$ (list (text$ label) (type->syntax type))))) fields))))) @@ -3029,10 +3029,10 @@ (` (#ExT (~ (int$ id)))) (#AllT env name arg type) - (let [env' (: Syntax + (let [env' (: AST (case env #None (` #None) - (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) AST) (lambda [[label type]] (tuple$ (list (text$ label) (type->syntax type))))) _env)))))))] @@ -3062,7 +3062,7 @@ (~@ inits)))))) (do Lux/Monad [aliases (map% Lux/Monad - (: (-> Syntax (Lux Syntax)) + (: (-> AST (Lux AST)) (lambda [_] (gensym ""))) inits)] (return (list (` (let [(~@ (interleave aliases inits))] -- cgit v1.2.3 From 691b3e3174e01ed7d859f58442371328aefcfad4 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Aug 2015 20:38:02 -0400 Subject: - Struct definition no longer required prefixed members (now, it actually prohibits them). --- source/lux.lux | 469 +++++++++++++++++++++++++++++---------------------------- 1 file changed, 242 insertions(+), 227 deletions(-) (limited to 'source/lux.lux') 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) -- cgit v1.2.3 From f855c20a7af7428b638e4c2a3c4c654bd01576dc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Aug 2015 00:05:04 -0400 Subject: - The compiler now stores the cursor of the last analysed AST in order to avoid the problem of error ocurring "nowhere" (at ["" -1 -1]). --- source/lux.lux | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) (limited to 'source/lux.lux') 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) -- cgit v1.2.3 From 24cc40e76f83188688ad43c499a44508e1aa5d60 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Aug 2015 20:21:04 -0400 Subject: - Local vars can now longer have prefixed symbols. --- source/lux.lux | 220 ++++++++++++++++++++++++++++++--------------------------- 1 file changed, 116 insertions(+), 104 deletions(-) (limited to 'source/lux.lux') 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) -- cgit v1.2.3 From 4134c811399abfce64b54a821e427d2b153f3e57 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Aug 2015 18:25:39 -0400 Subject: - Changing tags so they're actually indices (part 1). - Fixed a bug regarding type coercion (type-checking was ocurring unnecessarily). - Fixed another bug regarding Local/Global variables. --- source/lux.lux | 308 +++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 190 insertions(+), 118 deletions(-) (limited to 'source/lux.lux') 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''"))))) -- cgit v1.2.3 From 72a9ed29ca5518ca98658873f4616d5637db80af Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Aug 2015 23:55:56 -0400 Subject: - Changing tags so they're actually indices (part 2). - Fixed some bugs. - Now pattern-matching on variants works with indices, rather than text tags. --- source/lux.lux | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'source/lux.lux') 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)) -- cgit v1.2.3 From 95e7125c36dfa04a29ac363f1fc7e4c59b505415 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 12 Aug 2015 00:14:53 -0400 Subject: - Changing tags so they're actually indices (part 3). - Added several bug fixes - Changed "Reader" to "Source" and "HostState" to "Host" in lux.lux - Set up indexing of records via tags. - Added lux.analyser.record namespace. - Removed some (now) unnecessary code for working with records. - Added the license (can't believe I missed it for so long.) --- source/lux.lux | 108 +++++++++++++++++++++++++++++++-------------------------- 1 file changed, 58 insertions(+), 50 deletions(-) (limited to 'source/lux.lux') 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 -- cgit v1.2.3 From e60e9ef86b8653726ac8d99310640122c9242098 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 12 Aug 2015 00:15:51 -0400 Subject: - Changing tags so they're actually indices (part 4). - Bug fixes and adjustments. --- source/lux.lux | 27 ++++----------------------- 1 file changed, 4 insertions(+), 23 deletions(-) (limited to 'source/lux.lux') 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)) -- cgit v1.2.3 From 9ccdc7b5b59c2f0ffea49fc32d7b37eb2308bb9c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Aug 2015 12:48:18 -0400 Subject: - Some clean-up of needless code. - some adjustments to the new format for types. --- source/lux.lux | 276 ++++++++++++++++++++++----------------------------------- 1 file changed, 105 insertions(+), 171 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index 22d49315b..824113b92 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1462,50 +1462,6 @@ _ (return ident))) -(defmacro #export (| tokens) - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> AST ($' Lux AST)) - (lambda' [token] - (_lux_case token - (#Meta [_ (#TagS ident)]) - (do Lux/Monad - [ident (normalize ident)] - (wrap (`' [(~ (text$ (ident->text ident))) (;,)]))) - - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) - (do Lux/Monad - [ident (normalize ident) - #let [case-body (_lux_: AST - (_lux_case values - #Nil (`' Unit) - (#Cons value #Nil) value - _ (`' (, (~@ values)))))]] - (wrap (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) - - _ - (fail "Wrong syntax for |")))) - tokens)] - (wrap (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) - -(defmacro #export (& tokens) - (if (not (multiple? 2 (length tokens))) - (fail "& expects an even number of arguments.") - (do Lux/Monad - [pairs (map% Lux/Monad - (_lux_: (-> (, AST AST) ($' Lux AST)) - (lambda' [pair] - (_lux_case pair - [(#Meta [_ (#TagS ident)]) value] - (do Lux/Monad - [ident (normalize ident)] - (wrap (`' [(~ (text$ (ident->text ident))) (~ value)]))) - - _ - (fail "Wrong syntax for &")))) - (as-pairs tokens))] - (wrap (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) - (def''' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) @@ -1626,6 +1582,59 @@ #Nil true _ false)) +(do-template [ ] + [(def''' ( xy) + (All [a b] (-> (, a b) )) + (let' [[x y] xy] ))] + + [first a x] + [second b y]) + +(def''' (unfold-type-def type) + (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) + (_lux_case type + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "|")) cases))) + (do Lux/Monad + [members (map% Lux/Monad + (: (-> AST ($' Lux (, Text AST))) + (lambda' [case] + (_lux_case case + (#Meta _ (#TagS "" member-name)) + (return [member-name (`' Unit)]) + + (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "" member-name)) (#Cons member-type #Nil)))) + (return [member-name member-type]) + + _ + (fail "Wrong syntax for variant case.")))) + cases)] + (return [(`' (#VariantT (~ (untemplate-list (map second members))))) + (#Some (|> members + (map first) + (map (: (-> Text AST) + (lambda' [name] (tag$ ["" name]))))))])) + + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "&")) pairs))) + (do Lux/Monad + [members (map% Lux/Monad + (: (-> (, AST AST) ($' Lux (, Text AST))) + (lambda' [pair] + (_lux_case pair + [(#Meta _ (#TagS "" member-name)) member-type] + (return [member-name member-type]) + + _ + (fail "Wrong syntax for variant case.")))) + (as-pairs pairs))] + (return [(`' (#RecordT (~ (untemplate-list (map second members))))) + (#Some (|> members + (map first) + (map (: (-> Text AST) + (lambda' [name] (tag$ ["" name]))))))])) + + _ + (return [type #None]))) + (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens @@ -1653,73 +1662,46 @@ #None))] (_lux_case parts (#Some name args type) - (let' [with-export (: (List AST) - (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) - #Nil)) - type' (: (Maybe AST) - (if rec? - (if (empty? args) - (let' [g!param (symbol$ ["" ""]) - prime-name (symbol$ ["" (text:++ name "'")]) - type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] - (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) - ;Void)))) - #None) - (_lux_case args - #Nil - (#Some type) - - _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] - (_lux_case type' - (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) - with-export)) - - #None - (fail "Wrong syntax for deftype"))) + (do Lux/Monad + [type+tags?? (unfold-type-def type)] + (let' [[type tags??] type+tags?? + with-export (: (List AST) + (if export? + (list (`' (_lux_export (~ (symbol$ ["" name]))))) + #Nil)) + with-tags (: (List AST) + (_lux_case tags?? + (#Some tags) + (list (`' (_lux_declare-tags [(~@ tags)]))) + + _ + (list))) + type' (: (Maybe AST) + (if rec? + (if (empty? args) + (let' [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] + (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) + ;Void)))) + #None) + (_lux_case args + #Nil + (#Some type) + + _ + (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + (list:++ with-export with-tags))) + + #None + (fail "Wrong syntax for deftype")))) #None (fail "Wrong syntax for deftype")) )) -## (defmacro #export (deftype tokens) -## (let' [[export? tokens'] (: (, Bool (List AST)) -## (_lux_case (:! (List AST) tokens) -## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) -## [true (:! (List AST) tokens')] - -## _ -## [false (:! (List AST) tokens)])) -## parts (: (Maybe (, AST (List AST) AST)) -## (_lux_case tokens' -## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) #Nil type]) - -## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) -## (#Some (symbol$ name) args type) - -## _ -## #None))] -## (_lux_case parts -## (#Some name args type]) -## (let' [with-export (: (List AST) -## (if export? -## (list (`' (_lux_export (~ name)))) -## #Nil)) -## type' (: AST -## (_lux_case args -## #Nil -## type - -## _ -## (`' (;All (~ name) [(~@ args)] (~ type)))))] -## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) -## with-export))) - -## #None -## (fail "Wrong syntax for deftype")) -## )) (defmacro #export (exec tokens) (_lux_case (reverse tokens) @@ -1920,8 +1902,8 @@ (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) (#Some ["" ""] head tail body) - (\ (list (#Meta _ (#SymbolS ident)) (#Meta _ (#TupleS (#Cons head tail))) body)) - (#Some ident head tail body) + (\ (list (#Meta _ (#SymbolS [_ name])) (#Meta _ (#TupleS (#Cons head tail))) body)) + (#Some ["" name] head tail body) _ #None)) @@ -2260,35 +2242,19 @@ (defmacro #export (struct tokens) (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - struct-type expected-type] - (case (resolve-struct-type struct-type) - (#Some (#RecordT slots)) - (do Lux/Monad - [#let [translations (map (: (-> (, Text Type) (, Text Ident)) - (lambda [[sname _]] - (let [[module name] (split-slot sname)] - [name [module name]]))) - slots)] - members (map% Lux/Monad - (: (-> AST (Lux (, AST AST))) - (lambda [token] - (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS ["" name])) value)))) - (case (get name translations) - (#Some tag-name) - (wrap (: (, AST AST) [(tag$ tag-name) value])) - - _ - (fail "Structures require defined members")) + [tokens' (map% Lux/Monad macro-expand tokens)] + (do Lux/Monad + [members (map% Lux/Monad + (: (-> AST (Lux (, AST AST))) + (lambda [token] + (case token + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS tag-name)) value)))) + (wrap (: (, AST AST) [(tag$ tag-name) value])) - _ - (fail "Structures members must be unqualified.")))) - (list:join tokens'))] - (wrap (list (record$ members)))) - - _ - (fail "struct can only use records.")))) + _ + (fail "Structures members must be unqualified.")))) + (list:join tokens'))] + (wrap (list (record$ members)))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) @@ -2721,24 +2687,6 @@ (#ValueD [type _]) (#Some type) (#MacroD m) (#Some Macro) (#AliasD name') (find-in-defs name' state)))))) -## (def (find-in-defs name state) -## (-> Ident Compiler (Maybe Type)) -## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] -## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-defs #1: " (ident->text name) "\n")]) -## (let [[v-prefix v-name] name -## {#source source #modules modules -## #envs envs #types types #host host -## #seed seed #eval? eval? #expected expected} state] -## (do Maybe/Monad -## [module (get v-prefix modules) -## #let [{#defs defs #module-aliases _ #imports _ #tags tags} module] -## def (get v-name defs) -## #let [[_ def-data] def]] -## (case def-data -## #TypeD (wrap Type) -## (#ValueD type) (wrap type) -## (#MacroD m) (wrap Macro) -## (#AliasD name') (find-in-defs name' state)))))) (def (find-var-type ident) (-> Ident (Lux Type)) @@ -3065,14 +3013,6 @@ _ (fail "Wrong syntax for \\template"))) -(do-template [ ] - [(def ( [x y]) - (All [a b] (-> (, a b) )) - )] - - [first a x] - [second b y]) - (def (interleave xs ys) (All [a] (-> (List a) (List a) (List a))) (case xs @@ -3105,16 +3045,10 @@ (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) (#VariantT cases) - (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) AST) - (lambda [[label type]] - (tuple$ (list (text$ label) (type->syntax type))))) - cases))))) + (` (#VariantT (~ (untemplate-list (map type->syntax cases))))) (#RecordT fields) - (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) AST) - (lambda [[label type]] - (tuple$ (list (text$ label) (type->syntax type))))) - fields))))) + (` (#RecordT (~ (untemplate-list (map type->syntax fields))))) (#LambdaT in out) (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) -- cgit v1.2.3 From 3d18954a2307b48c955f5bdd3790a92ffeb7284c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Aug 2015 13:28:07 -0400 Subject: Unified tuples & records. --- source/lux.lux | 331 ++++++++++++++++++++++++++------------------------------- 1 file changed, 152 insertions(+), 179 deletions(-) (limited to 'source/lux.lux') 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)))) -- cgit v1.2.3 From df3e4ba2df6462812174e69ea5c334a7edbbd5c7 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Aug 2015 15:37:46 -0400 Subject: Introduced named types (#NamedT Ident Type). --- source/lux.lux | 429 +++++++++++++++++++++++++++++++-------------------------- 1 file changed, 235 insertions(+), 194 deletions(-) (limited to 'source/lux.lux') 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 -- cgit v1.2.3 From 1b48e9e06cb90187b28381bcadbeeba60806964d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 17 Aug 2015 16:59:18 -0400 Subject: - Finished turning tags into indices. - As an unexpected bonus, the compiler has become 2.5x faster. - Fixed some minor bugs. - Tag declarations now include associated types. - Tag declarations info is now stored twice (one from the perspective of tags, the other from the perspective of types). - Changed the named of the "types" member of the Compiler type, to "type-vars" to avoid collision with the "types" member of the Module type. --- source/lux.lux | 752 +++++++++++++++++++++++++++++++-------------------------- 1 file changed, 416 insertions(+), 336 deletions(-) (limited to 'source/lux.lux') 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 -- cgit v1.2.3 From 9606c19f9947c8f2ff5647b4613ac2029ac3881f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 02:54:00 -0400 Subject: - Restructuring how sums & products work [part 1] --- source/lux.lux | 489 +++++++++++++++++++++++++++------------------------------ 1 file changed, 234 insertions(+), 255 deletions(-) (limited to 'source/lux.lux') 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)] -- cgit v1.2.3 From 82b019a5b5f547f3b321642ce687d8aec59e802e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 17:41:45 -0400 Subject: - Restructuring how sums & products work [part 2] --- source/lux.lux | 154 ++++++++++++++++++++++++++++++--------------------------- 1 file changed, 82 insertions(+), 72 deletions(-) (limited to 'source/lux.lux') 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)]) -- cgit v1.2.3 From 37a9044d8ec523a282c0470d65380ce5cff27084 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 20:27:51 -0400 Subject: - Restructuring how sums & products work [part 3] --- source/lux.lux | 252 ++++++++++++++++++++++++++++++--------------------------- 1 file changed, 134 insertions(+), 118 deletions(-) (limited to 'source/lux.lux') 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))) -- cgit v1.2.3 From f403ee7a9662f81c91aa124f0573c5957a88ebe5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 06:37:46 -0400 Subject: Due to several performance issues and my inability to optimize them away due to too many corner cases, I decided the abandon the path towards a more mathematical implementation of tuples & variants. --- source/lux.lux | 885 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 440 insertions(+), 445 deletions(-) (limited to 'source/lux.lux') 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))) -- cgit v1.2.3 From d916be54994c8266f005744f7c3a61a36a39e31d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 07:01:33 -0400 Subject: Changed the license from EPL to MPL. --- source/lux.lux | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) (limited to 'source/lux.lux') 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" [] -- cgit v1.2.3 From a10d922283a9256f0f0015d9d00a0c549b1891cb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 17:58:32 -0400 Subject: The environments of AllT types are no longer stored inside a Maybe. --- source/lux.lux | 53 ++++++++++++++++++++++++----------------------------- 1 file changed, 24 insertions(+), 29 deletions(-) (limited to 'source/lux.lux') 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) -- cgit v1.2.3 From 8de225f98aaed212bf3b683208bff5c6ab85a835 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 22:46:12 -0400 Subject: - Changed the name of AllT (for-all type) to UnivQ (universal quantification). - UnivQ no longer stores the environment as key-val pairs with Text names, but instead stores it as type-lists with variables accessed via an index through a (updated) BoundT. - UnivQ no longer stores the name of the type-fun, not the name of the type-arg. --- source/lux.lux | 882 +++++++++++++++++++++++++++++---------------------------- 1 file changed, 456 insertions(+), 426 deletions(-) (limited to 'source/lux.lux') 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)))) -- cgit v1.2.3 From cc928a8675cb35dabd4a4957ab6612b70f015d58 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 18:12:27 -0400 Subject: - Removed the (unnecessary) lux/data/cont module. - Removed the (unnecessary) lux/data/error module and moved it's structures to lux/data/either. - Implemented the \slots destructurer for records. - Implemented quicksort for lists as the "sort" function in lux/data/list. - Added tags for the Cursor type. --- source/lux.lux | 45 +++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 41 insertions(+), 4 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index d96b18fcb..cf56f326a 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -160,6 +160,7 @@ (#NamedT ["lux" "Cursor"] (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) (_lux_export Cursor) +(_lux_declare-tags [#module #line #column] Cursor) ## (deftype (Meta m v) ## (| (#Meta m v))) @@ -785,8 +786,8 @@ (#Meta _ (#RecordS pairs)) (record$ (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) (lambda'' [pair] - (let'' [name val] pair - [name (update-bounds val)]))) + (let'' [name val] pair + [name (update-bounds val)]))) pairs)) (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "lux" "BoundT")) (#Cons (#Meta _ (#IntS idx)) #Nil)))) @@ -931,8 +932,8 @@ (def''' (as-pairs xs) (All' [a] (->' ($' List a) ($' List (#TupleT (list a a))))) (_lux_case xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) + (#Cons x (#Cons y xs')) + (#Cons [x y] (as-pairs xs')) _ #Nil)) @@ -3224,3 +3225,39 @@ (defmacro #export (export tokens) (return (map (lambda [token] (` (_lux_export (~ token)))) tokens))) + +(defmacro #export (\slots tokens) + (case tokens + (\ (list body (#Meta _ (#TupleS (list& hslot' tslots'))))) + (do Lux/Monad + [slots (: (Lux (, Ident (List Ident))) + (case (: (Maybe (, Ident (List Ident))) + (do Maybe/Monad + [hslot (get-ident hslot') + tslots (map% Maybe/Monad get-ident tslots')] + (wrap [hslot tslots]))) + (#Some slots) + (return slots) + + #None + (fail "Wrong syntax for \\slots"))) + #let [[hslot tslots] slots] + hslot (normalize hslot) + tslots (map% Lux/Monad normalize tslots) + output (resolve-tag hslot) + g!_ (gensym "_") + #let [[idx tags type] output + slot-pairings (map (: (-> Ident (, Text AST)) + (lambda [[module name]] [name (symbol$ ["" name])])) + (list& hslot tslots)) + pattern (record$ (map (: (-> Ident (, AST AST)) + (lambda [[module name]] + (let [tag (tag$ [module name])] + (case (get name slot-pairings) + (#Some binding) [tag binding] + #None [tag g!_])))) + tags))]] + (return (list pattern body))) + + _ + (fail "Wrong syntax for \\slots"))) -- cgit v1.2.3 From 253d5a4a3f7ef5d42c467733e394a28d18a4d9b3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 19:39:10 -0400 Subject: - Added some compiler optimizations. - Removed the (unnecessary) lux/control/dict & lux/control/stack modules. - The "Meta" type is now a record instead of a variant. --- source/lux.lux | 342 +++++++++++++++++++++++++++++---------------------------- 1 file changed, 174 insertions(+), 168 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index cf56f326a..422fb4fad 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -155,7 +155,9 @@ (_lux_declare-tags [#name #inner-closures #locals #closure] Env) ## (deftype Cursor -## (, Text Int Int)) +## (& #module Text +## #line Int +## #column Int)) (_lux_def Cursor (#NamedT ["lux" "Cursor"] (#TupleT (#Cons Text (#Cons Int (#Cons Int #Nil)))))) @@ -163,18 +165,17 @@ (_lux_declare-tags [#module #line #column] Cursor) ## (deftype (Meta m v) -## (| (#Meta m v))) +## (& #meta m +## #datum v)) (_lux_def Meta (#NamedT ["lux" "Meta"] (#UnivQ #Nil (#UnivQ #Nil - (#VariantT (#Cons ## "lux;Meta" - (#TupleT (#Cons (#BoundT 3) - (#Cons (#BoundT 1) - #Nil))) - #Nil)))))) + (#TupleT (#Cons (#BoundT 3) + (#Cons (#BoundT 1) + #Nil))))))) (_lux_export Meta) -(_lux_declare-tags [#Meta] Meta) +(_lux_declare-tags [#meta #datum] Meta) ## (deftype (AST' w) ## (| (#BoolS Bool) @@ -414,13 +415,13 @@ ## (def (_meta data) ## (-> (AST' (Meta Cursor)) AST) -## (#Meta [["" -1 -1] data])) +## [["" -1 -1] data]) (_lux_def _meta (_lux_: (#LambdaT (#AppT AST' (#AppT Meta Cursor)) AST) (_lux_lambda _ data - (#Meta _cursor data)))) + [_cursor data]))) ## (def (return x) ## (All [a] @@ -523,7 +524,7 @@ (_lux_: Macro (_lux_lambda _ tokens (_lux_case tokens - (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil)) + (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil)) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS "" "")) (#Cons arg @@ -538,7 +539,7 @@ #Nil)))))) #Nil)) - (#Cons (#Meta _ (#SymbolS self)) (#Cons (#Meta _ (#TupleS (#Cons arg args'))) (#Cons body #Nil))) + (#Cons [_ (#SymbolS self)] (#Cons [_ (#TupleS (#Cons arg args'))] (#Cons body #Nil))) (return (#Cons (_meta (#FormS (#Cons (_meta (#SymbolS "" "_lux_lambda")) (#Cons (_meta (#SymbolS self)) (#Cons arg @@ -561,8 +562,8 @@ (_lux_: Macro (lambda'' [tokens] (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name @@ -577,7 +578,7 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) @@ -588,7 +589,7 @@ (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])]) (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) (#Cons [name @@ -620,7 +621,7 @@ (def'' (defmacro tokens) Macro (_lux_case tokens - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(form$ (#Cons [name args])) (#Cons [(symbol$ ["lux" "Macro"]) @@ -630,7 +631,7 @@ (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])])]) (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def''"]) (#Cons [(tag$ ["" "export"]) (#Cons [(form$ (#Cons [name args])) @@ -730,7 +731,7 @@ (def'' (replace-syntax reps syntax) (->' RepEnv AST AST) (_lux_case syntax - (#Meta _ (#SymbolS "" name)) + [_ (#SymbolS "" name)] (_lux_case (get-rep name reps) (#Some replacement) replacement @@ -738,19 +739,19 @@ #None syntax) - (#Meta _ (#FormS parts)) - (#Meta _ (#FormS (map (replace-syntax reps) parts))) + [meta (#FormS parts)] + [meta (#FormS (map (replace-syntax reps) parts))] - (#Meta _ (#TupleS members)) - (#Meta _ (#TupleS (map (replace-syntax reps) members))) + [meta (#TupleS members)] + [meta (#TupleS (map (replace-syntax reps) members))] - (#Meta _ (#RecordS slots)) - (#Meta _ (#RecordS (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) - (lambda'' [slot] - (_lux_case slot - [k v] - [(replace-syntax reps k) (replace-syntax reps v)]))) - slots))) + [meta (#RecordS slots)] + [meta (#RecordS (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) + (lambda'' [slot] + (_lux_case slot + [k v] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))] _ syntax) @@ -759,47 +760,47 @@ (def'' (update-bounds ast) (->' AST AST) (_lux_case ast - (#Meta _ (#BoolS value)) + [_ (#BoolS value)] (bool$ value) - (#Meta _ (#IntS value)) + [_ (#IntS value)] (int$ value) - (#Meta _ (#RealS value)) + [_ (#RealS value)] (real$ value) - (#Meta _ (#CharS value)) + [_ (#CharS value)] (char$ value) - (#Meta _ (#TextS value)) + [_ (#TextS value)] (text$ value) - (#Meta _ (#SymbolS value)) + [_ (#SymbolS value)] (symbol$ value) - (#Meta _ (#TagS value)) + [_ (#TagS value)] (tag$ value) - (#Meta _ (#TupleS members)) + [_ (#TupleS members)] (tuple$ (map update-bounds members)) - (#Meta _ (#RecordS pairs)) + [_ (#RecordS pairs)] (record$ (map (_lux_: (->' (#TupleT (#Cons AST (#Cons AST #Nil))) (#TupleT (#Cons AST (#Cons AST #Nil)))) (lambda'' [pair] (let'' [name val] pair [name (update-bounds val)]))) pairs)) - (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "lux" "BoundT")) (#Cons (#Meta _ (#IntS idx)) #Nil)))) + [_ (#FormS (#Cons [_ (#TagS "lux" "BoundT")] (#Cons [_ (#IntS idx)] #Nil)))] (form$ (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ (_jvm_ladd 2 idx)) #Nil))) - (#Meta _ (#FormS members)) + [_ (#FormS members)] (form$ (map update-bounds members))) ) (defmacro (All' tokens) (_lux_case tokens - (#Cons (#Meta _ (#TupleS (#Cons (#Meta _ (#SymbolS "" arg-name)) other-args))) + (#Cons [_ (#TupleS (#Cons [_ (#SymbolS "" arg-name)] other-args))] (#Cons body #Nil)) (let'' bound-var (_meta (#FormS (#Cons (tag$ ["lux" "BoundT"]) (#Cons (int$ 1) #Nil)))) (let'' body' (replace-syntax (#Cons [arg-name bound-var] #Nil) @@ -860,13 +861,13 @@ (defmacro (lambda' tokens) (let'' [name tokens'] (_lux_: (#TupleT (list Ident ($' List AST))) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + (#Cons [[_ (#SymbolS name)] tokens']) [name tokens'] _ [["" ""] tokens])) (_lux_case tokens' - (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (#Cons [[_ (#TupleS args)] (#Cons [body #Nil])]) (_lux_case args #Nil (fail "lambda' requires a non-empty arguments tuple.") @@ -888,8 +889,8 @@ (defmacro (def''' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#TagS ["" "export"])] + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -901,7 +902,7 @@ body)))))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (#Cons [[_ (#TagS ["" "export"])] (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name (form$ (list (symbol$ ["" "_lux_:"]) @@ -909,7 +910,7 @@ body)))) (form$ (list (symbol$ ["" "_lux_export"]) name)))) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [type (#Cons [body #Nil])])]) (return (list (form$ (list (symbol$ ["" "_lux_def"]) name @@ -940,7 +941,7 @@ (defmacro (let' tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) (return (list (foldL (_lux_: (->' AST (#TupleT (list AST AST)) AST) (lambda' [body binding] @@ -968,7 +969,7 @@ (def''' (spliced? token) (->' AST Bool) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [_ #Nil])]))] true _ @@ -976,9 +977,8 @@ (def''' (wrap-meta content) (->' AST AST) - (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) - (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) - content))))))) + (tuple$ (list (tuple$ (list (text$ "") (int$ -1) (int$ -1))) + content))) (def''' (untemplate-list tokens) (->' ($' List AST) AST) @@ -1017,7 +1017,7 @@ true (let' [elems' (map (lambda' [elem] (_lux_case elem - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + [_ (#FormS (#Cons [[_ (#SymbolS ["" "~@"])] (#Cons [spliced #Nil])]))] spliced _ @@ -1039,22 +1039,22 @@ (def''' (untemplate replace? subst token) (->' Bool Text AST AST) (_lux_case (_lux_: (#TupleT (list Bool AST)) [replace? token]) - [_ (#Meta [_ (#BoolS value)])] + [_ [_ (#BoolS value)]] (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) - [_ (#Meta [_ (#IntS value)])] + [_ [_ (#IntS value)]] (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) - [_ (#Meta [_ (#RealS value)])] + [_ [_ (#RealS value)]] (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) - [_ (#Meta [_ (#CharS value)])] + [_ [_ (#CharS value)]] (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) - [_ (#Meta [_ (#TextS value)])] + [_ [_ (#TextS value)]] (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) - [_ (#Meta [_ (#TagS [module name])])] + [_ [_ (#TagS [module name])]] (let' [module' (_lux_case module "" subst @@ -1063,7 +1063,7 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ (#Meta [_ (#SymbolS [module name])])] + [_ [_ (#SymbolS [module name])]] (let' [module' (_lux_case module "" subst @@ -1072,17 +1072,17 @@ module)] (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) - [_ (#Meta [_ (#TupleS elems)])] + [_ [_ (#TupleS elems)]] (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) - [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + [true [_ (#FormS (#Cons [[_ (#SymbolS ["" "~"])] (#Cons [unquoted #Nil])]))]] unquoted - [_ (#Meta [meta (#FormS elems)])] - (let' [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] - (#Meta [meta form'])) + [_ [meta (#FormS elems)]] + (let' [[_ form'] (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] + [meta form']) - [_ (#Meta [_ (#RecordS fields)])] + [_ [_ (#RecordS fields)]] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list (map (_lux_: (->' (#TupleT (list AST AST)) AST) (lambda' [kv] @@ -1110,16 +1110,17 @@ (defmacro #export (|> tokens) (_lux_case tokens (#Cons [init apps]) - (return (list (foldL (lambda' [acc app] - (_lux_case app - (#Meta [_ (#TupleS parts)]) - (tuple$ (list:++ parts (list acc))) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [acc app] + (_lux_case app + [_ (#TupleS parts)] + (tuple$ (list:++ parts (list acc))) - (#Meta [_ (#FormS parts)]) - (form$ (list:++ parts (list acc))) + [_ (#FormS parts)] + (form$ (list:++ parts (list acc))) - _ - (`' ((~ app) (~ acc))))) + _ + (`' ((~ app) (~ acc)))))) init apps))) @@ -1189,7 +1190,7 @@ (defmacro #export (^ tokens) (_lux_case tokens - (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil) + (#Cons [_ (#SymbolS "" class-name)] #Nil) (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ @@ -1198,7 +1199,8 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) (#Cons output inputs) - (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))) + (return (list (foldL (_lux_: (->' AST AST AST) + (lambda' [o i] (`' (#;LambdaT (~ i) (~ o))))) output inputs))) @@ -1210,12 +1212,12 @@ (defmacro (do tokens) (_lux_case tokens - (#Cons monad (#Cons (#Meta _ (#TupleS bindings)) (#Cons body #Nil))) + (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) (let' [body' (foldL (_lux_: (-> AST (, AST AST) AST) (lambda' [body' binding] (let' [[var value] binding] (_lux_case var - (#Meta _ (#TagS "" "let")) + [_ (#TagS "" "let")] (`' (;let' (~ value) (~ body'))) _ @@ -1261,7 +1263,7 @@ (def''' (get-ident x) (-> AST ($' Maybe Ident)) (_lux_case x - (#Meta _ (#SymbolS sname)) + [_ (#SymbolS sname)] (#Some sname) _ @@ -1270,7 +1272,7 @@ (def''' (get-name x) (-> AST ($' Maybe Text)) (_lux_case x - (#Meta _ (#SymbolS "" sname)) + [_ (#SymbolS "" sname)] (#Some sname) _ @@ -1279,7 +1281,7 @@ (def''' (tuple->list tuple) (-> AST ($' Maybe ($' List AST))) (_lux_case tuple - (#Meta _ (#TupleS members)) + [_ (#TupleS members)] (#Some members) _ @@ -1288,7 +1290,7 @@ (def''' (apply-template env template) (-> RepEnv AST AST) (_lux_case template - (#Meta _ (#SymbolS "" sname)) + [_ (#SymbolS "" sname)] (_lux_case (get-rep sname env) (#Some subst) subst @@ -1296,13 +1298,13 @@ _ template) - (#Meta _ (#TupleS elems)) + [_ (#TupleS elems)] (tuple$ (map (apply-template env) elems)) - (#Meta _ (#FormS elems)) + [_ (#FormS elems)] (form$ (map (apply-template env) elems)) - (#Meta _ (#RecordS members)) + [_ (#RecordS members)] (record$ (map (_lux_: (-> (, AST AST) (, AST AST)) (lambda' [kv] (let' [[slot value] kv] @@ -1324,7 +1326,7 @@ (defmacro #export (do-template tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) @@ -1413,19 +1415,20 @@ (defmacro #export (All tokens) (let' [[self-name tokens] (_lux_: (, Text ASTList) (_lux_case tokens - (#Cons (#Meta _ (#SymbolS "" self-name)) tokens) + (#Cons [_ (#SymbolS "" self-name)] tokens) [self-name tokens] _ ["" tokens]))] (_lux_case tokens - (#Cons (#Meta _ (#TupleS (#Cons harg targs))) (#Cons body #Nil)) + (#Cons [_ (#TupleS (#Cons harg targs))] (#Cons body #Nil)) (_lux_case (map% Maybe/Monad get-name (#Cons harg targs)) (#Some names) - (let' [body' (foldL (lambda' [body' name'] - (`' (#;UnivQ #;Nil (~ (|> body' - (update-bounds) - (replace-syntax (list [name' (make-bound 1)]))))))) + (let' [body' (foldL (_lux_: (-> AST Text AST) + (lambda' [body' name'] + (`' (#;UnivQ #;Nil (~ (|> body' + (update-bounds) + (replace-syntax (list [name' (make-bound 1)])))))))) (replace-syntax (list [self-name (make-bound -2)]) body) names)] @@ -1547,7 +1550,7 @@ (def''' (macro-expand token) (-> AST ($' Lux ($' List AST))) (_lux_case token - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1567,7 +1570,7 @@ (def''' (macro-expand-all syntax) (-> AST ($' Lux ($' List AST))) (_lux_case syntax - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -1583,13 +1586,13 @@ [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (wrap (list (form$ (list:join parts'))))))) - (#Meta [_ (#FormS (#Cons [harg targs]))]) + [_ (#FormS (#Cons [harg targs]))] (do Lux/Monad [harg+ (macro-expand-all harg) targs+ (map% Lux/Monad macro-expand-all targs)] (wrap (list (form$ (list:++ harg+ (list:join targs+)))))) - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (do Lux/Monad [members' (map% Lux/Monad macro-expand-all members)] (wrap (list (tuple$ (list:join members'))))) @@ -1600,14 +1603,15 @@ (def''' (walk-type type) (-> AST AST) (_lux_case type - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + [_ (#FormS (#Cons [[_ (#TagS tag)] parts]))] (form$ (#Cons [(tag$ tag) (map walk-type parts)])) - (#Meta [_ (#TupleS members)]) + [_ (#TupleS members)] (tuple$ (map walk-type members)) - (#Meta [_ (#FormS (#Cons [type-fn args]))]) - (foldL (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + [_ (#FormS (#Cons [type-fn args]))] + (foldL (_lux_: (-> AST AST AST) + (lambda' [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) (walk-type type-fn) (map walk-type args)) @@ -1662,16 +1666,16 @@ (def''' (unfold-type-def type) (-> AST ($' Lux (, AST ($' Maybe ($' List AST))))) (_lux_case type - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "|")) cases))) + [_ (#FormS (#Cons [_ (#SymbolS "" "|")] cases))] (do Lux/Monad [members (map% Lux/Monad (: (-> AST ($' Lux (, Text AST))) (lambda' [case] (_lux_case case - (#Meta _ (#TagS "" member-name)) + [_ (#TagS "" member-name)] (return [member-name (`' Unit)]) - (#Meta _ (#FormS (#Cons (#Meta _ (#TagS "" member-name)) (#Cons member-type #Nil)))) + [_ (#FormS (#Cons [_ (#TagS "" member-name)] (#Cons member-type #Nil)))] (return [member-name member-type]) _ @@ -1683,13 +1687,13 @@ (map (: (-> Text AST) (lambda' [name] (tag$ ["" name]))))))])) - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" "&")) pairs))) + [_ (#FormS (#Cons [_ (#SymbolS "" "&")] pairs))] (do Lux/Monad [members (map% Lux/Monad (: (-> (, AST AST) ($' Lux (, Text AST))) (lambda' [pair] (_lux_case pair - [(#Meta _ (#TagS "" member-name)) member-type] + [[_ (#TagS "" member-name)] member-type] (return [member-name member-type]) _ @@ -1707,24 +1711,24 @@ (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) [rec? tokens'] (: (, Bool (List AST)) (_lux_case tokens' - (#Cons (#Meta _ (#TagS "" "rec")) tokens') + (#Cons [_ (#TagS "" "rec")] tokens') [true tokens'] _ [false tokens'])) parts (: (Maybe (, Text (List AST) AST)) (_lux_case tokens' - (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) + (#Cons [_ (#SymbolS "" name)] (#Cons type #Nil)) (#Some name #Nil type) - (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil)) + (#Cons [_ (#FormS (#Cons [_ (#SymbolS "" name)] args))] (#Cons type #Nil)) (#Some name args type) _ @@ -1780,7 +1784,8 @@ (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] - (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + (return (list (foldL (_lux_: (-> AST AST AST) + (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))) value actions)))) @@ -1790,20 +1795,20 @@ (defmacro (def' tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (_lux_case tokens' - (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil))) + (#Cons [_ (#FormS (#Cons name args))] (#Cons type (#Cons body #Nil))) (#Some name args (#Some type) body) (#Cons name (#Cons type (#Cons body #Nil))) (#Some name #Nil (#Some type) body) - (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil)) + (#Cons [_ (#FormS (#Cons name args))] (#Cons body #Nil)) (#Some name args #None body) (#Cons name (#Cons body #Nil)) @@ -1849,7 +1854,7 @@ (lambda' expander [branch] (let' [[pattern body] branch] (_lux_case pattern - (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) + [_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))] (do Lux/Monad [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] @@ -1908,7 +1913,7 @@ (def' (symbol? ast) (-> AST Bool) (case ast - (#Meta _ (#SymbolS _)) + [_ (#SymbolS _)] true _ @@ -1916,7 +1921,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list (#Meta _ (#TupleS bindings)) body)) + (\ (list [_ (#TupleS bindings)] body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> AST (, AST AST) AST) @@ -1936,7 +1941,7 @@ (def' (ast:show ast) (-> AST Text) (case ast - (#Meta _ ast) + [_ ast] (case ast (\or (#BoolS val) (#IntS val) (#RealS val)) (->text val) @@ -1972,10 +1977,10 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens - (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) + (\ (list [_ (#TupleS (#Cons head tail))] body)) (#Some ["" ""] head tail body) - (\ (list (#Meta _ (#SymbolS [_ name])) (#Meta _ (#TupleS (#Cons head tail))) body)) + (\ (list [_ (#SymbolS [_ name])] [_ (#TupleS (#Cons head tail))] body)) (#Some ["" name] head tail body) _ @@ -2001,20 +2006,20 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (#Cons (#Meta _ (#TagS "" "export")) tokens') + (#Cons [_ (#TagS "" "export")] tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, AST (List AST) (Maybe AST) AST)) (case tokens' - (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) + (\ (list [_ (#FormS (#Cons name args))] type body)) (#Some name args (#Some type) body) (\ (list name type body)) (#Some name #Nil (#Some type) body) - (\ (list (#Meta _ (#FormS (#Cons name args))) body)) + (\ (list [_ (#FormS (#Cons name args))] body)) (#Some name args #None body) (\ (list name body)) @@ -2062,17 +2067,17 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& (#Meta _ (#TagS "" "export")) tokens')) + (\ (list& [_ (#TagS "" "export")] tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& (#Meta _ (#FormS (list& (#Meta _ (#SymbolS name)) args))) sigs)) + (\ (list& [_ (#FormS (list& [_ (#SymbolS name)] args))] sigs)) (#Some name args sigs) - (\ (list& (#Meta _ (#SymbolS name)) sigs)) + (\ (list& [_ (#SymbolS name)] sigs)) (#Some name #Nil sigs) _ @@ -2086,7 +2091,7 @@ (: (-> AST (Lux (, Text AST))) (lambda [token] (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS ["" name])))))) + (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_:")] type [_ (#SymbolS ["" name])]))]) (wrap (: (, Text AST) [name type])) _ @@ -2380,7 +2385,7 @@ (: (-> AST (Lux (, AST AST))) (lambda [token] (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS tag-name)) value)))) + (\ [_ (#FormS (list [_ (#SymbolS _ "_lux_def")] [_ (#SymbolS tag-name)] value))]) (wrap (: (, AST AST) [(tag$ tag-name) value])) _ @@ -2391,14 +2396,14 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens - (\ (list& (#Meta _ (#TagS "" "export")) tokens')) + (\ (list& [_ (#TagS "" "export")] tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, AST (List AST) AST (List AST))) (case tokens' - (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) + (\ (list& [_ (#FormS (list& name args))] type defs)) (#Some name args type defs) (\ (list& name type defs)) @@ -2431,7 +2436,8 @@ [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) - (return (list (foldL (lambda [post pre] (` )) + (return (list (foldL (: (-> AST AST AST) + (lambda [post pre] (` ))) last init))) @@ -2459,7 +2465,7 @@ (: (-> AST (Lux Text)) (lambda [def] (case def - (#Meta _ (#SymbolS "" name)) + [_ (#SymbolS "" name)] (return name) _ @@ -2469,7 +2475,7 @@ (def (parse-alias tokens) (-> (List AST) (Lux (, (Maybe Text) (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) + (\ (list& [_ (#TagS "" "as")] [_ (#SymbolS "" alias)] tokens')) (return (: (, (Maybe Text) (List AST)) [(#Some alias) tokens'])) _ @@ -2478,17 +2484,17 @@ (def (parse-referrals tokens) (-> (List AST) (Lux (, Referrals (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) + (\ (list& [_ (#TagS "" "refer")] referral tokens')) (case referral - (#Meta _ (#TagS "" "all")) + [_ (#TagS "" "all")] (return (: (, Referrals (List AST)) [#All tokens'])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) + (\ [_ (#FormS (list& [_ (#TagS "" "only")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Only defs') tokens']))) - (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) + (\ [_ (#FormS (list& [_ (#TagS "" "exclude")] defs))]) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List AST)) [(#Exclude defs') tokens']))) @@ -2502,7 +2508,7 @@ (def (extract-symbol syntax) (-> AST (Lux Ident)) (case syntax - (#Meta _ (#SymbolS ident)) + [_ (#SymbolS ident)] (return ident) _ @@ -2511,7 +2517,7 @@ (def (parse-openings tokens) (-> (List AST) (Lux (, (Maybe Openings) (List AST)))) (case tokens - (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) + (\ (list& [_ (#TagS "" "open")] [_ (#FormS (list& [_ (#TextS prefix)] structs))] tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] (return (: (, (Maybe Openings) (List AST)) [(#Some prefix structs') tokens']))) @@ -2525,10 +2531,10 @@ (: (-> AST (Lux AST)) (lambda [token] (case token - (#Meta _ (#SymbolS "" sub-name)) + [_ (#SymbolS "" sub-name)] (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts)))) + (\ [_ (#FormS (list& [_ (#SymbolS "" sub-name)] parts))]) (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ @@ -2542,10 +2548,10 @@ (: (-> AST (Lux (List Import))) (lambda [token] (case token - (#Meta _ (#SymbolS "" m-name)) + [_ (#SymbolS "" m-name)] (wrap (list [m-name #None #All #None])) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) + (\ [_ (#FormS (list& [_ (#SymbolS "" m-name)] extra))]) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2724,10 +2730,11 @@ (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] (wrap ($ list:++ - (list (` (_lux_import (~ (text$ m-name))))) - (case m-alias - #None (list) - (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) + (: (List AST) (list (` (_lux_import (~ (text$ m-name)))))) + (: (List AST) + (case m-alias + #None (list) + (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name))))))) (map (: (-> Text AST) (lambda [def] (` (_lux_def (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) @@ -2737,10 +2744,9 @@ (wrap (list:join output'))) _ - (wrap (: (List AST) - (list:++ (map (lambda [m-name] (` (_lux_import (~ (text$ m-name))))) - unknowns) - (list (` (import (~@ tokens)))))))))) + (wrap (list:++ (map (: (-> Text AST) (lambda [m-name] (` (_lux_import (~ (text$ m-name)))))) + unknowns) + (: (List AST) (list (` (import (~@ tokens)))))))))) (def (try-both f x1 x2) (All [a b] @@ -2877,7 +2883,7 @@ (case tokens (\ (list struct body)) (case struct - (#Meta _ (#SymbolS name)) + [_ (#SymbolS name)] (do Lux/Monad [struct-type (find-var-type name) output (resolve-type-tags struct-type)] @@ -2939,7 +2945,7 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) record)) + (\ (list [_ (#TagS slot')] record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -2981,11 +2987,11 @@ (defmacro #export (open tokens) (case tokens - (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) + (\ (list& [_ (#SymbolS struct-name)] tokens')) (do Lux/Monad [@module get-module-name #let [prefix (case tokens' - (\ (list (#Meta _ (#TextS prefix)))) + (\ (list [_ (#TextS prefix)])) prefix _ @@ -3028,12 +3034,12 @@ (: (-> AST AST (Lux AST)) (lambda [so-far part] (case part - (#Meta _ (#SymbolS slot)) - (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + [_ (#SymbolS slot)] + (return (: AST (` (get@ (~ (tag$ slot)) (~ so-far))))) - (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args)))) - (return (` ((get@ (~ (tag$ slot)) (~ so-far)) - (~@ args)))) + (\ [_ (#FormS (list& [_ (#SymbolS slot)] args))]) + (return (: AST (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args))))) _ (fail "Wrong syntax for ::")))) @@ -3045,7 +3051,7 @@ (defmacro #export (set@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) value record)) + (\ (list [_ (#TagS slot')] value record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3080,7 +3086,7 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list (#Meta _ (#TagS slot')) fun record)) + (\ (list [_ (#TagS slot')] fun record)) (do Lux/Monad [slot (normalize slot') output (resolve-tag slot) @@ -3115,9 +3121,9 @@ (defmacro #export (\template tokens) (case tokens - (\ (list (#Meta _ (#TupleS data)) - (#Meta _ (#TupleS bindings)) - (#Meta _ (#TupleS templates)))) + (\ (list [_ (#TupleS data)] + [_ (#TupleS bindings)] + [_ (#TupleS templates)])) (case (: (Maybe (List AST)) (do Maybe/Monad [bindings' (map% Maybe/Monad get-name bindings) @@ -3194,7 +3200,7 @@ (defmacro #export (loop tokens) (case tokens - (\ (list (#Meta _ (#TupleS bindings)) body)) + (\ (list [_ (#TupleS bindings)] body)) (let [pairs (as-pairs bindings) vars (map first pairs) inits (map second pairs)] @@ -3224,11 +3230,11 @@ (fail "Wrong syntax for loop"))) (defmacro #export (export tokens) - (return (map (lambda [token] (` (_lux_export (~ token)))) tokens))) + (return (map (: (-> AST AST) (lambda [token] (` (_lux_export (~ token))))) tokens))) (defmacro #export (\slots tokens) (case tokens - (\ (list body (#Meta _ (#TupleS (list& hslot' tslots'))))) + (\ (list body [_ (#TupleS (list& hslot' tslots'))])) (do Lux/Monad [slots (: (Lux (, Ident (List Ident))) (case (: (Maybe (, Ident (List Ident))) -- cgit v1.2.3 From 196f56b83ed357169efb75b864f81f26c10641f1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 23:17:27 -0400 Subject: - Remove the (unnec) "All'" and "->'" macros. - Improved the "struct" macro so that (once again) it doesn't ask for the prefixes of the members. - Added tests for the lux.reader namespace. --- source/lux.lux | 291 +++++++++++++++++++++++++++++---------------------------- 1 file changed, 146 insertions(+), 145 deletions(-) (limited to 'source/lux.lux') 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)))))) -- cgit v1.2.3 From 0a0fab3581eedbc13df2af40e3db8bc2d2fd8178 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 30 Aug 2015 01:20:08 -0400 Subject: - Removed the (now obsolete) `' macro. - Implemented hygienic macros by adding global symbol resolution inside the ` macro. --- source/lux.lux | 789 ++++++++++++++++++++++++++++++--------------------------- 1 file changed, 413 insertions(+), 376 deletions(-) (limited to 'source/lux.lux') 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 -- cgit v1.2.3 From 1857af8628216353c4fa0b75a921d66b266aa0b9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 31 Aug 2015 12:35:50 -0400 Subject: - Found a compromise with the issue of certain definitions clashing with each other when saving the class files in case-insensitive file-systems (https://github.com/LuxLang/lux/issues/8). The names of certain definitions were changed slightly to avoid clashes and the compiler throws an error if the names end up clashing prior to saving the .class file. --- source/lux.lux | 516 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 258 insertions(+), 258 deletions(-) (limited to 'source/lux.lux') 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"))) -- cgit v1.2.3 From 2cfaf65019015ffe34fba5d5a723b94350cd4e84 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Sep 2015 11:18:26 -0400 Subject: - Added a macro to write recursive types. - Corrected some code that still involved the old names for the list macros. - Corrected some code in the pattern-matcher analyser to it fails properly when encountering invalid pattern-syntax. --- source/lux.lux | 196 ++++++++++++++++++++++++++++++++------------------------- 1 file changed, 112 insertions(+), 84 deletions(-) (limited to 'source/lux.lux') 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"))) -- cgit v1.2.3 From e085c8c685b1e22827443a43d6f20b5ab6e72d6a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Sep 2015 16:48:54 -0400 Subject: - Fixed the implementation of the Rec macro, which forgot to do application on Void to achieve "recursion". - Introduced ExQ types into the type-system (still pending work on inference). --- source/lux.lux | 171 +++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 111 insertions(+), 60 deletions(-) (limited to 'source/lux.lux') 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)))) -- cgit v1.2.3 From 455018ec68f2c127db489048351bc48f3982fe23 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 01:03:19 -0400 Subject: - Expanded the standard library. - Fixed some minor bugs. - Added the updated code for the parser (forgot to add it to a previous commit). --- source/lux.lux | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index 5f5c6925b..164dea835 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -2932,23 +2932,23 @@ _ (fail "Can only \"use\" records."))) + + [_ (#TupleS members)] + (return (@list (foldL (: (-> AST AST AST) + (lambda [body' struct'] (` (;;using (~ struct') (~ body'))))) + body + members))) _ (let [dummy (symbol$ ["" ""])] (return (@list (` (;_lux_case (~ struct) (~ dummy) - (;using (~ dummy) - (~ body)))))))) + (;;using (~ dummy) + (~ body)))))))) _ (fail "Wrong syntax for using"))) -(def (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [y x] - (f x y))) - (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") -- cgit v1.2.3 From 0f596a44ffc486b7e0369eebd3b79d22315e8814 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 02:11:23 -0400 Subject: - Removed the (unnecessary) lux/meta/macro module. --- source/lux.lux | 122 ++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 78 insertions(+), 44 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index 164dea835..76ca9517f 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -621,7 +621,7 @@ ))) (_lux_declare-macro def'') -(def'' (defmacro tokens) +(def'' (defmacro' tokens) Macro (_lux_case tokens (#Cons [[_ (#FormS (#Cons [name args]))] (#Cons [body #Nil])]) @@ -646,13 +646,13 @@ #Nil])])) _ - (fail "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) + (fail "Wrong syntax for defmacro'"))) +(_lux_declare-macro defmacro') -(defmacro #export (comment tokens) +(defmacro' #export (comment tokens) (return #Nil)) -(defmacro ($' tokens) +(defmacro' ($' tokens) (_lux_case tokens (#Cons x #Nil) (return tokens) @@ -817,7 +817,7 @@ (#Cons x xs') (foldL f (f init x) xs'))) -(defmacro #export (All tokens) +(defmacro' #export (All tokens) (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil))) (_lux_case tokens (#Cons [_ (#SymbolS "" self-name)] tokens) @@ -844,7 +844,7 @@ (fail "Wrong syntax for All")) )) -(defmacro #export (Ex tokens) +(defmacro' #export (Ex tokens) (let'' [self-name tokens] (_lux_: (#TupleT (#Cons Text (#Cons ASTList #Nil))) (_lux_case tokens (#Cons [_ (#SymbolS "" self-name)] tokens) @@ -877,7 +877,7 @@ #Nil list)) -(defmacro #export (-> tokens) +(defmacro' #export (-> tokens) (_lux_case (reverse tokens) (#Cons output inputs) (return (#Cons (foldL (_lux_: (#LambdaT AST (#LambdaT AST AST)) @@ -889,7 +889,7 @@ _ (fail "Wrong syntax for ->"))) -(defmacro (@list xs) +(defmacro' (@list xs) (return (#Cons (foldL (lambda'' [tail head] (form$ (#Cons (tag$ ["lux" "Cons"]) (#Cons (tuple$ (#Cons [head (#Cons [tail #Nil])])) @@ -898,7 +898,7 @@ (reverse xs)) #Nil))) -(defmacro (@list& xs) +(defmacro' (@list& xs) (_lux_case (reverse xs) (#Cons last init) (return (@list (foldL (lambda'' [tail head] @@ -910,7 +910,7 @@ _ (fail "Wrong syntax for @list&"))) -(defmacro #export (^ tokens) +(defmacro' #export (^ tokens) (_lux_case tokens (#Cons [_ (#SymbolS "" class-name)] #Nil) (return (@list (form$ (@list (tag$ ["lux" "DataT"]) (text$ class-name))))) @@ -918,13 +918,13 @@ _ (fail "Wrong syntax for ^"))) -(defmacro #export (, tokens) +(defmacro' #export (, tokens) (return (@list (form$ (@list (tag$ ["lux" "TupleT"]) (foldL (lambda'' [tail head] (form$ (@list (tag$ ["lux" "Cons"]) head tail))) (tag$ ["lux" "Nil"]) (reverse tokens))))))) -(defmacro (lambda' tokens) +(defmacro' (lambda' tokens) (let'' [name tokens'] (_lux_: (, Text ($' List AST)) (_lux_case tokens (#Cons [[_ (#SymbolS ["" name])] tokens']) @@ -953,7 +953,7 @@ _ (fail "Wrong syntax for lambda'")))) -(defmacro (def''' tokens) +(defmacro' (def''' tokens) (_lux_case tokens (#Cons [[_ (#TagS ["" "export"])] (#Cons [[_ (#FormS (#Cons [name args]))] @@ -1005,7 +1005,7 @@ _ #Nil)) -(defmacro (let' tokens) +(defmacro' (let' tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [body #Nil])]) (return (@list (foldL (_lux_: (-> AST (, AST AST) @@ -1064,7 +1064,7 @@ #Nil ys)) -(defmacro #export ($ tokens) +(defmacro' #export ($ tokens) (_lux_case tokens (#Cons op (#Cons init args)) (return (@list (foldL (lambda' [a1 a2] (form$ (@list op a1 a2))) @@ -1125,7 +1125,7 @@ (#Right state' a) (f a state'))))}) -(defmacro (do tokens) +(defmacro' (do tokens) (_lux_case tokens (#Cons monad (#Cons [_ (#TupleS bindings)] (#Cons body #Nil))) (let' [g!wrap (symbol$ ["" "wrap"]) @@ -1171,7 +1171,7 @@ (wrap (#Cons y ys))) ))) -(defmacro #export (if tokens) +(defmacro' #export (if tokens) (_lux_case tokens (#Cons test (#Cons then (#Cons else #Nil))) (return (@list (form$ (@list (symbol$ ["" "_lux_case"]) test @@ -1279,19 +1279,19 @@ (-> Bool Text AST ($' Lux AST)) (_lux_case (_lux_: (, Bool AST) [replace? token]) [_ [_ (#BoolS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "BoolS"]) (bool$ value))))) [_ [_ (#IntS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (_meta (#IntS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "IntS"]) (int$ value))))) [_ [_ (#RealS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (_meta (#RealS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "RealS"]) (real$ value))))) [_ [_ (#CharS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (_meta (#CharS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "CharS"]) (char$ value))))) [_ [_ (#TextS value)]] - (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (_meta (#TextS value)))))) + (return (wrap-meta (form$ (@list (tag$ ["lux" "TextS"]) (text$ value))))) [_ [_ (#TagS [module name])]] (let' [module' (_lux_case module @@ -1353,31 +1353,31 @@ #Nil (#Left "Can't get the module name without a module!") - (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Cons {#name module-name #inner-closures _ #locals _ #closure _} _) (#Right [state module-name])))) -(defmacro #export (` tokens) +(defmacro' #export (` tokens) (_lux_case tokens (#Cons template #Nil) (do Lux/Monad [current-module get-module-name =template (untemplate true current-module template)] - (wrap (@list =template))) + (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ (fail "Wrong syntax for `"))) -(defmacro #export (' tokens) +(defmacro' #export (' tokens) (_lux_case tokens (#Cons template #Nil) (do Lux/Monad [=template (untemplate false "" template)] - (wrap (@list =template))) + (wrap (@list (form$ (@list (symbol$ ["" "_lux_:"]) (symbol$ ["lux" "AST"]) =template))))) _ (fail "Wrong syntax for '"))) -(defmacro #export (|> tokens) +(defmacro' #export (|> tokens) (_lux_case tokens (#Cons [init apps]) (return (@list (foldL (_lux_: (-> AST AST AST) @@ -1467,7 +1467,7 @@ (#Cons [x xs']) (list:++ (f x) (join-map f xs')))) -(defmacro #export (do-template tokens) +(defmacro' #export (do-template tokens) (_lux_case tokens (#Cons [[_ (#TupleS bindings)] (#Cons [[_ (#TupleS templates)] data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List AST)))) @@ -1688,7 +1688,7 @@ _ type)) -(defmacro #export (@type tokens) +(defmacro' #export (@type tokens) (_lux_case tokens (#Cons type #Nil) (do Lux/Monad @@ -1703,7 +1703,7 @@ _ (fail "Wrong syntax for @type"))) -(defmacro #export (: tokens) +(defmacro' #export (: tokens) (_lux_case tokens (#Cons type (#Cons value #Nil)) (return (@list (` (;_lux_: (@type (~ type)) (~ value))))) @@ -1711,7 +1711,7 @@ _ (fail "Wrong syntax for :"))) -(defmacro #export (:! tokens) +(defmacro' #export (:! tokens) (_lux_case tokens (#Cons type (#Cons value #Nil)) (return (@list (` (;_lux_:! (@type (~ type)) (~ value))))) @@ -1791,7 +1791,7 @@ #cursor cursor} (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) -(defmacro #export (Rec tokens) +(defmacro' #export (Rec tokens) (_lux_case tokens (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil)) (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)] @@ -1800,7 +1800,7 @@ _ (fail "Wrong syntax for Rec"))) -(defmacro #export (deftype tokens) +(defmacro' #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens (#Cons [_ (#TagS "" "export")] tokens') @@ -1872,7 +1872,7 @@ (fail "Wrong syntax for deftype")) )) -(defmacro #export (exec tokens) +(defmacro' #export (exec tokens) (_lux_case (reverse tokens) (#Cons value actions) (let' [dummy (symbol$ ["" ""])] @@ -1884,7 +1884,7 @@ _ (fail "Wrong syntax for exec"))) -(defmacro (def' tokens) +(defmacro' (def' tokens) (let' [[export? tokens'] (: (, Bool (List AST)) (_lux_case tokens (#Cons [_ (#TagS "" "export")] tokens') @@ -1979,7 +1979,7 @@ (let' [[left right] pair] (@list left right))) -(defmacro #export (case tokens) +(defmacro' #export (case tokens) (_lux_case tokens (#Cons value branches) (do Lux/Monad @@ -2007,7 +2007,7 @@ _ (fail "Wrong syntax for case"))) -(defmacro #export (\ tokens) +(defmacro' #export (\ tokens) (case tokens (#Cons body (#Cons pattern #Nil)) (do Lux/Monad @@ -2023,7 +2023,7 @@ _ (fail "Wrong syntax for \\"))) -(defmacro #export (\or tokens) +(defmacro' #export (\or tokens) (case tokens (#Cons body patterns) (case patterns @@ -2048,7 +2048,7 @@ _ false)) -(defmacro #export (let tokens) +(defmacro' #export (let tokens) (case tokens (\ (@list [_ (#TupleS bindings)] body)) (if (multiple? 2 (length bindings)) @@ -2067,7 +2067,7 @@ _ (fail "Wrong syntax for let"))) -(defmacro #export (lambda tokens) +(defmacro' #export (lambda tokens) (case (: (Maybe (, Ident AST (List AST) AST)) (case tokens (\ (@list [_ (#TupleS (#Cons head tail))] body)) @@ -2086,7 +2086,7 @@ (if (symbol? arg) (` (;_lux_lambda (~ g!blank) (~ arg) (~ body'))) (` (;_lux_lambda (~ g!blank) (~ g!blank) - (case (~ g!blank) (~ arg) (~ body'))))))) + (case (~ g!blank) (~ arg) (~ body'))))))) body (reverse tail)))] (return (@list (if (symbol? head) @@ -2096,7 +2096,7 @@ #None (fail "Wrong syntax for lambda"))) -(defmacro #export (def tokens) +(defmacro' #export (def tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens (#Cons [_ (#TagS "" "export")] tokens') @@ -2144,6 +2144,40 @@ #None (fail "Wrong syntax for def")))) +(defmacro' #export (defmacro tokens) + (let [[exported? tokens] (: (, Bool (List AST)) + (case tokens + (\ (@list& [_ (#TagS ["" "export"])] tokens')) + [true tokens'] + + _ + [false tokens])) + name+args+body?? (: (Maybe (, Ident (List AST) AST)) + (case tokens + (\ (@list [_ (#;FormS (@list& [_ (#SymbolS name)] args))] body)) + (#Some [name args body]) + + (\ (@list [_ (#;SymbolS name)] body)) + (#Some [name #Nil body]) + + _ + #None))] + (case name+args+body?? + (#Some [name args body]) + (let [name (symbol$ name) + decls (list:++ (: (List AST) (if exported? (@list (` (;_lux_export (~ name)))) #;Nil)) + (: (List AST) (@list (` (;;_lux_declare-macro (~ name)))))) + def-sig (: AST + (case args + #;Nil name + _ (` ((~ name) (~@ args)))))] + (return (@list& (` (;;def (~ def-sig) ;;Macro (~ body))) + decls))) + + + #None + (fail "Wrong syntax for defmacro")))) + (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens -- cgit v1.2.3 From 514d03851b20c2f8b818ee26194a93515a685ae5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 19:52:07 -0400 Subject: - Added type-inference when constructing tuples. --- source/lux.lux | 126 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 61 insertions(+), 65 deletions(-) (limited to 'source/lux.lux') 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] -- cgit v1.2.3 From 77aae538ed0d128e291292b5defe80967d181be9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 20:37:10 -0400 Subject: - Added the (untested) inference of tuple destructuring. - Removed several (unnecessary) type annotations. --- source/lux.lux | 143 +++++++++++++++++++++++++++------------------------------ 1 file changed, 67 insertions(+), 76 deletions(-) (limited to 'source/lux.lux') 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 ::")))) -- cgit v1.2.3 From dbbd680d0a47c64eeb2627d458c22e8ea16206d5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 9 Sep 2015 18:36:22 -0400 Subject: - Added type inference for functions. - Fixed a bug wherein the "case" macro ignored tokens when receiving uneven inputs. --- source/lux.lux | 46 ++++++++++++++++++++++++---------------------- 1 file changed, 24 insertions(+), 22 deletions(-) (limited to 'source/lux.lux') 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"))) -- cgit v1.2.3 From 113143d5d2e86185a8fca5214cfa57b4456bfbbb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 11 Sep 2015 01:37:26 -0400 Subject: - Updated the standard library. --- source/lux.lux | 171 ++++++++++----------------------------------------------- 1 file changed, 30 insertions(+), 141 deletions(-) (limited to 'source/lux.lux') 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)))))) -- cgit v1.2.3 From 5fd179352bbf25bbe4000ae51132fd5553ba256a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 15:06:14 -0400 Subject: - Primitive data-types can now be parameterized by other types. --- source/lux.lux | 43 +++++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 20 deletions(-) (limited to 'source/lux.lux') 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))))) -- cgit v1.2.3 From c9560da3760d0d277a715a966496451020f3f2f8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 22:36:34 -0400 Subject: - Added exhaustiveness testing for exception-handling code. - Added some optimizations for using List & Maybe within the compiler. --- source/lux.lux | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'source/lux.lux') 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) -- cgit v1.2.3 From 5dafb9ad900f990a14e280db2e00fb668a6606b9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 00:31:35 -0400 Subject: - Compiler now takes into consideration exceptions that can be thrown by constructors. - Changed the order of parameters in UnivQ & ExQ (even params are now arguments & odd params are now the UnivQ/ExQ types). --- source/lux.lux | 86 +++++++++++++++++++++++++++++----------------------------- 1 file changed, 43 insertions(+), 43 deletions(-) (limited to 'source/lux.lux') 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 -- cgit v1.2.3 From 79f2b2d51b8210d0a2bc81344ea82b4e5cbc7429 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 00:59:45 -0400 Subject: - The Macro type now flows from lux.lux into the compiler, to achieve a perfect match without having the write the type in 2 places. - Made the "Host" type fully opaque to avoid letting users manipulate instances. --- source/lux.lux | 23 +++-------------------- 1 file changed, 3 insertions(+), 20 deletions(-) (limited to 'source/lux.lux') 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) -- cgit v1.2.3 From 0f358c4052cf766a74b0354124736cb3652cda1d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 02:18:07 -0400 Subject: - :: no longer demands prefixes for the struct members - Fixed both lux/control/comonad;be & lux/codata/stream;\stream --- source/lux.lux | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'source/lux.lux') 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)))) _ -- cgit v1.2.3 From 6a84a06475463ffdaf3d6512696c7577afc8fed1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 16 Sep 2015 18:54:38 -0400 Subject: - Now the file-name & the line numbers are stored inside the .class files for debug info. --- source/lux.lux | 35 ++++++++++++++--------------------- 1 file changed, 14 insertions(+), 21 deletions(-) (limited to 'source/lux.lux') 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))) -- cgit v1.2.3 From 03bf7b58e6cf45b76b317369aa476443236658f9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 09:22:21 -0400 Subject: - Both method declarations & method definitions in classes can now include declarations of which exceptions they throw. --- source/lux.lux | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'source/lux.lux') 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"] -- cgit v1.2.3 From 506ec627005cca8a2e6f7c4fcf374634be3653de Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 18:10:00 -0400 Subject: - Added support for Java annotations. --- source/lux.lux | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'source/lux.lux') 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"] -- cgit v1.2.3 From 57ed0ef20db8f6ae926c1f7580f5bfa26928612b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 29 Sep 2015 07:40:29 -0400 Subject: - Returned to old format of type-environments where odds are arguments & evens are quantifiers. --- source/lux.lux | 86 +++++++++++++++++++++++++++++----------------------------- 1 file changed, 43 insertions(+), 43 deletions(-) (limited to 'source/lux.lux') 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 -- cgit v1.2.3 From 1ff2c6ced65171a68ef761275a75ba4dc56caf7b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 30 Sep 2015 16:44:42 -0400 Subject: - Changed the license in the project.clj file (had forgotten until now). - Some minor updates to the standard library. - Some minor bug fixes & improvements. - program.lux has been removed. --- source/lux.lux | 41 ++++++++++++++++++++++++++++++++--------- 1 file changed, 32 insertions(+), 9 deletions(-) (limited to 'source/lux.lux') 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]) -- cgit v1.2.3