diff options
Diffstat (limited to 'input')
| -rw-r--r-- | input/lux.lux | 2173 | ||||
| -rw-r--r-- | input/program.lux | 15 |
2 files changed, 2188 insertions, 0 deletions
diff --git a/input/lux.lux b/input/lux.lux new file mode 100644 index 000000000..6c9a50f9d --- /dev/null +++ b/input/lux.lux @@ -0,0 +1,2173 @@ +## 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"])) + +## (_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")) + +## 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 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])]))])])) + +## (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])])])]))])])) + +## (deftype Cursor +## (, Text Int Int)) +(_lux_def Cursor + (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) + +## (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])])])]))])) + +## (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 +## #seen-sources (List Text) +## #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;seen-sources" (#AppT [List Text])] + (#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 (_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 [["" -1 -1] 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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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' #export (defmacro tokens) + Macro + (_lux_case tokens + (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList #Nil))) + +(defmacro (->' tokens) + (_lux_case tokens + (#Cons [input (#Cons [output #Nil])]) + (return (_lux_: SyntaxList + (#Cons [(_meta (#FormS (#Cons [(_meta (#TagS ["lux" "LambdaT"])) + (#Cons [(_meta (#TupleS (#Cons [input (#Cons [output #Nil])]))) + #Nil])]))) + #Nil]))) + + (#Cons [input (#Cons [output others])]) + (return (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#Cons [body + #Nil]))) + + (#Cons [(#Meta [_ (#TupleS (#Cons [(#Meta [_ (#SymbolS ["" arg-name])]) other-args]))]) + (#Cons [body #Nil])]) + (return (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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 (_lux_: SyntaxList + (#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' #export (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' #export (foldR f init xs) + (All' [a b] + (->' (->' (B' b) (B' a) (B' a)) + (B' a) + ($' List (B' b)) + (B' a))) + (_lux_case xs + #Nil + init + + (#Cons [x xs']) + (f x (foldR f init xs')))) + +(def' #export (reverse list) + (All' [a] + (->' ($' List (B' a)) ($' List (B' a)))) + (foldL (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda' [tail head] + (#Cons [head tail]))) + #Nil + list)) + +(defmacro #export (list xs) + (return (_lux_: SyntaxList + (#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 #export (list& xs) + (_lux_case (reverse xs) + (#Cons [last init]) + (return (_lux_: SyntaxList + (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 (_lux_: SyntaxList + (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 (_lux_: SyntaxList + (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 (_lux_: SyntaxList + (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 (_lux_: SyntaxList + (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 (_lux_: SyntaxList + (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 (_lux_: SyntaxList + (list (foldL (_lux_: (->' Syntax (#TupleT (list Syntax Syntax)) + Syntax) + (lambda [body binding] + (_lux_case binding + [label value] + (_meta (#FormS (list (_meta (#SymbolS ["lux" "let'"])) label value body)))))) + body + (foldL (_lux_: (All' [a] + (->' ($' List (B' a)) (B' a) ($' List (B' a)))) + (lambda [tail head] (#Cons [head tail]))) + #Nil + (as-pairs bindings)))))) + + _ + (fail "Wrong syntax for let"))) + +(def'' #export (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'' #export (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'' (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 (_lux_: SyntaxList + (list (foldL (lambda [a1 a2] ($form (list op a1 a2))) + init + args)))) + + _ + (fail "Wrong syntax for $"))) + +(def'' (splice untemplate tag elems) + (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) + (_lux_case (any? spliced? elems) + true + (let [elems' (map (_lux_: (->' Syntax Syntax) + (lambda [elem] + (_lux_case elem + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~@"])]) (#Cons [spliced #Nil])]))]) + spliced + + _ + ($form (list ($symbol ["" "_lux_:"]) + ($symbol ["lux" "SyntaxList"]) + ($form (list ($symbol ["lux" "list"]) (untemplate elem)))))))) + 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))))))) + +(def'' (untemplate subst token) + (->' Text Syntax Syntax) + (_lux_case 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 (untemplate subst) ($tag ["lux" "TupleS"]) elems) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" "~"])]) (#Cons [unquoted #Nil])]))]) + unquoted + + (#Meta [_ (#FormS elems)]) + (splice (untemplate subst) ($tag ["lux" "FormS"]) elems) + + (#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 subst k) (untemplate subst v)))))) + fields))))) + )) + +(defmacro (`' tokens) + (_lux_case tokens + (#Cons [template #Nil]) + (return (_lux_: SyntaxList + (list (untemplate "" template)))) + + _ + (fail "Wrong syntax for `'"))) + +(defmacro #export (|> tokens) + (_lux_case tokens + (#Cons [init apps]) + (return (_lux_: SyntaxList + (list (foldL (_lux_: (->' Syntax Syntax Syntax) + (lambda [acc app] + (_lux_case app + (#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 (_lux_: SyntaxList + (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 (_lux_: SyntaxList + (list (`' (#;DataT (~ (_meta (#TextS class-name)))))))) + + _ + (fail "Wrong syntax for ^"))) + +(defmacro #export (-> tokens) + (_lux_case (reverse tokens) + (#Cons [output inputs]) + (return (_lux_: SyntaxList + (list (foldL (_lux_: (->' Syntax Syntax Syntax) + (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) + output + inputs)))) + + _ + (fail "Wrong syntax for ->"))) + +(defmacro #export (, tokens) + (return (_lux_: SyntaxList + (list (`' (#;TupleT (;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 (_lux_: SyntaxList + (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 (_lux_: List #Nil)) + + (#Cons [x xs']) + (do m + [y (f x) + ys (map% m f xs')] + (;return (_lux_: List (#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'' (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 "All the do-template bindigns must be symbols.")) + + _ + (fail "Wrong syntax for do-template"))) + +(do-template [<name> <cmp> <type>] + [(def'' #export (<name> x y) + (-> <type> <type> Bool) + (<cmp> x y))] + + [int:= _jvm_leq Int] + [int:> _jvm_lgt Int] + [int:< _jvm_llt Int] + [real:= _jvm_deq Real] + [real:> _jvm_dgt Real] + [real:< _jvm_dlt Real] + ) + +(do-template [<name> <cmp> <type>] + [(def'' #export (<name> x y) + (-> <type> <type> <type>) + (<cmp> x y))] + + [int:+ _jvm_ladd Int] + [int:- _jvm_lsub Int] + [int:* _jvm_lmul Int] + [int:/ _jvm_ldiv Int] + [int:% _jvm_lrem Int] + [real:+ _jvm_dadd Real] + [real:- _jvm_dsub Real] + [real:* _jvm_dmul Real] + [real:/ _jvm_ddiv Real] + [real:% _jvm_drem Real] + ) + +(def'' (multiple? div n) + (-> Int Int Bool) + (int:= 0 (int:% n div))) + +(def'' #export (length list) + (-> List Int) + (foldL (lambda [acc _] (int:+ 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 (_lux_: SyntaxList + (list body))) + + (#Cons [harg targs]) + (let [replacements (map (_lux_: (-> Text (, Text Syntax)) + (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) + (list& self-ident idents)) + body' (foldL (_lux_: (-> Syntax Text Syntax) + (lambda [body' arg'] + (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) + (replace-syntax replacements body) + (reverse targs))] + (return (_lux_: SyntaxList + (list (`' (#;AllT [(#;Some #;Nil) (~ ($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'' #export (get-module-name state) + ($' Lux Text) + (_lux_case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #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'' #export (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 #seen-sources seen-sources #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'' #export (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 (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) + + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (do Lux:Monad + [ident (normalize ident)] + (;return (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + + _ + (fail "Wrong syntax for |")))) + tokens)] + (;return (_lux_: SyntaxList + (list (`' (#;VariantT (;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 (_lux_: Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) + + _ + (fail "Wrong syntax for &")))) + (as-pairs tokens))] + (;return (_lux_: SyntaxList + (list (`' (#;RecordT (;list (~@ pairs)))))))))) + +(def'' #export (->text x) + (-> (^ java.lang.Object) Text) + (_jvm_invokevirtual java.lang.Object toString [] x [])) + +(def'' #export (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'' #export (syntax:show syntax) + (-> Syntax Text) + (_lux_case syntax + (#Meta [_ (#BoolS value)]) + (->text value) + + (#Meta [_ (#IntS value)]) + (->text value) + + (#Meta [_ (#RealS value)]) + (->text value) + + (#Meta [_ (#CharS value)]) + ($ text:++ "#\"" (->text value) "\"") + + (#Meta [_ (#TextS value)]) + value + + (#Meta [_ (#SymbolS ident)]) + (ident->text ident) + + (#Meta [_ (#TagS ident)]) + (text:++ "#" (ident->text ident)) + + (#Meta [_ (#TupleS members)]) + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) "]") + + (#Meta [_ (#FormS members)]) + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (foldL text:++ "")) ")") + + (#Meta [_ (#RecordS slots)]) + ($ text:++ "{" + (|> slots + (map (_lux_: (-> (, Syntax Syntax) Text) + (lambda [slot] + (let [[k v] slot] + ($ text:++ (syntax:show k) " " (syntax:show v)))))) + (interpose " ") + (foldL text:++ "")) + "}") + )) + +(def'' #export (macro-expand syntax) + (-> 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 (_lux_: Ident macro-name'))] + (_lux_case (_lux_: ($' Maybe Macro) ?macro) + (#Some macro) + (do Lux:Monad + [expansion (macro args) + expansion' (map% Lux:Monad macro-expand (_lux_: SyntaxList expansion))] + (;return (_lux_: SyntaxList (list:join (_lux_: ($' List SyntaxList) expansion'))))) + + #None + (do Lux:Monad + [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] + (;return (_lux_: SyntaxList (list ($form (list:join (_lux_: ($' List SyntaxList) parts'))))))))) + + (#Meta [_ (#FormS (#Cons [harg targs]))]) + (do Lux:Monad + [harg+ (macro-expand harg) + targs+ (map% Lux:Monad macro-expand (_lux_: SyntaxList targs))] + (;return (_lux_: SyntaxList (list ($form (list:++ harg+ (list:join (_lux_: ($' List SyntaxList) targs+)))))))) + + (#Meta [_ (#TupleS members)]) + (do Lux:Monad + [members' (map% Lux:Monad macro-expand members)] + (;return (_lux_: SyntaxList (list ($tuple (list:join (_lux_: ($' List SyntaxList) members'))))))) + + _ + (return (_lux_: SyntaxList (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 (_lux_: (-> Syntax Syntax Syntax) + (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 (_lux_: SyntaxList type+) + (#Cons [type' #Nil]) + (;return (_lux_: SyntaxList + (list (walk-type type')))) + + _ + (fail "type`: 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 (_lux_: SyntaxList + (list (`' (_lux_: (;type` (~ type)) (~ value)))))) + + _ + (fail "Wrong syntax for :"))) + +(defmacro #export (:! tokens) + (_lux_case tokens + (#Cons [type (#Cons [value #Nil])]) + (return (: (List Syntax) + (list (`' (_lux_:! (;type` (~ type)) (~ value)))))) + + _ + (fail "Wrong syntax for :!"))) + +(defmacro #export (deftype tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (_lux_case tokens + (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + [true tokens'] + + _ + [false 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 Syntax) + (list& (`' (_lux_def (~ name) (;type` (~ type')))) + with-export)))) + + #None + (fail "Wrong syntax for deftype")) + )) + +(deftype #export (IO a) + (-> (,) a)) + +(defmacro #export (io tokens) + (_lux_case tokens + (#Cons [value #Nil]) + (let [blank ($symbol ["" ""])] + (return (_lux_: SyntaxList + (list (`' (_lux_lambda (~ blank) (~ blank) (~ value))))))) + + _ + (fail "Wrong syntax for io"))) + +(defmacro #export (exec tokens) + (_lux_case (reverse tokens) + (#Cons [value actions]) + (let [dummy ($symbol ["" ""])] + (return (_lux_: SyntaxList + (list (foldL (: (-> Syntax Syntax Syntax) + (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 Syntax) + (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 (: (List Syntax) expansion)))] + (;return (: (List (, Syntax Syntax)) (list:join (: (List (List (, Syntax Syntax))) expansions))))) + + _ + (;return (: (List (, Syntax Syntax)) (list branch))))))) + (as-pairs branches))] + (;return (_lux_: SyntaxList + (list (`' (_lux_case (~ value) + (~@ (|> (: (List (List (, Syntax Syntax))) 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 (: (List Syntax) pattern+) + (#Cons [pattern' #Nil]) + (;return (: (List Syntax) + (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 Syntax) + (list:join (map (: (-> Syntax (List Syntax)) + (lambda [pattern] (list pattern body))) + (list:join patterns'))))))) + + _ + (fail "Wrong syntax for \\or"))) + +(do-template [<name> <offset>] + [(def #export <name> (int:+ <offset>))] + + [inc 1] + [dec -1]) + +(def (int:show int) + (-> Int Text) + (_jvm_invokevirtual java.lang.Object toString [] + int [])) + +(defmacro #export (` tokens) + (do Lux:Monad + [module-name get-module-name] + (case tokens + (\ (list template)) + (;return (_lux_: SyntaxList + (list (untemplate module-name template)))) + + _ + (fail "Wrong syntax for `")))) + +(def #export (gensym prefix state) + (-> Text (Lux Syntax)) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (#Right [{#source source #modules modules + #envs envs #types types #host host + #seed (inc seed) #seen-sources seen-sources #eval? eval?} + ($symbol ["__gensym__" (int:show seed)])]))) + +(def #export (macro-expand-1 token) + (-> Syntax (Lux Syntax)) + (do Lux:Monad + [token+ (macro-expand token)] + (case (: (List Syntax) 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-1 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!")))) + tokens')] + (;return (: (List Syntax) + (list (`' (#;RecordT (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 Syntax) + (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-1 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!")))) + tokens')] + (;return (: (List Syntax) + (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 Syntax) + (list& (`' (def (~ name) (~ type) (~ defs'))) + (if export? + (list (`' (_lux_export (~ name)))) + #Nil))))) + + #None + (fail "Wrong syntax for defsig")))) + +(defsig #export (Eq a) + (: (-> a a Bool) + =)) + +(do-template [<name> <type> <test>] + [(defstruct #export <name> (Eq <type>) + (def (= x y) + (<test> x y)))] + + [Int:Eq Int _jvm_leq] + [Real:Eq Real _jvm_deq]) + +(def #export (id x) + (All [a] (-> a a)) + x) + +(defsig #export (Show a) + (: (-> a Text) + show)) + +(do-template [<name> <type> <body>] + [(defstruct #export <name> (Show <type>) + (def (show x) + <body>))] + + [Bool:Show Bool (->text x)] + [Int:Show Int (->text x)] + [Real:Show Real (->text x)] + [Char:Show Char ($ text:++ "#\"" (->text x) "\"")]) + +(defsig #export (Ord a) + (: (-> a a Bool) + <) + (: (-> a a Bool) + <=) + (: (-> a a Bool) + >) + (: (-> a a Bool) + >=)) + +(do-template [<name> <form> <message>] + [(defmacro #export (<name> tokens) + (case (reverse tokens) + (\ (list& last init)) + (return (: (List Syntax) + (list (foldL (: (-> Syntax Syntax Syntax) + (lambda [post pre] (` <form>))) + last + init)))) + + _ + (fail <message>)))] + + [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] + [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) + +(do-template [<name> <type> <lt> <gt> <eq>] + [(defstruct #export <name> (Ord <type>) + (def (< x y) + (<lt> x y)) + + (def (<= x y) + (or (<lt> x y) + (<eq> x y))) + + (def (> x y) + (<gt> x y)) + + (def (>= x y) + (or (<gt> x y) + (<eq> x y))))] + + [Int:Ord Int _jvm_llt _jvm_lgt _jvm_leq] + [Real:Ord Real _jvm_dlt _jvm_dgt _jvm_deq]) + +(defmacro #export (lux tokens state) + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (case (get "lux" modules) + (#Some lux) + (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [($ text:++ "Importing: " name "\n")]) + (list name)) + (list))))) + (let [{#module-aliases _ #defs defs #imports _} lux] + defs))] + (#Right [state (: (List Syntax) + (map (: (-> Text Syntax) + (lambda [name] + (` ((~ ($symbol ["" "_lux_def"])) (~ ($symbol ["" name])) (~ ($symbol ["lux" name])))))) + (list:join to-alias)))])) + + #None + (#Left "Uh, oh... The universe is not working properly...")) + )) + +(def #export (print x) + (-> Text (IO (,))) + (lambda [_] + (exec (_jvm_invokevirtual java.io.PrintStream print [java.lang.Object] + (_jvm_getstatic java.lang.System out) [x]) + []))) + +(def #export (println x) + (-> Text (IO (,))) + (print (text:++ x "\n"))) + +(def #export (some f xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #Nil + #None + + (#Cons [x xs']) + (case (f x) + #None + (some f xs') + + (#Some y) + (#Some y)))) + + +(def (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-slot slot) + (-> Text (, Text Text)) + (let [idx (index-of ";" slot) + module (substring2 0 idx slot) + name (substring1 (inc idx) slot)] + [module name])) + +(def (resolve-struct-type type) + (-> Type (Maybe Type)) + (case type + (#RecordT slots) + (#Some type) + + (#AppT [fun arg]) + (resolve-struct-type fun) + + (#AllT [_ _ _ body]) + (resolve-struct-type body) + + _ + #None)) + +(defmacro #export (using tokens state) + (case tokens + (\ (list struct body)) + (case struct + (#Meta [_ (#SymbolS vname)]) + (let [vname' (ident->text vname)] + (case state + {#source source #modules modules + #envs envs #types types #host host + #seed seed #seen-sources seen-sources #eval? eval?} + (let [?struct-type (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) + (lambda [env] + (case env + {#name _ #inner-closures _ #locals {#counter _ #mappings mappings} #closure _} + (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) + (lambda [binding] + (let [[bname [_ type]] binding] + (if (text:= vname' bname) + (#Some type) + #None)))) + mappings)))) + envs)] + (case ?struct-type + #None + (#Left ($ text:++ "Unknown structure: " vname')) + + (#Some struct-type) + (case (resolve-struct-type struct-type) + (#Some (#RecordT slots)) + (let [pattern ($record (map (: (-> (, Text Type) (, Syntax Syntax)) + (lambda [slot] + (let [[sname stype] slot + [module name] (split-slot sname)] + [($tag [module name]) ($symbol ["" name])]))) + slots))] + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))])) + + _ + (#Left "Can only \"use\" records.")))))) + + _ + (let [dummy ($symbol ["" ""])] + (#Right [state (: (List Syntax) + (list (` (_lux_case (~ struct) + (~ dummy) + (using (~ dummy) + (~ body))))))]))) + + _ + (#Left "Wrong syntax for defsig"))) + +(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 [[x y]] +## (f x y))) + +## (defmacro (loop tokens) +## (_lux_case tokens +## (#Cons [bindings (#Cons [body #Nil])]) +## (let [pairs (as-pairs bindings)] +## (return (list (#FormS (#Cons [(` (lambda (~ (#SymbolS ["" "recur"])) (~ (#TupleS (map first pairs))) +## (~ body))) +## (map second pairs)]))))))) + +## (defmacro (get@ tokens) +## (let [output (_lux_case tokens +## (#Cons [tag (#Cons [record #Nil])]) +## (` (get@' (~ tag) (~ record))) + +## (#Cons [tag #Nil]) +## (` (lambda [record] (get@' (~ tag) record))))] +## (return (list output)))) + +## (defmacro (set@ tokens) +## (let [output (_lux_case tokens +## (#Cons [tag (#Cons [value (#Cons [record #Nil])])]) +## (` (set@' (~ tag) (~ value) (~ record))) + +## (#Cons [tag (#Cons [value #Nil])]) +## (` (lambda [record] (set@' (~ tag) (~ value) record))) + +## (#Cons [tag #Nil]) +## (` (lambda [value record] (set@' (~ tag) value record))))] +## (return (list output)))) + +## (defmacro (update@ tokens) +## (let [output (_lux_case tokens +## (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) +## (` (let [_record_ (~ record)] +## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_))) + +## (#Cons [tag (#Cons [func #Nil])]) +## (` (lambda [record] +## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record)))) + +## (#Cons [tag #Nil]) +## (` (lambda [func record] +## (set@' (~ tag) (func (get@' (~ tag) record)) record))))] +## (return (list output)))) diff --git a/input/program.lux b/input/program.lux new file mode 100644 index 000000000..4f329c3fa --- /dev/null +++ b/input/program.lux @@ -0,0 +1,15 @@ +(;lux) + +(def (filter p xs) + (All [a] (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons [x xs']) + (if (p x) + (list& x (filter p xs')) + (filter p xs')))) + +(_jvm_program args + (println "Hello, world!")) |