## 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) ## (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])]))] #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) ## (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 CompilerState ## (& #source (Maybe Reader) ## #modules (List Void) ## #module-aliases (List Void) ## #envs (List (Env Text Void)) ## #types (Bindings Int Type) ## #host HostState)) (def' CompilerState (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])] (#Cons [["lux;modules" (#AppT [List Void])] (#Cons [["lux;module-aliases" (#AppT [List Void])] (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) Void])])] (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] (#Cons [["lux;host" HostState] #Nil])])])])])]))) (export' CompilerState) ## (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']) Syntax'List (case' (#TupleT (#Cons [Text (#Cons [Text #Nil])])) Ident (#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" Syntax'List] (#Cons [["lux;Tuple" Syntax'List] (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#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 Macro ## (-> (List Syntax) CompilerState ## (Either Text (, CompilerState (List Syntax))))) (def' Macro (#LambdaT [SyntaxList (#LambdaT [CompilerState (#AppT [(#AppT [Either Text]) (#TupleT (#Cons [CompilerState (#Cons [SyntaxList #Nil])]))])])])) (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' Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) (export' Ident) (def' $text (:' (#LambdaT [Text Syntax]) (lambda' _ text (_meta (#Text text))))) (export' $text) (def' $symbol (:' (#LambdaT [Ident Syntax]) (lambda' _ ident (_meta (#Symbol ident))))) (export' $symbol) (def' $tag (:' (#LambdaT [Ident Syntax]) (lambda' _ ident (_meta (#Tag ident))))) (export' $tag) (def' $form (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) (lambda' _ tokens (_meta (#Form tokens))))) (export' $form) (def' $tuple (:' (#LambdaT [(#AppT [List Syntax]) Syntax]) (lambda' _ tokens (_meta (#Tuple tokens))))) (export' $tuple) (def' let' (:' Macro (lambda' _ tokens (case' tokens (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "case'"])) (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))) #Nil]))) _ (fail "Wrong syntax for 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"))))) (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") )))) (def_ #export (defmacro tokens) Macro (case' tokens (#Cons [usage (#Cons [body #Nil])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [($symbol ["lux" "def_"]) (#Cons [usage (#Cons [($symbol ["lux" "Macro"]) (#Cons [body #Nil])]) ])]))) #Nil]))) (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [usage (#Cons [body #Nil])])]) (return (:' SyntaxList (#Cons [(_meta (#Form (#Cons [($symbol ["lux" "def_"]) (#Cons [($tag ["" "export"]) (#Cons [usage (#Cons [($symbol ["lux" "Macro"]) (#Cons [body #Nil])]) ])])]))) #Nil]))) _ (fail "Wrong syntax for 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 #export (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'])]) (list& [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 (untemplate token) ## (->' Syntax Syntax) ## (case' token ## (#Meta [_ (#Bool value)]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value))))) ## (#Meta [_ (#Int value)]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value))))) ## (#Meta [_ (#Real value)]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value))))) ## (#Meta [_ (#Char value)]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value))))) ## (#Meta [_ (#Text value)]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value))))) ## (#Meta [_ (#Tag [module name])]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) ## (#Meta [_ (#Symbol [module name])]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) ## (#Meta [_ (#Tuple elems)]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tuple"])) (untemplate-list (map untemplate elems))))) ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [(#Meta [_ unquoted]) #Nil])]))]) ## (_meta unquoted) ## (#Meta [_ (#Form elems)]) ## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Form"])) (untemplate-list (map untemplate elems))))) ## (#Meta [_ (#Record fields)]) ## (wrap-meta (#Record (map (:' (->' (#TupleT (list Text Syntax)) (#TupleT (list Text Syntax))) ## (lambda [kv] ## (let [[k v] kv] ## [k (untemplate v)]))) ## fields))) ## )) (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 _ (_meta (#Form (list ($symbol ["lux" "list"]) elem)))))) elems)] (wrap-meta ($form (list tag (wrap-meta ($form (list& ($tag ["lux" "$"]) ($tag ["lux" "list:++"]) elems'))))))) false (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) (def (untemplate token) (->' Syntax Syntax) (case' token (#Meta [_ (#Bool value)]) (wrap-meta ($form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value))))) (#Meta [_ (#Int value)]) (wrap-meta ($form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value))))) (#Meta [_ (#Real value)]) (wrap-meta ($form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value))))) (#Meta [_ (#Char value)]) (wrap-meta ($form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value))))) (#Meta [_ (#Text value)]) (wrap-meta ($form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value))))) (#Meta [_ (#Tag [module name])]) (wrap-meta ($form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) (#Meta [_ (#Symbol [module name])]) (wrap-meta ($form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name)))))))) (#Meta [_ (#Tuple elems)]) (splice untemplate ($tag ["lux" "Tuple"]) elems) (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~"])]) (#Cons [unquoted #Nil])]))]) unquoted (#Meta [_ (#Form elems)]) (splice untemplate ($tag ["lux" "Form"]) elems) (#Meta [_ (#Record fields)]) (wrap-meta (_meta (#Record (map (:' (->' (#TupleT (list Text Syntax)) (#TupleT (list Text Syntax))) (lambda [kv] (let [[k v] kv] [k (untemplate v)]))) fields)))) )) (defmacro #export (` tokens) (case' tokens (#Cons [template #Nil]) (return (:' SyntaxList (list (untemplate template)))) _ (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 (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 #export (| tokens) ## (do Lux:Monad ## [pairs (map% Lux:Monad ## (lambda [token] ## (case' token ## (#Tag ident) ## (;return (` [(~ ($text (ident->text ident))) (,)])) ## (#Form (#Cons [(#Tag ident) (#Cons [value #Nil])])) ## (;return (` [(~ ($text (ident->text ident))) (~ value)])) ## _ ## (fail "Wrong syntax for |"))) ## tokens)] ## (` (#VariantT (list (~@ pairs)))))) ## (defmacro #export (& tokens) ## (if (not (int:= 2 (length tokens))) ## (fail "& expects an even number of arguments.") ## (do Lux:Monad ## [pairs (map% Lux:Monad ## (lambda [pair] ## (case' pair ## [(#Tag ident) value] ## (;return (` [(~ ($text (ident->text ident))) (~ value)])) ## _ ## (fail "Wrong syntax for &"))) ## (as-pairs tokens))] ## (` (#RecordT (list (~@ pairs))))))) ## (defmacro #export (All tokens) ## (case' (:' (, Ident SyntaxList) ## (case' tokens ## (#Cons [(#Meta [_ (#Symbol self-ident)]) tokens']) ## [self-ident tokens'] ## _ ## [["" ""] tokens])) ## [self-ident tokens'] ## (case' tokens' ## (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) ## (do Lux:Monad ## [idents (map% Lux:Monad get-ident args)] ## (case' idents ## #Nil ## (return (list body)) ## (#Cons [harg targs]) ## (let [replacements (map (:' (-> Ident (, Ident Syntax)) ## (lambda [ident] ## (let [[module name] ident] ## [ident (_meta (#Bound ($ text:++ module ";" name)))]))) ## (list& self-ident idents)) ## body' (fold (lambda [body' arg'] ## (let [[module name] arg'] ## (` (#AllT [#None "" (~ ($text ($ text:++ module ";" name))) ## (~ body')])))) ## (replace-syntax replacements body) ## (reverse targs)) ## [smodule sname] self-ident ## [amodule aname] harg] ## (return (list (` (#AllT [#None (~ ($text ($ text:++ smodule ";" sname))) ## (~ ($text ($ text:++ amodule ";" aname))) ## (~ body')]))))))) ## _ ## (fail "Wrong syntax for All")) ## )) ## (def (ident->text ident) ## (->' Ident Text) ## (let [[module name] ident] ## ($ text:++ module ";" name))) ## (def (map% monad f xs) ## (All' [m a b] ## (->' ($' Monad (B' m)) ## (->' (B' a) ($' (B' m) (B' b))) ## ($' (B' m) ($' List (B' b))))) ## (let [{#;return ;return #;bind ;bind} monad] ## (case' xs ## #Nil ## (;return #Nil) ## (#Cons [x xs']) ## (do monad ## [x' (f x) ## xs'' (map% monad f xs')] ## (;return (#Cons [x' xs''])))))) ## (defmacro (do tokens) ## (case' tokens ## (#Cons [monad (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) ## (return (:' SyntaxList ## (list (` (case' (~ monad) ## {#;return ;return #;bind ;bind} ## (~ (fold (:' (-> Syntax (, Syntax Syntax) Syntax) ## (lambda [body' binding] ## (let [[lhs rhs] binding] ## (` (;bind (lambda [(~ lhs)] (~ body')) (~ rhs)))))) ## body ## (reverse (as-pairs bindings))))))))) ## _ ## (fail "Wrong syntax for do"))) ## (def #export (find-macro ident state) ## (->' Ident ($' Lux Macro)) ## (let [[module name] ident] ## (case' state ## {#source source #modules modules #module-aliases module-aliases ## #envs envs #types types #host host} ## (case' (:' ($' Maybe Macro) ## (do Maybe:Monad ## [bindings (get module modules) ## gdef (get name bindings)] ## (case' gdef ## (#MacroD macro') ## macro' ## _ ## #None))) ## (#Some macro) ## (#Right [state macro]) ## #None ## (#Left ($ text:++ "There is no macro by the name: " module ";" name)))))) ## ## (def (id x) ## ## (All [a] (-> a a)) ## ## x) ## ## (export' id) ## ## (def (text:= x y) ## ## (-> Text Text Bool) ## ## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] ## ## x [y])) ## ## (def #export (int:+ x y) ## ## (-> Int Int Int) ## ## (jvm-ladd x y)) ## ## (def (replace-ident ident value syntax) ## ## (-> (, Text Text) Syntax Syntax Syntax) ## ## (let [[module name] ident] ## ## (case' syntax ## ## (#Meta [_ (#Symbol [?module ?name])]) ## ## (if (and (text:= module ?module) ## ## (text:= name ?name)) ## ## value ## ## syntax) ## ## (#Meta [_ (#Form members)]) ## ## (_meta (#Form (map (replace-ident ident value) members))) ## ## (#Meta [_ (#Tuple members)]) ## ## (_meta (#Tuple (map (replace-ident ident value) members))) ## ## (#Meta [_ (#Record members)]) ## ## (_meta (#Record (map (lambda [kv] ## ## (case' kv ## ## [k v] ## ## [k (replace-ident ident value v)])) ## ## members))) ## ## _ ## ## syntax))) ## ## (defsig (Eq a) ## ## (: (-> a a Bool) ## ## =)) ## ## (defstruct Text:Eq (Eq Text) ## ## (def = text=)) ## ## (defstruct Ident:Eq (Eq Ident) ## ## (def (= x y) ## ## (let [[m1 n1] x ## ## [m2 n2] y] ## ## (and (text:= m1 m2) ## ## (text:= n1 n2))))) ## ## (deftype (Dict k v) ## ## (: (-> k v (Dict k v) (Dict k v)) ## ## put) ## ## (: (-> k (Dict k v) (Maybe v)) ## ## get) ## ## (: (-> k (Dict k v) (Dict k v)) ## ## remove)) ## ## (deftype (PList k v) ## ## (| (#PList (, (Eq k) (List (, k v)))))) ## ## (def (some f xs) ## ## (All [a b] ## ## (-> (-> a (Maybe b)) (List a) (Maybe b))) ## ## (case' xs ## ## #Nil ## ## #None ## ## (#Cons [x xs']) ## ## (if-let [y (f x)] ## ## (#Some y) ## ## (some f xs')) ## ## )) ## ## (defstruct PList:Dict (Dict PList) ## ## (def (get k plist) ## ## (let [(#PList [{#= =} kvs]) plist] ## ## (some (:' (-> (, )) ## ## (lambda [kv] ## ## (let [[k' v'] kv] ## ## (when (= k k') ## ## v')))) ## ## kvs)))) ## ## (def (walk-type type) ## ## (-> Syntax ($' Lux Syntax)) ## ## (case' type ## ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol sym)]) args]))]) ## ## (do' [macro' (find-macro sym)] ## ## (case' macro' ## ## (#Some macro) ## ## (do' [expansion (macro args)] ## ## (case' expansion ## ## (#Cons [expansion' #Nil]) ## ## (walk-type expansion') ## ## _ ## ## (fail "Macro can't expand to more than 1 output."))) ## ## #None ## ## (do' [args' (map% walk-type args)] ## ## (return (fold (:' (-> Syntax Syntax Syntax) ## ## (lambda [f a] ## ## (` (#AppT [(~ f) (~ a)])))) ## ## sym ## ## args'))))) ## ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) args]))]) ## ## ... ## ## (#Meta [_ (#Symbol _)]) ## ## (return type) ## ## _ ## ## (fail "Wrong syntax for walk-type"))) ## ## (defmacro (->type tokens) ## ## (case' tokens ## ## (#Cons [type #Nil]) ## ## (do' [type' (walk-type type)] ## ## (return (list type'))) ## ## _ ## ## (fail "Wrong syntax for ->type"))) ## ## (defmacro (: tokens) ## ## (case' tokens ## ## (#Cons [type (#Cons [value #Nil])]) ## ## (return (list (` (:' (->type (~ type)) (~ value))))) ## ## _ ## ## (fail "Wrong syntax for :"))) ## ## (defmacro (:! tokens) ## ## (case' tokens ## ## (#Cons [type (#Cons [value #Nil])]) ## ## (return (list (` (:!' (->type (~ type)) (~ value))))) ## ## _ ## ## (fail "Wrong syntax for :!"))) ## ## (def (print x) ## ## (-> (^ java.lang.Object) []) ## ## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] ## ## (jvm-getstatic java.lang.System "out") [x])) ## ## (def (println x) ## ## (-> (^ java.lang.Object) []) ## ## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] ## ## (jvm-getstatic java.lang.System "out") [x])) ## ## (deftype (IO a) ## ## (-> (,) a)) ## ## (defmacro (io tokens) ## ## (case' tokens ## ## (#Cons [value #Nil]) ## ## (return (list (` (lambda [_] (~ value))))))) ## ## (def (. f g) ## ## (All [a b c] ## ## (-> (-> b c) (-> a b) (-> a c))) ## ## (lambda [x] ## ## (f (g x)))) ## ## (def (++ xs ys) ## ## (All [a] ## ## (-> (List a) (List a) (List a))) ## ## (case' xs ## ## #Nil ## ## ys ## ## (#Cons [x xs']) ## ## (#Cons [x (++ xs' ys)]))) ## ## (def concat ## ## (All [a] ## ## (-> (List (List a)) (List a))) ## ## (fold ++ #Nil)) ## ## (def flat-map ## ## (All [a b] ## ## (-> (-> a (List b)) (List a) (List b))) ## ## (. concat map)) ## ## (def (filter p xs) ## ## (All [a] ## ## (-> (-> a Bool) (List a) (List a))) ## ## (case' xs ## ## #Nil ## ## #Nil ## ## (#Cons [x xs']) ## ## (if (p x) ## ## (#Cons [x (filter p xs')]) ## ## (filter p xs')))) ## ## (deftype (Lux a) ## ## (-> CompilerState (Either Text (, CompilerState a)))) ## ## (def (first pair) ## ## (All [a b] (-> (, a b) a)) ## ## (case' pair ## ## [f s] ## ## f)) ## ## (def (second pair) ## ## (All [a b] (-> (, a b) b)) ## ## (case' pair ## ## [f s] ## ## s)) ## ## (defmacro (loop tokens) ## ## (case' tokens ## ## (#Cons [bindings (#Cons [body #Nil])]) ## ## (let [pairs (as-pairs bindings)] ## ## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["lux" "recur"])) (~ (#Tuple (map first pairs))) ## ## (~ body))) ## ## (map second pairs)]))))))) ## ## (defmacro (and tokens) ## ## (let [as-if (case' tokens ## ## #Nil ## ## (` true) ## ## (#Cons [init tests]) ## ## (fold (lambda [prev next] ## ## (` (if (~ prev) (~ next) false))) ## ## init ## ## tokens) ## ## )] ## ## (return (list as-if)))) ## ## (defmacro (or tokens) ## ## (let [as-if (case' tokens ## ## #Nil ## ## (` false) ## ## (#Cons [init tests]) ## ## (fold (lambda [prev next] ## ## (` (if (~ prev) true (~ next)))) ## ## init ## ## tokens) ## ## )] ## ## (return (list as-if)))) ## ## (def (not x) ## ## (-> Bool Bool) ## ## (case' x ## ## true false ## ## false true)) ## ## (defmacro (|> tokens) ## ## (case' tokens ## ## (#Cons [init apps]) ## ## (return (list (fold (lambda [acc app] ## ## (case' app ## ## (#Form parts) ## ## (#Form (++ parts (list acc))) ## ## _ ## ## (` ((~ app) (~ acc))))) ## ## init ## ## apps))))) ## ## (defmacro ($ tokens) ## ## (case' tokens ## ## (#Cons [op (#Cons [init args])]) ## ## (return (list (fold (lambda [acc elem] ## ## (` ((~ op) (~ acc) (~ elem)))) ## ## init ## ## args))))) ## ## (def (const x) ## ## (All [a b] ## ## (-> a (-> b a))) ## ## (lambda [_] ## ## x)) ## ## (def (int> x y) ## ## (-> Int Int Bool) ## ## (jvm-lgt x y)) ## ## (def (int< x y) ## ## (-> Int Int Bool) ## ## (jvm-llt x y)) ## ## (def inc ## ## (-> Int Int) ## ## (int+ 1)) ## ## (def dec ## ## (-> Int Int) ## ## (int+ -1)) ## ## (def (repeat n x) ## ## (All [a] (-> Int a (List a))) ## ## (if (int> n 0) ## ## (#Cons [x (repeat (dec n) x)]) ## ## #Nil)) ## ## (def size ## ## (All [a] ## ## (-> (List a) Int)) ## ## (fold (lambda [acc _] (inc acc)) 0)) ## ## (def (last xs) ## ## (All [a] ## ## (-> (List a) (Maybe a))) ## ## (case' xs ## ## #Nil #None ## ## (#Cons [x #Nil]) (#Some x) ## ## (#Cons [_ xs']) (last xs'))) ## ## (def (init xs) ## ## (All [a] ## ## (-> (List a) (Maybe (List a)))) ## ## (case' xs ## ## #Nil #None ## ## (#Cons [_ #Nil]) (#Some #Nil) ## ## (#Cons [x xs']) (case' (init xs') ## ## (#Some xs'') ## ## (#Some (#Cons [x xs''])) ## ## _ ## ## (#Some (#Cons [x #Nil]))))) ## ## (defmacro (cond tokens) ## ## (case' (reverse tokens) ## ## (#Cons [else branches']) ## ## (return (list (fold (lambda [else branch] ## ## (case' branch ## ## [test then] ## ## (` (if (~ test) (~ then) (~ else))))) ## ## else ## ## (|> branches' reverse as-pairs)))))) ## ## (def (interleave xs ys) ## ## (All [a] ## ## (-> (List a) (List a) (List a))) ## ## (case' [xs ys] ## ## [(#Cons [x xs']) (#Cons [y ys'])] ## ## (list+ x y (interleave xs' ys')) ## ## _ ## ## #Nil)) ## ## (def (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 (empty? xs) ## ## (All [a] ## ## (-> (List a) Bool)) ## ## (case' xs ## ## #Nil true ## ## _ false)) ## ## ## (do-template [ ] ## ## ## (def ( p xs) ## ## ## (case xs ## ## ## #Nil true ## ## ## (#Cons [x xs']) ( (p x) ( p xs')))) ## ## ## [every? and] ## ## ## [any? or]) ## ## (def (tuple->list tuple) ## ## (-> Syntax (List Syntax)) ## ## (case' tuple ## ## (#Meta [_ (#Tuple list)]) ## ## list)) ## ## (def (zip2 xs ys) ## ## (All [a b] ## ## (-> (List a) (List b) (List (, a b)))) ## ## (case' [xs ys] ## ## [(#Cons [x xs']) (#Cons [y ys'])] ## ## (#Cons [[x y] (zip2 xs' ys')]) ## ## _ ## ## #Nil)) ## ## (def (get-ident x) ## ## (-> Syntax Text) ## ## (case' x ## ## (#Meta [_ (#Symbol [_ ident])]) ## ## ident)) ## ## (def (text-++ x y) ## ## (-> Text Text Text) ## ## (jvm-invokevirtual java.lang.String "concat" [java.lang.String] ## ## x [y])) ## ## (def (show-env env) ## ## ... ## ## (|> env (map first) (interpose ", ") (fold text-++ ""))) ## ## (def (apply-template env template) ## ## (case' template ## ## (#Meta [_ (#Symbol [_ ident])]) ## ## (case' (get ident env) ## ## (#Some subst) ## ## subst ## ## _ ## ## template) ## ## (#Meta [_ (#Tuple elems)]) ## ## (_meta (#Tuple (map (apply-template env) elems))) ## ## (#Meta [_ (#Form elems)]) ## ## (_meta (#Form (map (apply-template env) elems))) ## ## (#Meta [_ (#Record members)]) ## ## (_meta (#Record (map (lambda [kv] ## ## (case' kv ## ## [slot value] ## ## [(apply-template env slot) (apply-template env value)])) ## ## members))) ## ## _ ## ## template)) ## ## (defmacro (do-templates tokens) ## ## (case' tokens ## ## (#Cons [bindings (#Cons [(#Meta [_ (#Tuple templates)]) data])]) ## ## (let [bindings-list (map get-ident (tuple->list bindings)) ## ## data-lists (map tuple->list data) ## ## apply (lambda [env] (map (apply-template env) templates))] ## ## (|> data-lists ## ## (map (. apply (zip2 bindings-list))) ## ## return)))) ## ## ## (do-template [ ] ## ## ## (def (int+ )) ## ## ## [inc 1] ## ## ## [dec -1]) ## ## (def (int= x y) ## ## (-> Int Int Bool) ## ## (jvm-leq x y)) ## ## (def (int% x y) ## ## (-> Int Int Int) ## ## (jvm-lrem x y)) ## ## (def (int>= x y) ## ## (-> Int Int Bool) ## ## (or (int= x y) ## ## (int> x y))) ## ## (do-templates [ ] ## ## [(def ( x y) ## ## (-> Int Int Int) ## ## (if ( x y) ## ## x ## ## y))] ## ## [max int>] ## ## [min int<]) ## ## (do-templates [ ] ## ## [(def ( n) ## ## (-> Int Bool) ## ## ( n 0))] ## ## [neg? int<] ## ## [pos? int>=]) ## ## (def (even? n) ## ## (-> Int Bool) ## ## (int= 0 (int% n 0))) ## ## (def (odd? n) ## ## (-> Int Bool) ## ## (not (even? n))) ## ## (do-templates [ ] ## ## [(def ( n xs) ## ## (All [a] ## ## (-> Int (List a) (List a))) ## ## (if (int> n 0) ## ## (case' xs ## ## #Nil #Nil ## ## (#Cons [x xs']) ) ## ## ))] ## ## [take #Nil (list+ x (take (dec n) xs'))] ## ## [drop xs (drop (dec n) xs')]) ## ## (do-templates [ ] ## ## [(def ( f xs) ## ## (All [a] ## ## (-> (-> a Bool) (List a) (List a))) ## ## (case' xs ## ## #Nil #Nil ## ## (#Cons [x xs']) (if (f x) #Nil)))] ## ## [take-while #Nil (list+ x (take-while f xs'))] ## ## [drop-while xs (drop-while f xs')]) ## ## ## (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)))) ## ## (def (show-int int) ## ## (-> Int Text) ## ## (jvm-invokevirtual java.lang.Object "toString" [] ## ## int [])) ## ## (def gensym ## ## (LuxStateM Syntax) ## ## (lambda [state] ## ## [(update@ [#gen-seed] inc state) ## ## (_meta (#Symbol ($ text-++ "__" (show-int (get@ [#gen-seed] state)) "__")))])) ## ## ## (do-template [ ] ## ## ## (def ( pair) ## ## ## (case' pair ## ## ## [f s] ## ## ## )) ## ## ## [first f] ## ## ## [second s]) ## ## (def (show-syntax syntax) ## ## (-> Syntax Text) ## ## (case' syntax ## ## (#Meta [_ (#Bool value)]) ## ## (jvm-invokevirtual java.lang.Object "toString" [] ## ## value []) ## ## (#Meta [_ (#Int value)]) ## ## (jvm-invokevirtual java.lang.Object "toString" [] ## ## value []) ## ## (#Meta [_ (#Real value)]) ## ## (jvm-invokevirtual java.lang.Object "toString" [] ## ## value []) ## ## (#Meta [_ (#Char value)]) ## ## (jvm-invokevirtual java.lang.Object "toString" [] ## ## value []) ## ## (#Meta [_ (#Text value)]) ## ## (jvm-invokevirtual java.lang.Object "toString" [] ## ## value []) ## ## (#Meta [_ (#Symbol [module name])]) ## ## ($ text-++ module ";" name) ## ## (#Meta [_ (#Tag [module name])]) ## ## ($ text-++ "#" module ";" name) ## ## (#Meta [_ (#Tuple members)]) ## ## ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]") ## ## (#Meta [_ (#Form members)]) ## ## ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")") ## ## )) ## ## (defmacro (do tokens) ## ## (case' tokens ## ## (#Cons [(#Meta [_ monad]) (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])]) ## ## (let [output (fold (lambda [body binding] ## ## (case' binding ## ## [lhs rhs] ## ## (` (lux;bind (lambda [(~ lhs)] (~ body)) ## ## (~ rhs))))) ## ## body ## ## (reverse (as-pairs bindings)))] ## ## (return (list (` (using (~ monad) (~ output)))))))) ## ## (def (map% f xs) ## ## (All [m a b] ## ## (-> (-> a (m b)) (List a) (m (List b)))) ## ## (case' xs ## ## #Nil ## ## (return xs) ## ## (#Cons [x xs']) ## ## (do [y (f x) ## ## ys (map% f xs')] ## ## (return (#Cons [y ys]))))) ## ## ## (defmacro ($keys tokens) ## ## ## (case' tokens ## ## ## (#Cons [(#Meta [_ (#Tuple fields)]) #Nil]) ## ## ## (return (list (_meta (#Record (map (lambda [slot] ## ## ## (case' slot ## ## ## (#Meta [_ (#Tag [module name])]) ## ## ## [($ text-++ module ";" name) (_meta (#Symbol [module name]))])) ## ## ## fields))))))) ## ## ## (defmacro ($or tokens) ## ## ## (case' tokens ## ## ## (#Cons [(#Meta [_ (#Tuple patterns)]) (#Cons [body #Nil])]) ## ## ## (return (flat-map (lambda [pattern] (list pattern body)) ## ## ## patterns)))) ## ## (def (macro-expand syntax) ## ## (-> Syntax (LuxStateM (List Syntax))) ## ## (case' syntax ## ## (#Form (#Cons [(#Symbol macro-name) args])) ## ## (do [macro (get-macro macro-name)] ## ## ((:'! macro Macro) args)))) ## ## (defmacro (case tokens) ## ## (case' tokens ## ## (#Cons value branches) ## ## (loop [kind #Pattern ## ## pieces branches ## ## new-pieces (list)] ## ## (case' pieces ## ## #Nil ## ## (return (list (' (case' (~ value) (~@ new-pieces))))) ## ## (#Cons piece pieces') ## ## (let [[kind' expanded more-pieces] (case' kind ## ## #Body ## ## [#Pattern (list piece) #Nil] ## ## #Pattern ## ## (do [expansion (macro-expand piece)] ## ## (case' expansion ## ## #Nil ## ## [#Pattern #Nil #Nil] ## ## (#Cons exp #Nil) ## ## [#Body (list exp) #Nil] ## ## (#Cons exp exps) ## ## [#Body (list exp) exps])) ## ## )] ## ## (recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) ## ## ))) ## ## (def (defsyntax tokens) ## ## ...) ## ## (deftype (State s a) ## ## (-> s (, s a))) ## ## (deftype (Parser a) ## ## (State (List Syntax) a)) ## ## (def (parse-ctor tokens) ## ## (Parser (, Syntax (List Syntax))) ## ## (case tokens ## ## (list+ (#Symbol name) tokens') ## ## [tokens' [(#Symbol name) (list)]] ## ## (list+ (#Form (list+ (#Symbol name) args)) tokens') ## ## [tokens' [(#Symbol name) args]])) ## ## (defsyntax (defsig ## ## [[name args] parse-ctor] ## ## [anns ($+ $1)]) ## ## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) ## ## (` (#Record (~ (untemplate-list ...)))) ## ## args)] ## ## (return (list (` (def (~ name) (~ def-body))))))) ## ## (defsyntax (defstruct ## ## [[name args] parse-ctor] ## ## signature ## ## [defs ($+ $1)]) ## ## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body)))) ## ## (` (#Record (~ (untemplate-list ...)))) ## ## args)] ## ## (return (list (` (def (~ name) ## ## (:' (~ def-body) (~ signature)))))))) ## ## ## (def (with tokens) ## ## ## ...) ## ## (import' lux) ## ## (module-alias' lux l) ## ## (import lux #as l #use [map]) ## ## (defsyntax #export (All [name (%? %name)] [args %args] body) ## ## (let [name' (case name ## ## #None "" ## ## (#Some name) name) ## ## arg-replacements (map (lambda [arg] ## ## [(#Symbol ["" arg]) (` (#Bound (~ arg)))]) ## ## args) ## ## args' (map (lambda [arg] ## ## (#Symbol ["" arg])) ## ## args) ## ## body' (replace-syntax arg-replacements body)] ## ## (return (list (` (#AllT [#None (~ name') (#Tuple (list (~@ args'))) ## ## (~ body')])))))) ## ## (def (walk-syntax type) ## ## (case type ## ## (#Meta [_ (#Form (\list& op args))]) ## ## (case op ## ## (#Meta [_ (#Symbol ident)]) ## ## (do' [macro?? (find-macro ident)] ## ## (case macro?? ## ## (#Some macro) ## ## (do' [expansion (macro args)] ## ## (flat-map% walk-syntax expansion)) ## ## #None ## ## (do' [flat-map% (map% walk-syntax args)] ## ## (return (list (fold (lambda [fun arg] ## ## (` (#AppT [(~ fun) (~ arg)]))) ## ## op ## ## args)))))) ## ## _ ## ## (do' [flat-map% (map% walk-syntax args)] ## ## (return (list (_meta (#Form (list op args'))))))) ## ## _ ## ## (return (list type)))) ## ## (defsyntax #export (type type-syntax) ## ## (walk-syntax type-syntax)) ## ## (defsyntax #export (deftype [[name args] %usage] body) ## ## (return (list (` (def (~ name) ## ## (:' Type ## ## (type (All [(~@ args)] ## ## (~ body)))))))))