## 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 [meta (#FormS elems)])] (let [(#Meta [_ form']) (splice replace? (untemplate replace? subst) (tag$ ["lux" "FormS"]) elems)] (#Meta [meta form'])) [_ (#Meta [_ (#RecordS fields)])] (wrap-meta (form$ (list (tag$ ["lux" "RecordS"]) (untemplate-list (map (_lux_: (->' (#TupleT (list Syntax Syntax)) Syntax) (lambda [kv] (let [[k v] kv] (tuple$ (list (untemplate replace? subst k) (untemplate replace? subst v)))))) 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'' (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 [ ] [(def'' #export ( x y) (-> Bool) ( 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 [ ] [(def'' #export ( x y) (-> Bool) (if ( x y) true ( x y)))] [i>= i> i= Int] [i<= i< i= Int] [r>= r> r= Real] [r<= r< r= Real] ) (do-template [ ] [(def'' #export ( x y) (-> ) ( 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'' (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 [ ] [(def #export (i+ ))] [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 [
] [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) (return (list (foldL (lambda [post pre] (` )) last init))) _ (fail )))] [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 Openings (, Text (List Ident))) (deftype Import (, Text (Maybe Text) Referrals (Maybe Openings))) (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 (extract-symbol syntax) (-> Syntax (Lux Ident)) (case syntax (#Meta [_ (#SymbolS ident)]) (return ident) _ (fail "Not a symbol."))) (def (parse-openings tokens) (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) (case tokens (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) _ (return (: (, (Maybe Openings) (List Syntax)) [#None 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 [imports' (map% Lux/Monad (: (-> Syntax (Lux (List Import))) (lambda [token] (case token (#Meta [_ (#SymbolS ["" m-name])]) (;return (list [m-name #None #All #None])) (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] referral+extra (parse-referrals extra) #let [[referral extra] referral+extra] openings+extra (parse-openings extra) #let [[openings extra] openings+extra] extra (decorate-imports m-name extra) sub-imports (parse-imports extra)] (;return (case (: (, Referrals (Maybe Text) (Maybe Openings)) [referral alias openings]) [#Nothing #None #None] sub-imports _ (list& [m-name alias referral openings] sub-imports)))) _ (fail "Wrong syntax for import")))) imports)] (;return (list:join imports')))) (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 m-openings] (do Lux/Monad [m-name (clean-module m-name)] (;return (: Import [m-name m-alias m-referrals m-openings])))))) imports) unknowns' (map% Lux/Monad (: (-> Import (Lux (List Text))) (lambda [import] (case import [m-name _ _ _] (do Lux/Monad [? (module-exists? m-name)] (;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 m-openings] (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))) #let [openings (: (List Syntax) (case m-openings #None (list) (#Some [prefix structs]) (map (: (-> Ident Syntax) (lambda [struct] (let [[_ name] struct] (` (open (~ (symbol$ [m-name name])) (~ (text$ prefix))))))) structs)))]] (;return ($ list:++ (list (` (_lux_import (~ (text$ m-name))))) (case m-alias #None (list) (#Some alias) (list (` (_lux_alias (~ (text$ alias)) (~ (text$ m-name)))))) (map (: (-> Text Syntax) (lambda [def] (` ((~ (symbol$ ["" "_lux_def"])) (~ (symbol$ ["" def])) (~ (symbol$ [m-name def])))))) defs) openings)))))) 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 [module name] (split-slot sname)] [(tag$ [module name]) (symbol$ ["" 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)]) tokens')) (do Lux/Monad [#let [prefix (case tokens' (\ (list (#Meta [_ (#TextS prefix)]))) prefix _ "")] 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$ ["" (text:++ prefix 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")))