diff options
33 files changed, 2825 insertions, 534 deletions
diff --git a/input/lux.lux b/input/lux.lux index 282ca97b1..de407bafe 100644 --- a/input/lux.lux +++ b/input/lux.lux @@ -126,6 +126,7 @@ ## (, Text Int Int)) (_lux_def Cursor (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) +(_lux_export Cursor) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) @@ -234,6 +235,7 @@ (#Cons [["lux;MacroD" (#BoundT "")] (#Cons [["lux;AliasD" Ident] #Nil])])])]))])) +(_lux_export DefData') ## (deftype LuxVar ## (| (#Local Int) @@ -341,32 +343,32 @@ (_lux_lambda _ state (#Left msg))))) -(_lux_def $text +(_lux_def text$ (_lux_: (#LambdaT [Text Syntax]) (_lux_lambda _ text (_meta (#TextS text))))) -(_lux_def $symbol +(_lux_def symbol$ (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident (_meta (#SymbolS ident))))) -(_lux_def $tag +(_lux_def tag$ (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident (_meta (#TagS ident))))) -(_lux_def $form +(_lux_def form$ (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) (_lux_lambda _ tokens (_meta (#FormS tokens))))) -(_lux_def $tuple +(_lux_def tuple$ (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) (_lux_lambda _ tokens (_meta (#TupleS tokens))))) -(_lux_def $record +(_lux_def record$ (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) (_lux_lambda _ tokens (_meta (#RecordS tokens))))) @@ -376,7 +378,7 @@ (_lux_lambda _ tokens (_lux_case tokens (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (return (#Cons [($form (#Cons [($symbol ["" "_lux_case"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) #Nil])) @@ -439,7 +441,7 @@ (#Cons [body #Nil])])])]))) #Nil])])]))) #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) @@ -450,7 +452,7 @@ (#Cons [body #Nil])])]))) #Nil])])]))) - (#Cons [(_meta (#FormS (#Cons [($symbol ["" "_lux_export"]) (#Cons [name #Nil])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) #Nil])])) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) @@ -482,28 +484,28 @@ )))) (_lux_declare-macro def') -(def' #export (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'"]) - (#Cons [($form (#Cons [name args])) - (#Cons [($symbol ["lux" "Macro"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [(form$ (#Cons [name args])) + (#Cons [(symbol$ ["lux" "Macro"]) (#Cons [body #Nil])]) ])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #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])) - (#Cons [($symbol ["lux" "Macro"]) + (return (#Cons [(form$ (#Cons [(symbol$ ["lux" "def'"]) + (#Cons [(tag$ ["" "export"]) + (#Cons [(form$ (#Cons [name args])) + (#Cons [(symbol$ ["lux" "Macro"]) (#Cons [body #Nil])]) ])])])) - (#Cons [($form (#Cons [($symbol ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) #Nil])])) _ @@ -585,7 +587,7 @@ _ (fail "Wrong syntax for $'"))) -(def' #export (foldL f init xs) +(def' (foldL f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) @@ -598,27 +600,14 @@ (#Cons [x xs']) (foldL f (f init x) xs'))) -(def' #export (foldR f init xs) - (All' [a b] - (->' (->' (B' b) (B' a) (B' a)) - (B' a) - ($' List (B' b)) - (B' a))) - (_lux_case xs - #Nil - init - - (#Cons [x xs']) - (f x (foldR f init xs')))) - -(def' #export (reverse list) +(def' (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) (foldL (lambda' [tail head] (#Cons [head tail])) #Nil list)) -(defmacro #export (list xs) +(defmacro (list xs) (return (#Cons [(foldL (lambda' [tail head] (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) @@ -627,7 +616,7 @@ (reverse xs)) #Nil]))) -(defmacro #export (list& xs) +(defmacro (list& xs) (_lux_case (reverse xs) (#Cons [last init]) (return (list (foldL (lambda' [tail head] @@ -654,12 +643,12 @@ (fail "lambda requires a non-empty arguments tuple.") (#Cons [harg targs]) - (return (list ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol name) + (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ name) harg (foldL (lambda' [body' arg] - ($form (list ($symbol ["" "_lux_lambda"]) - ($symbol ["" ""]) + (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) arg body'))) body @@ -673,39 +662,39 @@ (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) name - ($form (list ($symbol ["" "_lux_:"]) + (form$ (list (symbol$ ["" "_lux_:"]) type - ($form (list ($symbol ["lux" "lambda"]) + (form$ (list (symbol$ ["lux" "lambda"]) name - ($tuple args) + (tuple$ args) body)))))) - ($form (list ($symbol ["" "_lux_export"]) name)))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) name - ($form (list ($symbol ["" "_lux_:"]) + (form$ (list (symbol$ ["" "_lux_:"]) type body)))) - ($form (list ($symbol ["" "_lux_export"]) name)))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) name - ($form (list ($symbol ["" "_lux_:"]) + (form$ (list (symbol$ ["" "_lux_:"]) type - ($form (list ($symbol ["lux" "lambda"]) + (form$ (list (symbol$ ["lux" "lambda"]) name - ($tuple args) + (tuple$ args) body)))))))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) - (return (list ($form (list ($symbol ["" "_lux_def"]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) name - ($form (list ($symbol ["" "_lux_:"]) type body)))))) + (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) _ (fail "Wrong syntax for def") @@ -729,16 +718,14 @@ (lambda [body binding] (_lux_case binding [label value] - (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) body - (foldL (lambda [tail head] (#Cons [head tail])) - #Nil - (as-pairs bindings))))) + (reverse (as-pairs bindings))))) _ (fail "Wrong syntax for let"))) -(def'' #export (map f xs) +(def'' (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (_lux_case xs @@ -748,7 +735,7 @@ (#Cons [x xs']) (#Cons [(f x) (map f xs')]))) -(def'' #export (any? p xs) +(def'' (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (_lux_case xs @@ -785,7 +772,7 @@ (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) (_meta (#TupleS (list token (untemplate-list tokens'))))))))) -(def'' (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']) @@ -797,7 +784,7 @@ (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))) @@ -814,35 +801,36 @@ spliced _ - ($form (list ($symbol ["" "_lux_:"]) - ($symbol ["lux" "SyntaxList"]) - ($form (list ($symbol ["lux" "list"]) (untemplate elem))))))) + (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:++"]) + (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) elems')))))) false - (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) (def'' (untemplate subst token) (->' Text Syntax Syntax) (_lux_case token (#Meta [_ (#BoolS value)]) - (wrap-meta ($form (list ($tag ["lux" "BoolS"]) (_meta (#BoolS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "BoolS"]) (_meta (#BoolS value))))) (#Meta [_ (#IntS value)]) - (wrap-meta ($form (list ($tag ["lux" "IntS"]) (_meta (#IntS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "IntS"]) (_meta (#IntS value))))) (#Meta [_ (#RealS value)]) - (wrap-meta ($form (list ($tag ["lux" "RealS"]) (_meta (#RealS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "RealS"]) (_meta (#RealS value))))) (#Meta [_ (#CharS value)]) - (wrap-meta ($form (list ($tag ["lux" "CharS"]) (_meta (#CharS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "CharS"]) (_meta (#CharS value))))) (#Meta [_ (#TextS value)]) - (wrap-meta ($form (list ($tag ["lux" "TextS"]) (_meta (#TextS value))))) + (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) (#Meta [_ (#TagS [module name])]) (let [module' (_lux_case module @@ -851,7 +839,7 @@ _ module)] - (wrap-meta ($form (list ($tag ["lux" "TagS"]) ($tuple (list ($text module') ($text name))))))) + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) (#Meta [_ (#SymbolS [module name])]) (let [module' (_lux_case module @@ -860,23 +848,23 @@ _ module)] - (wrap-meta ($form (list ($tag ["lux" "SymbolS"]) ($tuple (list ($text module') ($text name))))))) + (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) (#Meta [_ (#TupleS elems)]) - (splice (untemplate subst) ($tag ["lux" "TupleS"]) elems) + (splice (untemplate subst) (tag$ ["lux" "TupleS"]) elems) (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) unquoted (#Meta [_ (#FormS elems)]) - (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) + (splice (untemplate subst) (tag$ ["lux" "FormS"]) elems) (#Meta [_ (#RecordS fields)]) - (wrap-meta ($form (list ($tag ["lux" "RecordS"]) + (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 subst k) (untemplate subst v)))))) + (tuple$ (list (untemplate subst k) (untemplate subst v)))))) fields))))) )) @@ -893,8 +881,11 @@ (#Cons [init apps]) (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))) + (form$ (list:++ parts (list acc))) _ (`' ((~ app) (~ acc))))) @@ -982,7 +973,7 @@ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) - (return (list (`' (#;TupleT (;list (~@ tokens))))))) + (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) (defmacro (do tokens) (_lux_case tokens @@ -995,7 +986,7 @@ (`' (;let (~ value) (~ body'))) _ - (`' (;bind (_lux_lambda (~ ($symbol ["" ""])) + (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) (~ var) (~ body')) (~ value))))))) @@ -1066,7 +1057,7 @@ _ #Nil)) -(def'' (text:= x y) +(def'' #export (text:= x y) (-> Text Text Bool) (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] x [y])) @@ -1094,13 +1085,13 @@ template) (#Meta [_ (#TupleS elems)]) - ($tuple (map (apply-template env) elems)) + (tuple$ (map (apply-template env) elems)) (#Meta [_ (#FormS elems)]) - ($form (map (apply-template env) elems)) + (form$ (map (apply-template env) elems)) (#Meta [_ (#RecordS members)]) - ($record (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) (lambda [kv] (let [[slot value] kv] [(apply-template env slot) (apply-template env value)]))) @@ -1133,7 +1124,7 @@ return)) _ - (fail "All the do-template bindigns must be symbols.")) + (fail "Wrong syntax for do-template")) _ (fail "Wrong syntax for do-template"))) @@ -1151,6 +1142,19 @@ [real:< _jvm_dlt Real] ) +(do-template [<name> <cmp> <eq> <type>] + [(def'' #export (<name> x y) + (-> <type> <type> Bool) + (if (<cmp> x y) + true + (<eq> x y)))] + + [ int:>= int:> int:= Int] + [ int:<= int:< int:= Int] + [real:>= real:> real:= Real] + [real:<= real:< real:= Real] + ) + (do-template [<name> <cmp> <type>] [(def'' #export (<name> x y) (-> <type> <type> <type>) @@ -1172,7 +1176,7 @@ (-> Int Int Bool) (int:= 0 (int:% n div))) -(def'' #export (length list) +(def'' (length list) (-> List Int) (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) @@ -1236,13 +1240,14 @@ (#Cons [harg targs]) (let [replacements (map (_lux_: (-> Text (, Text Syntax)) - (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) + (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) (list& self-ident idents)) body' (foldL (lambda [body' arg'] - (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')]))) + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) (replace-syntax replacements body) (reverse targs))] - (return (list (`' (#;AllT [(#;Some #;Nil) (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))) + ## (#;Some #;Nil) + (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) #None (fail "'All' arguments must be symbols.")) @@ -1263,7 +1268,19 @@ #Nil #None)) -(def'' #export (get-module-name state) +(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'' (get-module-name state) ($' Lux Text) (_lux_case state {#source source #modules modules @@ -1298,7 +1315,7 @@ _ #None))) -(def'' #export (find-macro ident) +(def'' (find-macro ident) (-> Ident ($' Lux ($' Maybe Macro))) (do Lux:Monad [current-module get-module-name] @@ -1315,7 +1332,7 @@ (-> ($' List ($' List a)) ($' List a))) (foldL list:++ #Nil xs)) -(def'' #export (normalize ident) +(def'' (normalize ident) (-> Ident ($' Lux Ident)) (_lux_case ident ["" name] @@ -1335,17 +1352,17 @@ (#Meta [_ (#TagS ident)]) (do Lux:Monad [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text 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)]))) + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for |")))) tokens)] - (;return (list (`' (#;VariantT (;list (~@ pairs)))))))) + (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) (defmacro #export (& tokens) (if (not (multiple? 2 (length tokens))) @@ -1358,18 +1375,18 @@ [(#Meta [_ (#TagS ident)]) value] (do Lux:Monad [ident (normalize ident)] - (;return (`' [(~ ($text (ident->text ident))) (~ value)]))) + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) _ (fail "Wrong syntax for &")))) (as-pairs tokens))] - (;return (list (`' (#;RecordT (;list (~@ pairs))))))))) + (;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'' #export (interpose sep xs) +(def'' (interpose sep xs) (All [a] (-> a ($' List a) ($' List a))) (_lux_case xs @@ -1382,49 +1399,7 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def'' #export (syntax:show syntax) - (-> Syntax Text) - (_lux_case syntax - (#Meta [_ (#BoolS value)]) - (->text value) - - (#Meta [_ (#IntS value)]) - (->text value) - - (#Meta [_ (#RealS value)]) - (->text value) - - (#Meta [_ (#CharS value)]) - ($ text:++ "#\"" (->text value) "\"") - - (#Meta [_ (#TextS value)]) - value - - (#Meta [_ (#SymbolS ident)]) - (ident->text ident) - - (#Meta [_ (#TagS ident)]) - (text:++ "#" (ident->text ident)) - - (#Meta [_ (#TupleS members)]) - ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]") - - (#Meta [_ (#FormS members)]) - ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")") - - (#Meta [_ (#RecordS slots)]) - ($ text:++ "{" - (|> slots - (map (_lux_: (-> (, Syntax Syntax) Text) - (lambda [slot] - (let [[k v] slot] - ($ text:++ (syntax:show k) " " (syntax:show v)))))) - (interpose " ") - (foldL text:++ "")) - "}") - )) - -(def'' #export (macro-expand syntax) +(def'' (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (_lux_case syntax (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) @@ -1440,19 +1415,19 @@ #None (do Lux:Monad - [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] - (;return (list ($form (list:join parts'))))))) + [parts' (map% Lux:Monad macro-expand (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)] - (;return (list ($form (list:++ harg+ (list:join targs+)))))) + (;return (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] - (;return (list ($tuple (list:join members'))))) + (;return (list (tuple$ (list:join members'))))) _ (return (list syntax)))) @@ -1461,10 +1436,10 @@ (-> Syntax Syntax) (_lux_case type (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) - ($form (#Cons [($tag tag) (map walk-type parts)])) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) (#Meta [_ (#TupleS members)]) - ($tuple (map walk-type members)) + (tuple$ (map walk-type members)) (#Meta [_ (#FormS (#Cons [type-fn args]))]) (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) @@ -1474,7 +1449,7 @@ _ type)) -(defmacro #export (type` tokens) +(defmacro #export (type tokens) (_lux_case tokens (#Cons [type #Nil]) (do Lux:Monad @@ -1484,15 +1459,15 @@ (;return (list (walk-type type'))) _ - (fail "type`: The expansion of the type-syntax had to yield a single element."))) + (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 :"))) @@ -1500,7 +1475,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 :!"))) @@ -1516,10 +1491,10 @@ parts (: (Maybe (, Syntax (List Syntax) Syntax)) (_lux_case tokens' (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) - (#Some [($symbol name) #Nil type]) + (#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))] @@ -1536,29 +1511,17 @@ _ (`' (;All (~ name) [(~@ args)] (~ type)))))] - (return (list& (`' (_lux_def (~ name) (;type` (~ type')))) + (return (list& (`' (_lux_def (~ name) (;type (~ type')))) with-export))) #None (fail "Wrong syntax for deftype")) )) -(deftype #export (IO a) - (-> (,) a)) - -(defmacro #export (io tokens) - (_lux_case tokens - (#Cons [value #Nil]) - (let [blank ($symbol ["" ""])] - (return (list (`' (_lux_lambda (~ blank) (~ blank) (~ value)))))) - - _ - (fail "Wrong syntax for io"))) - (defmacro #export (exec tokens) (_lux_case (reverse tokens) (#Cons [value actions]) - (let [dummy ($symbol ["" ""])] + (let [dummy (symbol$ ["" ""])] (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) value actions)))) @@ -1626,16 +1589,16 @@ [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)))))) + (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))))))) @@ -1680,11 +1643,6 @@ [inc 1] [dec -1]) -(def (int:show int) - (-> Int Text) - (_jvm_invokevirtual java.lang.Object toString [] - int [])) - (defmacro #export (` tokens) (do Lux:Monad [module-name get-module-name] @@ -1695,7 +1653,7 @@ _ (fail "Wrong syntax for `")))) -(def #export (gensym prefix state) +(def (gensym prefix state) (-> Text (Lux Syntax)) (case state {#source source #modules modules @@ -1704,9 +1662,9 @@ (#Right [{#source source #modules modules #envs envs #types types #host host #seed (inc seed) #seen-sources seen-sources #eval? eval?} - ($symbol ["__gensym__" (int:show seed)])]))) + (symbol$ ["__gensym__" (->text seed)])]))) -(def #export (macro-expand-1 token) +(def (macro-expand-1 token) (-> Syntax (Lux Syntax)) (do Lux:Monad [token+ (macro-expand token)] @@ -1719,7 +1677,7 @@ (defmacro #export (sig tokens) (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) + [tokens' (map% Lux:Monad macro-expand tokens) members (map% Lux:Monad (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] @@ -1731,13 +1689,13 @@ _ (fail "Signatures require typed members!")))) - tokens')] - (;return (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) - (lambda [pair] - (let [[name type] pair] - (`' [(~ (|> name ident->text $text)) - (~ type)])))) - 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))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1776,7 +1734,7 @@ (defmacro #export (struct tokens) (do Lux:Monad - [tokens' (map% Lux:Monad macro-expand-1 tokens) + [tokens' (map% Lux:Monad macro-expand tokens) members (map% Lux:Monad (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] @@ -1784,12 +1742,12 @@ (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) (do Lux:Monad [name' (normalize name)] - (;return (: (, Syntax Syntax) [($tag name') value]))) + (;return (: (, Syntax Syntax) [(tag$ name') value]))) _ (fail "Structures require defined members!")))) - tokens')] - (;return (list ($record members))))) + (list:join tokens'))] + (;return (list (record$ members))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) @@ -1824,48 +1782,12 @@ #Nil)))) #None - (fail "Wrong syntax for defsig")))) - -(defsig #export (Eq a) - (: (-> a a Bool) - =)) - -(do-template [<name> <type> <test>] - [(defstruct #export <name> (Eq <type>) - (def (= x y) - (<test> x y)))] - - [Int:Eq Int _jvm_leq] - [Real:Eq Real _jvm_deq]) + (fail "Wrong syntax for defstruct")))) (def #export (id x) (All [a] (-> a a)) x) -(defsig #export (Show a) - (: (-> a Text) - show)) - -(do-template [<name> <type> <body>] - [(defstruct #export <name> (Show <type>) - (def (show x) - <body>))] - - [Bool:Show Bool (->text x)] - [Int:Show Int (->text x)] - [Real:Show Real (->text x)] - [Char:Show Char ($ text:++ "#\"" (->text x) "\"")]) - -(defsig #export (Ord a) - (: (-> a a Bool) - <) - (: (-> a a Bool) - <=) - (: (-> a a Bool) - >) - (: (-> a a Bool) - >=)) - (do-template [<name> <form> <message>] [(defmacro #export (<name> tokens) (case (reverse tokens) @@ -1877,80 +1799,152 @@ _ (fail <message>)))] - [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] - [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) - -(do-template [<name> <type> <lt> <gt> <eq>] - [(defstruct #export <name> (Ord <type>) - (def (< x y) - (<lt> x y)) - - (def (<= x y) - (or (<lt> x y) - (<eq> x y))) - - (def (> x y) - (<gt> x y)) - - (def (>= x y) - (or (<gt> x y) - (<eq> x y))))] - - [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] - [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) - -(defmacro #export (lux tokens state) + [and (if (~ pre) (~ post) false) "and requires >=1 clauses."] + [or (if (~ pre) true (~ post)) "or requires >=1 clauses."]) + +(deftype Referrals + (| #All + (#Only (List Text)) + (#Except (List Text)) + #Nothing)) + +(deftype Import + (, Text (Maybe Text) Referrals)) + +(def (extract-defs defs) + (-> (List Syntax) (Lux (List Text))) + (map% Lux:Monad + (: (-> Syntax (Lux Text)) + (lambda [def] + (case def + (#Meta [_ (#SymbolS ["" name])]) + (return name) + + _ + (fail "only/except requires symbols.")))) + defs)) + +(def (parse-alias tokens) + (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) + (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) + + _ + (return (: (, (Maybe Text) (List Syntax)) [#None tokens])))) + +(def (parse-referrals tokens) + (-> (List Syntax) (Lux (, Referrals (List Syntax)))) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) + (case referral + (#Meta [_ (#TagS ["" "all"])]) + (return (: (, Referrals (List Syntax)) [#All tokens'])) + + (\ (#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 ["" "except"])]) defs))])) + (do Lux:Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Except defs') tokens']))) + + _ + (fail "Incorrect syntax for referral.")) + + _ + (return (: (, Referrals (List Syntax)) [#Nothing tokens])))) + +(def (decorate-imports super-name tokens) + (-> Text (List Syntax) (Lux (List Syntax))) + (map% Lux:Monad + (: (-> Syntax (Lux Syntax)) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" sub-name])]) + (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) + (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) + + _ + (fail "Wrong import syntax.")))) + tokens)) + +(def (parse-imports imports) + (-> (List Syntax) (Lux (List Import))) + (do Lux:Monad + [referrals' (map% Lux:Monad + (: (-> Syntax (Lux (List Import))) + (lambda [token] + (case token + (#Meta [_ (#SymbolS ["" m-name])]) + (;return (list [m-name #None #All])) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (do Lux:Monad + [alias+extra' (parse-alias extra) + #let [[alias extra'] (: (, (Maybe Text) (List Syntax)) + alias+extra')] + referral+extra'' (parse-referrals extra') + #let [[referral extra''] (: (, Referrals (List Syntax)) + referral+extra'')] + extra''' (decorate-imports m-name extra'') + sub-imports (parse-imports extra''')] + (;return (case referral + #Nothing (case alias + #None sub-imports + (#Some _) (list& [m-name alias referral] sub-imports)) + _ (list& [m-name alias referral] sub-imports)))) + + _ + (fail "Wrong syntax for import")))) + imports)] + (;return (list:join referrals')))) + +(def (module-exists? module state) + (-> Text (Lux Bool)) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #types types #host host #seed seed #seen-sources seen-sources #eval? eval?} - (case (get "lux" modules) - (#Some lux) + (case (get module modules) + (#Some =module) + (#Right [state true]) + + #None + (#Right [state false])) + )) + +(def (exported-defs module state) + (-> Text (Lux (List Text))) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (case (get module modules) + (#Some =module) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] (if export? - (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [($ text:++ "Importing: " name "\n")]) - (list name)) + (list name) (list))))) - (let [{#module-aliases _ #defs defs #imports _} lux] + (let [{#module-aliases _ #defs defs #imports _} =module] defs))] - (#Right [state (map (lambda [name] - (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name]))))) - (list:join to-alias))])) + (#Right [state (list:join to-alias)])) #None - (#Left "Uh, oh... The universe is not working properly...")) + (#Left ($ text:++ "Unknown module: " module))) )) -(def #export (print x) - (-> Text (IO (,))) - (lambda [_] - (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] - (_jvm_getstatic java.lang.System out) [x]) - []))) - -(def #export (println x) - (-> Text (IO (,))) - (print (text:++ x "\n"))) - -(def #export (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) @@ -1967,6 +1961,177 @@ (_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 (int:< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module))))])) + +(def (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (int:< idx 0) + (#Cons [module #Nil]) + (#Cons [(substring2 0 idx module) + (split-module (substring1 (inc idx) module))])))) + +(def (@ idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (if (int:= idx 0) + (#Some x) + (@ (dec idx) xs') + ))) + +(def (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) + (case xs + #Nil + [ys xs] + + (#Cons [x xs']) + (if (p x) + (split-with' p (list& x ys) xs') + [ys xs]))) + +(def (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) (, (List a) (List a)))) + (let [[ys' xs'] (split-with' p #Nil xs)] + [(reverse ys') xs'])) + +(def (clean-module module) + (-> Text (Lux Text)) + (do Lux:Monad + [module-name get-module-name] + (case (split-module module) + (\ (list& "." parts)) + (return (|> (list& module-name parts) (interpose "/") (foldL text:++ ""))) + + parts + (let [[ups parts'] (split-with (text:= "..") parts) + num-ups (length ups)] + (if (int:= num-ups 0) + (return module) + (case (@ num-ups (split-module-contexts module-name)) + #None + (fail (text:++ "Can't clean module: " module)) + + (#Some top-module) + (return (|> (list& top-module parts') (interpose "/") (foldL text:++ "")))) + ))) + )) + +(def (filter p xs) + (All [a] (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def (is-member? cases name) + (-> (List Text) Text Bool) + (let [output (foldL (lambda [prev case] + (or prev + (text:= case name))) + false + 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] + (do Lux:Monad + [m-name (clean-module m-name)] + (;return (: Import [m-name m-alias m-referrals])))))) + imports) + unknowns' (map% Lux:Monad + (: (-> Import (Lux (List Text))) + (lambda [import] + (case import + [m-name _ _] + (do Lux:Monad + [? (module-exists? m-name)] + (;return (if ? + (list) + (list m-name))))))) + imports) + #let [unknowns (list:join unknowns')]] + (case unknowns + #Nil + (do Lux:Monad + [output' (map% Lux:Monad + (: (-> Import (Lux (List Syntax))) + (lambda [import] + (case import + [m-name m-alias m-referrals] + (do Lux:Monad + [defs (case m-referrals + #All + (exported-defs m-name) + + (#Only +defs) + (do Lux:Monad + [*defs (exported-defs m-name)] + (;return (filter (is-member? +defs) *defs))) + + (#Except -defs) + (do Lux:Monad + [*defs (exported-defs m-name)] + (;return (filter (. not (is-member? -defs)) *defs))) + + #Nothing + (;return (list)))] + (;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 Syntax) + (lambda [def] + (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) + defs))))))) + imports)] + (;return (list:join output'))) + + _ + (;return (: (List Syntax) + (list:++ (map (lambda [m-name] + (` (_lux_import (~ (text$ m-name))))) + 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) @@ -1974,6 +2139,154 @@ name (substring1 (inc 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 + )) + +(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)) + (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 @@ -1981,7 +2294,7 @@ (#Some type) (#AppT [fun arg]) - (resolve-struct-type fun) + (apply-type fun arg) (#AllT [_ _ _ body]) (resolve-struct-type body) @@ -1989,55 +2302,160 @@ _ #None)) -(defmacro #export (using tokens state) +(def (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def (try-both% x1 x2) + (All [a b] + (-> (Maybe a) (Maybe a) (Maybe a))) + (case x1 + #;None x2 + (#;Some _) x1)) + +(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 #seen-sources seen-sources #eval? eval?} + (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) + (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#Some type) + #None)))) + closure)) + ## (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + ## (lambda [binding] + ## (let [[bname [_ type]] binding] + ## (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + ## (_jvm_getstatic java.lang.System out) [($ text:++ "find-in-env #2: " bname "\n")]) + ## (if (text:= vname' bname) + ## (#Some type) + ## #None))))) + ## locals) + ))) + 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 + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} state] + (case (get v-prefix modules) + #None + #None + + (#Some {#defs defs #module-aliases _ #imports _}) + (case (get v-name defs) + #None + #None + + (#Some [_ def-data]) + (case def-data + #TypeD (#Some Type) + (#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 #seen-sources seen-sources #eval? eval?} state] +## (do Maybe:Monad +## [module (get v-prefix modules) +## #let [{#defs defs #module-aliases _ #imports _} module] +## def (get v-name defs) +## #let [[_ def-data] def]] +## (case def-data +## #TypeD (;return Type) +## (#ValueD type) (;return type) +## (#MacroD m) (;return Macro) +## (#AliasD name') (find-in-defs name' state)))))) + +(def (find-var-type name) + (-> Ident (Lux Type)) + (do Lux:Monad + [name' (normalize name)] + (lambda [state] + (case (find-in-env name state) + (#Some struct-type) + (#Right [state struct-type]) + + _ + (case (find-in-defs name' state) + (#Some struct-type) + (#Right [state struct-type]) + + _ + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} state] + (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) + +(defmacro #export (using tokens) (case tokens (\ (list struct body)) (case struct - (#Meta [_ (#SymbolS vname)]) - (let [vname' (ident->text vname)] - (case state - {#source source #modules modules - #envs envs #types types #host host - #seed seed #seen-sources seen-sources #eval? eval?} - (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _} - (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#Some type) - #None)))) - mappings)))) - envs)] - (case ?struct-type - #None - (#Left ($ text:++ "Unknown structure: " vname')) - - (#Some struct-type) - (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])]))) - slots))] - (#Right [state (list (` (_lux_case (~ struct) (~ pattern) (~ body))))])) - - _ - (#Left "Can only \"use\" records.")))))) + (#Meta [_ (#SymbolS name)]) + (do Lux:Monad + [struct-type (find-var-type name)] + (case (resolve-struct-type struct-type) + (#Some (#RecordT slots)) + (let [pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [slot] + (let [[sname stype] slot + full-name (split-slot sname)] + [(tag$ full-name) (symbol$ full-name)]))) + slots))] + (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) + _ + (fail "Can only \"use\" records."))) + _ - (let [dummy ($symbol ["" ""])] - (#Right [state (list (` (_lux_case (~ struct) - (~ dummy) - (using (~ dummy) - (~ body)))))]))) + (let [dummy (symbol$ ["" ""])] + (return (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body)))))))) _ - (#Left "Wrong syntax for defsig"))) + (fail "Wrong syntax for using"))) (def #export (flip f) (All [a b c] @@ -2045,60 +2463,244 @@ (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 [[x y]] -## (f x y))) - -## (defmacro (loop tokens) -## (_lux_case tokens -## (#Cons [bindings (#Cons [body #Nil])]) -## (let [pairs (as-pairs bindings)] -## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs))) -## (~ body))) -## (map second pairs)]))))))) - -## (defmacro (get@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [record #Nil])]) -## (` (get@' (~ tag) (~ record))) - -## (#Cons [tag #Nil]) -## (` (lambda [record] (get@' (~ tag) record))))] -## (return (list output)))) - -## (defmacro (set@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) -## (` (set@' (~ tag) (~ value) (~ record))) - -## (#Cons [tag (#Cons [value #Nil])]) -## (` (lambda [record] (set@' (~ tag) (~ value) record))) - -## (#Cons [tag #Nil]) -## (` (lambda [value record] (set@' (~ tag) value record))))] -## (return (list output)))) - -## (defmacro (update@ tokens) -## (let [output (_lux_case tokens -## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) -## (` (let [_record_ (~ record)] -## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) - -## (#Cons [tag (#Cons [func #Nil])]) -## (` (lambda [record] -## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) - -## (#Cons [tag #Nil]) -## (` (lambda [func record] -## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] -## (return (list output)))) +(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 (int:= 0 (int:% (length tokens) 2)) + (fail "cond requires an even number of arguments.") + (case (reverse tokens) + (\ (list& else branches')) + (return (list (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [else branch] + (let [[right left] branch] + (` (if (~ left) (~ right) (~ else)))))) + else + (as-pairs branches')))) + + _ + (fail "Wrong syntax for cond")))) + +(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 (#RecordT slots)) + (do Lux:Monad + [slot (normalize slot')] + (let [[s-prefix s-name] (: Ident slot) + pattern (record$ (map (: (-> (, Text Type) (, Syntax Syntax)) + (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))))))) + + _ + (fail "get@ can only use records."))) + + _ + (do Lux:Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (get@ (~ (tag$ slot')) (~ _record)))))))) + + _ + (fail "Wrong syntax for get@"))) + +(defmacro #export (open tokens) + (case tokens + (\ (list (#Meta [_ (#SymbolS struct-name)]))) + (do Lux:Monad + [struct-type (find-var-type 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$ ["" name])) + (get@ (~ (tag$ [module name])) (~ (symbol$ struct-name)))))))) + slots)) + + _ + (fail "Can only \"open\" records."))) + + _ + (fail "Wrong syntax for open"))) + +(def (foldL% M f x ys) + (All [m a b] + (-> (Monad m) (-> a b (m a)) a (List b) + (m a))) + (case ys + (#Cons [y ys']) + (do M + [x' (f x y)] + (foldL% M f x' ys')) + + #Nil + ((get@ #return M) x))) + +(defmacro #export (:: tokens) + (case tokens + (\ (list& start parts)) + (do Lux:Monad + [output (foldL% Lux:Monad + (: (-> Syntax Syntax (Lux Syntax)) + (lambda [so-far part] + (case part + (#Meta [_ (#SymbolS slot)]) + (return (` (get@ (~ (tag$ slot)) (~ so-far)))) + + (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) + (return (` ((get@ (~ (tag$ slot)) (~ so-far)) + (~@ args)))) + + _ + (fail "Wrong syntax for ::")))) + start parts)] + (return (list output))) + + _ + (fail "Wrong syntax for ::"))) + +(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 (#RecordT slots)) + (do Lux:Monad + [pattern' (map% Lux:Monad + (: (-> (, Text Type) (Lux (, Text Syntax))) + (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 Syntax) (, Syntax Syntax)) + (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)) + (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))))))) + + _ + (fail "set@ can only use records."))) + + _ + (do Lux:Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) + + _ + (fail "Wrong syntax for set@"))) + +(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 (#RecordT slots)) + (do Lux:Monad + [pattern' (map% Lux:Monad + (: (-> (, Text Type) (Lux (, Text Syntax))) + (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 Syntax) (, Syntax Syntax)) + (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)) + (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))))))) + + _ + (fail "update@ can only use records."))) + + _ + (do Lux:Monad + [_record (gensym "")] + (return (list (` (let [(~ _record) (~ record)] + (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) + + _ + (fail "Wrong syntax for update@"))) + +## (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"))) diff --git a/input/lux/codata/stream.lux b/input/lux/codata/stream.lux new file mode 100644 index 000000000..1bfd19292 --- /dev/null +++ b/input/lux/codata/stream.lux @@ -0,0 +1,63 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (control (lazy #as L #refer #all)))) + +## Types +(deftype #export (Stream a) + (Lazy (, a (Stream a)))) + +## Functions +(def #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (... [x (iterate f (f x))])) + +## (def #export (take n xs) +## (All [a] +## (-> Int (Stream a) (List a))) +## (if (int:> n 0) +## (let [[x xs'] (! xs)] +## (list& x (take (dec n) xs'))) +## (list))) + +## (def #export (drop n xs) +## (All [a] +## (-> Int (Stream a) (Stream a))) +## (if (int:> n 0) +## (drop (dec n) (get@ 1 (! xs))) +## xs)) + +## Pattern-matching +## (defmacro #export (\stream tokens) +## (case tokens +## (\ (list& body patterns')) +## (do Lux:Monad +## [patterns (map% Lux:Monad M;macro-expand-1 patterns') +## g!s (M;gensym "s") +## #let [patterns+ (do List:Monad +## [pattern (reverse patterns)] +## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]] +## (wrap (list g!s +## (` (;let [(~@ patterns+)] +## (~ body)))))) + +## _ +## "Wrong syntax for \stream")) + +## (defsyntax #export (\stream body [patterns' (+$ id$)]) +## (do Lux:Monad +## [patterns (map% Lux:Monad M;macro-expand-1 patterns') +## g!s (M;gensym "s") +## #let [patterns+ (do List:Monad +## [pattern (reverse patterns)] +## (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s)))))]] +## (wrap (list g!s +## (` (;let [(~@ patterns+)] +## (~ body))))))) diff --git a/input/lux/control/comonad.lux b/input/lux/control/comonad.lux new file mode 100644 index 000000000..1830ff44f --- /dev/null +++ b/input/lux/control/comonad.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../functor #as F) + lux/data/list + lux/meta/macro) + +## Signatures +(defsig #export (CoMonad w) + (: (F;Functor w) + _functor) + (: (All [a] + (-> (w a) a)) + unwrap) + (: (All [a] + (-> (w a) (w (w a)))) + split)) + +## Functions +(def #export (extend w f ma) + (All [w a b] + (-> (CoMonad w) (-> (w a) b) (w a) (w b))) + (using w + (using ;;_functor + (F;map f (;;split ma))))) + +## Syntax +(defmacro #export (be tokens state) + (case tokens + (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (extend (;lambda [(~ var)] (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (list (` (;case (~ monad) + {#;return ;return #;bind ;bind} + (~ body'))))])) + + _ + (#;Left "Wrong syntax for be"))) diff --git a/input/lux/control/functor.lux b/input/lux/control/functor.lux new file mode 100644 index 000000000..3362dd21a --- /dev/null +++ b/input/lux/control/functor.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data state)) + +## Signatures +(defsig #export (Functor f) + (: (All [a b] + (-> (-> a b) (f a) (f b))) + map)) + +## Structures +(defstruct #export Maybe:Functor (Functor Maybe) + (def (map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(defstruct #export List:Functor (Functor List) + (def (map f ma) + (case ma + #;Nil #;Nil + (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) + +(defstruct #export State:Functor (Functor State) + (def (map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) diff --git a/input/lux/control/lazy.lux b/input/lux/control/lazy.lux new file mode 100644 index 000000000..83f094592 --- /dev/null +++ b/input/lux/control/lazy.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/meta macro) + (.. (functor #as F #refer #all) + (monad #as M #refer #all)) + (lux/data list)) + +## Types +(deftype #export (Lazy a) + (All [b] + (-> (-> a b) b))) + +## Syntax +(defmacro #export (... tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (;lambda [(~ blank)] ((~ blank) (~ value)))))])) + + _ + (#;Left "Wrong syntax for ..."))) + +## Functions +(def #export (! thunk) + (All [a] + (-> (Lazy a) a)) + (thunk id)) + +## Structs +(defstruct #export Lazy:Functor (Functor Lazy) + (def (F;map f ma) + (... (f (! ma))))) + +(defstruct #export Lazy:Monad (Monad Lazy) + (def M;_functor Lazy:Functor) + + (def (M;wrap a) + (... a)) + + (def M;join !)) diff --git a/input/lux/control/monad.lux b/input/lux/control/monad.lux new file mode 100644 index 000000000..2ca541574 --- /dev/null +++ b/input/lux/control/monad.lux @@ -0,0 +1,107 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data list + state) + (.. (functor #as F) + (monoid #as M)) + lux/meta/macro) + +## Signatures +(defsig #export (Monad m) + (: (F;Functor m) + _functor) + (: (All [a] + (-> a (m a))) + wrap) + (: (All [a] + (-> (m (m a)) (m a))) + join)) + +## Syntax +(defmacro #export (do tokens state) + (case tokens + (\ (list monad (#;Meta [_ (#;TupleS bindings)]) body)) + (let [body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (case var + (#;Meta [_ (#;TagS ["" "let"])]) + (` (;let (~ value) (~ body'))) + + _ + (` (;case ;;_functor + {#F;map F;map} + (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;;join)))) + ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) + )))) + body + (reverse (as-pairs bindings)))] + (#;Right [state (list (` (;case (~ monad) + {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + (~ body'))))])) + + _ + (#;Left "Wrong syntax for do"))) + +## Structures +(defstruct #export Maybe:Monad (Monad Maybe) + (def _functor F;Maybe:Functor) + + (def (wrap x) + (#;Some x)) + + (def (join mma) + (case mma + #;None #;None + (#;Some xs) xs))) + +(defstruct #export List:Monad (Monad List) + (def _functor F;List:Functor) + + (def (wrap x) + (#;Cons [x #;Nil])) + + (def (join xss) + (using M;List:Monoid + (foldL M;++ M;unit xss)))) + +(defstruct #export State:Monad (All [s] + (Monad (State s))) + (def _functor F;State:Functor) + + (def (wrap x) + (lambda [state] + [state x])) + + (def (join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) + +## Functions +(def #export (bind m f ma) + (All [m a b] + (-> (Monad m) (-> a (m b)) (m a) (m b))) + (using m + (;;join (:: ;;_functor (F;map f ma))))) + +(def #export (map% m f xs) + (All [m a b] + (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (case xs + #;Nil + (:: m (;;wrap #;Nil)) + + (#;Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;;wrap (#;Cons [y ys]))) + )) diff --git a/input/lux/control/monoid.lux b/input/lux/control/monoid.lux new file mode 100644 index 000000000..cfb282c52 --- /dev/null +++ b/input/lux/control/monoid.lux @@ -0,0 +1,57 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data ord + (bounded #as B))) + +## Signatures +(defsig #export (Monoid a) + (: a + unit) + (: (-> a a a) + ++)) + +## Constructors +(def #export (monoid$ unit ++) + (All [a] + (-> a (-> a a a) (Monoid a))) + (struct + (def unit unit) + (def ++ ++))) + +## Structures +(defstruct #export Maybe:Monoid (Monoid Maybe) + (def unit #;None) + (def (++ xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(defstruct #export List:Monoid (All [a] + (Monoid (List a))) + (def unit #;Nil) + (def (++ xs ys) + (case xs + #;Nil ys + (#;Cons [x xs']) (#;Cons [x (++ xs' ys)])))) + +(do-template [<name> <type> <unit> <++>] + [(defstruct #export <name> (Monoid <type>) + (def unit <unit>) + (def ++ <++>))] + + [ IntAdd:Monoid Int 0 int:+] + [ IntMul:Monoid Int 1 int:*] + [RealAdd:Monoid Real 0.0 real:+] + [RealMul:Monoid Real 1.0 real:*] + [ IntMax:Monoid Int (:: B;Int:Bounded B;bottom) (max Int:Ord)] + [ IntMin:Monoid Int (:: B;Int:Bounded B;top) (min Int:Ord)] + [RealMax:Monoid Real (:: B;Real:Bounded B;bottom) (max Real:Ord)] + [RealMin:Monoid Real (:: B;Real:Bounded B;top) (min Real:Ord)] + ) diff --git a/input/lux/data/bounded.lux b/input/lux/data/bounded.lux new file mode 100644 index 000000000..14f4d2e86 --- /dev/null +++ b/input/lux/data/bounded.lux @@ -0,0 +1,26 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Bounded a) + (: a + top) + + (: a + bottom)) + +## Structure +(do-template [<name> <type> <top> <bottom>] + [(defstruct #export <name> (Bounded <type>) + (def top <top>) + (def bottom <bottom>))] + + [Int:Bounded Int (_jvm_getstatic java.lang.Long MAX_VALUE) (_jvm_getstatic java.lang.Long MIN_VALUE)] + [Real:Bounded Real (_jvm_getstatic java.lang.Double MAX_VALUE) (_jvm_getstatic java.lang.Double MIN_VALUE)]) diff --git a/input/lux/data/dict.lux b/input/lux/data/dict.lux new file mode 100644 index 000000000..8bd6635fd --- /dev/null +++ b/input/lux/data/dict.lux @@ -0,0 +1,83 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (eq #as E))) + +## Signatures +(defsig #export (Dict d) + (: (All [k v] + (-> k (d k v) (Maybe v))) + get) + (: (All [k v] + (-> k v (d k v) (d k v))) + put) + (: (All [k v] + (-> k (d k v) (d k v))) + remove)) + +## Types +(deftype #export (PList k v) + (| (#PList (, (E;Eq k) (List (, k v)))))) + +## Constructors +(def #export (plist eq) + (All [k v] + (-> (E;Eq k) (PList k v))) + (#PList [eq #;Nil])) + +## Utils +(def (pl-get eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (Maybe v))) + (case kvs + #;Nil + #;None + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Some v') + (pl-get eq k kvs')))) + +(def (pl-put eq k v kvs) + (All [k v] + (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + (#;Cons [[k v] kvs]) + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + (#;Cons [[k v] kvs']) + (#;Cons [[k' v'] (pl-put eq k v kvs')])))) + +(def (pl-remove eq k kvs) + (All [k v] + (-> (E;Eq k) k (List (, k v)) (List (, k v)))) + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (pl-remove eq k kvs')])))) + +## Structs +(defstruct #export PList:Dict (Dict PList) + (def (get k plist) + (let [(#PList [eq kvs]) plist] + (pl-get eq k kvs))) + + (def (put k v plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-put eq k v kvs)]))) + + (def (remove k plist) + (let [(#PList [eq kvs]) plist] + (#PList [eq (pl-remove eq k kvs)])))) diff --git a/input/lux/data/eq.lux b/input/lux/data/eq.lux new file mode 100644 index 000000000..948f8e2ab --- /dev/null +++ b/input/lux/data/eq.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Eq a) + (: (-> a a Bool) + =)) + +## Structures +(defstruct #export Bool:Eq (Eq Bool) + (def (= x y) + (case (: (, Bool Bool) [x y]) + (\or [true true] [false false]) + true + + _ + false))) + +(defstruct #export Int:Eq (Eq Int) + (def = int:=)) + +(defstruct #export Real:Eq (Eq Real) + (def = real:=)) + +(defstruct #export Text:Eq (Eq Text) + (def (= x y) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y]))) diff --git a/input/lux/data/io.lux b/input/lux/data/io.lux new file mode 100644 index 000000000..ab74daefd --- /dev/null +++ b/input/lux/data/io.lux @@ -0,0 +1,51 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/meta macro) + (lux/control (functor #as F) + (monad #as M)) + lux/data/list) + +## Types +(deftype #export (IO a) + (-> (,) a)) + +## Syntax +(defmacro #export (io tokens state) + (case tokens + (\ (list value)) + (let [blank (symbol$ ["" ""])] + (#;Right [state (list (` (_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for io"))) + +## Structures +(defstruct #export IO:Functor (F;Functor IO) + (def (F;map f ma) + (io (f (ma []))))) + +(defstruct #export IO:Monad (M;Monad IO) + (def M;_functor IO:Functor) + + (def (M;wrap x) + (io x)) + + (def (M;join mma) + (mma []))) + +## Functions +(def #export (print x) + (-> Text (IO (,))) + (io (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x]))) + +(def #export (println x) + (-> Text (IO (,))) + (print (text:++ x "\n"))) diff --git a/input/lux/data/list.lux b/input/lux/data/list.lux new file mode 100644 index 000000000..edbdb6160 --- /dev/null +++ b/input/lux/data/list.lux @@ -0,0 +1,218 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import (lux #refer (#except reverse as-pairs)) + lux/meta/macro) + +## Types +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) + +## Functions +(def #export (foldL f init xs) + (All [a b] + (-> (-> a b a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + +(def #export (foldR f init xs) + (All [a b] + (-> (-> b a a) a (List b) a)) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (f x (foldR f init xs')))) + +(def #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def #export (filter p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def #export (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (\ (#;Cons [x1 (#;Cons [x2 xs'])])) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +(do-template [<name> <then> <else>] + [(def #export (<name> n xs) + (All [a] + (-> Int (List a) (List a))) + (if (int:> n 0) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + <then>) + <else>))] + + [take (#;Cons [x (take (dec n) xs')]) #;Nil] + [drop (drop (dec n) xs') xs] + ) + +(do-template [<name> <then> <else>] + [(def #export (<name> p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + <then> + <else>)))] + + [take-while (#;Cons [x (take-while p xs')]) #;Nil] + [drop-while (drop-while p xs') xs] + ) + +(def #export (split-at n xs) + (All [a] + (-> Int (List a) (, (List a) (List a)))) + (if (int:> n 0) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons [x xs']) + (let [[tail rest] (split-at (dec n) xs')] + [(#;Cons [x tail]) rest])) + [#;Nil xs])) + +(def (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) (, (List a) (List a)))) + (case xs + #;Nil + [ys xs] + + (#;Cons [x xs']) + (if (p x) + (split-with' p (#;Cons [x ys]) xs') + [ys xs]))) + +(def #export (split-with p xs) + (All [a] + (-> (-> a Bool) (List a) (, (List a) (List a)))) + (let [[ys' xs'] (split-with' p #;Nil xs)] + [(reverse ys') xs'])) + +(def #export (repeat n x) + (All [a] + (-> Int a (List a))) + (if (int:> n 0) + (#;Cons [x (repeat (dec n) x)]) + #;Nil)) + +(def #export (iterate f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (#;Cons [x (iterate f x')]) + + #;None + (#;Cons [x #;Nil]))) + +(def #export (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 #export (interpose sep xs) + (All [a] + (-> a (List a) (List a))) + (case xs + #;Nil + xs + + (#;Cons [x #;Nil]) + xs + + (#;Cons [x xs']) + (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) + +(def #export (size list) + (-> List Int) + (foldL (lambda [acc _] (int:+ 1 acc)) 0 list)) + +(do-template [<name> <init> <op>] + [(def #export (<name> p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))] + + [every? true and] + [any? false or]) + +(def #export (@ i xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (int:= 0 i) + (#;Some x) + (@ (dec i) xs')))) + +## Syntax +(defmacro #export (list xs state) + (#;Right [state (#;Cons [(foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + (` #;Nil) + (reverse xs)) + #;Nil])])) + +(defmacro #export (list& xs state) + (case (reverse xs) + (#;Cons [last init]) + (#;Right [state (list (foldL (lambda [tail head] + (` (#;Cons [(~ head) (~ tail)]))) + last + init))]) + + _ + (#;Left "Wrong syntax for list&"))) diff --git a/input/lux/data/number.lux b/input/lux/data/number.lux new file mode 100644 index 000000000..7941daa4e --- /dev/null +++ b/input/lux/data/number.lux @@ -0,0 +1,64 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Number n) + (: (-> n n n) + +) + + (: (-> n n n) + -) + + (: (-> n n n) + *) + + (: (-> n n n) + /) + + (: (-> n n n) + %) + + (: (-> Int n) + from-int) + + (: (-> n n) + negate) + + (: (-> n n) + sign) + + (: (-> n n) + abs)) + +## Structures +(do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] + [(defstruct #export <name> (Number <type>) + (def + <+>) + (def - <->) + (def * <*>) + (def / </>) + (def % <%>) + (def (from-int x) + (<from> x)) + (def (negate x) + (<*> <-1> x)) + (def (abs x) + (if (<<> x <0>) + (<*> <-1> x) + x)) + (def (sign x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [Int:Number Int int:+ int:- int:* int:/ int:% int:= int:< id 0 1 -1] + [Real:Number Real real:+ real:- real:* real:/ real:% real:= real:< _jvm_l2d 0.0 1.0 -1.0]) diff --git a/input/lux/data/ord.lux b/input/lux/data/ord.lux new file mode 100644 index 000000000..573106830 --- /dev/null +++ b/input/lux/data/ord.lux @@ -0,0 +1,56 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../eq #as E)) + +## Signatures +(defsig #export (Ord a) + (: (E;Eq a) + _eq) + (: (-> a a Bool) + <) + (: (-> a a Bool) + <=) + (: (-> a a Bool) + >) + (: (-> a a Bool) + >=)) + +## Constructors +(def #export (ord$ eq < >) + (All [a] + (-> (E;Eq a) (-> a a Bool) (-> a a Bool) (Ord a))) + (struct + (def _eq eq) + (def < <) + (def (<= x y) + (or (< x y) + (:: eq (E;= x y)))) + (def > >) + (def (>= x y) + (or (> x y) + (:: eq (E;= x y)))))) + +## Functions +(do-template [<name> <op>] + [(def #export (<name> ord x y) + (All [a] + (-> (Ord a) a a a)) + (using ord + (if (<op> x y) x y)))] + + [max ;;>] + [min ;;<]) + +## Structures +(def #export Int:Ord (Ord Int) + (ord$ E;Int:Eq int:< int:>)) + +(def #export Real:Ord (Ord Real) + (ord$ E;Real:Eq real:< real:>)) diff --git a/input/lux/data/show.lux b/input/lux/data/show.lux new file mode 100644 index 000000000..3748d481a --- /dev/null +++ b/input/lux/data/show.lux @@ -0,0 +1,27 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Show a) + (: (-> a Text) + show)) + +## Structures +(do-template [<name> <type> <body>] + [(defstruct #export <name> (Show <type>) + (def (show x) + <body>))] + + [Bool:Show Bool (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Int:Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Real:Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Char:Show Char (let [char (_jvm_invokevirtual java.lang.Object toString [] x [])] + ($ text:++ "#\"" char "\""))] + [Text:Show Text x]) diff --git a/input/lux/data/state.lux b/input/lux/data/state.lux new file mode 100644 index 000000000..386c7be1d --- /dev/null +++ b/input/lux/data/state.lux @@ -0,0 +1,13 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Types +(deftype #export (State s a) + (-> s (, s a))) diff --git a/input/lux/data/text.lux b/input/lux/data/text.lux new file mode 100644 index 000000000..1a8587f46 --- /dev/null +++ b/input/lux/data/text.lux @@ -0,0 +1,139 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (eq #as E) + (ord #as O))) + +## [Functions] +(def #export (size x) + (-> Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String length [] + x []))) + +(def #export (@ idx x) + (-> Int Text (Maybe Char)) + (if (and (int:< idx (size x)) + (int:>= idx 0)) + (#;Some (_jvm_invokevirtual java.lang.String charAt [int] + x [(_jvm_l2i idx)])) + #;None)) + +(def #export (++ x y) + (-> Text Text Text) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y])) + +(def #export (contains? x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.String contains [java.lang.CharSequence] + x [y])) + +(do-template [<name> <method>] + [(def #export (<name> x) + (-> Text Text) + (_jvm_invokevirtual java.lang.String <method> [] + x []))] + [lower-case toLowerCase] + [upper-case toUpperCase] + [trim trim] + ) + +(def #export (sub' from to x) + (-> Int Int Text (Maybe Text)) + (if (and (int:< from to) + (int:>= from 0) + (int:<= to (size x))) + (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i from) (_jvm_l2i to)]) + #;None)) + +(def #export (sub from x) + (-> Int Text (Maybe Text)) + (sub' from (size x) x)) + +(def #export (split at x) + (-> Int Text (Maybe (, Text Text))) + (if (and (int:< at (size x)) + (int:>= at 0)) + (let [pre (_jvm_invokevirtual java.lang.String substring [int int] + x [(_jvm_l2i 0) (_jvm_l2i at)]) + post (_jvm_invokevirtual java.lang.String substring [int] + x [(_jvm_l2i at)])] + (#;Some [pre post])) + #;None)) + +(def #export (replace pattern value template) + (-> Text Text Text Text) + (_jvm_invokevirtual java.lang.String replace [java.lang.CharSequence java.lang.CharSequence] + template [pattern value])) + +(do-template [<common> <general> <method>] + [(def #export (<general> pattern from x) + (-> Text Int Text (Maybe Int)) + (if (and (int:< from (size x)) + (int:>= from 0)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String int] + x [pattern (_jvm_l2i from)])) + -1 #;None + idx (#;Some idx)) + #;None)) + + (def #export (<common> pattern x) + (-> Text Text (Maybe Int)) + (case (_jvm_i2l (_jvm_invokevirtual java.lang.String <method> [java.lang.String] + x [pattern])) + -1 #;None + idx (#;Some idx)))] + + [index-of index-of' indexOf] + [last-index-of last-index-of' lastIndexOf] + ) + +(def #export (starts-with? prefix x) + (-> Text Text Bool) + (case (index-of prefix x) + (#;Some 0) + true + + _ + false)) + +(def #export (ends-with? postfix x) + (-> Text Text Bool) + (case (last-index-of postfix x) + (#;Some n) + (int:= (int:+ n (size postfix)) + (size x)) + + _ + false)) + +(defstruct #export Text:Eq (E;Eq Text) + (def (E;= x y) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y]))) + +(defstruct #export Text:Ord (O;Ord Text) + (def O;_eq Text:Eq) + (def (O;< x y) + (int:< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;<= x y) + (int:<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;> x y) + (int:> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;>= x y) + (int:>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0))) diff --git a/input/lux/meta/lux.lux b/input/lux/meta/lux.lux new file mode 100644 index 000000000..bd4fab8b6 --- /dev/null +++ b/input/lux/meta/lux.lux @@ -0,0 +1,185 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. macro) + (lux/control (monoid #as m #refer (#only List:Monoid)) + (functor #as F) + (monad #as M #refer (#only do))) + (lux/data list + (show #as S))) + +## Types +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) + +## Structures +(defstruct #export Lux:Functor (F;Functor Lux) + (def (F;map f fa) + (lambda [state] + (case (fa state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' a]) + (#;Right [state' (f a)]))))) + +(defstruct #export Lux:Monad (M;Monad Lux) + (def M;_functor Lux:Functor) + (def (M;wrap x) + (lambda [state] + (#;Right [state x]))) + (def (M;join mma) + (lambda [state] + (case (mma state) + (#;Left msg) + (#;Left msg) + + (#;Right [state' ma]) + (ma state'))))) + +## Functions +(def #export (get-module-name state) + (Lux Text) + (case (reverse (get@ #;envs state)) + #;Nil + (#;Left "Can't get the module name without a module!") + + (#;Cons [env _]) + (#;Right [state (get@ #;name env)]))) + +(def (get k plist) + (All [a] + (-> Text (List (, Text a)) (Maybe a))) + (case plist + #;Nil + #;None + + (#;Cons [[k' v] plist']) + (if (text:= k k') + (#;Some v) + (get k plist')))) + +(def (find-macro' modules current-module module name) + (-> (List (, Text (Module Compiler))) Text Text Text + (Maybe Macro)) + (do M;Maybe:Monad + [$module (get module modules) + gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] + (case (: (, Bool (DefData' Macro)) gdef) + [exported? (#;MacroD macro')] + (if (or exported? (text:= module current-module)) + (#;Some macro') + #;None) + + [_ (#;AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #;None))) + +(def #export (find-macro ident) + (-> Ident (Lux (Maybe Macro))) + (do Lux:Monad + [current-module get-module-name] + (let [[module name] ident] + (: (Lux (Maybe Macro)) + (lambda [state] + (#;Right [state (find-macro' (get@ #;modules state) current-module module name)])))))) + +(def #export (normalize ident) + (-> Ident (Lux Ident)) + (case ident + ["" name] + (do Lux:Monad + [module-name get-module-name] + (M;wrap (: Ident [module-name name]))) + + _ + (:: Lux:Monad (M;wrap ident)))) + +(def #export (macro-expand syntax) + (-> Syntax (Lux (List Syntax))) + (case syntax + (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + (do Lux:Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Lux:Monad + [expansion (macro args) + expansion' (M;map% Lux:Monad macro-expand expansion)] + (M;wrap (:: M;List:Monad (M;join expansion')))) + + #;None + (do Lux:Monad + [parts' (M;map% Lux:Monad macro-expand (list& (symbol$ macro-name) args))] + (M;wrap (list (form$ (:: M;List:Monad (M;join parts')))))))) + + (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) + (do Lux:Monad + [harg+ (macro-expand harg) + targs+ (M;map% Lux:Monad macro-expand targs)] + (M;wrap (list (form$ (list:++ harg+ (:: M;List:Monad (M;join (: (List (List Syntax)) targs+)))))))) + + (#;Meta [_ (#;TupleS members)]) + (do Lux:Monad + [members' (M;map% Lux:Monad macro-expand members)] + (M;wrap (list (tuple$ (:: M;List:Monad (M;join members')))))) + + _ + (:: Lux:Monad (M;wrap (list syntax))))) + +(def #export (gensym prefix state) + (-> Text (Lux Syntax)) + (#;Right [(update@ #;seed inc state) + (symbol$ ["__gensym__" (:: S;Int:Show (S;show (get@ #;seed state)))])])) + +(def #export (fail msg) + (All [a] + (-> Text (Lux a))) + (lambda [_] + (#;Left msg))) + +(def #export (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux:Monad + [token+ (macro-expand token)] + (case token+ + (\ (list token')) + (M;wrap token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(def #export (module-exists? module state) + (-> Text (Lux Bool)) + (#;Right [state (case (get module (get@ #;modules state)) + (#;Some _) + true + + #;None + false)])) + +(def #export (exported-defs module state) + (-> Text (Lux (List Text))) + (case (get module (get@ #;modules state)) + (#;Some =module) + (using M;List:Monad + (#;Right [state (M;join (:: M;_functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (list name) + (list))))) + (get@ #;defs =module))))])) + + #;None + (#;Left ($ text:++ "Unknown module: " module)))) diff --git a/input/lux/meta/macro.lux b/input/lux/meta/macro.lux new file mode 100644 index 000000000..22aeaf874 --- /dev/null +++ b/input/lux/meta/macro.lux @@ -0,0 +1,54 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Utils] +(def (_meta x) + (-> (Syntax' (Meta Cursor)) Syntax) + (#;Meta [["" -1 -1] x])) + +## [Syntax] +(def #export (defmacro tokens state) + Macro + (case tokens + (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) + (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) + (~ (_meta (#;SymbolS ["lux" "Macro"]))) + (~ body))) + (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) + #;Nil])])]) + + _ + (#;Left "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +## [Functions] +(do-template [<name> <type> <tag>] + [(def #export (<name> x) + (-> <type> Syntax) + (#;Meta [["" -1 -1] (<tag> x)]))] + + [bool$ Bool #;BoolS] + [int$ Int #;IntS] + [real$ Real #;RealS] + [char$ Char #;CharS] + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS] + [tag$ Ident #;TagS] + [form$ (List Syntax) #;FormS] + [tuple$ (List Syntax) #;TupleS] + [record$ (List (, Syntax Syntax)) #;RecordS] + ) diff --git a/input/lux/meta/syntax.lux b/input/lux/meta/syntax.lux new file mode 100644 index 000000000..cf08ff0eb --- /dev/null +++ b/input/lux/meta/syntax.lux @@ -0,0 +1,237 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (.. (macro #as m #refer #all) + lux) + (lux (control (functor #as F) + (monad #as M #refer (#only do))) + (data list))) + +## [Utils] +(def (first xy) + (All [a b] (-> (, a b) a)) + (let [[x y] xy] + x)) + +## Types +(deftype #export (Parser a) + (-> (List Syntax) (Maybe (, (List Syntax) a)))) + +## Structures +(defstruct #export Parser:Functor (F;Functor Parser) + (def (F;map f ma) + (lambda [tokens] + (case (ma tokens) + #;None + #;None + + (#;Some [tokens' a]) + (#;Some [tokens' (f a)]))))) + +(defstruct #export Parser:Monad (M;Monad Parser) + (def M;_functor Parser:Functor) + + (def (M;wrap x tokens) + (#;Some [tokens x])) + + (def (M;join mma) + (lambda [tokens] + (case (mma tokens) + #;None + #;None + + (#;Some [tokens' ma]) + (ma tokens'))))) + +## Parsers +(def #export (id^ tokens) + (Parser Syntax) + (case tokens + #;Nil #;None + (#;Cons [t tokens']) (#;Some [tokens' t]))) + +(do-template [<name> <type> <tag>] + [(def #export (<name> tokens) + (Parser <type>) + (case tokens + (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [ bool^ Bool #;BoolS] + [ int^ Int #;IntS] + [ real^ Real #;RealS] + [ char^ Char #;CharS] + [ text^ Text #;TextS] + [symbol^ Ident #;SymbolS] + [ tag^ Ident #;TagS] + ) + +(def (bool:= x y) + (-> Bool Bool Bool) + (if x + y + (not y))) + +(def (ident:= x y) + (-> Ident Ident Bool) + (let [[x1 x2] x + [y1 y2] y] + (and (text:= x1 y1) + (text:= x2 y2)))) + +(do-template [<name> <type> <tag> <eq>] + [(def #export (<name> v tokens) + (-> <type> (Parser (,))) + (case tokens + (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) + (if (<eq> v x) + (#;Some [tokens' []]) + #;None) + + _ + #;None))] + + [ bool?^ Bool #;BoolS bool:=] + [ int?^ Int #;IntS int:=] + [ real?^ Real #;RealS real:=] + ## [ char?^ Char #;CharS char:=] + [ text?^ Text #;TextS text:=] + [symbol?^ Ident #;SymbolS ident:=] + [ tag?^ Ident #;TagS ident:=] + ) + +(do-template [<name> <tag>] + [(def #export (<name> p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [(#;Meta [_ (<tag> form)]) tokens']) + (case (p form) + (#;Some [#;Nil x]) (#;Some [tokens' x]) + _ #;None) + + _ + #;None))] + + [ form^ #;FormS] + [tuple^ #;TupleS] + ) + +(def #export (?^ p tokens) + (All [a] + (-> (Parser a) (Parser (Maybe a)))) + (case (p tokens) + #;None (#;Some [tokens #;None]) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))) + +(def (run-parser p tokens) + (All [a] + (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) + (p tokens)) + +(def #export (*^ p tokens) + (All [a] + (-> (Parser a) (Parser (List a)))) + (case (p tokens) + #;None (#;Some [tokens (list)]) + (#;Some [tokens' x]) (run-parser (do Parser:Monad + [xs (*^ p)] + (M;wrap (list& x xs))) + tokens'))) + +(def #export (+^ p) + (All [a] + (-> (Parser a) (Parser (List a)))) + (do Parser:Monad + [x p + xs (*^ p)] + (M;wrap (list& x xs)))) + +(def #export (&^ p1 p2) + (All [a b] + (-> (Parser a) (Parser b) (Parser (, a b)))) + (do Parser:Monad + [x1 p1 + x2 p2] + (M;wrap [x1 x2]))) + +(def #export (|^ p1 p2 tokens) + (All [a b] + (-> (Parser a) (Parser b) (Parser (Either b)))) + (case (p1 tokens) + (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) + #;None (run-parser (do Parser:Monad + [x2 p2] + (M;wrap (#;Right x2))) + tokens))) + +(def #export (||^ ps tokens) + (All [a] + (-> (List (Parser a)) (Parser (Maybe a)))) + (case ps + #;Nil #;None + (#;Cons [p ps']) (case (p tokens) + #;None (||^ ps' tokens) + (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])) + )) + +(def #export (end^ tokens) + (Parser (,)) + (case tokens + #;Nil (#;Some [tokens []]) + _ #;None)) + +## Syntax +(defmacro #export (defsyntax tokens) + (case tokens + (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) + body)) + (do Lux:Monad + [names+parsers (M;map% Lux:Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [arg] + (case arg + (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) + parser))])) + (M;wrap [(symbol$ var-name) parser]) + + _ + (fail "Syntax pattern expects 2-tuples.")))) + args) + g!tokens (gensym "tokens") + #let [names (:: F;List:Functor (F;map first names+parsers)) + error-msg (text$ (text:++ "Wrong syntax for " name)) + parsing (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body name+parser] + (let [[name parser] name+parser] + (` (_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) + + _ + #;None))))) + (: Syntax (` (#;Some [(~@ names)]))) + (reverse names+parsers)) + body' (: Syntax + (` (_lux_case (~ parsing) + (#;Some [#;Nil [(~@ names)]]) + (~ body) + + _ + (l;fail (~ (text$ (text:++ "Wrong syntax for " name))))))) + macro-def (: Syntax + (` (m/defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] + (M;wrap (list macro-def))) + + _ + (fail "Wrong syntax for defsyntax"))) diff --git a/input/program.lux b/input/program.lux index 4f329c3fa..6495854c1 100644 --- a/input/program.lux +++ b/input/program.lux @@ -1,15 +1,28 @@ -(;lux) - -(def (filter p xs) - (All [a] (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - (list) - - (#;Cons [x xs']) - (if (p x) - (list& x (filter p xs')) - (filter p xs')))) +(;import lux + (lux (control monoid + functor + monad + lazy + comonad) + (data eq + bounded + ord + io + list + state + number + (text #as t) + dict + show) + (codata (stream #refer (#except iterate))) + (meta lux + macro + syntax))) (_jvm_program args - (println "Hello, world!")) + (case args + #;Nil + (println "Hello, world!") + + (#;Cons [name _]) + (println ($ text:++ "Hello, " name "!")))) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 039db810a..8c8be29d2 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -115,6 +115,12 @@ ["lux;Nil" _]]]]]]] (&&lux/analyse-export analyse ?ident) + [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] + ["lux;Nil" _]]]]]]]]] + (&&lux/analyse-alias analyse ?alias ?module) + [_] (fail ""))) @@ -447,7 +453,7 @@ ;; Programs [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?args]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-program analyse ?args ?body) @@ -500,6 +506,9 @@ [["lux;Right" [state* output]]] (return* state* output) + [["lux;Left" ""]] + (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + [["lux;Left" msg]] (fail* (add-loc meta msg))) @@ -522,6 +531,21 @@ (fail* (add-loc meta msg)) )))) +(defn ^:private just-analyse [analyse-ast eval! compile-module syntax] + (&type/with-var + (fn [?var] + (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)] + (matchv ::M/objects [?var ?output-type] + [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] + (if (= ?e-id ?a-id) + (|do [?output-type* (&type/deref ?e-id)] + (return (&/T ?output-term ?output-type*))) + (return (&/T ?output-term ?output-type))) + + [_ _] + (return (&/T ?output-term ?output-type))) + )))) + (defn ^:private analyse-ast [eval! compile-module exo-type token] (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] @@ -530,10 +554,12 @@ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] (fn [state] - (matchv ::M/objects [((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)] + (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state) + ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) + ] [["lux;Right" [state* =fn]]] (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type =fn ?args) state*)) [_] ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 43e5ee5e7..6efe7fd5f 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -15,6 +15,15 @@ (fail "##9##")))] (resolve-type type*)) + [["lux;AllT" ?id]] + (|do [$var &type/existential + =type (&type/apply-type type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type type $var)] + ;; (&type/actual-type =type)))) + [_] (&type/actual-type type))) @@ -68,7 +77,7 @@ (return (&/T (&/V "TupleTestAC" =tests) =kont)))) [_] - (fail "[Analyser Error] Tuple requires tuple-type.")) + (fail "[Analyser Error] Tuples require tuple-type.")) [["lux;RecordS" ?slots]] (|do [value-type* (resolve-type value-type)] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index fa7b9aa1a..de6bdb036 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -16,18 +16,20 @@ =return (body (&/update$ &/$ENVS (fn [stack] (let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] - (&/|cons (->> (&/|head stack) - (&/update$ &/$LOCALS #(&/update$ &/$COUNTER inc %)) - (&/update$ &/$LOCALS #(&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)) %))) + (&/|cons (&/update$ &/$LOCALS #(->> % + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/|head stack)) (&/|tail stack)))) state))] (matchv ::M/objects [=return] [["lux;Right" [?state ?value]]] (return* (&/update$ &/$ENVS (fn [stack*] - (&/|cons (->> (&/|head stack*) - (&/update$ &/$LOCALS #(&/update$ &/$COUNTER dec %)) - (&/update$ &/$LOCALS #(&/set$ &/$MAPPINGS old-mappings %))) - (&/|tail stack*))) + (&/|cons (&/update$ &/$LOCALS #(->> % + (&/update$ &/$COUNTER dec) + (&/set$ &/$MAPPINGS old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) ?state) ?value) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index b9361b8c3..3db4bd16d 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -352,7 +352,8 @@ ) (defn analyse-jvm-program [analyse ?args ?body] - (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] - (return (&/|list (&/V "jvm-program" =body))))) + (|let [[_module _name] ?args] + (|do [=body (&/with-scope "" + (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] + (return (&/|list (&/V "jvm-program" =body)))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6bbcd0fcf..d02599f10 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -76,6 +76,15 @@ (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) + [["lux;AllT" _]] + (|do [$var &type/existential + =type (&type/apply-type exo-type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type exo-type $var)] + ;; (&type/actual-type =type)))) + [_] (&type/actual-type exo-type)) types (matchv ::M/objects [exo-type*] @@ -83,7 +92,9 @@ (return ?table) [_] - (fail "[Analyser Error] The type of a record must be a record type.")) + (fail (str "[Analyser Error] The type of a record must be a record type:\n" + (&type/show-type exo-type*) + "\n"))) =slots (&/map% (fn [kv] (matchv ::M/objects [kv] [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] @@ -196,6 +207,9 @@ (|do [?fun-type* (&type/actual-type fun-type)] (matchv ::M/objects [?fun-type*] [["lux;AllT" _]] + ;; (|do [$var &type/existential + ;; type* (&type/apply-type ?fun-type* $var)] + ;; (analyse-apply* analyse exo-type type* ?args)) (&type/with-var (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) @@ -216,6 +230,9 @@ =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) + ;; [["lux;VarT" ?id-t]] + ;; (|do [ (&type/deref ?id-t)]) + [_] (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) @@ -229,7 +246,14 @@ (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (matchv ::M/objects [$def] [["lux;MacroD" macro]] - (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))] + (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) + :let [_ (when (and ;; (= "lux/control/monad" ?module) + (= "do" ?name)) + (->> (&/|map &/show-ast macro-expansion) + (&/|interpose "\n") + (&/fold str "") + (prn ?module "do")))] + ] (&/flat-map% (partial analyse exo-type) macro-expansion)) [_] @@ -254,16 +278,26 @@ exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - (matchv ::M/objects [exo-type] - [["lux;LambdaT" [?arg-t ?return-t]]] - (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type))) - - [_] - (fail (str "[Analyser Error] Functions require function types: " - (&type/show-type exo-type))))) + (|do [exo-type* (&type/actual-type exo-type)] + (matchv ::M/objects [exo-type] + [["lux;AllT" _]] + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) + ;; (|do [$var &type/existential + ;; exo-type** (&type/apply-type exo-type* $var)] + ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + + [["lux;LambdaT" [?arg-t ?return-t]]] + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body))] + (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) + + [_] + (fail (str "[Analyser Error] Functions require function types: " + (&type/show-type exo-type*)))))) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (matchv ::M/objects [exo-type] @@ -281,6 +315,14 @@ [["lux;ExT" _]] (return (&/T _expr exo-type)) + [["lux;VarT" ?_id]] + (|do [?? (&type/bound? ?_id)] + ;; (return (&/T _expr exo-type)) + (if ?? + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) + (return (&/T _expr exo-type))) + ) + [_] (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) @@ -295,7 +337,7 @@ (return (&/|list output)))) (defn analyse-def [analyse ?name ?value] - (prn 'analyse-def/BEGIN ?name) + ;; (prn 'analyse-def/BEGIN ?name) (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? @@ -306,14 +348,16 @@ (matchv ::M/objects [=value] [[["lux;Global" [?r-module ?r-name]] _]] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) - :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) - _ (println)]] + ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) + ;; _ (println)] + ] (return (&/|list))) [_] (|do [=value-type (&&/expr-type =value) - :let [_ (prn 'analyse-def/END ?name) - _ (println) + :let [;; _ (prn 'analyse-def/END ?name) + _ (println 'DEF (str module-name ";" ?name)) + ;; _ (println) def-data (cond (&type/type= &type/Type =value-type) (&/V "lux;TypeD" nil) @@ -328,23 +372,32 @@ (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) (defn analyse-import [analyse compile-module ?path] - (prn 'analyse-import ?path) - (fn [state] - (let [already-compiled? (&/fold false #(or %1 (= %2 ?path)) (&/get$ &/$SEEN-SOURCES state))] - (&/run-state (|do [_ (&&module/add-import ?path) - _ (if already-compiled? - (return nil) - (compile-module ?path))] - (return (&/|list))) - (if already-compiled? - state - (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state)))))) + (|do [module-name &/get-module-name] + (if (= module-name ?path) + (fail (str "[Analyser Error] Module can't import itself: " ?path)) + (&/save-module + (fn [state] + (let [already-compiled? (&/fold #(or %1 (= %2 ?path)) false (&/get$ &/$SEEN-SOURCES state))] + (prn 'analyse-import module-name ?path already-compiled?) + (&/run-state (|do [_ (&&module/add-import ?path) + _ (if already-compiled? + (return nil) + (compile-module ?path))] + (return (&/|list))) + (if already-compiled? + state + (&/update$ &/$SEEN-SOURCES (partial &/|cons ?path) state))))))))) (defn analyse-export [analyse name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] (return (&/|list)))) +(defn analyse-alias [analyse ex-alias ex-module] + (|do [module-name &/get-module-name + _ (&&module/alias module-name ex-alias ex-module)] + (return (&/|list)))) + (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index f0e5b82b4..27aa7374c 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,5 +1,6 @@ (ns lux.analyser.module - (:require [clojure.core.match :as M :refer [matchv]] + (:require [clojure.string :as string] + [clojure.core.match :as M :refer [matchv]] clojure.core.match.array (lux [base :as & :refer [|let |do return return* fail fail*]] [type :as &type] @@ -46,13 +47,14 @@ #(&/|put name (&/T false def-data) %) m)) ms))) - (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - (&/update$ &/$MAPPINGS (fn [mappings] - (&/|put (str "" &/+name-separator+ name) - (&/T (&/V "lux;Global" (&/T module name)) type) - mappings)) - locals)) - ?env)))) + ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] + ;; (&/update$ &/$MAPPINGS (fn [mappings] + ;; (&/|put (str "" &/+name-separator+ name) + ;; (&/T (&/V "lux;Global" (&/T module name)) type) + ;; mappings)) + ;; locals)) + ;; ?env))) + ) nil) [_] @@ -93,14 +95,15 @@ #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) m)) ms))) - (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] - (&/update$ &/$MAPPINGS (fn [mappings] - (&/|put (str "" &/+name-separator+ a-name) - (&/T (&/V "lux;Global" (&/T r-module r-name)) type) - ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1) - mappings)) - locals)) - ?env)))) + ;; (&/set$ &/$ENVS (&/|list (&/update$ &/$LOCALS (fn [locals] + ;; (&/update$ &/$MAPPINGS (fn [mappings] + ;; (&/|put (str "" &/+name-separator+ a-name) + ;; (&/T (&/V "lux;Global" (&/T r-module r-name)) type) + ;; ;; (aget (->> state (&/get$ &/$MODULES) (&/|get r-module) (&/get$ $DEFS) (&/|get r-name)) 1) + ;; mappings)) + ;; locals)) + ;; ?env))) + ) nil) [_] @@ -112,7 +115,7 @@ (return* state (->> state (&/get$ &/$MODULES) (&/|contains? name))))) -(defn alias-module [module reference alias] +(defn alias [module alias reference] (fn [state] (return* (->> state (&/update$ &/$MODULES @@ -136,23 +139,23 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] + (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? $$def]] - (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) - (if (or exported? (.equals ^Object current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] - (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) - ((find-def ?r-module ?r-name) - state)) - - [_] - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name))))) + (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (matchv ::M/objects [$def] + [[exported? $$def]] + (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) + (if (or exported? (.equals ^Object current-module module)) + (matchv ::M/objects [$$def] + [["lux;AliasD" [?r-module ?r-name]]] + (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) + ((find-def ?r-module ?r-name) + state)) + + [_] + (return* state (&/T (&/T module name) $$def))) + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (do (prn [module name] (str "[Analyser Error] Module doesn't exist: " module) (->> state (&/get$ &/$MODULES) &/|keys &/->seq)) @@ -171,7 +174,7 @@ [[exported? ["lux;ValueD" ?type]]] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str module ".$" (&/normalize-ident name))) + :let [macro (-> (.loadClass loader (str (string/replace module #"/" ".") ".$" (&/normalize-ident name))) (.getField "_datum") (.get nil))]] (fn [state*] @@ -191,9 +194,9 @@ (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) [[_ ["lux;TypeD" _]]] - (fail* (str "[Analyser Error] Definition doesn't have macro type: " module ";" name))) - (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name)))) - (fail* (str "[Analyser Error] Module doesn't exist: " module))))) + (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) + (fail* (str "[Analyser Error] Module does not exist: " module))))) (defn export [module name] (fn [state] @@ -213,7 +216,7 @@ m)) ms)))) nil)) - (fail* (str "[Analyser Error] Can't export an inexistent definition: " module ";" name))) + (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) [_] (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) diff --git a/src/lux/base.clj b/src/lux/base.clj index aecb3fd13..d88bb2ec1 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -483,13 +483,25 @@ ;; "lux;seed" 0 ;; "lux;seen-sources" - (|list) + (|list "lux") ;; "lux;source" (V "lux;None" nil) ;; "lux;types" +init-bindings+ )) +(defn save-module [body] + (fn [state] + (matchv ::M/objects [(body state)] + [["lux;Right" [state* output]]] + (return* (->> state* + (set$ $ENVS (get$ $ENVS state)) + (set$ $SOURCE (get$ $SOURCE state))) + output) + + [["lux;Left" msg]] + (fail* msg)))) + (defn with-eval [body] (fn [state] (matchv ::M/objects [(body (set$ $EVAL? true state))] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 1970c548a..04f4fb4c2 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -342,7 +342,7 @@ .visitEnd))] _ (&&/save-class! (str id) bytecode) loader &/loader] - (-> (.loadClass ^ClassLoader loader (str module "." id)) + (-> (.loadClass ^ClassLoader loader (str (string/replace module #"/" ".") "." id)) (.getField "_eval") (.get nil) return)))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index bc1ab23f1..2a8bdac89 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -146,7 +146,7 @@ compile-jvm-igt Opcodes/IF_ICMPGT "java.lang.Integer" "intValue" "()I" ) -(do-template [<name> <cmpcode> <ifcode> <wrapper-class> <value-method> <value-method-sig>] +(do-template [<name> <cmpcode> <cmp-output> <wrapper-class> <value-method> <value-method-sig>] (defn <name> [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class <wrapper-class>)] ^MethodVisitor *writer* &/get-writer @@ -162,25 +162,26 @@ $end (new Label) _ (doto *writer* (.visitInsn <cmpcode>) - (.visitJumpInsn <ifcode> $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) + (.visitLdcInsn (int <cmp-output>)) + (.visitJumpInsn Opcodes/IF_ICMPEQ $then) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) (.visitJumpInsn Opcodes/GOTO $end) (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "FALSE" (&host/->type-signature "java.lang.Boolean")) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class "java.lang.Boolean") "TRUE" (&host/->type-signature "java.lang.Boolean")) (.visitLabel $end))]] (return nil))) - compile-jvm-leq Opcodes/LCMP Opcodes/IFEQ "java.lang.Long" "longValue" "()J" - compile-jvm-llt Opcodes/LCMP Opcodes/IFLT "java.lang.Long" "longValue" "()J" - compile-jvm-lgt Opcodes/LCMP Opcodes/IFGT "java.lang.Long" "longValue" "()J" + compile-jvm-leq Opcodes/LCMP 0 "java.lang.Long" "longValue" "()J" + compile-jvm-llt Opcodes/LCMP 1 "java.lang.Long" "longValue" "()J" + compile-jvm-lgt Opcodes/LCMP -1 "java.lang.Long" "longValue" "()J" - compile-jvm-feq Opcodes/FCMPG Opcodes/IFEQ "java.lang.Float" "floatValue" "()F" - compile-jvm-flt Opcodes/FCMPG Opcodes/IFLT "java.lang.Float" "floatValue" "()F" - compile-jvm-fgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Float" "floatValue" "()F" + compile-jvm-feq Opcodes/FCMPG 0 "java.lang.Float" "floatValue" "()F" + compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" + compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" - compile-jvm-deq Opcodes/DCMPG Opcodes/IFEQ "java.lang.Double" "doubleValue" "()I" - compile-jvm-dlt Opcodes/DCMPG Opcodes/IFLT "java.lang.Double" "doubleValue" "()I" - compile-jvm-dgt Opcodes/FCMPG Opcodes/IFGT "java.lang.Double" "doubleValue" "()I" + compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I" + compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I" + compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I" ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index ecb614732..7d6b2b502 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -25,6 +25,17 @@ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) +(defn compile-int [compile *type* value] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW "java/lang/Long") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (bit-shift-left (long value) 0) + ;; (bit-shift-left (long value) 32) + ) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Long" "<init>" "(J)V"))]] + (return nil))) + (do-template [<name> <class> <sig> <caster>] (defn <name> [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer @@ -35,7 +46,7 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL <class> "<init>" <sig>))]] (return nil))) - compile-int "java/lang/Long" "(J)V" long + ;; compile-int "java/lang/Long" "(J)V" long compile-real "java/lang/Double" "(D)V" double compile-char "java/lang/Character" "(C)V" char ) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index a137ca863..fbfe1f757 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -67,8 +67,8 @@ (return (&/V "lux;Meta" (&/T meta (&/V <tag> token)))))) ^:private lex-bool "Bool" #"^(true|false)" - ^:private lex-int "Int" #"^-?(0|[1-9][0-9]*)" - ^:private lex-real "Real" #"^-?(0|[1-9][0-9]*)\.[0-9]+" + ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" + ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char @@ -89,14 +89,14 @@ (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] (&/try-all% (&/|list (|do [_ (&reader/read-text ";") - [_ local-token] (&reader/read-regex +ident-re+)] - (&/try-all% (&/|list (|do [unaliased (&module/dealias token)] - (return (&/T meta (&/T unaliased local-token)))) - (|do [? (&module/exists? token)] - (if ? - (return (&/T meta (&/T token local-token))) - (fail (str "[Lexer Error] Unknown module: " token)))) - ))) + [_ local-token] (&reader/read-regex +ident-re+) + ? (&module/exists? token)] + (if ? + (return (&/T meta (&/T token local-token))) + (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) + (&module/dealias token))] + (do ;; (prn "Unaliased: " unaliased ";" local-token) + (return (&/T meta (&/T unaliased local-token))))))) (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") diff --git a/src/lux/type.clj b/src/lux/type.clj index e0315f8e7..e7d6353e8 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -349,16 +349,18 @@ (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) [["lux;VariantT" cases]] - (str "(| " (->> cases - (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k ["Tuple" ["Nil" _]]]] - (str "#" k) - - [[k v]] - (str "(#" k " " (show-type v) ")")))) - (&/|interpose " ") - (&/fold str "")) ")") + (if (&/|empty? cases) + "(|)" + (str "(| " (->> cases + (&/|map (fn [kv] + (matchv ::M/objects [kv] + [[k ["lux;TupleT" ["lux;Nil" _]]]] + (str "#" k) + + [[k v]] + (str "(#" k " " (show-type v) ")")))) + (&/|interpose " ") + (&/fold str "")) ")")) [["lux;RecordT" fields]] @@ -485,7 +487,9 @@ (&/|cons (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] - (str "Type " (show-type expected) " does not subsume type " (show-type actual))) + (str "[Type Checker]\nExpected: " (show-type expected) + "\n\nActual: " (show-type actual) + "\n")) (defn beta-reduce [env type] (matchv ::M/objects [type] @@ -555,7 +559,7 @@ (apply-type type-fn* param)) [_] - (fail (str "[Type System] Can't apply type function " (show-type type-fn) " to type " (show-type param))))) + (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) (def init-fixpoints (&/|list)) @@ -826,10 +830,10 @@ [["lux;ExT" e!id] ["lux;ExT" a!id]] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) - (check-error expected actual)) + (fail (check-error expected actual))) [_ _] - (fail (println-str "[Type Error] Can't type-check: " (show-type expected) (show-type actual))) + (fail (check-error expected actual)) ))) (defn check [expected actual] @@ -850,7 +854,7 @@ (clean $var =return)))) [_] - (fail (str "[Type System] Can't apply type " (show-type func) " to type " (show-type param))) + (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] @@ -859,6 +863,9 @@ (|do [type* (apply-type ?all ?param)] (actual-type type*)) + [["lux;VarT" ?id]] + (deref ?id) + [_] (return type) )) |