diff options
Diffstat (limited to 'source')
31 files changed, 5222 insertions, 0 deletions
diff --git a/source/lux.lux b/source/lux.lux new file mode 100644 index 000000000..50f8f1af2 --- /dev/null +++ b/source/lux.lux @@ -0,0 +1,2784 @@ +## 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. + +## First things first, must define functions +(_jvm_interface "Function" [] + (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## Basic types +(_lux_def Bool (#DataT "java.lang.Boolean")) +(_lux_export Bool) + +(_lux_def Int (#DataT "java.lang.Long")) +(_lux_export Int) + +(_lux_def Real (#DataT "java.lang.Double")) +(_lux_export Real) + +(_lux_def Char (#DataT "java.lang.Character")) +(_lux_export Char) + +(_lux_def Text (#DataT "java.lang.String")) +(_lux_export Text) + +(_lux_def Unit (#TupleT #Nil)) +(_lux_export Unit) + +(_lux_def Void (#VariantT #Nil)) +(_lux_export Void) + +(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_export Ident) + +## (deftype (List a) +## (| #Nil +## (#Cons (, a (List a))))) +(_lux_def List + (#AllT [(#Some #Nil) "lux;List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) +(_lux_export List) + +## (deftype (Maybe a) +## (| #None +## (#Some a))) +(_lux_def Maybe + (#AllT [(#Some #Nil) "lux;Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) +(_lux_export Maybe) + +## (deftype #rec Type +## (| (#DataT Text) +## (#TupleT (List Type)) +## (#VariantT (List (, Text Type))) +## (#RecordT (List (, Text Type))) +## (#LambdaT (, Type Type)) +## (#BoundT Text) +## (#VarT Int) +## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) +## (#AppT (, Type Type)))) +(_lux_def Type + (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + Type + (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + TypeEnv + (#AppT [(#AllT [(#Some #Nil) "Type" "_" + (#VariantT (#Cons [["lux;DataT" Text] + (#Cons [["lux;TupleT" (#AppT [List Type])] + (#Cons [["lux;VariantT" TypeEnv] + (#Cons [["lux;RecordT" TypeEnv] + (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;BoundT" Text] + (#Cons [["lux;VarT" Int] + (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + (#Cons [["lux;ExT" Int] + #Nil])])])])])])])])])]))]) + Void])))) +(_lux_export Type) + +## (deftype (Bindings k v) +## (& #counter Int +## #mappings (List (, k v)))) +(_lux_def Bindings + (#AllT [(#Some #Nil) "lux;Bindings" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;counter" Int] + (#Cons [["lux;mappings" (#AppT [List + (#TupleT (#Cons [(#BoundT "k") + (#Cons [(#BoundT "v") + #Nil])]))])] + #Nil])]))])])) +(_lux_export Bindings) + +## (deftype (Env k v) +## (& #name Text +## #inner-closures Int +## #locals (Bindings k v) +## #closure (Bindings k v))) +(_lux_def Env + (#AllT [(#Some #Nil) "lux;Env" "k" + (#AllT [#None "" "v" + (#RecordT (#Cons [["lux;name" Text] + (#Cons [["lux;inner-closures" Int] + (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")]) + (#BoundT "v")])] + #Nil])])])]))])])) +(_lux_export Env) + +## (deftype Cursor +## (, Text Int Int)) +(_lux_def Cursor + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) +(_lux_export Cursor) + +## (deftype (Meta m v) +## (| (#Meta (, m v)))) +(_lux_def Meta + (#AllT [(#Some #Nil) "lux;Meta" "m" + (#AllT [#None "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) +(_lux_export Meta) + +## (deftype (Syntax' w) +## (| (#BoolS Bool) +## (#IntS Int) +## (#RealS Real) +## (#CharS Char) +## (#TextS Text) +## (#SymbolS (, Text Text)) +## (#TagS (, Text Text)) +## (#FormS (List (w (Syntax' w)))) +## (#TupleS (List (w (Syntax' w)))) +## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) +(_lux_def Syntax' + (_lux_case (#AppT [(#BoundT "w") + (#AppT [(#BoundT "lux;Syntax'") + (#BoundT "w")])]) + Syntax + (_lux_case (#AppT [List Syntax]) + SyntaxList + (#AllT [(#Some #Nil) "lux;Syntax'" "w" + (#VariantT (#Cons [["lux;BoolS" Bool] + (#Cons [["lux;IntS" Int] + (#Cons [["lux;RealS" Real] + (#Cons [["lux;CharS" Char] + (#Cons [["lux;TextS" Text] + (#Cons [["lux;SymbolS" Ident] + (#Cons [["lux;TagS" Ident] + (#Cons [["lux;FormS" SyntaxList] + (#Cons [["lux;TupleS" SyntaxList] + (#Cons [["lux;RecordS" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] + #Nil]) + ])])])])])])])])]) + )])))) +(_lux_export Syntax') + +## (deftype Syntax +## (Meta Cursor (Syntax' (Meta Cursor)))) +(_lux_def Syntax + (_lux_case (#AppT [Meta Cursor]) + w + (#AppT [w (#AppT [Syntax' w])]))) +(_lux_export Syntax) + +(_lux_def SyntaxList (#AppT [List Syntax])) + +## (deftype (Either l r) +## (| (#Left l) +## (#Right r))) +(_lux_def Either + (#AllT [(#Some #Nil) "lux;Either" "l" + (#AllT [#None "" "r" + (#VariantT (#Cons [["lux;Left" (#BoundT "l")] + (#Cons [["lux;Right" (#BoundT "r")] + #Nil])]))])])) +(_lux_export Either) + +## (deftype (StateE s a) +## (-> s (Either Text (, s a)))) +(_lux_def StateE + (#AllT [(#Some #Nil) "lux;StateE" "s" + (#AllT [#None "" "a" + (#LambdaT [(#BoundT "s") + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [(#BoundT "s") + (#Cons [(#BoundT "a") + #Nil])]))])])])])) + +## (deftype Reader +## (List (Meta Cursor Text))) +(_lux_def Reader + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) +(_lux_export Reader) + +## (deftype HostState +## (& #writer (^ org.objectweb.asm.ClassWriter) +## #loader (^ java.net.URLClassLoader) +## #classes (^ clojure.lang.Atom))) +(_lux_def HostState + (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] + (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] + (#Cons [["lux;classes" (#DataT "clojure.lang.Atom")] + #Nil])])]))) + +## (deftype (DefData' m) +## (| #TypeD +## (#ValueD Type) +## (#MacroD m) +## (#AliasD Ident))) +(_lux_def DefData' + (#AllT [(#Some #Nil) "lux;DefData'" "" + (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)] + (#Cons [["lux;ValueD" Type] + (#Cons [["lux;MacroD" (#BoundT "")] + (#Cons [["lux;AliasD" Ident] + #Nil])])])]))])) +(_lux_export DefData') + +## (deftype LuxVar +## (| (#Local Int) +## (#Global Ident))) +(_lux_def LuxVar + (#VariantT (#Cons [["lux;Local" Int] + (#Cons [["lux;Global" Ident] + #Nil])]))) +(_lux_export LuxVar) + +## (deftype (Module Compiler) +## (& #module-aliases (List (, Text Text)) +## #defs (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))) +## #imports (List Text) +## )) +(_lux_def Module + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#RecordT (#Cons [["lux;module-aliases" (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))])] + (#Cons [["lux;defs" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + SyntaxList])])]) + #Nil])])) + #Nil])]))])] + (#Cons [["lux;imports" (#AppT [List Text])] + #Nil])])]))])) +(_lux_export Module) + +## (deftype #rec Compiler +## (& #source Reader +## #modules (List (, Text (Module Compiler))) +## #envs (List (Env Text (, LuxVar Type))) +## #types (Bindings Int Type) +## #host HostState +## #seed Int +## #eval? Bool)) +(_lux_def Compiler + (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" + (#RecordT (#Cons [["lux;source" Reader] + (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#AppT [Module (#AppT [(#BoundT "lux;Compiler") (#BoundT "")])]) + #Nil])]))])] + (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) + (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;host" HostState] + (#Cons [["lux;seed" Int] + (#Cons [["lux;eval?" Bool] + #Nil])])])])])])]))]) + Void])) +(_lux_export Compiler) + +## (deftype Macro +## (-> (List Syntax) (StateE Compiler (List Syntax)))) +(_lux_def Macro + (#LambdaT [SyntaxList + (#AppT [(#AppT [StateE Compiler]) + SyntaxList])])) +(_lux_export Macro) + +## Base functions & macros +## (def _cursor +## Cursor +## ["" -1 -1]) +(_lux_def _cursor + (_lux_: Cursor ["" -1 -1])) + +## (def (_meta data) +## (-> (Syntax' (Meta Cursor)) Syntax) +## (#Meta [["" -1 -1] data])) +(_lux_def _meta + (_lux_: (#LambdaT [(#AppT [Syntax' + (#AppT [Meta Cursor])]) + Syntax]) + (_lux_lambda _ data + (#Meta [_cursor data])))) + +## (def (return x) +## (All [a] +## (-> a Compiler +## (Either Text (, Compiler a)))) +## ...) +(_lux_def return + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [(#BoundT "a") + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ val + (_lux_lambda _ state + (#Right [state val]))))) + +## (def (fail msg) +## (All [a] +## (-> Text Compiler +## (Either Text (, Compiler a)))) +## ...) +(_lux_def fail + (_lux_: (#AllT [(#Some #Nil) "" "a" + (#LambdaT [Text + (#LambdaT [Compiler + (#AppT [(#AppT [Either Text]) + (#TupleT (#Cons [Compiler + (#Cons [(#BoundT "a") + #Nil])]))])])])]) + (_lux_lambda _ msg + (_lux_lambda _ state + (#Left msg))))) + +(_lux_def text$ + (_lux_: (#LambdaT [Text Syntax]) + (_lux_lambda _ text + (_meta (#TextS text))))) + +(_lux_def symbol$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#SymbolS ident))))) + +(_lux_def tag$ + (_lux_: (#LambdaT [Ident Syntax]) + (_lux_lambda _ ident + (_meta (#TagS ident))))) + +(_lux_def form$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#FormS tokens))))) + +(_lux_def tuple$ + (_lux_: (#LambdaT [(#AppT [List Syntax]) Syntax]) + (_lux_lambda _ tokens + (_meta (#TupleS tokens))))) + +(_lux_def record$ + (_lux_: (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) + (_lux_lambda _ tokens + (_meta (#RecordS tokens))))) + +(_lux_def let' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) + (return (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_case"]) + (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) + #Nil])) + + _ + (fail "Wrong syntax for let'"))))) +(_lux_declare-macro let') + +(_lux_def lambda' + (_lux_: Macro + (_lux_lambda _ tokens + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS ["" ""])) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + (#Cons [(#Meta [_ (#SymbolS self)]) (#Cons [(#Meta [_ (#TupleS (#Cons [arg args']))]) (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_lambda"])) + (#Cons [(_meta (#SymbolS self)) + (#Cons [arg + (#Cons [(_lux_case args' + #Nil + body + + _ + (_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [(_meta (#TupleS args')) + (#Cons [body #Nil])])])))) + #Nil])])])]))) + #Nil])) + + _ + (fail "Wrong syntax for lambda"))))) +(_lux_declare-macro lambda') + +(_lux_def def' + (_lux_: Macro + (lambda' [tokens] + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + (#Cons [(_meta (#FormS (#Cons [(symbol$ ["" "_lux_export"]) (#Cons [name #Nil])]))) + #Nil])])) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "lambda'"])) + (#Cons [name + (#Cons [(_meta (#TupleS args)) + (#Cons [body #Nil])])])]))) + #Nil])])]))) + #Nil])])]))) + #Nil])) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_def"])) + (#Cons [name + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["" "_lux_:"])) + (#Cons [type + (#Cons [body + #Nil])])]))) + #Nil])])]))) + #Nil])) + + _ + (fail "Wrong syntax for def") + )))) +(_lux_declare-macro def') + +(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"]) + (#Cons [body + #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"]) + (#Cons [body + #Nil])]) + ])])])) + (#Cons [(form$ (#Cons [(symbol$ ["" "_lux_declare-macro"]) (#Cons [name #Nil])])) + #Nil])])) + + _ + (fail "Wrong syntax for defmacro"))) +(_lux_declare-macro defmacro) + +(defmacro #export (comment tokens) + (return #Nil)) + +(defmacro (->' tokens) + (_lux_case tokens + (#Cons [input (#Cons [output #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil])) + + (#Cons [input (#Cons [output others])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "->'"])) + (#Cons [output others])]))) + #Nil])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for ->'"))) + +(defmacro (All' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS #Nil)]) + (#Cons [body #Nil])]) + (return (#Cons [body + #Nil])) + + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AllT"])) + (#Cons [(_meta (#TupleS (#Cons [(_meta (#TagS ["lux" "None"])) + (#Cons [(_meta (#TextS "")) + (#Cons [(_meta (#TextS arg-name)) + (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "All'"])) + (#Cons [(_meta (#TupleS other-args)) + (#Cons [body + #Nil])])]))) + #Nil])])])]))) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for All'"))) + +(defmacro (B' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" bound-name])]) + #Nil]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "BoundT"])) + (#Cons [(_meta (#TextS bound-name)) + #Nil])]))) + #Nil])) + + _ + (fail "Wrong syntax for B'"))) + +(defmacro ($' tokens) + (_lux_case tokens + (#Cons [x #Nil]) + (return tokens) + + (#Cons [x (#Cons [y xs])]) + (return (#Cons [(_meta (#FormS (#Cons [(_meta (#SymbolS ["lux" "$'"])) + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "AppT"])) + (#Cons [(_meta (#TupleS (#Cons [x (#Cons [y #Nil])]))) + #Nil])]))) + xs])]))) + #Nil])) + + _ + (fail "Wrong syntax for $'"))) + +(def' (foldL f init xs) + (All' [a b] + (->' (->' (B' a) (B' b) (B' a)) + (B' a) + ($' List (B' b)) + (B' a))) + (_lux_case xs + #Nil + init + + (#Cons [x xs']) + (foldL f (f init x) xs'))) + +(def' (reverse list) + (All' [a] + (->' ($' List (B' a)) ($' List (B' a)))) + (foldL (lambda' [tail head] (#Cons [head tail])) + #Nil + list)) + +(defmacro (list xs) + (return (#Cons [(foldL (lambda' [tail head] + (_meta (#FormS (#Cons [(_meta (#TagS ["lux" "Cons"])) + (#Cons [(_meta (#TupleS (#Cons [head (#Cons [tail #Nil])]))) + #Nil])])))) + (_meta (#TagS ["lux" "Nil"])) + (reverse xs)) + #Nil]))) + +(defmacro (list& xs) + (_lux_case (reverse xs) + (#Cons [last init]) + (return (list (foldL (lambda' [tail head] + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list head tail))))))) + last + init))) + + _ + (fail "Wrong syntax for list&"))) + +(defmacro #export (lambda tokens) + (let' [name tokens'] (_lux_: (#TupleT (list Ident ($' List Syntax))) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS name)]) tokens']) + [name tokens'] + + _ + [["" ""] tokens])) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case args + #Nil + (fail "lambda requires a non-empty arguments tuple.") + + (#Cons [harg targs]) + (return (list (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ name) + harg + (foldL (lambda' [body' arg] + (form$ (list (symbol$ ["" "_lux_lambda"]) + (symbol$ ["" ""]) + arg + body'))) + body + (reverse targs))))))) + + _ + (fail "Wrong syntax for lambda")))) + +(defmacro (def'' tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda"]) + name + (tuple$ args) + body)))))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#TagS ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + body)))) + (form$ (list (symbol$ ["" "_lux_export"]) name)))) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) + (#Cons [type (#Cons [body #Nil])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) + type + (form$ (list (symbol$ ["lux" "lambda"]) + name + (tuple$ args) + body)))))))) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (return (list (form$ (list (symbol$ ["" "_lux_def"]) + name + (form$ (list (symbol$ ["" "_lux_:"]) type body)))))) + + _ + (fail "Wrong syntax for def") + )) + +(def'' (as-pairs xs) + (All' [a] + (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) + (_lux_case xs + (#Cons [x (#Cons [y xs'])]) + (#Cons [[x y] (as-pairs xs')]) + + _ + #Nil)) + +(defmacro #export (let tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])]) + (return (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (form$ (list (symbol$ ["" "_lux_case"]) value label body))))) + body + (reverse (as-pairs bindings))))) + + _ + (fail "Wrong syntax for let"))) + +(def'' (map f xs) + (All' [a b] + (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (#Cons [(f x) (map f xs')]))) + +(def'' (any? p xs) + (All' [a] + (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) + (_lux_case xs + #Nil + false + + (#Cons [x xs']) + (_lux_case (p x) + true true + false (any? p xs')))) + +(def'' (spliced? token) + (->' Syntax Bool) + (_lux_case token + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [_ #Nil])]))]) + true + + _ + false)) + +(def'' (wrap-meta content) + (->' Syntax Syntax) + (_meta (#FormS (list (_meta (#TagS ["lux" "Meta"])) + (_meta (#TupleS (list (_meta (#TupleS (list (_meta (#TextS "")) (_meta (#IntS -1)) (_meta (#IntS -1))))) + content))))))) + +(def'' (untemplate-list tokens) + (->' ($' List Syntax) Syntax) + (_lux_case tokens + #Nil + (_meta (#TagS ["lux" "Nil"])) + + (#Cons [token tokens']) + (_meta (#FormS (list (_meta (#TagS ["lux" "Cons"])) + (_meta (#TupleS (list token (untemplate-list tokens'))))))))) + +(def'' #export (list:++ xs ys) + (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) + (_lux_case xs + (#Cons [x xs']) + (#Cons [x (list:++ xs' ys)]) + + #Nil + ys)) + +(defmacro #export ($ tokens) + (_lux_case tokens + (#Cons [op (#Cons [init args])]) + (return (list (foldL (lambda [a1 a2] (form$ (list op a1 a2))) + init + args))) + + _ + (fail "Wrong syntax for $"))) + +(def'' (splice replace? untemplate tag elems) + (->' Bool (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) + (_lux_case replace? + true + (_lux_case (any? spliced? elems) + true + (let [elems' (map (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + (form$ (list (symbol$ ["" "_lux_:"]) + (form$ (list (tag$ ["lux" "AppT"]) (tuple$ (list (symbol$ ["lux" "List"]) (symbol$ ["lux" "Syntax"]))))) + (form$ (list (tag$ ["lux" "Cons"]) (tuple$ (list (untemplate elem) + (tag$ ["lux" "Nil"]))))))))) + elems)] + (wrap-meta (form$ (list tag + (form$ (list& (symbol$ ["lux" "$"]) + (symbol$ ["lux" "list:++"]) + elems')))))) + + false + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems)))))) + false + (wrap-meta (form$ (list tag (untemplate-list (map untemplate elems))))))) + +(def'' (untemplate replace? subst token) + (->' Bool Text Syntax Syntax) + (_lux_case (_lux_: (#TupleT (list Bool Syntax)) [replace? token]) + [_ (#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))))) + + [_ (#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))))) + + [_ (#Meta [_ (#TextS value)])] + (wrap-meta (form$ (list (tag$ ["lux" "TextS"]) (_meta (#TextS value))))) + + [_ (#Meta [_ (#TagS [module name])])] + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "TagS"]) (tuple$ (list (text$ module') (text$ name))))))) + + [_ (#Meta [_ (#SymbolS [module name])])] + (let [module' (_lux_case module + "" + subst + + _ + module)] + (wrap-meta (form$ (list (tag$ ["lux" "SymbolS"]) (tuple$ (list (text$ module') (text$ name))))))) + + [_ (#Meta [_ (#TupleS elems)])] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "TupleS"]) elems) + + [true (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))])] + unquoted + + [_ (#Meta [_ (#FormS elems)])] + (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems) + + [_ (#Meta [_ (#RecordS fields)])] + (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) + (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) + (lambda [kv] + (let [[k v] kv] + (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) + fields))))) + )) + +(defmacro (`' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate true "" template))) + + _ + (fail "Wrong syntax for `'"))) + +(defmacro (' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (list (untemplate false "" template))) + + _ + (fail "Wrong syntax for '"))) + +(defmacro #export (|> tokens) + (_lux_case tokens + (#Cons [init apps]) + (return (list (foldL (lambda [acc app] + (_lux_case app + (#Meta [_ (#TupleS parts)]) + (tuple$ (list:++ parts (list acc))) + + (#Meta [_ (#FormS parts)]) + (form$ (list:++ parts (list acc))) + + _ + (`' ((~ app) (~ acc))))) + init + apps))) + + _ + (fail "Wrong syntax for |>"))) + +(defmacro #export (if tokens) + (_lux_case tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (list (`' (_lux_case (~ test) + true (~ then) + false (~ else))))) + + _ + (fail "Wrong syntax for if"))) + +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) +(def'' #export Lux + Type + (All' [a] + (->' Compiler ($' Either Text (#TupleT (list Compiler (B' a))))))) + +## (defsig (Monad m) +## (: (All [a] (-> a (m a))) +## return) +## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) +## bind)) +(def'' Monad + Type + (All' [m] + (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] + ["lux;bind" (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b))))])))) + +(def'' Maybe/Monad + ($' Monad Maybe) + {#lux;return + (lambda return [x] + (#Some x)) + + #lux;bind + (lambda [f ma] + (_lux_case ma + #None #None + (#Some a) (f a)))}) + +(def'' Lux/Monad + ($' Monad Lux) + {#lux;return + (lambda [x] + (lambda [state] + (#Right [state x]))) + + #lux;bind + (lambda [f ma] + (lambda [state] + (_lux_case (ma state) + (#Left msg) + (#Left msg) + + (#Right [state' a]) + (f a state'))))}) + +(defmacro #export (^ tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) + + _ + (fail "Wrong syntax for ^"))) + +(defmacro #export (-> tokens) + (_lux_case (reverse tokens) + (#Cons [output inputs]) + (return (list (foldL (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + output + inputs))) + + _ + (fail "Wrong syntax for ->"))) + +(defmacro #export (, tokens) + (return (list (`' (#;TupleT (~ (untemplate-list tokens))))))) + +(defmacro (do tokens) + (_lux_case tokens + (#Cons [monad (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [body #Nil])])]) + (let [body' (foldL (_lux_: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body' binding] + (let [[var value] binding] + (_lux_case var + (#Meta [_ (#TagS ["" "let"])]) + (`' (;let (~ value) (~ body'))) + + _ + (`' (;bind (_lux_lambda (~ (symbol$ ["" ""])) + (~ var) + (~ body')) + (~ value))))))) + body + (reverse (as-pairs bindings)))] + (return (list (`' (_lux_case (~ monad) + {#;return ;return #;bind ;bind} + (~ body')))))) + + _ + (fail "Wrong syntax for do"))) + +(def'' (map% m f xs) + ## (All [m a b] + ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) + (All' [m a b] + (-> ($' Monad (B' m)) + (-> (B' a) ($' (B' m) (B' b))) + ($' List (B' a)) + ($' (B' m) ($' List (B' b))))) + (let [{#;return ;return #;bind _} m] + (_lux_case xs + #Nil + (;return #Nil) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (#Cons [y ys]))) + ))) + +(def'' #export (. f g) + (All' [a b c] + (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c)))) + (lambda [x] + (f (g x)))) + +(def'' (get-ident x) + (-> Syntax ($' Maybe Text)) + (_lux_case x + (#Meta [_ (#SymbolS ["" sname])]) + (#Some sname) + + _ + #None)) + +(def'' (tuple->list tuple) + (-> Syntax ($' Maybe ($' List Syntax))) + (_lux_case tuple + (#Meta [_ (#TupleS members)]) + (#Some members) + + _ + #None)) + +(def'' RepEnv + Type + ($' List (, Text Syntax))) + +(def'' (make-env xs ys) + (-> ($' List Text) ($' List Syntax) RepEnv) + (_lux_case (_lux_: (, ($' List Text) ($' List Syntax)) + [xs ys]) + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (make-env xs' ys')]) + + _ + #Nil)) + +(def'' #export (text:= x y) + (-> Text Text Bool) + (_jvm_invokevirtual java.lang.Object equals [java.lang.Object] + x [y])) + +(def'' (get-rep key env) + (-> Text RepEnv ($' Maybe Syntax)) + (_lux_case env + #Nil + #None + + (#Cons [[k v] env']) + (if (text:= k key) + (#Some v) + (get-rep key env')))) + +(def'' (apply-template env template) + (-> RepEnv Syntax Syntax) + (_lux_case template + (#Meta [_ (#SymbolS ["" sname])]) + (_lux_case (get-rep sname env) + (#Some subst) + subst + + _ + template) + + (#Meta [_ (#TupleS elems)]) + (tuple$ (map (apply-template env) elems)) + + (#Meta [_ (#FormS elems)]) + (form$ (map (apply-template env) elems)) + + (#Meta [_ (#RecordS members)]) + (record$ (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [kv] + (let [[slot value] kv] + [(apply-template env slot) (apply-template env value)]))) + members)) + + _ + template)) + +(def'' (join-map f xs) + (All' [a b] + (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) + (_lux_case xs + #Nil + #Nil + + (#Cons [x xs']) + (list:++ (f x) (join-map f xs')))) + +(defmacro #export (do-template tokens) + (_lux_case tokens + (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) + (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) + [(map% Maybe/Monad get-ident bindings) + (map% Maybe/Monad tuple->list data)]) + [(#Some bindings') (#Some data')] + (let [apply (_lux_: (-> RepEnv ($' List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + return)) + + _ + (fail "Wrong syntax for do-template")) + + _ + (fail "Wrong syntax for do-template"))) + +(do-template [<name> <cmp> <type>] + [(def'' #export (<name> x y) + (-> <type> <type> Bool) + (<cmp> x y))] + + [i= _jvm_leq Int] + [i> _jvm_lgt Int] + [i< _jvm_llt Int] + [r= _jvm_deq Real] + [r> _jvm_dgt Real] + [r< _jvm_dlt Real] + ) + +(do-template [<name> <cmp> <eq> <type>] + [(def'' #export (<name> x y) + (-> <type> <type> Bool) + (if (<cmp> x y) + true + (<eq> x y)))] + + [i>= i> i= Int] + [i<= i< i= Int] + [r>= r> r= Real] + [r<= r< r= Real] + ) + +(do-template [<name> <cmp> <type>] + [(def'' #export (<name> x y) + (-> <type> <type> <type>) + (<cmp> x y))] + + [i+ _jvm_ladd Int] + [i- _jvm_lsub Int] + [i* _jvm_lmul Int] + [i/ _jvm_ldiv Int] + [i% _jvm_lrem Int] + [r+ _jvm_dadd Real] + [r- _jvm_dsub Real] + [r* _jvm_dmul Real] + [r/ _jvm_ddiv Real] + [r% _jvm_drem Real] + ) + +(def'' (multiple? div n) + (-> Int Int Bool) + (i= 0 (i% n div))) + +(def'' (length list) + (-> List Int) + (foldL (lambda [acc _] (i+ 1 acc)) 0 list)) + +(def'' #export (not x) + (-> Bool Bool) + (if x false true)) + +(def'' #export (text:++ x y) + (-> Text Text Text) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y])) + +(def'' (ident->text ident) + (-> Ident Text) + (let [[module name] ident] + ($ text:++ module ";" name))) + +(def'' (replace-syntax reps syntax) + (-> RepEnv Syntax Syntax) + (_lux_case syntax + (#Meta [_ (#SymbolS ["" name])]) + (_lux_case (get-rep name reps) + (#Some replacement) + replacement + + #None + syntax) + + (#Meta [_ (#FormS parts)]) + (#Meta [_ (#FormS (map (replace-syntax reps) parts))]) + + (#Meta [_ (#TupleS members)]) + (#Meta [_ (#TupleS (map (replace-syntax reps) members))]) + + (#Meta [_ (#RecordS slots)]) + (#Meta [_ (#RecordS (map (_lux_: (-> (, Syntax Syntax) (, Syntax Syntax)) + (lambda [slot] + (let [[k v] slot] + [(replace-syntax reps k) (replace-syntax reps v)]))) + slots))]) + + _ + syntax) + ) + +(defmacro #export (All tokens) + (let [[self-ident tokens'] (_lux_: (, Text SyntaxList) + (_lux_case tokens + (#Cons [(#Meta [_ (#SymbolS ["" self-ident])]) tokens']) + [self-ident tokens'] + + _ + ["" tokens]))] + (_lux_case tokens' + (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) + (_lux_case (map% Maybe/Monad get-ident args) + (#Some idents) + (_lux_case idents + #Nil + (return (list body)) + + (#Cons [harg targs]) + (let [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda [ident] [ident (`' (#;BoundT (~ (text$ ident))))])) + (list& self-ident idents)) + body' (foldL (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ (text$ arg')) (~ body')]))) + (replace-syntax replacements body) + (reverse targs))] + ## (#;Some #;Nil) + (return (list (`' (#;AllT [#;None (~ (text$ self-ident)) (~ (text$ harg)) (~ body')])))))) + + #None + (fail "'All' arguments must be symbols.")) + + _ + (fail "Wrong syntax for All")) + )) + +(def'' (get k plist) + (All [a] + (-> Text ($' List (, Text a)) ($' Maybe a))) + (_lux_case plist + (#Cons [[k' v] plist']) + (if (text:= k k') + (#Some v) + (get k plist')) + + #Nil + #None)) + +(def'' (put k v dict) + (All [a] + (-> Text a ($' List (, Text a)) ($' List (, Text a)))) + (_lux_case dict + #Nil + (list [k v]) + + (#Cons [[k' v'] dict']) + (if (text:= k k') + (#Cons [[k' v] dict']) + (#Cons [[k' v'] (put k v dict')])))) + +(def'' (get-module-name state) + ($' Lux Text) + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (_lux_case (reverse envs) + #Nil + (#Left "Can't get the module name without a module!") + + (#Cons [{#name module-name #inner-closures _ #locals _ #closure _} _]) + (#Right [state module-name])))) + +(def'' (find-macro' modules current-module module name) + (-> ($' List (, Text ($' Module Compiler))) + Text Text Text + ($' Maybe Macro)) + (do Maybe/Monad + [$module (get module modules) + gdef (let [{#module-aliases _ #defs bindings #imports _} (_lux_: ($' Module Compiler) $module)] + (get name bindings))] + (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) + [exported? (#MacroD macro')] + (if exported? + (#Some macro') + (if (text:= module current-module) + (#Some macro') + #None)) + + [_ (#AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ + #None))) + +(def'' (find-macro ident) + (-> Ident ($' Lux ($' Maybe Macro))) + (do Lux/Monad + [current-module get-module-name] + (let [[module name] ident] + (lambda [state] + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (#Right [state (find-macro' modules current-module module name)])))))) + +(def'' (list:join xs) + (All [a] + (-> ($' List ($' List a)) ($' List a))) + (foldL list:++ #Nil xs)) + +(def'' (normalize ident) + (-> Ident ($' Lux Ident)) + (_lux_case ident + ["" name] + (do Lux/Monad + [module-name get-module-name] + (;return (_lux_: Ident [module-name name]))) + + _ + (return ident))) + +(defmacro #export (| tokens) + (do Lux/Monad + [pairs (map% Lux/Monad + (_lux_: (-> Syntax ($' Lux Syntax)) + (lambda [token] + (_lux_case token + (#Meta [_ (#TagS ident)]) + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for |")))) + tokens)] + (;return (list (`' (#;VariantT (~ (untemplate-list pairs)))))))) + +(defmacro #export (& tokens) + (if (not (multiple? 2 (length tokens))) + (fail "& expects an even number of arguments.") + (do Lux/Monad + [pairs (map% Lux/Monad + (_lux_: (-> (, Syntax Syntax) ($' Lux Syntax)) + (lambda [pair] + (_lux_case pair + [(#Meta [_ (#TagS ident)]) value] + (do Lux/Monad + [ident (normalize ident)] + (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) + + _ + (fail "Wrong syntax for &")))) + (as-pairs tokens))] + (;return (list (`' (#;RecordT (~ (untemplate-list pairs))))))))) + +(def'' #export (->text x) + (-> (^ java.lang.Object) Text) + (_jvm_invokevirtual java.lang.Object toString [] x [])) + +(def'' (interpose sep xs) + (All [a] + (-> a ($' List a) ($' List a))) + (_lux_case xs + #Nil + xs + + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list& x sep (interpose sep xs')))) + +(def'' (macro-expand syntax) + (-> Syntax ($' Lux ($' List Syntax))) + (_lux_case syntax + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (map% Lux/Monad macro-expand expansion)] + (;return (list:join expansion'))) + + #None + (do Lux/Monad + [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+)))))) + + (#Meta [_ (#TupleS members)]) + (do Lux/Monad + [members' (map% Lux/Monad macro-expand members)] + (;return (list (tuple$ (list:join members'))))) + + _ + (return (list syntax)))) + +(def'' (walk-type type) + (-> Syntax Syntax) + (_lux_case type + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS tag)]) parts]))]) + (form$ (#Cons [(tag$ tag) (map walk-type parts)])) + + (#Meta [_ (#TupleS members)]) + (tuple$ (map walk-type members)) + + (#Meta [_ (#FormS (#Cons [type-fn args]))]) + (foldL (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)]))) + (walk-type type-fn) + (map walk-type args)) + + _ + type)) + +(defmacro #export (type tokens) + (_lux_case tokens + (#Cons [type #Nil]) + (do Lux/Monad + [type+ (macro-expand type)] + (_lux_case type+ + (#Cons [type' #Nil]) + (;return (list (walk-type type'))) + + _ + (fail "The expansion of the type-syntax had to yield a single element."))) + + _ + (fail "Wrong syntax for type"))) + +(defmacro #export (: tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_: (;type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :"))) + +(defmacro #export (:! tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) + + _ + (fail "Wrong syntax for :!"))) + +(def'' (empty? xs) + (All [a] (-> ($' List a) Bool)) + (_lux_case xs + #Nil true + _ false)) + +(defmacro #export (deftype tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + [rec? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + [true tokens'] + + _ + [false tokens'])) + parts (: (Maybe (, Text (List Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) + (#Some [name #Nil type]) + + (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) + (#Some [name args type]) + + _ + #None))] + (_lux_case parts + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (`' (_lux_export (~ (symbol$ ["" name]))))) + #Nil)) + type' (: (Maybe Syntax) + (if rec? + (if (empty? args) + (let [g!param (symbol$ ["" ""]) + prime-name (symbol$ ["" (text:++ name "'")]) + type+ (replace-syntax (list [name (`' ((~ prime-name) (~ g!param)))]) type)] + (#Some (`' ((;All (~ prime-name) [(~ g!param)] (~ type+)) + ;Void)))) + #None) + (_lux_case args + #Nil + (#Some type) + + _ + (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (_lux_case type' + (#Some type'') + (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + with-export)) + + #None + (fail "Wrong syntax for deftype"))) + + #None + (fail "Wrong syntax for deftype")) + )) +## (defmacro #export (deftype tokens) +## (let [[export? tokens'] (: (, Bool (List Syntax)) +## (_lux_case (:! (List Syntax) tokens) +## (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) +## [true (:! (List Syntax) tokens')] + +## _ +## [false (:! (List Syntax) tokens)])) +## parts (: (Maybe (, Syntax (List Syntax) Syntax)) +## (_lux_case tokens' +## (#Cons [(#Meta [_ (#SymbolS name)]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) #Nil type]) + +## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) +## (#Some [(symbol$ name) args type]) + +## _ +## #None))] +## (_lux_case parts +## (#Some [name args type]) +## (let [with-export (: (List Syntax) +## (if export? +## (list (`' (_lux_export (~ name)))) +## #Nil)) +## type' (: Syntax +## (_lux_case args +## #Nil +## type + +## _ +## (`' (;All (~ name) [(~@ args)] (~ type)))))] +## (return (list& (`' (_lux_def (~ name) (;type (~ type')))) +## with-export))) + +## #None +## (fail "Wrong syntax for deftype")) +## )) + +(defmacro #export (exec tokens) + (_lux_case (reverse tokens) + (#Cons [value actions]) + (let [dummy (symbol$ ["" ""])] + (return (list (foldL (lambda [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) + value + actions)))) + + _ + (fail "Wrong syntax for exec"))) + +(defmacro #export (def tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + (_lux_case tokens' + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) + + _ + #None))] + (_lux_case parts + (#Some [name args ?type body]) + (let [body' (: Syntax + (_lux_case args + #Nil + body + + _ + (`' (;lambda (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (_lux_case ?type + (#Some type) + (`' (: (~ type) (~ body'))) + + #None + body'))] + (return (list& (`' (_lux_def (~ name) (~ body''))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for def")))) + +(def (rejoin-pair pair) + (-> (, Syntax Syntax) (List Syntax)) + (let [[left right] pair] + (list left right))) + +(defmacro #export (case tokens) + (_lux_case tokens + (#Cons [value branches]) + (do Lux/Monad + [expansions (map% Lux/Monad + (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) + (lambda expander [branch] + (let [[pattern body] branch] + (_lux_case pattern + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (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))))))) + + _ + (fail "Wrong syntax for case"))) + +(defmacro #export (\ tokens) + (case tokens + (#Cons [body (#Cons [pattern #Nil])]) + (do Lux/Monad + [pattern+ (macro-expand pattern)] + (case pattern+ + (#Cons [pattern' #Nil]) + (;return (list pattern' body)) + + _ + (fail "\\ can only expand to 1 pattern."))) + + _ + (fail "Wrong syntax for \\"))) + +(defmacro #export (\or tokens) + (case tokens + (#Cons [body patterns]) + (case patterns + #Nil + (fail "\\or can't have 0 patterns") + + _ + (do Lux/Monad + [patterns' (map% Lux/Monad macro-expand patterns)] + (;return (list:join (map (lambda [pattern] (list pattern body)) + (list:join patterns')))))) + + _ + (fail "Wrong syntax for \\or"))) + +(do-template [<name> <offset>] + [(def #export <name> (i+ <offset>))] + + [inc 1] + [dec -1]) + +(defmacro #export (` tokens) + (do Lux/Monad + [module-name get-module-name] + (case tokens + (\ (list template)) + (;return (list (untemplate true module-name template))) + + _ + (fail "Wrong syntax for `")))) + +(def (gensym prefix state) + (-> Text (Lux Syntax)) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (#Right [{#source source #modules modules + #envs envs #types types #host host + #seed (inc seed) #eval? eval?} + (symbol$ ["__gensym__" (->text seed)])]))) + +(def (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux/Monad + [token+ (macro-expand token)] + (case token+ + (\ (list token')) + (;return token') + + _ + (fail "Macro expanded to more than 1 element.")))) + +(defmacro #export (sig tokens) + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad + (: (-> Syntax (Lux (, Ident Syntax))) + (lambda [token] + (case token + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (do Lux/Monad + [name' (normalize name)] + (;return (: (, Ident Syntax) [name' type]))) + + _ + (fail "Signatures require typed members!")))) + (list:join tokens'))] + (;return (list (`' (#;RecordT (~ (untemplate-list (map (: (-> (, Ident Syntax) Syntax) + (lambda [pair] + (let [[name type] pair] + (`' [(~ (|> name ident->text text$)) + (~ type)])))) + members))))))))) + +(defmacro #export (defsig tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens])) + ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) + (case tokens' + (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) + (#Some [name args sigs]) + + (\ (list& name sigs)) + (#Some [name #Nil sigs]) + + _ + #None))] + (case ?parts + (#Some [name args sigs]) + (let [sigs' (: Syntax + (case args + #Nil + (`' (;sig (~@ sigs))) + + _ + (`' (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] + (return (list& (`' (_lux_def (~ name) (~ sigs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for defsig")))) + +(defmacro #export (struct tokens) + (do Lux/Monad + [tokens' (map% Lux/Monad macro-expand tokens) + members (map% Lux/Monad + (: (-> Syntax (Lux (, Syntax Syntax))) + (lambda [token] + (case token + (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS ["" "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (do Lux/Monad + [name' (normalize name)] + (;return (: (, Syntax Syntax) [(tag$ name') value]))) + + _ + (fail "Structures require defined members!")))) + (list:join tokens'))] + (;return (list (record$ members))))) + +(defmacro #export (defstruct tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false tokens])) + ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) + (case tokens' + (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) + (#Some [name args type defs]) + + (\ (list& name type defs)) + (#Some [name #Nil type defs]) + + _ + #None))] + (case ?parts + (#Some [name args type defs]) + (let [defs' (: Syntax + (case args + #Nil + (`' (;struct (~@ defs))) + + _ + (`' (;lambda (~ name) [(~@ args)] (;struct (~@ defs))))))] + (return (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil)))) + + #None + (fail "Wrong syntax for defstruct")))) + +(def #export (id x) + (All [a] (-> a a)) + x) + +(do-template [<name> <form> <message>] + [(defmacro #export (<name> tokens) + (case (reverse tokens) + (\ (list& last init)) + (return (list (foldL (lambda [post pre] (` <form>)) + last + init))) + + _ + (fail <message>)))] + + [and (if (~ pre) (~ post) false) "and requires >=1 clauses."] + [or (if (~ pre) true (~ post)) "or requires >=1 clauses."]) + +(deftype Referrals + (| #All + (#Only (List Text)) + (#Exclude (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/exclude 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 ["" "exclude"])]) defs))])) + (do Lux/Monad + [defs' (extract-defs defs)] + (return (: (, Referrals (List Syntax)) [(#Exclude 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 + #seed seed #eval? eval?} + (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 #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? + (list name) + (list))))) + (let [{#module-aliases _ #defs defs #imports _} =module] + defs))] + (#Right [state (list:join to-alias)])) + + #None + (#Left ($ text:++ "Unknown module: " module))) + )) + +(def (last-index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String lastIndexOf [java.lang.String] + text [part]))) + +(def (index-of part text) + (-> Text Text Int) + (_jvm_i2l (_jvm_invokevirtual java.lang.String indexOf [java.lang.String] + text [part]))) + +(def (substring1 idx text) + (-> Int Text Text) + (_jvm_invokevirtual java.lang.String substring [int] + text [(_jvm_l2i idx)])) + +(def (substring2 idx1 idx2 text) + (-> Int Int Text Text) + (_jvm_invokevirtual java.lang.String substring [int int] + text [(_jvm_l2i idx1) (_jvm_l2i idx2)])) + +(def (split-module-contexts module) + (-> Text (List Text)) + (#Cons [module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module))))])) + +(def (split-module module) + (-> Text (List Text)) + (let [idx (index-of "/" module)] + (if (i< idx 0) + (#Cons [module #Nil]) + (#Cons [(substring2 0 idx module) + (split-module (substring1 (inc idx) module))])))) + +(def (@ idx xs) + (All [a] + (-> Int (List a) (Maybe a))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (if (i= 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 (i= 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))) + + (#Exclude -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) + module (substring2 0 idx slot) + 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 + (#RecordT slots) + (#Some type) + + (#AppT [fun arg]) + (apply-type fun arg) + + (#AllT [_ _ _ body]) + (resolve-struct-type body) + + _ + #None)) + +(def (try-both f x1 x2) + (All [a b] + (-> (-> a (Maybe b)) a a (Maybe b))) + (case (f x1) + #;None (f x2) + (#;Some y) (#;Some y))) + +(def (find-in-env name state) + (-> Ident Compiler (Maybe Type)) + (let [vname' (ident->text name)] + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval?} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings locals} #closure {#counter _ #mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#Some type) + #None))))) + locals + closure)))) + envs)))) + +(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 #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 #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 #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 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$ ["" ""])] + (return (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body)))))))) + + _ + (fail "Wrong syntax for using"))) + +(def #export (flip f) + (All [a b c] + (-> (-> a b c) (-> b a c))) + (lambda [y x] + (f x y))) + +(def #export (curry f) + (All [a b c] + (-> (-> (, a b) c) + (-> a b c))) + (lambda [x y] + (f [x y]))) + +(def #export (uncurry f) + (All [a b c] + (-> (-> a b c) + (-> (, a b) c))) + (lambda [xy] + (let [[x y] xy] + (f x y)))) + +(defmacro #export (cond tokens) + (if (i= 0 (i% (length tokens) 2)) + (fail "cond requires an even number of arguments.") + (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 (\template tokens) + (case tokens + (\ (list (#Meta [_ (#TupleS data)]) + (#Meta [_ (#TupleS bindings)]) + (#Meta [_ (#TupleS templates)]))) + (case (: (Maybe (List Syntax)) + (do Maybe/Monad + [bindings' (map% Maybe/Monad get-ident bindings) + data' (map% Maybe/Monad tuple->list data)] + (let [apply (: (-> RepEnv (List Syntax)) + (lambda [env] (map (apply-template env) templates)))] + (|> data' + (join-map (. apply (make-env bindings'))) + ;return)))) + (#Some output) + (return output) + + #None + (fail "Wrong syntax for \\template")) + + _ + (fail "Wrong syntax for \\template"))) + +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) + +## (defmacro #export (loop tokens) +## (case tokens +## (\ (list bindings body)) +## (let [pairs (as-pairs bindings) +## vars (map first pairs) +## inits (map second pairs)] +## (if (every? symbol? inits) +## (do Lux/Monad +## [inits' (map% Maybe/Monad get-ident inits) +## init-types (map% Maybe/Monad find-var-type inits')] +## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] +## (~ body)) +## (~@ inits)))))) +## (do Lux/Monad +## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] +## (return (list (` (let [(~@ (interleave aliases inits))] +## (loop [(~@ (interleave vars aliases))] +## (~ body))))))))) + +## _ +## (fail "Wrong syntax for loop"))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux new file mode 100644 index 000000000..1d6dd1b50 --- /dev/null +++ b/source/lux/codata/stream.lux @@ -0,0 +1,133 @@ +## 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) + (functor #as F #refer #all) + (monad #as M #refer #all) + (comonad #as CM #refer #all)) + (meta lux + macro + syntax) + (data (list #as l #refer (#only list list& List/Monad))))) + +## [Types] +(deftype #export (Stream a) + (Lazy (, a (Stream a)))) + +## [Utils] +(def (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (cycle' init full init full) + (#;Cons [y xs']) (... [x (cycle' y xs' init full)]))) + +## [Functions] +(def #export (iterate f x) + (All [a] + (-> (-> a a) a (Stream a))) + (... [x (iterate f (f x))])) + +(def #export (repeat x) + (All [a] + (-> a (Stream a))) + (... [x (repeat x)])) + +(def #export (cycle xs) + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons [x xs']) (#;Some (cycle' x xs' x xs')))) + +(do-template [<name> <return> <part>] + [(def #export (<name> s) + (All [a] (-> (Stream a) <return>)) + (let [[h t] (! s)] + <part>))] + + [head a h] + [tail (Stream a) t]) + +(def #export (@ idx s) + (All [a] (-> Int (Stream a) a)) + (let [[h t] (! s)] + (if (i> idx 0) + (@ (dec idx) t) + h))) + +(do-template [<taker> <dropper> <splitter> <det-type> <det-test> <det-step>] + [(def #export (<taker> det xs) + (All [a] + (-> <det-type> (Stream a) (List a))) + (let [[x xs'] (! xs)] + (if <det-test> + (list& x (<taker> <det-step> xs')) + (list)))) + + (def #export (<dropper> det xs) + (All [a] + (-> <det-type> (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if <det-test> + (<dropper> <det-step> xs') + xs))) + + (def #export (<splitter> det xs) + (All [a] + (-> <det-type> (Stream a) (, (List a) (Stream a)))) + (let [[x xs'] (! xs)] + (if <det-test> + (let [[tail next] (<splitter> <det-step> xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-with (-> a Bool) (det x) det] + [take drop split Int (i> det 0) (dec det)] + ) + +(def #export (unfold step init) + (All [a b] + (-> (-> a (, a b)) a (Stream b))) + (let [[next x] (step init)] + (... [x (unfold step next)]))) + +(def #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (! xs)] + (if (p x) + (... [x (filter p xs')]) + (filter p xs')))) + +(def #export (partition p xs) + (All [a] (-> (-> a Bool) (Stream a) (, (Stream a) (Stream a)))) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(defstruct #export Stream/Functor (Functor Stream) + (def (F;map f fa) + (let [[h t] (! fa)] + (... [(f h) (F;map f t)])))) + +(defstruct #export Stream/CoMonad (CoMonad Stream) + (def CM;_functor Stream/Functor) + (def CM;unwrap head) + (def (CM;split wa) + (:: Stream/Functor (F;map repeat wa)))) + +## [Pattern-matching] +(defsyntax #export (\stream body [patterns' (+^ id^)]) + (do Lux/Monad + [patterns (map% Lux/Monad macro-expand-1 patterns') + g!s (gensym "s") + #let [patterns+ (: (List Syntax) + (do List/Monad + [pattern (l;reverse patterns)] + (list (` [(~ pattern) (~ g!s)]) (` (L;! (~ g!s))))))]] + (M;wrap (list g!s (` (;let [(~@ patterns+)] (~ body))))))) diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux new file mode 100644 index 000000000..1830ff44f --- /dev/null +++ b/source/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/source/lux/control/functor.lux b/source/lux/control/functor.lux new file mode 100644 index 000000000..6a9dcfff8 --- /dev/null +++ b/source/lux/control/functor.lux @@ -0,0 +1,15 @@ +## 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 (Functor f) + (: (All [a b] + (-> (-> a b) (f a) (f b))) + map)) diff --git a/source/lux/control/lazy.lux b/source/lux/control/lazy.lux new file mode 100644 index 000000000..22dac74fe --- /dev/null +++ b/source/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) + (lambda [k] (ma (. k f))))) + +(defstruct #export Lazy/Monad (Monad Lazy) + (def M;_functor Lazy/Functor) + + (def (M;wrap a) + (... a)) + + (def M;join !)) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux new file mode 100644 index 000000000..b5552f987 --- /dev/null +++ b/source/lux/control/monad.lux @@ -0,0 +1,99 @@ +## 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) + (monoid #as M)) + lux/meta/macro) + +## [Utils] +(def (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 (reverse xs) + (All [a] + (-> (List a) (List a))) + (foldL (lambda [tail head] (#;Cons [head tail])) + #;Nil + xs)) + +(def (as-pairs xs) + (All [a] (-> (List a) (List (, a a)))) + (case xs + (#;Cons [x1 (#;Cons [x2 xs'])]) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +## [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)) + (#;Cons [monad (#;Cons [(#;Meta [_ (#;TupleS bindings)]) (#;Cons [body #;Nil])])]) + (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 (#;Cons [(` (;case (~ monad) + {#;;_functor ;;_functor #;;wrap ;;wrap #;;join ;;join} + (~ body'))) + #;Nil])])) + + _ + (#;Left "Wrong syntax for do"))) + +## [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/source/lux/control/monoid.lux b/source/lux/control/monoid.lux new file mode 100644 index 000000000..d32baabc5 --- /dev/null +++ b/source/lux/control/monoid.lux @@ -0,0 +1,24 @@ +## 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 (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 ++ ++))) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux new file mode 100644 index 000000000..d4f223612 --- /dev/null +++ b/source/lux/data/bool.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m)) + (.. (eq #as E) + (show #as S))) + +## [Structures] +(defstruct #export Bool/Eq (E;Eq Bool) + (def (E;= x y) + (if x + y + (not y)))) + +(defstruct #export Bool/Show (S;Show Bool) + (def (S;show x) + (if x "true" "false"))) + +(do-template [<name> <unit> <op>] + [(defstruct #export <name> (m;Monoid Bool) + (def m;unit <unit>) + (def (m;++ x y) + (<op> x y)))] + + [ Or/Monoid false or] + [And/Monoid true and] + ) diff --git a/source/lux/data/bounded.lux b/source/lux/data/bounded.lux new file mode 100644 index 000000000..9d2dabde1 --- /dev/null +++ b/source/lux/data/bounded.lux @@ -0,0 +1,17 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Bounded a) + (: a + top) + + (: a + bottom)) diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux new file mode 100644 index 000000000..42e57509e --- /dev/null +++ b/source/lux/data/char.lux @@ -0,0 +1,20 @@ +## 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) + (show #as S))) + +## [Structures] +(defstruct #export Char/Eq (E;Eq Char) + (def (E;= x y) + (_jvm_ceq x y))) + +(defstruct #export Char/Show (S;Show Char) + (def (S;show x) + ($ text:++ "#\"" (_jvm_invokevirtual java.lang.Object toString [] x []) "\""))) diff --git a/source/lux/data/dict.lux b/source/lux/data/dict.lux new file mode 100644 index 000000000..63a66d49b --- /dev/null +++ b/source/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/source/lux/data/either.lux b/source/lux/data/either.lux new file mode 100644 index 000000000..eba6438db --- /dev/null +++ b/source/lux/data/either.lux @@ -0,0 +1,46 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/data (list #refer (#exclude partition)))) + +## [Types] +## (deftype (Either l r) +## (| (#;Left l) +## (#;Right r))) + +## [Functions] +(def #export (either f g e) + (All [a b c] (-> (-> a c) (-> b c) (Either a b) c)) + (case e + (#;Left x) (f x) + (#;Right x) (g x))) + +(do-template [<name> <side> <tag>] + [(def #export (<name> es) + (All [a b] (-> (List (Either a b)) (List <side>))) + (case es + #;Nil #;Nil + (#;Cons [(<tag> x) es']) (#;Cons [x (<name> es')]) + (#;Cons [_ es']) (<name> es')))] + + [lefts a #;Left] + [rights b #;Right] + ) + +(def #export (partition es) + (All [a b] (-> (List (Either a b)) (, (List a) (List b)))) + (foldL (: (All [a b] + (-> (, (List a) (List b)) (Either a b) (, (List a) (List b)))) + (lambda [tails e] + (let [[ltail rtail] tails] + (case e + (#;Left x) [(#;Cons [x ltail]) rtail] + (#;Right x) [ltail (#;Cons [x rtail])])))) + [(list) (list)] + (reverse es))) diff --git a/source/lux/data/eq.lux b/source/lux/data/eq.lux new file mode 100644 index 000000000..be3400208 --- /dev/null +++ b/source/lux/data/eq.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Signatures] +(defsig #export (Eq a) + (: (-> a a Bool) + =)) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux new file mode 100644 index 000000000..cb5c309a6 --- /dev/null +++ b/source/lux/data/error.lux @@ -0,0 +1,34 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Error a) + (| (#Fail Text) + (#Ok a))) + +## [Structures] +(defstruct #export Error/Functor (Functor Error) + (def (F;map f ma) + (case ma + (#Fail msg) (#Fail msg) + (#Ok datum) (#Ok (f datum))))) + +(defstruct #export Error/Monad (Monad Error) + (def M;_functor Error/Functor) + + (def (M;wrap a) + (#Ok a)) + + (def (M;join mma) + (case mma + (#Fail msg) (#Fail msg) + (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux new file mode 100644 index 000000000..0e3bdbee6 --- /dev/null +++ b/source/lux/data/id.lux @@ -0,0 +1,28 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Id a) + (| (#Id a))) + +## [Structures] +(defstruct #export Id/Functor (Functor Id) + (def (F;map f fa) + (let [(#Id a) fa] + (#Id (f a))))) + +(defstruct #export Id/Monad (Monad Id) + (def M;_functor Id/Functor) + (def (M;wrap a) (#Id a)) + (def (M;join mma) + (let [(#Id ma) mma] + ma))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux new file mode 100644 index 000000000..c08023df5 --- /dev/null +++ b/source/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/source/lux/data/list.lux b/source/lux/data/list.lux new file mode 100644 index 000000000..450dee275 --- /dev/null +++ b/source/lux/data/list.lux @@ -0,0 +1,250 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all)) + 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 (partition p xs) + (All [a] (-> (-> a Bool) (List a) (, (List a) (List a)))) + [(filter p xs) (filter (complement 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 (i> 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 n xs) + (All [a] + (-> Int (List a) (, (List a) (List a)))) + (if (i> n 0) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons [x xs']) + (let [[tail rest] (split (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 (i> 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 _] (i+ 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 (i= 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&"))) + +## Structures +(defstruct #export List/Monoid (All [a] + (Monoid (List a))) + (def m;unit #;Nil) + (def (m;++ xs ys) + (case xs + #;Nil ys + (#;Cons [x xs']) (#;Cons [x (m;++ xs' ys)])))) + +(defstruct #export List/Functor (Functor List) + (def (F;map f ma) + (case ma + #;Nil #;Nil + (#;Cons [a ma']) (#;Cons [(f a) (F;map f ma')])))) + +(defstruct #export List/Monad (Monad List) + (def M;_functor List/Functor) + + (def (M;wrap a) + (#;Cons [a #;Nil])) + + (def (M;join mma) + (using List/Monoid + (foldL m;++ m;unit mma)))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux new file mode 100644 index 000000000..faec53c2e --- /dev/null +++ b/source/lux/data/maybe.lux @@ -0,0 +1,42 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +## (deftype (Maybe a) +## (| #;None +## (#;Some a))) + +## [Structures] +(defstruct #export Maybe/Monoid (Monoid Maybe) + (def m;unit #;None) + (def (m;++ xs ys) + (case xs + #;None ys + (#;Some x) (#;Some x)))) + +(defstruct #export Maybe/Functor (Functor Maybe) + (def (F;map f ma) + (case ma + #;None #;None + (#;Some a) (#;Some (f a))))) + +(defstruct #export Maybe/Monad (Monad Maybe) + (def M;_functor Maybe/Functor) + + (def (M;wrap x) + (#;Some x)) + + (def (M;join mma) + (case mma + #;None #;None + (#;Some xs) xs))) diff --git a/source/lux/data/number.lux b/source/lux/data/number.lux new file mode 100644 index 000000000..8da674d88 --- /dev/null +++ b/source/lux/data/number.lux @@ -0,0 +1,119 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m)) + (lux/data (eq #as E) + (ord #as O) + (bounded #as B) + (show #as S))) + +## Signatures +(defsig #export (Number n) + (do-template [<name>] + [(: (-> n n n) <name>)] + [+] [-] [*] [/] [%]) + + (: (-> Int n) + from-int) + + (do-template [<name>] + [(: (-> n n) <name>)] + [negate] [signum] [abs]) + ) + +## [Structures] +## Number +(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 (signum x) + (cond (<=> x <0>) <0> + (<<> x <0>) <-1> + ## else + <1>)) + )] + + [ Int/Number Int i+ i- i* i/ i% i= i< id 0 1 -1] + [Real/Number Real r+ r- r* r/ r% r= r< _jvm_l2d 0.0 1.0 -1.0]) + +## Eq +(defstruct #export Int/Eq (E;Eq Int) + (def E;= i=)) + +(defstruct #export Real/Eq (E;Eq Real) + (def E;= r=)) + +## Ord +## (def #export Int/Ord (O;Ord Int) +## (O;ord$ Int/Eq i< i>)) + +## (def #export Real/Ord (O;Ord Real) +## (O;ord$ Real/Eq r< r>)) + +(do-template [<name> <type> <eq> <lt> <gt>] + [(defstruct #export <name> (O;Ord <type>) + (def O;_eq <eq>) + (def O;< <lt>) + (def (O;<= x y) + (or (<lt> x y) + (using <eq> (E;= x y)))) + (def O;> <gt>) + (def (O;>= x y) + (or (<gt> x y) + (using <eq> (E;= x y)))))] + + [ Int/Ord Int Int/Eq i< i>] + [Real/Ord Real Real/Eq r< r>]) + +## Bounded +(do-template [<name> <type> <top> <bottom>] + [(defstruct #export <name> (B;Bounded <type>) + (def B;top <top>) + (def B;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)]) + +## Monoid +(do-template [<name> <type> <unit> <++>] + [(defstruct #export <name> (m;Monoid <type>) + (def m;unit <unit>) + (def m;++ <++>))] + + [ IntAdd/Monoid Int 0 i+] + [ IntMul/Monoid Int 1 i*] + [RealAdd/Monoid Real 0.0 r+] + [RealMul/Monoid Real 1.0 r*] + [ IntMax/Monoid Int (:: Int/Bounded B;bottom) (O;max Int/Ord)] + [ IntMin/Monoid Int (:: Int/Bounded B;top) (O;min Int/Ord)] + [RealMax/Monoid Real (:: Real/Bounded B;bottom) (O;max Real/Ord)] + [RealMin/Monoid Real (:: Real/Bounded B;top) (O;min Real/Ord)] + ) + +## Show +(do-template [<name> <type> <body>] + [(defstruct #export <name> (S;Show <type>) + (def (S;show x) + <body>))] + + [ Int/Show Int (_jvm_invokevirtual java.lang.Object toString [] x [])] + [Real/Show Real (_jvm_invokevirtual java.lang.Object toString [] x [])] + ) diff --git a/source/lux/data/ord.lux b/source/lux/data/ord.lux new file mode 100644 index 000000000..80f2e4fb5 --- /dev/null +++ b/source/lux/data/ord.lux @@ -0,0 +1,44 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (../eq #as E)) + +## [Signatures] +(defsig #export (Ord a) + (: (E;Eq a) + _eq) + (do-template [<name>] + [(: (-> a a Bool) <name>)] + + [<] [<=] [>] [>=])) + +## [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)) + (if (:: ord (<op> x y)) x y))] + + [max ;;>] + [min ;;<]) diff --git a/source/lux/data/reader.lux b/source/lux/data/reader.lux new file mode 100644 index 000000000..e91687c3a --- /dev/null +++ b/source/lux/data/reader.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import (lux #refer (#exclude Reader)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Reader r a) + (-> r a)) + +## [Structures] +(defstruct #export Reader/Functor (All [r] + (Functor (Reader r))) + (def (F;map f fa) + (lambda [env] + (f (fa env))))) + +(defstruct #export Reader/Monad (All [r] + (Monad (Reader r))) + (def M;_functor Reader/Functor) + + (def (M;wrap x) + (lambda [env] x)) + + (def (M;join mma) + (lambda [env] + (mma env env)))) diff --git a/source/lux/data/show.lux b/source/lux/data/show.lux new file mode 100644 index 000000000..f4e1cf762 --- /dev/null +++ b/source/lux/data/show.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## Signatures +(defsig #export (Show a) + (: (-> a Text) + show)) diff --git a/source/lux/data/state.lux b/source/lux/data/state.lux new file mode 100644 index 000000000..bc9858a29 --- /dev/null +++ b/source/lux/data/state.lux @@ -0,0 +1,35 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (State s a) + (-> s (, s a))) + +## [Structures] +(defstruct #export State/Functor (Functor State) + (def (F;map f ma) + (lambda [state] + (let [[state' a] (ma state)] + [state' (f a)])))) + +(defstruct #export State/Monad (All [s] + (Monad (State s))) + (def M;_functor State/Functor) + + (def (M;wrap x) + (lambda [state] + [state x])) + + (def (M;join mma) + (lambda [state] + (let [[state' ma] (mma state)] + (ma state'))))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux new file mode 100644 index 000000000..a3192a1d5 --- /dev/null +++ b/source/lux/data/text.lux @@ -0,0 +1,146 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m)) + (lux/data (eq #as E) + (ord #as O) + (show #as S))) + +## [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 (i< idx (size x)) + (i>= idx 0)) + (#;Some (_jvm_invokevirtual java.lang.String charAt [int] + x [(_jvm_l2i idx)])) + #;None)) + +(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 (i< from to) + (i>= from 0) + (i<= 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 (i< at (size x)) + (i>= 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 (i< from (size x)) (i>= 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) + (i= (i+ n (size postfix)) + (size x)) + + _ + false)) + +## [Structures] +(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) + (i< (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;<= x y) + (i<= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;> x y) + (i> (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0)) + (def (O;>= x y) + (i>= (_jvm_i2l (_jvm_invokevirtual java.lang.String compareTo [java.lang.String] + x [y])) + 0))) + +(defstruct #export Text/Show (S;Show Text) + (def (S;show x) + x)) + +(defstruct #export Text/Monoid (m;Monoid Text) + (def m;unit "") + (def (m;++ x y) + (_jvm_invokevirtual java.lang.String concat [java.lang.String] + x [y]))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux new file mode 100644 index 000000000..f71492e35 --- /dev/null +++ b/source/lux/data/writer.lux @@ -0,0 +1,34 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux/control (monoid #as m #refer #all) + (functor #as F #refer #all) + (monad #as M #refer #all))) + +## [Types] +(deftype #export (Writer l a) + (, l a)) + +## [Structures] +(defstruct #export Writer/Functor (All [l] + (Functor (Writer l))) + (def (F;map f fa) + (let [[log datum] fa] + [log (f datum)]))) + +(defstruct #export (Writer/Monad mon) (All [l] + (-> (Monoid l) (Monad (Writer l)))) + (def M;_functor Writer/Functor) + + (def (M;wrap x) + [(:: mon m;unit) x]) + + (def (M;join mma) + (let [[log1 [log2 a]] mma] + [(:: mon (m;++ log1 log2)) a]))) diff --git a/source/lux/host/java.lux b/source/lux/host/java.lux new file mode 100644 index 000000000..12525d3f2 --- /dev/null +++ b/source/lux/host/java.lux @@ -0,0 +1,312 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (control (monoid #as m) + (functor #as F) + (monad #as M #refer (#only do))) + (data list + (text #as text)) + (meta lux + macro + syntax))) + +## (open List/Functor) + +## [Utils/Parsers] +(def finally^ + (Parser Syntax) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "finally"]) + expr id^ + _ end^] + (M;wrap expr)))) + +(def catch^ + (Parser (, Text Ident Syntax)) + (form^ (do Parser/Monad + [_ (symbol?^ ["" "catch"]) + ex-class local-symbol^ + ex symbol^ + expr id^ + _ end^] + (M;wrap [ex-class ex expr])))) + +(def method-decl^ + (Parser (, (List Text) Text (List Text) Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ local-symbol^)) + output local-symbol^ + _ end^] + (M;wrap [modifiers name inputs output])))) + +(def field-decl^ + (Parser (, (List Text) Text Text)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + class local-symbol^ + _ end^] + (M;wrap [modifiers name class])))) + +(def arg-decl^ + (Parser (, Text Text)) + (form^ (do Parser/Monad + [arg-name local-symbol^ + arg-class local-symbol^ + _ end^] + (M;wrap [arg-name arg-class])))) + +(def method-def^ + (Parser (, (List Text) Text (List (, Text Text)) Text Syntax)) + (form^ (do Parser/Monad + [modifiers (*^ local-tag^) + name local-symbol^ + inputs (tuple^ (*^ arg-decl^)) + output local-symbol^ + body id^ + _ end^] + (M;wrap [modifiers name inputs output body])))) + +(def method-call^ + (Parser (, Text (List Text) (List Syntax))) + (form^ (do Parser/Monad + [method local-symbol^ + arity-classes (tuple^ (*^ local-symbol^)) + arity-args (tuple^ (*^ id^)) + _ end^ + _ (: (Parser (,)) + (if (i= (size arity-classes) + (size arity-args)) + (M;wrap []) + (lambda [_] #;None)))] + (M;wrap [method arity-classes arity-args]) + ))) + +## [Utils/Lux] +## (def (find-class-field field class) +## (-> Text Text (Lux Type)) +## ...) + +## (def (find-virtual-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + +## (def (find-static-method method class) +## (-> Text Text (Lux (List (, (List Type) Type)))) +## ...) + + +## [Syntax] +(defsyntax #export (throw ex) + (emit (list (` (_jvm_throw (~ ex)))))) + +(defsyntax #export (try body [catches (*^ catch^)] [finally (?^ finally^)]) + (emit (list (` (_jvm_try (~ body) + (~@ (list:++ (:: List/Functor (F;map (: (-> (, Text Ident Syntax) Syntax) + (lambda [catch] + (let [[class ex body] catch] + (` (_jvm_catch (~ (text$ class)) (~ (symbol$ ex)) (~ body)))))) + catches)) + (case finally + #;None + (list) + + (#;Some finally) + (list (` (_jvm_finally (~ finally)))))))))))) + +(defsyntax #export (definterface [name local-symbol^] [supers (tuple^ (*^ local-symbol^))] [members (*^ method-decl^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name))]] + (let [members' (:: List/Functor (F;map (: (-> (, (List Text) Text (List Text) Text) Syntax) + (lambda [member] + (let [[modifiers name inputs output] member] + (` ((~ (symbol$ ["" name])) [(~@ (:: List/Functor (F;map text$ inputs)))] (~ (text$ output)) [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + members))] + (emit (list (` (_jvm_interface (~ (text$ full-name)) [(~@ (:: List/Functor (F;map text$ supers)))] + (~@ members')))))))) + +(defsyntax #export (defclass [name local-symbol^] [super local-symbol^] [interfaces (tuple^ (*^ local-symbol^))] + [fields (*^ field-decl^)] + [methods (*^ method-def^)]) + (do Lux/Monad + [current-module get-module-name + #let [full-name (:: text;Text/Monoid (m;++ (text;replace "/" "." current-module) + name)) + fields' (:: List/Functor (F;map (: (-> (, (List Text) Text Text) Syntax) + (lambda [field] + (let [[modifiers name class] field] + (` ((~ (symbol$ ["" name])) + (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ modifiers)))]))))) + fields)) + methods' (:: List/Functor (F;map (: (-> (, (List Text) Text (List (, Text Text)) Text Syntax) Syntax) + (lambda [methods] + (let [[modifiers name inputs output body] methods] + (` ((~ (symbol$ ["" name])) + [(~@ (:: List/Functor (F;map (: (-> (, Text Text) Syntax) + (lambda [in] + (let [[left right] in] + (form$ (list (text$ left) + (text$ right)))))) + inputs)))] + (~ (text$ output)) + [(~@ (:: List/Functor (F;map text$ modifiers)))] + (~ body)))))) + methods))]] + (emit (list (` (_jvm_class (~ (text$ full-name)) (~ (text$ super)) + [(~@ (:: List/Functor (F;map text$ interfaces)))] + [(~@ fields')] + [(~@ methods')])))))) + +(defsyntax #export (new [class local-symbol^] [arg-classes (tuple^ (*^ local-symbol^))] [args (tuple^ (*^ id^))]) + (emit (list (` (_jvm_new (~ (text$ class)) + [(~@ (:: List/Functor (F;map text$ arg-classes)))] + [(~@ args)]))))) + +(defsyntax #export (instance? [class local-symbol^] obj) + (emit (list (` (_jvm_instanceof (~ (text$ class)) (~ obj)))))) + +(defsyntax #export (locking lock body) + (do Lux/Monad + [g!lock (gensym "") + g!body (gensym "")] + (emit (list (` (;let [(~ g!lock) (~ lock) + _ (_jvm_monitor-enter (~ g!lock)) + (~ g!body) (~ body) + _ (_jvm_monitor-exit (~ g!lock))] + (~ g!body))))) + )) + +(defsyntax #export (null? obj) + (emit (list (` (_jvm_null? (~ obj)))))) + +(defsyntax #export (program [args symbol^] body) + (emit (list (` (_jvm_program (~ (symbol$ args)) + (~ body)))))) + +## (defsyntax #export (.? [field local-symbol^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_getfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)))) + +## _ +## (fail "Can only get field from object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.? (~ field) (~ g!obj))))))))) + +## (defsyntax #export (.= [field local-symbol^] value obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [field-class (find-field field class)] +## (_jvm_putfield (~ (text$ class)) (~ (text$ field)) (~ (text$ field-class)) (~ value))) + +## _ +## (fail "Can only set field of object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.= (~ field) (~ value) (~ g!obj))))))))) + +## (defsyntax #export (.! [call method-call^] obj) +## (case obj +## (#;Meta [_ (#;SymbolS obj-name)]) +## (do Lux/Monad +## [obj-type (find-var-type obj-name)] +## (case obj-type +## (#;DataT class) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-virtual-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokevirtual (~ (text$ m-name)) (~ (text$ class)) [(~@ (:: List/Functor (F;map text$ m-ins)))] +## (~ obj) [(~@ m-args)]))))) + +## _ +## (fail "Can only call method on object."))) + +## _ +## (do Lux/Monad +## [g!obj (gensym "")] +## (emit (list (` (;let [(~ g!obj) (~ obj)] +## (.! (~@ *tokens*))))))))) + +## (defsyntax #export (..? [field local-symbol^] [class local-symbol^]) +## (emit (list (` (_jvm_getstatic (~ (text$ class)) (~ (text$ field))))))) + +## (defsyntax #export (..= [field local-symbol^] value [class local-symbol^]) +## (emit (list (` (_jvm_putstatic (~ (text$ class)) (~ (text$ field)) (~ value)))))) + +## (defsyntax #export (..! [call method-call^] [class local-symbol^]) +## (do Lux/Monad +## [#let [[m-name ?m-classes m-args] call] +## all-m-details (find-static-method m-name class) +## m-ins (case [?m-classes all-m-details] +## (\ [#;None (list [m-ins m-out])]) +## (M;wrap m-ins) + +## (\ [(#;Some m-ins) _]) +## (M;wrap m-ins) + +## _ +## #;None)] +## (emit (list (` (_jvm_invokestatic (~ (text$ m-name)) (~ (text$ class)) +## [(~@ (:: List/Functor (F;map text$ m-ins)))] +## [(~@ m-args)])))) +## )) + +## (definterface Function [] +## (#public #abstract apply [java.lang.Object] java.lang.Object)) + +## (_jvm_interface "Function" [] +## (apply ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) + +## (defclass MyFunction [Function] +## (#public #static foo java.lang.Object) +## (#public <init> [] void +## (_jvm_invokespecial java.lang.Object <init> [] this [])) +## (#public apply [(arg java.lang.Object)] java.lang.Object +## "YOLO")) + +## (_jvm_class "lux.MyFunction" "java.lang.Object" ["lux.Function"] +## [(foo "java.lang.Object" ["public" "static"])] +## (<init> [] "void" +## ["public"] +## (_jvm_invokespecial java.lang.Object <init> [] this [])) +## (apply [(arg "java.lang.Object")] "java.lang.Object" +## ["public"] +## "YOLO")) diff --git a/source/lux/math.lux b/source/lux/math.lux new file mode 100644 index 000000000..2e29c5da7 --- /dev/null +++ b/source/lux/math.lux @@ -0,0 +1,60 @@ +## 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) + +## [Constants] +(do-template [<name> <value>] + [(def #export <name> + Real + (_jvm_getstatic java.lang.Math <value>))] + + [e E] + [pi PI] + ) + +## [Functions] +(do-template [<name> <method>] + [(def #export (<name> n) + (-> Real Real) + (_jvm_invokestatic java.lang.Math <method> [double] [n]))] + + [cos cos] + [sin sin] + [tan tan] + + [acos acos] + [asin asin] + [atan atan] + + [cosh cosh] + [sinh sinh] + [tanh tanh] + + [ceil ceil] + [floor floor] + [round round] + + [exp exp] + [log log] + + [cbrt cbrt] + [sqrt sqrt] + + [->degrees toDegrees] + [->radians toRadians] + ) + +(do-template [<name> <method>] + [(def #export (<name> x y) + (-> Real Real Real) + (_jvm_invokestatic java.lang.Math <method> [double double] [x y]))] + + [atan2 atan2] + [pow pow] + ) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux new file mode 100644 index 000000000..a28d6e5d4 --- /dev/null +++ b/source/lux/meta/lux.lux @@ -0,0 +1,287 @@ +## 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) + (functor #as F) + (monad #as M #refer (#only do))) + (lux/data list + maybe + (show #as S) + (number #as N))) + +## [Types] +## (deftype (Lux a) +## (-> Compiler (Either Text (, Compiler a)))) + +## [Utils] +(def (ident->text ident) + (-> Ident Text) + (let [[pre post] ident] + ($ text:++ pre ";" post))) + +## [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 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 (:: 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$ (:: 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+ (:: 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$ (:: 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__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) + +(def #export (emit datum) + (All [a] + (-> a (Lux a))) + (lambda [state] + (#;Right [state datum]))) + +(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 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)))) + +(def (show-envs envs) + (-> (List (Env Text (, LuxVar Type))) Text) + (|> envs + (F;map (lambda [env] + (case env + {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} + ($ text:++ name ": " (|> locals + (F;map (: (All [a] (-> (, Text a) Text)) + (lambda [b] (let [[label _] b] label)))) + (:: List/Functor) + (interpose " ") + (foldL text:++ "")))))) + (:: List/Functor) + (interpose "\n") + (foldL text:++ ""))) + +(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 (find-in-env name state) + (-> Ident Compiler (Maybe Type)) + (let [vname' (ident->text name)] + (case state + {#;source source #;modules modules + #;envs envs #;types types #;host host + #;seed seed #;eval? eval?} + (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} + (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#;Some type) + #;None))))) + locals + closure)))) + envs)))) + +(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 #;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 #export (find-var-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (: (Lux Type) + (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 #;eval? eval?} state] + (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + )) diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux new file mode 100644 index 000000000..22aeaf874 --- /dev/null +++ b/source/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/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux new file mode 100644 index 000000000..1fe85c32f --- /dev/null +++ b/source/lux/meta/syntax.lux @@ -0,0 +1,262 @@ +## 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 #as l #refer (#only Lux/Monad gensym))) + (lux (control (functor #as F) + (monad #as M #refer (#only do))) + (data (eq #as E) + (bool #as b) + (char #as c) + (text #as t) + list))) + +## [Utils] +(def (first xy) + (All [a b] (-> (, a b) a)) + (let [[x y] xy] + x)) + +(def (join-pairs pairs) + (All [a] (-> (List (, a a)) (List a))) + (case pairs + #;Nil #;Nil + (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + +## 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] + ) + +(do-template [<name> <tag>] + [(def #export (<name> tokens) + (Parser Text) + (case tokens + (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens']) + (#;Some [tokens' x]) + + _ + #;None))] + + [local-symbol^ #;SymbolS] + [ local-tag^ #;TagS] + ) + +(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 (:: b;Bool/Eq E;=)] + [ int?^ Int #;IntS i=] + [ real?^ Real #;RealS r=] + [ char?^ Char #;CharS (:: c;Char/Eq E;=)] + [ text?^ Text #;TextS (:: t;Text/Eq E;=)] + [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) + (let [[exported? tokens] (: (, Bool (List Syntax)) + (case tokens + (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) + [true tokens'] + + _ + [false 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]) + + (\ (#;Meta [_ (#;SymbolS var-name)])) + (M;wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) + g!tokens (gensym "tokens") + g!_ (gensym "_") + #let [names (:: List/Functor (F;map first names+parsers)) + error-msg (text$ (text:++ "Wrong syntax for " name)) + body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + (lambda [body name+parser] + (let [[name parser] name+parser] + (` (_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) + + (~ g!_) + (l;fail (~ error-msg))))))) + body + (reverse names+parsers)) + macro-def (: Syntax + (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body'))))]] + (M;wrap (list& macro-def + (if exported? + (list (` (_lux_export (~ (symbol$ ["" name]))))) + (list))))) + + _ + (l;fail "Wrong syntax for defsyntax")))) diff --git a/source/program.lux b/source/program.lux new file mode 100644 index 000000000..052c0bf41 --- /dev/null +++ b/source/program.lux @@ -0,0 +1,48 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux + (lux (codata (stream #as S)) + (control monoid + functor + monad + lazy + comonad) + (data bool + bounded + char + ## cont + dict + (either #as e) + eq + error + id + io + list + maybe + number + ord + (reader #as r) + show + state + (text #as t) + writer) + (host java) + (meta lux + macro + syntax) + (math #as m) + )) + +(program args + (case args + #;Nil + (println "Hello, world!") + + (#;Cons [name _]) + (println ($ text:++ "Hello, " name "!")))) |