## 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 (:' Type (#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 (:' Type (#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 (:' Type (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))) ## (deftype (Meta m v) ## (| (#Meta (, m v)))) (def' Meta (:' Type (#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 (:' Type (#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 (:' Type (#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 (:' Type (#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 (, Text (w (Syntax' w))))))) (def' Syntax' (:' Type (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 (:' Type (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 (:' Type (#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 (:' Type (#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' let' ## (:' Macro ## (lambda' _ tokens ## (case' tokens ## (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) ## (return' (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "case'"])) ## (#Cons [rhs (#Cons [lhs (#Cons [body #Nil])])])]))) ## #Nil])) ## _ ## (#Left "Wrong syntax for let'"))))) (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"))))) (export' lambda) (def' def (:' Macro (lambda [tokens] (case' tokens (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [body #Nil])]) (return' (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) tokens]))) #Nil]))) (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [body #Nil])]) (return' (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) (#Cons [(_meta (#Symbol name)) (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"])) (#Cons [(_meta (#Symbol name)) (#Cons [(_meta (#Tuple args)) (#Cons [body #Nil])])])]))) #Nil])])]))) #Nil]))) (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type (#Cons [body #Nil])])]) (return' (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) (#Cons [(_meta (#Symbol name)) (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) (#Cons [type (#Cons [body #Nil])])]))) #Nil])])]))) #Nil]))) (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type (#Cons [body #Nil])])]) (return' (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) (#Cons [(_meta (#Symbol name)) (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" ":'"])) (#Cons [type (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"])) (#Cons [(_meta (#Symbol name)) (#Cons [(_meta (#Tuple args)) (#Cons [body #Nil])])])]))) #Nil])])]))) #Nil])])]))) #Nil]))) _ (fail' "Wrong syntax for def") )))) (export' def) (def (defmacro tokens) Macro (case' tokens (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol fn-name)]) args]))]) (#Cons [body #Nil])]) (return' (:' SyntaxList (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "def"])) (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol fn-name)) args]))) (#Cons [(_meta (#Symbol ["lux" "Macro"])) (#Cons [body #Nil])]) ])]))) #Nil]))) _ (fail' "Wrong syntax for defmacro"))) (defmacro (comment tokens) (return' (:' SyntaxList #Nil))) (export' comment) (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 ->'"))) (def (int:+ x y) (->' Int Int Int) (jvm-ladd x y)) (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 (id x) (All' [a] (->' (B' a) (B' a))) x) (export' id) (def (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 (reverse' list) (->' ($' List Syntax) ($' List Syntax)) (fold (:' (->' ($' List Syntax) Syntax ($' List Syntax)) (lambda [tail head] (#Cons [head tail]))) #Nil list)) (defmacro (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])))) (export' list) (defmacro (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&"))) (export' list&) (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 (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"))) (export' let) (def (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 (wrap-meta content) (->' ($' Syntax' ($' Meta Cursor)) Syntax) (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1))))) (_meta 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))) )) (defmacro (` tokens) (case' tokens (#Cons [template #Nil]) (return' (:' SyntaxList (list (untemplate template)))) _ (fail' "Wrong syntax for `"))) (export' `) (defmacro (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"))) (export' if) ## (defmacro (, tokens) ## (let [elems (fold (:' (->' Syntax Syntax Syntax) ## (lambda [tail head] ## (` (#Cons [(~ head) (~ tail)])))) ## (` #Nil) ## (reverse' tokens))] ## (return' (list (` (#TupleT (~ elems))))))) ## (export' ,) ## (defmacro (^ tokens) ## (case' tokens ## (#Cons [(#Meta [_ (#Symbol ["" class-name])]) #Nil]) ## (return' (list (` (#DataT (~ (_meta (#Text class-name))))))) ## _ ## (fail' "Wrong syntax for ^"))) ## (export' ^) ## (defmacro (-> tokens) ## (case' (reverse' tokens) ## (#Cons [f-return f-args]) ## (fold (:' (->' Syntax Syntax Syntax) ## (lambda [f-return f-arg] ## (` (#LambdaT [(~ f-arg) (~ f-return)])))) ## f-return ## f-args) ## _ ## (fail' "Wrong syntax for ^"))) ## (export' ->) ## (defmacro (| members) ## (let [members' (map (:' (->' Syntax Syntax) ## (lambda [m] ## (case' m ## (#Meta [_ (#Tag [module name])]) ## (` [(~ ($ text-++ module ";" name)) (#Tuple (list))]) ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))]) ## (` [(~ ($ text-++ module ";" name)) (~ value)])))) ## members)] ## (return' (list (` (#VariantT (~ (untemplate-list members)))))))) ## (export' |) ## (defmacro (& members) ## (let [members' (map (:' (->' Syntax Syntax) ## (lambda [m] ## (case' m ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))]) ## (` [(~ ($ text-++ module ";" name)) (~ value)])))) ## members)] ## (return' (list (` (#RecordT (~ (untemplate-list members)))))))) ## (export' &) ## (def (text:= x y) ## (-> Text Text Bool) ## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] ## 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))) ## (defmacro (All tokens) ## (let [[name args body] (case' tokens ## (#Cons [(#Meta [_ (#Symbol ["" name])]) (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])]) ## [name args body] ## (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])]) ## ["" args body]) ## rolled (fold (:' (-> Syntax Syntax Syntax) ## (lambda [body arg] ## (case' arg ## (#Meta [_ (#Symbol [arg-module arg-name])]) ## (` (#AllT #None "" (~ (_meta (#Text arg-name))) (~ (replace-ident [arg-module arg-name] ## (` (#BoundT (~ (#Text ($ text:++ arg-module ";" arg-name))))) ## body))))))) ## body ## args)] ## (case' rolled ## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ["lux" "AllT"])]) (#Cons [env (#Cons [(#Meta [_ (#Text "")]) (#Cons [(#Meta [_ (#Text arg-name)]) (#Cons [body #Nil])])])])]))]) ## (return' (list (` (#AllT (~ env) (~ (#Text name)) (~ (#Text arg-name)) ## (~ (replace-ident arg-name (` (#BoundT (~ (#Text name)))) ## body))))))))) ## (export' All) ## (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)))) ## (deftype CompilerState ## (& #source (Maybe Reader) ## #modules (List Void) ## #module-aliases (List Void) ## #envs (List (Env Text Void)) ## #types (Bindings Int Type) ## #writer (^ org.objectweb.asm.ClassWriter) ## #loader (^ java.net.URLClassLoader) ## #eval-ctor Int)) ## (deftype CompilerState ## (& (#source (Maybe Reader)) ## (#modules (PList Text Void)) ## (#module-aliases (PList Text Text)) ## (#envs (List (Env Text Void))) ## (#types (Bindings Int Type)) ## (#host (& (#writer (^ org.objectweb.asm.ClassWriter)) ## (#loader (^ java.net.URLClassLoader)) ## (#eval-ctor Int))))) ## (def (find-macro ident) ## (lambda [state] ## (let [[module name] ident] ## (case' state ## {#source source #modules modules #module-aliases module-aliases ## #envs envs #types types ## #writer writer #loader loader #eval-ctor eval-ctor} ## (when-let [bindings (get module modules) ## bound (get name bindings)] ## (case' bound ## (#Macro macro) ## (#Some macro) ## _ ## #None)))))) ## (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 (return val) ## (All [a] ## (-> a (Lux a))) ## (lambda [state] ## (#Right [state val]))) ## (def (fail msg) ## (All [a] ## (-> Text (Lux a))) ## (lambda [_] ## (#Left msg))) ## (def (bind f v) ## (All [m a b] (-> (-> a (m b)) (m a) (m b))) ## (lambda [state] ## (case' (v state) ## (#Right [state' x]) ## (f x state') ## (#Left msg) ## (#Left msg)))) ## (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 (export tokens) ## (return (map (lambda [t] (` (export' (~ t)))) ## tokens))) ## (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]) ## (deftype Ordering ## (| #< #> #=)) ## (defsig (Ord a) ## (: (-> a a Ordering) ## compare)) ## (defsig (Enum a) ## (: (Ord a) ## order) ## (: (-> a a) ## succ) ## (: (-> a a) ## pred)) ## (def (range enum from to) ## (All [a] ## (-> (Enum a) a a (List a))) ## (using [enum order] ## (case' (compare from to) ## #< ## (list& from (range enum (succ from) to)) ## _ ## #Nil))) ## (def (range from to) ## (-> Int Int (List Int)) ## (if (int< from to) ## (#Cons [from (range (inc from) to)]) ## #Nil)) ## (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)))))))) ## (defsig (Monad m) ## (:' (All [a] (-> a (m a))) ## return) ## (:' (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) ## (defstruct ListMonad (Monad List) ## (def (return x) ## (list x)) ## (def bind (. concat map))) ## (defsig (Eq a) ## (:' = (-> a a Bool))) ## (defstruct (List_Eq A_Eq) ## (All [a] (-> (Eq a) (Eq (List a)))) ## (def (= xs ys) ## (and (= (length xs) (length ys)) ## (map (lambda [[x y]] ## (with A_Eq ## (= x y))) ## (zip2 xs ys))))) ## ## (def (with tokens) ## ## ...) ## ## (import "lux") ## ## (module-alias "lux" "l") ## ## (def-alias "lux;map" "map") ## ## (def (require tokens) ## ## (case tokens ## ## ...)) ## ## (require lux #as l #refer [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)))))))))