## 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 (:' (-> [java.lang.Object] java.lang.Object) apply)) ## Basic types (def' Bool (#DataT "java.lang.Boolean")) (export' Bool) (def' Int (#DataT "java.lang.Long")) (export' Int) (def' Real (#DataT "java.lang.Double")) (export' Real) (def' Char (#DataT "java.lang.Character")) (export' Char) (def' Text (#DataT "java.lang.String")) (export' Text) (def' Void (#VariantT #Nil)) (export' Void) (def' Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) (export' Ident) ## (deftype (List a) ## (| #Nil ## (#Cons (, a (List a))))) (def' List (#AllT [#None "List" "a" (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) #Nil])]))] #Nil])]))])) (export' List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) (def' Maybe (#AllT [#None "Maybe" "a" (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] (#Cons [["lux;Some" (#BoundT "a")] #Nil])]))])) (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)))) (def' Type (case' (#AppT [(#BoundT "Type") (#BoundT "_")]) Type (case' (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) TypeEnv (#AppT [(#AllT [#None "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])))) (export' Type) ## (deftype (Bindings k v) ## (& #counter Int ## #mappings (List (, k v)))) (def' Bindings (#AllT [#None "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))) (def' Env (#AllT [#None "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)) (def' Cursor (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])]))) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) (def' Meta (#AllT [#None "Meta" "m" (#AllT [#None "" "v" (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") (#Cons [(#BoundT "v") #Nil])]))] #Nil]))])])) (export' Meta) ## (deftype (Syntax' w) ## (| (#Bool Bool) ## (#Int Int) ## (#Real Real) ## (#Char Char) ## (#Text Text) ## (#Symbol (, Text Text)) ## (#Tag (, Text Text)) ## (#Form (List (w (Syntax' w)))) ## (#Tuple (List (w (Syntax' w)))) ## (#Record (List (, (w (Syntax' w)) (w (Syntax' w))))))) (def' Syntax' (case' (#AppT [(#BoundT "w") (#AppT [(#BoundT "Syntax'") (#BoundT "w")])]) Syntax (case' (#AppT [List Syntax]) SyntaxList (#AllT [#None "Syntax'" "w" (#VariantT (#Cons [["lux;Bool" Bool] (#Cons [["lux;Int" Int] (#Cons [["lux;Real" Real] (#Cons [["lux;Char" Char] (#Cons [["lux;Text" Text] (#Cons [["lux;Symbol" Ident] (#Cons [["lux;Tag" Ident] (#Cons [["lux;Form" SyntaxList] (#Cons [["lux;Tuple" SyntaxList] (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))])] #Nil]) ])])])])])])])])]) )])))) (export' Syntax') ## (deftype Syntax ## (Meta Cursor (Syntax' (Meta Cursor)))) (def' Syntax (case' (#AppT [Meta Cursor]) w (#AppT [w (#AppT [Syntax' w])]))) (export' Syntax) (def' SyntaxList (#AppT [List Syntax])) ## (deftype (Either l r) ## (| (#Left l) ## (#Right r))) (def' Either (#AllT [#None "_" "l" (#AllT [#None "" "r" (#VariantT (#Cons [["lux;Left" (#BoundT "l")] (#Cons [["lux;Right" (#BoundT "r")] #Nil])]))])])) (export' Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) (def' StateE (#AllT [#None "StateE" "s" (#AllT [#None "" "a" (#LambdaT [(#BoundT "s") (#AppT [(#AppT [Either Text]) (#TupleT (#Cons [(#BoundT "s") (#Cons [(#BoundT "a") #Nil])]))])])])])) ## (def' Reader ## (List (Meta Cursor Text))) (def' Reader (#AppT [List (#AppT [(#AppT [Meta Cursor]) Text])])) (export' Reader) ## (deftype HostState ## (& #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader) ## #eval-ctor Int)) (def' HostState (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")] (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")] (#Cons [["lux;eval-ctor" Int] #Nil])])]))) ## (deftype (DefData' m) ## (| #TypeD ## (#ValueD Type) ## (#MacroD m) ## (#AliasD Ident))) (def' DefData' (#AllT [#None "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))) (def' LuxVar (#VariantT (#Cons [["lux;Local" Int] (#Cons [["lux;Global" Ident] #Nil])]))) (export' LuxVar) ## (deftype #rec CompilerState ## (& #source (Maybe Reader) ## #modules (List (, Text (List (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))))) ## #module-aliases (List Void) ## #envs (List (Env Text (, LuxVar Type))) ## #types (Bindings Int Type) ## #host HostState)) (def' CompilerState (#AppT [(#AllT [#None "CompilerState" "" (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])] (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text (#Cons [(#AppT [List (#TupleT (#Cons [Text (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState") (#BoundT "")])]) SyntaxList])])]) #Nil])])) #Nil])]))]) #Nil])]))])] (#Cons [["lux;module-aliases" (#AppT [List Void])] (#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] #Nil])])])])])])]))]) Void])) (export' CompilerState) ## (deftype Macro ## (-> (List Syntax) (StateE CompilerState (List Syntax)))) (def' Macro (#LambdaT [SyntaxList (#AppT [(#AppT [StateE CompilerState]) SyntaxList])])) (export' Macro) ## Base functions & macros ## (def (_meta data) ## (-> (Syntax' (Meta Cursor)) Syntax) ## (#Meta [["" -1 -1] data])) (def' _meta (:' (#LambdaT [(#AppT [Syntax' (#AppT [Meta Cursor])]) Syntax]) (lambda' _ data (#Meta [["" -1 -1] data])))) ## (def (return x) ## (All [a] ## (-> a CompilerState ## (Either Text (, CompilerState a)))) ## ...) (def' return (:' (#AllT [#None "" "a" (#LambdaT [(#BoundT "a") (#LambdaT [CompilerState (#AppT [(#AppT [Either Text]) (#TupleT (#Cons [CompilerState (#Cons [(#BoundT "a") #Nil])]))])])])]) (lambda' _ val (lambda' _ state (#Right [state val]))))) ## (def (fail msg) ## (All [a] ## (-> Text CompilerState ## (Either Text (, CompilerState a)))) ## ...) (def' fail (:' (#AllT [#None "" "a" (#LambdaT [Text (#LambdaT [CompilerState (#AppT [(#AppT [Either Text]) (#TupleT (#Cons [CompilerState (#Cons [(#BoundT "a") #Nil])]))])])])]) (lambda' _ msg (lambda' _ state (#Left msg))))) (def' $text (:' (#LambdaT [Text Syntax]) (lambda' _ text (_meta (#Text text))))) (def' $symbol (:' (#LambdaT [Ident Syntax]) (lambda' _ ident (_meta (#Symbol ident))))) (def' $tag (:' (#LambdaT [Ident Syntax]) (lambda' _ ident (_meta (#Tag ident))))) (def' $form (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) (lambda' _ tokens (_meta (#Form tokens))))) (def' $tuple (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) (lambda' _ tokens (_meta (#Tuple tokens))))) (def' $record (:' (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax]) (lambda' _ tokens (_meta (#Record tokens))))) (def' let' (:' Macro (lambda' _ tokens (case' tokens (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) (return (:' SyntaxList (#Cons [($form (#Cons [($symbol ["" "case'"]) (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])])) #Nil]))) _ (fail "Wrong syntax for let'"))))) (declare-macro' let') (def' lambda_ (:' Macro (lambda' _ tokens (case' tokens (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) (#Cons [(_meta (#Symbol ["" ""])) (#Cons [arg (#Cons [(case' args' #Nil body _ (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) (#Cons [(_meta (#Tuple args')) (#Cons [body #Nil])])])))) #Nil])])])]))) #Nil]))) (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"])) (#Cons [(_meta (#Symbol self)) (#Cons [arg (#Cons [(case' args' #Nil body _ (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) (#Cons [(_meta (#Tuple args')) (#Cons [body #Nil])])])))) #Nil])])])]))) #Nil]))) _ (fail "Wrong syntax for lambda"))))) (declare-macro' lambda_) (def' def_ (:' Macro (lambda_ [tokens] (case' tokens (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) (#Cons [name (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) (#Cons [type (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) (#Cons [name (#Cons [(_meta (#Tuple args)) (#Cons [body #Nil])])])]))) #Nil])])]))) #Nil])])]))) (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) #Nil])]))) (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) (#Cons [name (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) (#Cons [type (#Cons [body #Nil])])]))) #Nil])])]))) (#Cons [(_meta (#Form (#Cons [($symbol ["" "export'"]) (#Cons [name #Nil])]))) #Nil])]))) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) (#Cons [name (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) (#Cons [type (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda_"])) (#Cons [name (#Cons [(_meta (#Tuple args)) (#Cons [body #Nil])])])]))) #Nil])])]))) #Nil])])]))) #Nil]))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) (#Cons [name (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) (#Cons [type (#Cons [body #Nil])])]))) #Nil])])]))) #Nil]))) _ (fail "Wrong syntax for def") )))) (declare-macro' def_) (def_ #export (defmacro tokens) Macro (case' tokens (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) (return (:' SyntaxList (#Cons [($form (#Cons [($symbol ["lux" "def_"]) (#Cons [($form (#Cons [name args])) (#Cons [($symbol ["lux" "Macro"]) (#Cons [body #Nil])]) ])])) (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])])) #Nil])]))) (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])]) (return (:' 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 ["" "declare-macro'"]) (#Cons [name #Nil])])) #Nil])]))) _ (fail "Wrong syntax for defmacro"))) (declare-macro' defmacro) (defmacro #export (comment tokens) (return (:' SyntaxList #Nil))) (defmacro (->' tokens) (case' tokens (#Cons [input (#Cons [output #Nil])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) (#Cons [(_meta (#Tuple (#Cons [input (#Cons [output #Nil])]))) #Nil])]))) #Nil]))) (#Cons [input (#Cons [output others])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "LambdaT"])) (#Cons [(_meta (#Tuple (#Cons [input (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "->'"])) (#Cons [output others])]))) #Nil])]))) #Nil])]))) #Nil]))) _ (fail "Wrong syntax for ->'"))) (defmacro (All' tokens) (case' tokens (#Cons [(#Meta [_ (#Tuple #Nil)]) (#Cons [body #Nil])]) (return (:' SyntaxList (#Cons [body #Nil]))) (#Cons [(#Meta [_ (#Tuple (#Cons [(#Meta [_ (#Symbol ["" arg-name])]) other-args]))]) (#Cons [body #Nil])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AllT"])) (#Cons [(_meta (#Tuple (#Cons [(_meta (#Tag ["lux" "None"])) (#Cons [(_meta (#Text "")) (#Cons [(_meta (#Text arg-name)) (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "All'"])) (#Cons [(_meta (#Tuple other-args)) (#Cons [body #Nil])])]))) #Nil])])])]))) #Nil])]))) #Nil]))) _ (fail "Wrong syntax for All'"))) (defmacro (B' tokens) (case' tokens (#Cons [(#Meta [_ (#Symbol ["" bound-name])]) #Nil]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "BoundT"])) (#Cons [(_meta (#Text bound-name)) #Nil])]))) #Nil]))) _ (fail "Wrong syntax for B'"))) (defmacro ($' tokens) (case' tokens (#Cons [x #Nil]) (return tokens) (#Cons [x (#Cons [y xs])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "$'"])) (#Cons [(_meta (#Form (#Cons [(_meta (#Tag ["lux" "AppT"])) (#Cons [(_meta (#Tuple (#Cons [x (#Cons [y #Nil])]))) #Nil])]))) xs])]))) #Nil]))) _ (fail "Wrong syntax for $'"))) (def_ #export (fold f init xs) (All' [a b] (->' (->' (B' a) (B' b) (B' a)) (B' a) ($' List (B' b)) (B' a))) (case' xs #Nil init (#Cons [x xs']) (fold f (f init x) xs'))) (def_ #export (reverse list) (All' [a] (->' ($' List (B' a)) ($' List (B' a)))) (fold (:' (All' [a] (->' ($' List (B' a)) (B' a) ($' List (B' a)))) (lambda_ [tail head] (#Cons [head tail]))) #Nil list)) (defmacro #export (list xs) (return (:' SyntaxList (#Cons [(fold (:' (->' Syntax Syntax Syntax) (lambda_ [tail head] (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) #Nil])]))))) (_meta (#Tag ["lux" "Nil"])) (reverse xs)) #Nil])))) (defmacro #export (list& xs) (case' (reverse xs) (#Cons [last init]) (return (:' SyntaxList (list (fold (:' (->' Syntax Syntax Syntax) (lambda_ [tail head] (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) (_meta (#Tuple (list head tail)))))))) last init)))) _ (fail "Wrong syntax for list&"))) (defmacro #export (lambda tokens) (let' [name tokens'] (:' (#TupleT (list Ident ($' List Syntax))) (case' tokens (#Cons [(#Meta [_ (#Symbol name)]) tokens']) [name tokens'] _ [["" ""] tokens])) (case' tokens' (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) (case' args #Nil (fail "lambda requires a non-empty arguments tuple.") (#Cons [harg targs]) (let' body' (fold (:' (->' Syntax Syntax Syntax) (lambda_ [body' arg] ($form (list ($symbol ["" "lambda'"]) ($symbol ["" ""]) arg body')))) body (reverse targs)) (return (:' SyntaxList (list ($form (list ($symbol ["" "lambda'"]) ($symbol name) harg body'))))))) _ (fail "Wrong syntax for lambda")))) (defmacro (def__ tokens) (case' tokens (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])]) (return (:' SyntaxList (list ($form (list ($symbol ["" "def'"]) name ($form (list ($symbol ["" ":'"]) type ($form (list ($symbol ["lux" "lambda"]) name ($tuple args) body)))))) ($form (list ($symbol ["" "export'"]) name))))) (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [name (#Cons [type (#Cons [body #Nil])])])]) (return (:' SyntaxList (list ($form (list ($symbol ["" "def'"]) name ($form (list ($symbol ["" ":'"]) type body)))) ($form (list ($symbol ["" "export'"]) name))))) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) (return (:' SyntaxList (list ($form (list ($symbol ["" "def'"]) name ($form (list ($symbol ["" ":'"]) type ($form (list ($symbol ["lux" "lambda"]) name ($tuple args) body))))))))) (#Cons [name (#Cons [type (#Cons [body #Nil])])]) (return (:' SyntaxList (list ($form (list ($symbol ["" "def'"]) name ($form (list ($symbol ["" ":'"]) type body))))))) _ (fail "Wrong syntax for def") )) (def__ (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (case' xs (#Cons [x (#Cons [y xs'])]) (#Cons [[x y] (as-pairs xs')]) _ #Nil)) (defmacro #export (let tokens) (case' tokens (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) (return (:' SyntaxList (list (fold (:' (->' Syntax (#TupleT (list Syntax Syntax)) Syntax) (lambda [body binding] (case' binding [label value] (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))) body (fold (:' (->' ($' List (#TupleT (list Syntax Syntax))) (#TupleT (list Syntax Syntax)) ($' List (#TupleT (list Syntax Syntax)))) (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)))) (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)) (case' xs #Nil false (#Cons [x xs']) (case' (p x) true true false (any? p xs')))) (def__ (spliced? token) (->' Syntax Bool) (case' token (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) true _ false)) (def__ (wrap-meta content) (->' Syntax Syntax) (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1))))) content))))))) (def__ (untemplate-list tokens) (->' ($' List Syntax) Syntax) (case' tokens #Nil (_meta (#Tag ["lux" "Nil"])) (#Cons [token tokens']) (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) (_meta (#Tuple (list token (untemplate-list tokens'))))))))) (def__ (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (case' xs (#Cons [x xs']) (#Cons [x (list:++ xs' ys)]) #Nil ys)) (defmacro #export ($ tokens) (case' tokens (#Cons [op (#Cons [init args])]) (return (:' SyntaxList (list (fold (:' (->' Syntax Syntax Syntax) (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) (case' (any? spliced? elems) true (let [elems' (map (:' (->' Syntax Syntax) (lambda [elem] (case' elem (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [spliced #Nil])]))]) spliced _ ($form (list ($symbol ["" ":'"]) ($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) (case' token (#Meta [_ (#Bool value)]) (wrap-meta ($form (list ($tag ["lux" "Bool"]) (_meta (#Bool value))))) (#Meta [_ (#Int value)]) (wrap-meta ($form (list ($tag ["lux" "Int"]) (_meta (#Int value))))) (#Meta [_ (#Real value)]) (wrap-meta ($form (list ($tag ["lux" "Real"]) (_meta (#Real value))))) (#Meta [_ (#Char value)]) (wrap-meta ($form (list ($tag ["lux" "Char"]) (_meta (#Char value))))) (#Meta [_ (#Text value)]) (wrap-meta ($form (list ($tag ["lux" "Text"]) (_meta (#Text value))))) (#Meta [_ (#Tag [module name])]) (let [module' (case' module "" subst _ module)] (wrap-meta ($form (list ($tag ["lux" "Tag"]) ($tuple (list ($text module') ($text name))))))) (#Meta [_ (#Symbol [module name])]) (let [module' (case' module "" subst _ module)] (wrap-meta ($form (list ($tag ["lux" "Symbol"]) ($tuple (list ($text module') ($text name))))))) (#Meta [_ (#Tuple elems)]) (splice (untemplate subst) ($tag ["lux" "Tuple"]) elems) (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) unquoted (#Meta [_ (#Form elems)]) (splice (untemplate subst) ($tag ["lux" "Form"]) elems) (#Meta [_ (#Record fields)]) (wrap-meta ($form (list ($tag ["lux" "Record"]) (untemplate-list (map (:' (->' (#TupleT (list Syntax Syntax)) Syntax) (lambda [kv] (let [[k v] kv] ($tuple (list (untemplate subst k) (untemplate subst v)))))) fields))))) )) (defmacro (`' tokens) (case' tokens (#Cons [template #Nil]) (return (:' SyntaxList (list (untemplate "" template)))) _ (fail "Wrong syntax for `'"))) (defmacro #export (|> tokens) (case' tokens (#Cons [init apps]) (return (:' SyntaxList (list (fold (:' (->' Syntax Syntax Syntax) (lambda [acc app] (case' app (#Meta [_ (#Form parts)]) ($form (list:++ parts (list acc))) _ (`' ((~ app) (~ acc)))))) init apps)))) _ (fail "Wrong syntax for |>"))) (defmacro #export (if tokens) (case' tokens (#Cons [test (#Cons [then (#Cons [else #Nil])])]) (return (:' SyntaxList (list (`' (case' (~ test) true (~ then) false (~ else)))))) _ (fail "Wrong syntax for if"))) ## (deftype (Lux a) ## (-> CompilerState (Either Text (, CompilerState a)))) (def__ #export Lux Type (All' [a] (->' CompilerState ($' Either Text (#TupleT (list CompilerState (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] (case' ma #None #None (#Some a) (f a)))}) (def__ Lux:Monad ($' Monad Lux) {#lux;return (lambda return [x] (lambda [state] (#Right [state x]))) #lux;bind (lambda [f ma] (lambda [state] (case' (ma state) (#Left msg) (#Left msg) (#Right [state' a]) (f a state'))))}) (defmacro #export (^ tokens) (case' tokens (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) (return (:' SyntaxList (list (`' (#;DataT (~ (_meta (#Text class-name)))))))) _ (fail "Wrong syntax for ^"))) (defmacro #export (-> tokens) (case' (reverse tokens) (#Cons [output inputs]) (return (:' SyntaxList (list (fold (:' (->' Syntax Syntax Syntax) (lambda [o i] (`' (#;LambdaT [(~ i) (~ o)])))) output inputs)))) _ (fail "Wrong syntax for ->"))) (defmacro #export (, tokens) (return (:' SyntaxList (list (`' (#;TupleT (;list (~@ tokens)))))))) (defmacro (do tokens) (case' tokens (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) (let [body' (fold (:' (-> Syntax (, Syntax Syntax) Syntax) (lambda [body' binding] (let [[var value] binding] (case' var (#Meta [_ (#Tag ["" "let"])]) (`' (;let (~ value) (~ body'))) _ (`' (;bind (lambda' (~ ($symbol ["" ""])) (~ var) (~ body')) (~ value))))))) body (reverse (as-pairs bindings)))] (return (:' SyntaxList (list (`' (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] (case' xs #Nil (;return (:' List #Nil)) (#Cons [x xs']) (do m [y (f x) ys (map% m f xs')] (;return (:' 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)) (case' x (#Meta [_ (#Symbol ["" sname])]) (#Some sname) _ #None)) (def__ (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (case' tuple (#Meta [_ (#Tuple members)]) (#Some members) _ #None)) (def__ RepEnv Type ($' List (, Text Syntax))) (def__ (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) (case' (:' (, ($' 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)) (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) (case' template (#Meta [_ (#Symbol ["" sname])]) (case' (get-rep sname env) (#Some subst) subst _ template) (#Meta [_ (#Tuple elems)]) ($tuple (map (apply-template env) elems)) (#Meta [_ (#Form elems)]) ($form (map (apply-template env) elems)) (#Meta [_ (#Record members)]) ($record (map (:' (-> (, 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)))) (case' xs #Nil #Nil (#Cons [x xs']) (list:++ (f x) (join-map f xs')))) (defmacro (do-template tokens) (case' tokens (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])]) (case' (:' (, ($' 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 (:' (-> 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 [ ] [(def__ #export ( x y) (-> Bool) ( 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 [ ] [(def__ #export ( x y) (-> ) ( 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) (fold (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) (case' syntax (#Meta [_ (#Symbol ["" name])]) (case' (get-rep name reps) (#Some replacement) replacement #None syntax) (#Meta [_ (#Form parts)]) (#Meta [_ (#Form (map (replace-syntax reps) parts))]) (#Meta [_ (#Tuple members)]) (#Meta [_ (#Tuple (map (replace-syntax reps) members))]) (#Meta [_ (#Record slots)]) (#Meta [_ (#Record (map (:' (-> (, 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'] (:' (, Text SyntaxList) (case' tokens (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens']) [self-ident tokens'] _ ["" tokens]))] (case' tokens' (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) (case' (map% Maybe:Monad get-ident args) (#Some idents) (case' idents #Nil (return (:' SyntaxList (list body))) (#Cons [harg targs]) (let [replacements (map (:' (-> Text (, Text Syntax)) (lambda [ident] [ident (`' (#;BoundT (~ ($text ident))))])) (list& self-ident idents)) body' (fold (:' (-> Syntax Text Syntax) (lambda [body' arg'] (`' (#;AllT [#;None "" (~ ($text arg')) (~ body')])))) (replace-syntax replacements body) (reverse targs))] (return (:' SyntaxList (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))) (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) (case' state {#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host #seed seed} (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 ($' List (, Text (, Bool ($' DefData' (-> ($' List Syntax) ($' StateE CompilerState ($' List Syntax))))))))) Text Text Text ($' Maybe Macro)) (do Maybe:Monad [bindings (get module modules) gdef (get name bindings)] (case' (:' (, 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] (:' ($' Lux ($' Maybe Macro)) (lambda [state] (case' state {#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host #seed seed} (#Right [state (find-macro' modules current-module module name)]))))))) (def__ (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (fold list:++ #Nil xs)) (def__ #export (normalize ident state) (-> Ident ($' Lux Ident)) (case' ident ["" name] (case' state {#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host #seed seed} (case' (reverse envs) #Nil (#Left "Can't normalize Ident without a global environment.") (#Cons [{#name prefix #inner-closures _ #locals _ #closure _} _]) (#Right [state [prefix name]]))) _ (#Right [state ident]))) (defmacro #export (| tokens) (do Lux:Monad [pairs (map% Lux:Monad (:' (-> Syntax ($' Lux Syntax)) (lambda [token] (case' token (#Meta [_ (#Tag ident)]) (do Lux:Monad [ident (normalize ident)] (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (;,)])))) (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ident)]) (#Cons [value #Nil])]))]) (do Lux:Monad [ident (normalize ident)] (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) _ (fail "Wrong syntax for |")))) tokens)] (;return (:' 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 (:' (-> (, Syntax Syntax) ($' Lux Syntax)) (lambda [pair] (case' pair [(#Meta [_ (#Tag ident)]) value] (do Lux:Monad [ident (normalize ident)] (;return (:' Syntax (`' [(~ ($text (ident->text ident))) (~ value)])))) _ (fail "Wrong syntax for &")))) (as-pairs tokens))] (;return (:' 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))) (case' xs #Nil xs (#Cons [x #Nil]) xs (#Cons [x xs']) (list& x sep (interpose sep xs')))) (def__ #export (syntax:show syntax) (-> Syntax Text) (case' syntax (#Meta [_ (#Bool value)]) (->text value) (#Meta [_ (#Int value)]) (->text value) (#Meta [_ (#Real value)]) (->text value) (#Meta [_ (#Char value)]) ($ text:++ "#\"" (->text value) "\"") (#Meta [_ (#Text value)]) value (#Meta [_ (#Symbol ident)]) (ident->text ident) (#Meta [_ (#Tag ident)]) (text:++ "#" (ident->text ident)) (#Meta [_ (#Tuple members)]) ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") (#Meta [_ (#Form members)]) ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") (#Meta [_ (#Record slots)]) ($ text:++ "{" (|> slots (map (:' (-> (, Syntax Syntax) Text) (lambda [slot] (let [[k v] slot] ($ text:++ (syntax:show k) " " (syntax:show v)))))) (interpose " ") (fold text:++ "")) "}") )) (def__ #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (case' syntax (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) (do Lux:Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] (case' (:' ($' Maybe Macro) ?macro) (#Some macro) (do Lux:Monad [expansion (macro args) expansion' (map% Lux:Monad macro-expand expansion)] (;return (:' SyntaxList (list:join expansion')))) #None (do Lux:Monad [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] (;return (:' SyntaxList (list ($form (list:join parts')))))))) (#Meta [_ (#Form (#Cons [harg targs]))]) (do Lux:Monad [harg+ (macro-expand harg) targs+ (map% Lux:Monad macro-expand targs)] (;return (:' SyntaxList (list ($form (list:++ harg+ (list:join (:' ($' List ($' List Syntax)) targs+)))))))) (#Meta [_ (#Tuple members)]) (do Lux:Monad [members' (map% Lux:Monad macro-expand members)] (;return (:' SyntaxList (list ($tuple (list:join members')))))) _ (return (:' SyntaxList (list syntax))))) (def__ (walk-type type) (-> Syntax Syntax) (case' type (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) ($form (#Cons [($tag tag) (map walk-type parts)])) (#Meta [_ (#Tuple members)]) ($tuple (map walk-type members)) (#Meta [_ (#Form (#Cons [type-fn args]))]) (fold (:' (-> Syntax Syntax Syntax) (lambda [type-fn arg] (`' (#;AppT [(~ type-fn) (~ arg)])))) (walk-type type-fn) (map walk-type args)) _ type)) (defmacro #export (type` tokens) (case' tokens (#Cons [type #Nil]) (do Lux:Monad [type+ (macro-expand type)] (case' (:' SyntaxList type+) (#Cons [type' #Nil]) (;return (:' 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) (case' tokens (#Cons [type (#Cons [value #Nil])]) (return (:' SyntaxList (list (`' (:' (;type` (~ type)) (~ value)))))) _ (fail "Wrong syntax for :"))) (defmacro #export (:! tokens) (case' tokens (#Cons [type (#Cons [value #Nil])]) (return (:' SyntaxList (list (`' (:!' (;type` (~ type)) (~ value)))))) _ (fail "Wrong syntax for :!"))) (defmacro #export (deftype tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case' tokens (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) Syntax)) (case' tokens' (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) (#Some [($symbol name) #Nil type]) (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) (#Some [($symbol name) args type]) _ #None)) ] ## (return (: (List Syntax) #Nil)) (case' parts (#Some [name args type]) (let [with-export (: (List Syntax) (if export? (list (`' (export' (~ name)))) #Nil)) type' (: Syntax (case' args #Nil type _ (`' (;All (~ name) [(~@ args)] (~ type)))))] (return (: (List Syntax) (list& (`' (def' (~ name) (;type` (~ type')))) with-export)))) #None (fail "Wrong syntax for deftype")) )) (deftype #export (IO a) (-> (,) a)) (defmacro #export (io tokens) (case' tokens (#Cons [value #Nil]) (let [blank ($symbol ["" ""])] (return (: (List Syntax) (list (`' (lambda' (~ blank) (~ blank) (~ value))))))) _ (fail "Wrong syntax for io"))) (defmacro #export (exec tokens) (case' (reverse tokens) (#Cons [value actions]) (let [dummy ($symbol ["" ""])] (return (:' SyntaxList (list (fold (:' (-> Syntax Syntax Syntax) (lambda [post pre] (`' (case' (~ pre) (~ dummy) (~ post))))) value actions))))) _ (fail "Wrong syntax for exec"))) (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case' tokens (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (case' tokens' (#Cons [(#Meta [_ (#Form (#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 [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) (#Some [name args #None body]) (#Cons [name (#Cons [body #Nil])]) (#Some [name #Nil #None body]) _ #None))] (case' parts (#Some [name args ?type body]) (let [body' (: Syntax (case' args #Nil body _ (`' (;lambda (~ name) [(~@ args)] (~ body))))) body'' (: Syntax (case' ?type (#Some type) (`' (: (~ type) (~ body'))) #None body'))] (return (: (List Syntax) (list& (`' (def' (~ name) (~ body''))) (if export? (list (`' (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) (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] (case' pattern (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol 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:join (: (List (List (, Syntax Syntax))) expansions)))) _ (;return (: (List (, Syntax Syntax)) (list branch))))))) (as-pairs branches))] (;return (: (List Syntax) (list (`' (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 (: (List (List Syntax)) patterns')))))))) _ (fail "Wrong syntax for \\or"))) (do-template [ ] [(def #export (int:+ ))] [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 (: (List Syntax) (list (untemplate (: Text module-name) template)))) _ (fail "Wrong syntax for `")))) (def #export (gensym prefix state) (-> Text (Lux Syntax)) (case state {#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host #seed seed} (#Right [{#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host #seed (inc seed)} ($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 [_ (#Form (list (#Meta [_ (#Symbol ["" ":'"])]) type (#Meta [_ (#Symbol name)])))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) _ (fail "Signatures require typed members!")))) (: (List Syntax) tokens'))] (;return (: (List Syntax) (list (`' (#;RecordT (list (~@ (map (: (-> (, Ident Syntax) Syntax) (lambda [pair] (let [[name type] pair] (`' [(~ (|> name ident->text $text)) (~ type)])))) (: (List (, Ident Syntax)) members))))))))))) (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) (case tokens' (\ (list& (#Meta [_ (#Form (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& (`' (def' (~ name) (~ sigs'))) (if export? (list (`' (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 [_ (#Form (list (#Meta [_ (#Symbol ["" "def'"])]) (#Meta [_ (#Symbol name)]) value))])) (do Lux:Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [($tag name') value]))) _ (fail "Structures require defined members!")))) (: (List Syntax) tokens'))] (;return (: (List Syntax) (list ($record members)))))) (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens (\ (list& (#Meta [_ (#Tag ["" "export"])]) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) (case tokens' (\ (list& (#Meta [_ (#Form (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 (`' (export' (~ name)))) #Nil))))) #None (fail "Wrong syntax for defsig")))) (defsig #export (Eq a) (: (-> a a Bool) =)) (do-template [ ] [(defstruct #export (Eq ) (def (= x y) ( x y)))] [Int:Eq Int jvm-leq] [Real:Eq Real jvm-deq]) (def #export (id x) (All [a] (-> a a)) x) (defsig #export (Show a) (: (-> a Text) show)) (do-template [ ] [(defstruct #export (Show ) (def (show x) ))] [Bool:Show Bool (->text x)] [Int:Show Int (->text x)] [Real:Show Real (->text x)] [Char:Show Char ($ text:++ "#\"" (->text x) "\"")]) (defsig #export (Ord a) (: (-> a a Bool) <) (: (-> a a Bool) <=) (: (-> a a Bool) >) (: (-> a a Bool) >=)) (do-template [
] [(defmacro #export ( tokens) (case (reverse tokens) (\ (list& last init)) (return (: (List Syntax) (list (fold (: (-> Syntax Syntax Syntax) (lambda [post pre] (` ))) last init)))) _ (fail )))] [and (if (~ pre) true (~ post)) "and requires >=1 clauses."] [or (if (~ pre) (~ post) false) "or requires >=1 clauses."]) (do-template [ ] [(defstruct #export (Ord ) (def (< x y) ( x y)) (def (<= x y) (or ( x y) ( x y))) (def (> x y) ( x y)) (def (>= x y) (or ( x y) ( x y))))] [Int:Ord Int jvm-llt jvm-lgt jvm-leq] [Real:Ord Real jvm-dlt jvm-dgt jvm-deq]) (defmacro #export (alias-lux tokens state) (case state {#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host #seed seed} (case (get "lux" modules) (#Some lux) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax)))))) (List Text)) (lambda [gdef] (let [[name [export? _]] gdef] (if export? (list name) (list))))) lux)] (#Right [state (map (: (-> Text Syntax) (lambda [name] (` ((~ ($symbol ["" "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 (,)) (jvm-invokevirtual java.io.PrintStream print [java.lang.Object] (jvm-getstatic java.lang.System out) [x])) (def #export (println x) (-> Text (,)) (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 [_ (#Symbol vname)]) (let [vname' (ident->text vname)] (case state {#source source #modules modules #module-aliases module-aliases #envs envs #types types #host host #seed seed} (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)) _ (println (text:++ "Using pattern: " (syntax:show pattern)))] (#Right [state (list (` (case' (~ struct) (~ pattern) (~ body))))])) _ (#Left "Can only \"use\" records.")))))) _ (let [dummy ($symbol ["" ""])] (#Right [state (list (` (case' (~ struct) (~ dummy) (using (~ dummy) (~ body)))))]))) _ (#Left "Wrong syntax for defsig"))) ## (defmacro (loop tokens) ## (case' tokens ## (#Cons [bindings (#Cons [body #Nil])]) ## (let [pairs (as-pairs bindings)] ## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["" "recur"])) (~ (#Tuple (map first pairs))) ## (~ body))) ## (map second pairs)]))))))) ## (defmacro (get@ tokens) ## (let [output (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 (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 (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)))) ## (do-template [ ] ## (def ( pair) ## (All [a b] (-> (, a b) )) ## (case pair ## [f s] ## )) ## [first f a] ## [second s b])