diff options
Diffstat (limited to '')
| -rw-r--r-- | source/lux.lux | 2020 |
1 files changed, 1100 insertions, 920 deletions
diff --git a/source/lux.lux b/source/lux.lux index 34b15fd49..db579f2d8 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1,4 +1,4 @@ -## Base interfaces & classes +## First things first, must define functions (jvm-interface Function (: apply (-> [java.lang.Object] java.lang.Object))) @@ -22,938 +22,1118 @@ ## (jvm-invokevirtual lux.Function "apply2" [java.lang.Object java.lang.Object] ## this [arg1 arg2]) [arg3]))])) -## Base functions & macros -(def' _meta - (lambda' _ data - (#Meta [["" -1 -1] data]))) - -(def' let' - (lambda' _ tokens - (lambda' _ state - (case' tokens - (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) - (#Right [state - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "case'"])) - (#Cons [rhs - (#Cons [lhs - (#Cons [body - #Nil])])])]))) - #Nil])])) - ))) -(declare-macro let') - -(def' lambda - (lambda' _ tokens - (lambda' _ state - (let' output (case' tokens - (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) - (_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])])])]))) - - (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) - (_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])])])])))) - (#Right [state (#Cons [output #Nil])])) - ))) -(declare-macro lambda) - -(def' def - (lambda [tokens state] - (let' output (case' tokens - (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [body #Nil])]) - (_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) tokens]))) - - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) - (#Cons [body #Nil])]) - (_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])])])))) - (#Right [state (#Cons [output #Nil])])))) -(declare-macro def) - -(def (defmacro tokens state) - (let' [fn-name fn-def] (case' tokens - (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol fn-name)]) args]))]) - (#Cons [body #Nil])]) - [fn-name - (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "def"])) - (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol fn-name)) args]))) - (#Cons [body - #Nil])])])))]) - (let' declaration (_meta (#Form (#Cons [(_meta (#Symbol ["" "declare-macro"])) (#Cons [(_meta (#Symbol fn-name)) #Nil])]))) - (#Right [state (#Cons [fn-def (#Cons [declaration #Nil])])])))) -(declare-macro defmacro) - -(defmacro (comment tokens state) - (#Right [state #Nil])) - -(def (int+ x y) - (jvm-ladd x y)) - -(def (id x) - x) - -(def (print x) - (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] - (jvm-getstatic java.lang.System "out") [x])) - -(def (println x) - (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] - (jvm-getstatic java.lang.System "out") [x])) - -(def (fold f init xs) - (case' xs - #Nil - init - - (#Cons [x xs']) - (fold f (f init x) xs'))) - -(def (reverse list) - (fold (lambda [tail head] - (#Cons [head tail])) - #Nil - list)) - -(defmacro (list xs state) - (let' xs' (reverse xs) - (let' output (fold (lambda [tail head] - (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) - (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) - #Nil])])))) - (_meta (#Tag ["lux" "Nil"])) - xs') - (#Right [state (#Cons [output #Nil])])))) - -(defmacro (list+ xs state) - (case' (reverse xs) - #Nil - [#Nil state] - - (#Cons [last init']) - (let' output (fold (lambda [tail head] - (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) (_meta (#Tuple (list head tail))))))) - last - init') - (#Right [state (#Cons [output #Nil])])))) - -(def (as-pairs xs) - (case' xs - (#Cons [x (#Cons [y xs'])]) - (#Cons [[x y] (as-pairs xs')]) - - _ - #Nil)) - -(defmacro (let tokens state) - (case' tokens - (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) - (let' output (fold (lambda [body binding] - (case' binding - [label value] - (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body))))) - body - (reverse (as-pairs bindings))) - (#Right [state (list output)])))) - -(def (. f g) - (lambda [x] (f (g x)))) - -(def (++ xs ys) - (case' xs - #Nil - ys - - (#Cons [x xs']) - (#Cons [x (++ xs' ys)]))) - -(def concat - (fold ++ #Nil)) - -(def (map f xs) - (case' xs - #Nil - #Nil - - (#Cons [x xs']) - (#Cons [(f x) (map f xs')]))) - -(def flat-map (. concat map)) - -(def (wrap-meta content) - (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) - (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text ""))))) - (_meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int -1))))) - (_meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int -1)))))))) - (_meta content)))))))) - -(def (untemplate-list tokens) - (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) - (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))))) - )) - -(defmacro (` tokens state) - (case' tokens - (#Cons [template #Nil]) - (#Right [state (list (untemplate template))]))) - -(defmacro (if tokens state) - (case' tokens - (#Cons [test (#Cons [then (#Cons [else #Nil])])]) - (#Right [state - (list (` (case' (~ test) - true (~ then) - false (~ else))))]))) - -(def (filter p xs) - (case' xs - #Nil - #Nil - - (#Cons [x xs']) - (if (p x) - (#Cons [x (filter p xs')]) - (filter p xs')))) - -(def (return val) - (lambda [state] - (#Right [state val]))) - -(def (fail msg) - (lambda [_] - (#Left msg))) - -(def (bind f v) - (lambda [state] - (case' (v state) - (#Right [state' x]) - (f x state') - - (#Left msg) - (#Left msg)))) - -(def (first pair) - (case' pair - [f s] - f)) - -(def (second pair) - (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) - (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) - (lambda [_] x)) - -(def (int> x y) - (jvm-lgt x y)) - -(def (int< x y) - (jvm-llt x y)) - -(def inc (int+ 1)) -(def dec (int+ -1)) - -(def (repeat n x) - (if (int> n 0) - (#Cons [x (repeat (dec n) x)]) - #Nil)) - -(def size - (fold (lambda [acc _] (inc acc)) 0)) - -(def (last xs) - (case' xs - #Nil #None - (#Cons [x #Nil]) (#Some x) - (#Cons [_ xs']) (last xs'))) - -(def (init xs) - (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) - (case' [xs ys] - [(#Cons [x xs']) (#Cons [y ys'])] - (list+ x y (interleave xs' ys')) - - _ - #Nil)) - -(def (interpose sep xs) - (case' xs - #Nil - xs - - (#Cons [x #Nil]) - xs - - (#Cons [x xs']) - (list+ x sep (interpose sep xs')))) - -(def (empty? xs) - (case' xs - #Nil true - _ false)) - -## ## ## (do-template [<name> <op>] -## ## ## (def (<name> p xs) -## ## ## (case xs -## ## ## #Nil true -## ## ## (#Cons [x xs']) (<op> (p x) (<name> p xs')))) - -## ## ## [every? and] -## ## ## [any? or]) - -(def (range from to) - (if (int< from to) - (#Cons [from (range (inc from) to)]) - #Nil)) - -(def (tuple->list tuple) - (case' tuple - (#Meta [_ (#Tuple list)]) - list)) - -(def (zip2 xs ys) - (case' [xs ys] - [(#Cons [x xs']) (#Cons [y ys'])] - (#Cons [[x y] (zip2 xs' ys')]) - - _ - #Nil)) - -(def (get key map) - (case' map - #Nil - #None - - (#Cons [[k v] map']) - (if (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] - k [key]) - (#Some v) - (get key map')))) - -(def (get-ident x) - (case' x - (#Meta [_ (#Symbol [_ ident])]) - ident)) - -(def (text-++ x y) - (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-template tokens) - (case' tokens - (#Cons [bindings (#Cons [template data])]) - (let [bindings-list (map get-ident (tuple->list bindings)) - data-lists (map tuple->list data) - apply (lambda [env] (apply-template env template))] - (|> data-lists - (map (. apply (zip2 bindings-list))) - return)))) - -## ## ## (do-template [<name> <offset>] -## ## ## (def <name> (int+ <offset>)) - -## ## ## [inc 1] -## ## ## [dec -1]) - -(def (int= x y) - (jvm-leq x y)) - -(def (int% x y) - (jvm-lrem x y)) - -(def (int>= x y) - (or (int= x y) - (int> x y))) - -(do-template [<name> <cmp>] - (def (<name> x y) - (if (<cmp> x y) - x - y)) - - [max int>] - [min int<]) - -(do-template [<name> <cmp>] - (def (<name> n) (<cmp> n 0)) - - [neg? int<] - [pos? int>=]) - -(def (even? n) - (int= 0 (int% n 0))) - -(def (odd? n) - (not (even? n))) - -(do-template [<name> <done> <step>] - (def (<name> n xs) - (if (int> n 0) - (case' xs - #Nil #Nil - (#Cons [x xs']) <step>) - <done>)) - - [take #Nil (list+ x (take (dec n) xs'))] - [drop xs (drop (dec n) xs')]) - -(do-template [<name> <done> <step>] - (def (<name> f xs) - (case' xs - #Nil #Nil - (#Cons [x xs']) (if (f x) <step> #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) - (jvm-invokevirtual java.lang.Object "toString" [] - int [])) -## (def gensym -## (lambda [state] -## [(update@ #gen-seed inc state) -## (#Symbol ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))])) - -## (do-template [<name> <member>] -## (def (<name> pair) -## (case' pair -## [f s] -## <member>)) - -## [first f] -## [second s]) - -(def (show-syntax syntax) - (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 [_ (#Tuple bindings)]) (#Cons [body #Nil])]) - (let [output (fold (lambda [body binding] - (case' binding - [lhs rhs] - (` (bind (lambda [(~ lhs)] (~ body)) - (~ rhs))))) - body - (reverse (as-pairs bindings)))] - (return (list output))))) - -(def (map% f xs) - (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 null jvm-null) - -(defmacro (^ tokens) - (case' tokens - (#Cons [(#Meta [_ (#Symbol [_ class-name])]) #Nil]) - (return (list (` (#TData [(~ (_meta (#Text class-name))) (list)])))) - - (#Cons [(#Meta [_ (#Symbol [_ class-name])]) (#Cons [(#Meta [_ (#Tuple params)]) #Nil])]) - (return (list (` (#TData [(~ (_meta (#Text class-name))) (~ (untemplate-list params))])))))) - -(defmacro (, members) - (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "TTuple"])) (untemplate-list members))))))) - -(defmacro (| members) - (let [members' (map (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) (` (#Tuple (~ value)))])) - members)] - (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "TVariant"])) (untemplate-list members)))))))) - -(defmacro (& members) - (let [members' (map (lambda [m] - (case' m - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))]) - [($ text-++ module ";" name) (` (#Tuple (~ value)))])) - members)] - (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "TRecord"])) (untemplate-list members)))))))) - -(defmacro (-> tokens) - (case' (reverse tokens) - (#Cons [f-return f-args]) - (fold (lambda [f-return f-arg] - (` (#TLambda [(~ f-arg) (~ f-return)]))) - f-return - f-args))) - -(def (text= x y) - (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] - x [y])) - -(def (replace-ident ident value 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 (lambda [body arg] - (case' arg - (#Meta [_ (#Symbol [arg-module arg-name])]) - (` (#TAll (list) "" (~ (_meta (#Text arg-name))) (~ (replace-ident [arg-module arg-name] - (` (#TBound (~ (#Text arg-name)))) - body)))))) - body - args)] - (case' rolled - (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ["lux" "TAll"])]) (#Cons [env (#Cons [(#Meta [_ (#Text "")]) (#Cons [(#Meta [_ (#Text arg-name)]) (#Cons [body #Nil])])])])]))]) - (return (list (` (#TAll (~ env) (~ (#Text name)) (~ (#Text arg-name)) - (~ (replace-ident arg-name (` (#TBound (~ (#Text name)))) - body))))))))) - -(defmacro (Exists tokens) - (case' tokens - (#Cons [args (#Cons [body #Nil])]) - (return (list (` (All (~ args) (~ body))))))) - -(def Any #TAny) -(def Nothing #TNothing) -(def Bool (^ java.lang.Boolean)) -(def Int (^ java.lang.Long)) -(def Real (^ java.lang.Double)) -(def Char (^ java.lang.Character)) -(def Text (^ java.lang.String)) +## Basic types +(def' Any #AnyT) +(def' Bool (#DataT ["java.lang.Boolean" #Nil])) +(def' Int (#DataT ["java.lang.Long" #Nil])) +(def' Real (#DataT ["java.lang.Double" #Nil])) +(def' Char (#DataT ["java.lang.Character" #Nil])) +(def' Text (#DataT ["java.lang.String" #Nil])) ## (deftype (List a) ## (| #Nil ## (#Cons (, a (List a))))) +(def' List + (#AllT [#Nil "List" "a" + (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] + (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") + (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")]) + #Nil])]))] + #Nil])]))])) ## (deftype #rec Type -## (| #TAny -## #TNothing -## (#TData Text) -## (#TTuple (List Type)) -## (#TVariant (List (, Text Type))) -## (#TRecord (List (, Text Type))) -## (#TLambda (, Type Type)) -## (#TBound Text) -## (#TVar Int) -## (#TAll (, (List (, Text Type)) Text Text Type)) -## (#TApp (, Type Type)))) - -## (deftype (Either l r) -## (| (#Left l) -## (#Right r))) +## (| #AnyT +## #NothingT +## (#DataT Text) +## (#TupleT (List Type)) +## (#VariantT (List (, Text Type))) +## (#RecordT (List (, Text Type))) +## (#LambdaT (, Type Type)) +## (#BoundT Text) +## (#VarT Int) +## (#AllT (, (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 [#Nil "Type" "" + (#VariantT (#Cons [["lux;AnyT" (#TupleT #Nil)] + (#Cons [["lux;NothingT" (#TupleT #Nil)] + (#Cons [["lux;DataT" (#TupleT (#Cons [Text (#Cons [(#AppT [List Type]) #Nil])]))] + (#Cons [["lux;TupleT" (#AppT [List (#AppT [(#BoundT "Type") (#BoundT "")])])] + (#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 [TypeEnv (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] + (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] + #Nil])])])])])])])])])])]))]) + #NothingT])))) + +## (deftype (Maybe a) +## (| #None +## (#Some a))) +(def' Maybe + (#AllT [#Nil "Maybe" "a" + (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] + (#Cons [["lux;Some" (#BoundT "a")] + #Nil])]))])) + +## (deftype (Bindings k v) +## (& #counter Int +## #mappings (List (, k v)))) +(def' Bindings + (#AllT [#Nil "Bindings" "k" + (#AllT [#Nil "" "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 [#Nil "Env" "k" + (#AllT [#Nil "" "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 [#Nil "Meta" "m" + (#AllT [#Nil "" "v" + (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m") + (#Cons [(#BoundT "v") + #Nil])]))] + #Nil]))])])) + +## (def' Reader +## (List (Meta Cursor Text))) +(def' Reader + (#AppT [List + (#AppT [(#AppT [Meta Cursor]) + Text])])) + +## (deftype CompilerState +## (& #source (Maybe Reader) +## #modules (List Any) +## #module-aliases (List Any) +## #global-env (Maybe (Env Text Any)) +## #local-envs (List (Env Text Any)) +## #types (Bindings Int Type) +## #writer (^ org.objectweb.asm.ClassWriter) +## #loader (^ java.net.URLClassLoader) +## #eval-ctor Int)) +(def' CompilerState + (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])] + (#Cons [["lux;modules" (#AppT [List Any])] + (#Cons [["lux;module-aliases" (#AppT [List Any])] + (#Cons [["lux;global-env" (#AppT [Maybe (#AppT [(#AppT [Env Text]) Any])])] + (#Cons [["lux;local-envs" (#AppT [List (#AppT [(#AppT [Env Text]) Any])])] + (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])] + (#Cons [["lux;writer" (#DataT ["org.objectweb.asm.ClassWriter" #Nil])] + (#Cons [["lux;loader" (#DataT ["java.lang.ClassLoader" #Nil])] + (#Cons [["lux;eval-ctor" Int] + #Nil])])])])])])])])]))) ## (deftype #rec Syntax -## (| (#Bool Bool) -## (#Int Int) -## (#Real Real) -## (#Char Char) -## (#Text Text) -## (#Form (List Syntax)) -## (#Tuple (List Syntax)) -## (#Record (List (, Text Syntax))))) +## (Meta Cursor (| (#Bool Bool) +## (#Int Int) +## (#Real Real) +## (#Char Char) +## (#Text Text) +## (#Form (List Syntax)) +## (#Tuple (List Syntax)) +## (#Record (List (, Text Syntax)))))) +(def' Syntax + (case' (#AppT [(#BoundT "Syntax") (#BoundT "")]) + Syntax + (case' (#AppT [List Syntax]) + SyntaxList + (#AppT [(#AllT [#Nil "Syntax" "" + (#VariantT (#Cons [["lux;Bool" Bool] + (#Cons [["lux;Int" Int] + (#Cons [["lux;Real" Real] + (#Cons [["lux;Char" Char] + (#Cons [["lux;Text" Text] + (#Cons [["lux;Form" SyntaxList] + (#Cons [["lux;Tuple" SyntaxList] + (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#Cons [Syntax #Nil])]))])] + #Nil])])])])])])])]))]) + #NothingT])))) ## (deftype Macro ## (-> (List Syntax) CompilerState -## (Either Text (, CompilerState (List Syntax))))) +## [CompilerState (List Syntax)])) +(def' Macro + (case' (#AppT [List Syntax]) + SyntaxList + (#LambdaT [SyntaxList + (#LambdaT [CompilerState + (#TupleT (#Cons [CompilerState (#Cons [SyntaxList #Nil])]))])]))) + +## Base functions & macros +## (def (_meta data) +## (All [a] (-> a (Meta Cursor a))) +## (#Meta [["" -1 -1] data])) +(def' _meta + (check' (#AllT [#Nil "" "a" + (#LambdaT [(#BoundT "a") + (#AppT [(#AppT [Meta Cursor]) + (#BoundT "a")])])]) + (lambda' _ data + (#Meta [["" -1 -1] data])))) + +## (def' let' +## (check' Macro +## (lambda' _ tokens +## (lambda' _ state +## (case' tokens +## (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])]) +## (#Right [state +## (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "case'"])) +## (#Cons [rhs +## (#Cons [lhs +## (#Cons [body +## #Nil])])])]))) +## #Nil])])) +## )))) +## (declare-macro let') + +## (def' lambda +## (check' Macro +## (lambda' _ tokens +## (lambda' _ state +## (let' output (case' tokens +## (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])]) +## (_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])])])]))) + +## (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])]) +## (_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])])])])))) +## (#Right [state (#Cons [output #Nil])])) +## )))) +## (declare-macro lambda) + +## (def' def +## (check' Macro +## (lambda [tokens state] +## (let' output (case' tokens +## (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [body #Nil])]) +## (_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) tokens]))) + +## (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) +## (#Cons [body #Nil])]) +## (_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])])])))) +## (#Right [state (#Cons [output #Nil])]))))) +## (declare-macro def) + +## (def (defmacro tokens state) +## (let' [fn-name fn-def] (case' tokens +## (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol fn-name)]) args]))]) +## (#Cons [body #Nil])]) +## [fn-name +## (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "def"])) +## (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol fn-name)) args]))) +## (#Cons [body +## #Nil])])])))]) +## (let' declaration (_meta (#Form (#Cons [(_meta (#Symbol ["" "declare-macro"])) (#Cons [(_meta (#Symbol fn-name)) #Nil])]))) +## (#Right [state (#Cons [fn-def (#Cons [declaration #Nil])])])))) +## (declare-macro defmacro) + +## (defmacro (comment tokens state) +## (#Right [state #Nil])) + +## (def (int+ x y) +## (jvm-ladd x y)) + +## (def (id x) +## x) + +## (def (print x) +## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object] +## (jvm-getstatic java.lang.System "out") [x])) + +## (def (println x) +## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] +## (jvm-getstatic java.lang.System "out") [x])) + +## (def (fold f init xs) +## (case' xs +## #Nil +## init + +## (#Cons [x xs']) +## (fold f (f init x) xs'))) + +## (def (reverse list) +## (fold (lambda [tail head] +## (#Cons [head tail])) +## #Nil +## list)) + +## (defmacro (list xs state) +## (let' xs' (reverse xs) +## (let' output (fold (lambda [tail head] +## (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"])) +## (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])]))) +## #Nil])])))) +## (_meta (#Tag ["lux" "Nil"])) +## xs') +## (#Right [state (#Cons [output #Nil])])))) + +## (defmacro (list+ xs state) +## (case' (reverse xs) +## #Nil +## [#Nil state] + +## (#Cons [last init']) +## (let' output (fold (lambda [tail head] +## (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) (_meta (#Tuple (list head tail))))))) +## last +## init') +## (#Right [state (#Cons [output #Nil])])))) + +## (def (as-pairs xs) +## (case' xs +## (#Cons [x (#Cons [y xs'])]) +## (#Cons [[x y] (as-pairs xs')]) + +## _ +## #Nil)) + +## (defmacro (let tokens state) +## (case' tokens +## (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])]) +## (let' output (fold (lambda [body binding] +## (case' binding +## [label value] +## (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body))))) +## body +## (reverse (as-pairs bindings))) +## (#Right [state (list output)])))) + +## (def (. f g) +## (lambda [x] (f (g x)))) + +## (def (++ xs ys) +## (case' xs +## #Nil +## ys + +## (#Cons [x xs']) +## (#Cons [x (++ xs' ys)]))) + +## (def concat +## (fold ++ #Nil)) + +## (def (map f xs) +## (case' xs +## #Nil +## #Nil + +## (#Cons [x xs']) +## (#Cons [(f x) (map f xs')]))) + +## (def flat-map (. concat map)) + +## (def (wrap-meta content) +## (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) +## (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text ""))))) +## (_meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int -1))))) +## (_meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int -1)))))))) +## (_meta content)))))))) + +## (def (untemplate-list tokens) +## (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) +## (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))))) +## )) + +## (defmacro (` tokens state) +## (case' tokens +## (#Cons [template #Nil]) +## (#Right [state (list (untemplate template))]))) + +## (defmacro (if tokens state) +## (case' tokens +## (#Cons [test (#Cons [then (#Cons [else #Nil])])]) +## (#Right [state +## (list (` (case' (~ test) +## true (~ then) +## false (~ else))))]))) + +## (def (filter p xs) +## (case' xs +## #Nil +## #Nil + +## (#Cons [x xs']) +## (if (p x) +## (#Cons [x (filter p xs')]) +## (filter p xs')))) + +## (def (return val) +## (lambda [state] +## (#Right [state val]))) + +## (def (fail msg) +## (lambda [_] +## (#Left msg))) -## (def (macro-expand syntax) +## (def (bind f v) +## (lambda [state] +## (case' (v state) +## (#Right [state' x]) +## (f x state') + +## (#Left msg) +## (#Left msg)))) + +## (def (first pair) +## (case' pair +## [f s] +## f)) + +## (def (second pair) +## (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) +## (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) +## (lambda [_] x)) + +## (def (int> x y) +## (jvm-lgt x y)) + +## (def (int< x y) +## (jvm-llt x y)) + +## (def inc (int+ 1)) +## (def dec (int+ -1)) + +## (def (repeat n x) +## (if (int> n 0) +## (#Cons [x (repeat (dec n) x)]) +## #Nil)) + +## (def size +## (fold (lambda [acc _] (inc acc)) 0)) + +## (def (last xs) +## (case' xs +## #Nil #None +## (#Cons [x #Nil]) (#Some x) +## (#Cons [_ xs']) (last xs'))) + +## (def (init xs) +## (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) +## (case' [xs ys] +## [(#Cons [x xs']) (#Cons [y ys'])] +## (list+ x y (interleave xs' ys')) + +## _ +## #Nil)) + +## (def (interpose sep xs) +## (case' xs +## #Nil +## xs + +## (#Cons [x #Nil]) +## xs + +## (#Cons [x xs']) +## (list+ x sep (interpose sep xs')))) + +## (def (empty? xs) +## (case' xs +## #Nil true +## _ false)) + +## ## ## ## (do-template [<name> <op>] +## ## ## ## (def (<name> p xs) +## ## ## ## (case xs +## ## ## ## #Nil true +## ## ## ## (#Cons [x xs']) (<op> (p x) (<name> p xs')))) + +## ## ## ## [every? and] +## ## ## ## [any? or]) + +## (def (range from to) +## (if (int< from to) +## (#Cons [from (range (inc from) to)]) +## #Nil)) + +## (def (tuple->list tuple) +## (case' tuple +## (#Meta [_ (#Tuple list)]) +## list)) + +## (def (zip2 xs ys) +## (case' [xs ys] +## [(#Cons [x xs']) (#Cons [y ys'])] +## (#Cons [[x y] (zip2 xs' ys')]) + +## _ +## #Nil)) + +## (def (get key map) +## (case' map +## #Nil +## #None + +## (#Cons [[k v] map']) +## (if (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] +## k [key]) +## (#Some v) +## (get key map')))) + +## (def (get-ident x) +## (case' x +## (#Meta [_ (#Symbol [_ ident])]) +## ident)) + +## (def (text-++ x y) +## (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-template tokens) +## (case' tokens +## (#Cons [bindings (#Cons [template data])]) +## (let [bindings-list (map get-ident (tuple->list bindings)) +## data-lists (map tuple->list data) +## apply (lambda [env] (apply-template env template))] +## (|> data-lists +## (map (. apply (zip2 bindings-list))) +## return)))) + +## ## ## ## (do-template [<name> <offset>] +## ## ## ## (def <name> (int+ <offset>)) + +## ## ## ## [inc 1] +## ## ## ## [dec -1]) + +## (def (int= x y) +## (jvm-leq x y)) + +## (def (int% x y) +## (jvm-lrem x y)) + +## (def (int>= x y) +## (or (int= x y) +## (int> x y))) + +## (do-template [<name> <cmp>] +## (def (<name> x y) +## (if (<cmp> x y) +## x +## y)) + +## [max int>] +## [min int<]) + +## (do-template [<name> <cmp>] +## (def (<name> n) (<cmp> n 0)) + +## [neg? int<] +## [pos? int>=]) + +## (def (even? n) +## (int= 0 (int% n 0))) + +## (def (odd? n) +## (not (even? n))) + +## (do-template [<name> <done> <step>] +## (def (<name> n xs) +## (if (int> n 0) +## (case' xs +## #Nil #Nil +## (#Cons [x xs']) <step>) +## <done>)) + +## [take #Nil (list+ x (take (dec n) xs'))] +## [drop xs (drop (dec n) xs')]) + +## (do-template [<name> <done> <step>] +## (def (<name> f xs) +## (case' xs +## #Nil #Nil +## (#Cons [x xs']) (if (f x) <step> #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) +## (jvm-invokevirtual java.lang.Object "toString" [] +## int [])) + +## ## (def gensym +## ## (lambda [state] +## ## [(update@ #gen-seed inc state) +## ## (#Symbol ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))])) + +## ## (do-template [<name> <member>] +## ## (def (<name> pair) +## ## (case' pair +## ## [f s] +## ## <member>)) + +## ## [first f] +## ## [second s]) + +## (def (show-syntax syntax) ## (case' syntax -## (#Form (#Cons [(#Symbol macro-name) args])) -## (do [macro (get-macro macro-name)] -## ((coerce macro Macro) args)))) +## (#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 []) -## (defmacro (case tokens) +## (#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 [_ (#Tuple bindings)]) (#Cons [body #Nil])]) +## (let [output (fold (lambda [body binding] +## (case' binding +## [lhs rhs] +## (` (bind (lambda [(~ lhs)] (~ body)) +## (~ rhs))))) +## body +## (reverse (as-pairs bindings)))] +## (return (list output))))) + +## (def (map% f xs) +## (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 null jvm-null) + +## (defmacro (^ tokens) +## (case' tokens +## (#Cons [(#Meta [_ (#Symbol [_ class-name])]) #Nil]) +## (return (list (` (#DataT [(~ (_meta (#Text class-name))) (list)])))) + +## (#Cons [(#Meta [_ (#Symbol [_ class-name])]) (#Cons [(#Meta [_ (#Tuple params)]) #Nil])]) +## (return (list (` (#DataT [(~ (_meta (#Text class-name))) (~ (untemplate-list params))])))))) + +## (defmacro (, members) +## (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "TupleT"])) (untemplate-list members))))))) + +## (defmacro (| members) +## (let [members' (map (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) (` (#Tuple (~ value)))])) +## members)] +## (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "VariantT"])) (untemplate-list members)))))))) + +## (defmacro (& members) +## (let [members' (map (lambda [m] +## (case' m +## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))]) +## [($ text-++ module ";" name) (` (#Tuple (~ value)))])) +## members)] +## (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "RecordT"])) (untemplate-list members)))))))) + +## (defmacro (-> tokens) +## (case' (reverse tokens) +## (#Cons [f-return f-args]) +## (fold (lambda [f-return f-arg] +## (` (#LambdaT [(~ f-arg) (~ f-return)]))) +## f-return +## f-args))) + +## (def (text= x y) +## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] +## x [y])) + +## (def (replace-ident ident value 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 (lambda [body arg] +## (case' arg +## (#Meta [_ (#Symbol [arg-module arg-name])]) +## (` (#AllT (list) "" (~ (_meta (#Text arg-name))) (~ (replace-ident [arg-module arg-name] +## (` (#BoundT (~ (#Text 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))))))))) + +## (defmacro (Exists 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) -## (: return (All [a] (-> a (m a)))) -## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b))))) - -## (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) -## ...) - -## TODO: Full pattern-matching -## TODO: Type-related macros -## TODO: (Im|Ex)ports-related macros -## TODO: Macro-related macros - -## (import "lux") -## (module-alias "lux" "l") -## (def-alias "lux;map" "map") - -## (def (require tokens) -## (case tokens -## ...)) - -## (require lux #as l #refer [map]) +## (#Cons [args (#Cons [body #Nil])]) +## (return (list (` (All (~ args) (~ body))))))) + +## (def Any #AnyT) +## (def Nothing #NothingT) +## (def Bool (^ java.lang.Boolean)) +## (def Int (^ java.lang.Long)) +## (def Real (^ java.lang.Double)) +## (def Char (^ java.lang.Character)) +## (def Text (^ java.lang.String)) + +## ## (deftype (List a) +## ## (| #Nil +## ## (#Cons (, a (List a))))) + +## ## (deftype #rec Type +## ## (| #AnyT +## ## #NothingT +## ## (#DataT Text) +## ## (#TupleT (List Type)) +## ## (#VariantT (List (, Text Type))) +## ## (#RecordT (List (, Text Type))) +## ## (#LambdaT (, Type Type)) +## ## (#BoundT Text) +## ## (#VarT Int) +## ## (#AllT (, (List (, Text Type)) Text Text Type)) +## ## (#AppT (, Type Type)))) + +## ## (deftype (Either l r) +## ## (| (#Left l) +## ## (#Right r))) + +## ## (deftype #rec Syntax +## ## (| (#Bool Bool) +## ## (#Int Int) +## ## (#Real Real) +## ## (#Char Char) +## ## (#Text Text) +## ## (#Form (List Syntax)) +## ## (#Tuple (List Syntax)) +## ## (#Record (List (, Text Syntax))))) + +## ## (deftype Macro +## ## (-> (List Syntax) CompilerState +## ## (Either Text (, CompilerState (List Syntax))))) + +## ## (def (macro-expand syntax) +## ## (case' syntax +## ## (#Form (#Cons [(#Symbol macro-name) args])) +## ## (do [macro (get-macro macro-name)] +## ## ((coerce 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) +## ## (: return (All [a] (-> a (m a)))) +## ## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b))))) + +## ## (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) +## ## ...) + +## ## TODO: Full pattern-matching +## ## TODO: Type-related macros +## ## TODO: (Im|Ex)ports-related macros +## ## TODO: Macro-related macros + +## ## (import "lux") +## ## (module-alias "lux" "l") +## ## (def-alias "lux;map" "map") + +## ## (def (require tokens) +## ## (case tokens +## ## ...)) + +## ## (require lux #as l #refer [map]) |