From 658ff3e1e7d90ce72c8a02ef4cf7e177d8ac6f86 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 12 Jul 2015 21:04:56 -0400 Subject: - Added the beginnings of the standard library. - Fixed several bugs. --- input/lux.lux | 1400 +++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 1001 insertions(+), 399 deletions(-) (limited to 'input/lux.lux') 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 [ ] + [(def'' #export ( x y) + (-> Bool) + (if ( x y) + true + ( x y)))] + + [ int:>= int:> int:= Int] + [ int:<= int:< int:= Int] + [real:>= real:> real:= Real] + [real:<= real:< real:= Real] + ) + (do-template [ ] [(def'' #export ( x y) (-> ) @@ -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 [ ] - [(defstruct #export (Eq ) - (def (= x y) - ( 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 [ ] - [(defstruct #export (Show ) - (def (show x) - ))] - - [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 [
] [(defmacro #export ( tokens) (case (reverse tokens) @@ -1877,80 +1799,152 @@ _ (fail )))] - [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] - [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) - -(do-template [ ] - [(defstruct #export (Ord ) - (def (< x y) - ( x y)) - - (def (<= x y) - (or ( x y) - ( x y))) - - (def (> x y) - ( x y)) - - (def (>= x y) - (or ( x y) - ( 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"))) -- cgit v1.2.3