diff options
Diffstat (limited to 'source')
| -rw-r--r-- | source/lux.lux | 812 |
1 files changed, 429 insertions, 383 deletions
diff --git a/source/lux.lux b/source/lux.lux index 24b5cb837..30a0c6628 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -69,14 +69,11 @@ (def (defmacro tokens state) (let' [fn-name fn-def] (case' tokens - (#Cons [(#Form (#Cons [(#Ident ?name) (#Cons [(#Ident ?tokens) (#Cons [(#Ident ?state) #Nil])])])) + (#Cons [(#Form (#Cons [(#Ident name) args])) (#Cons [body #Nil])]) - [?name + [name (#Form (#Cons [(#Ident "lux;def") - (#Cons [(#Form (#Cons [(#Ident ?name) - (#Cons [(#Ident ?tokens) - (#Cons [(#Ident ?state) - #Nil])])])) + (#Cons [(#Form (#Cons [(#Ident name) args])) (#Cons [body #Nil])])]))]) (let' declaration (#Form (#Cons [(#Ident "declare-macro") (#Cons [(#Ident fn-name) #Nil])])) @@ -87,7 +84,7 @@ (#Ok [state #Nil])) (def (int+ x y) - (jvm-iadd x y)) + (jvm-ladd x y)) (def (id x) x) @@ -155,6 +152,9 @@ (reverse (as-pairs bindings))) (#Ok [state (list output)])))) +(def (. f g) + (lambda [x] (f (g x)))) + (def (++ xs ys) (case' xs #Nil @@ -163,6 +163,9 @@ (#Cons [x xs*]) (#Cons [x (++ xs* ys)]))) +(def concat + (fold ++ #Nil)) + (def (map f xs) (case' xs #Nil @@ -171,6 +174,8 @@ (#Cons [x xs*]) (#Cons [(f x) (map f xs*)]))) +(def flat-map (. concat map)) + (def (untemplate-list tokens) (case' tokens #Nil @@ -215,16 +220,17 @@ )) (defmacro (` tokens state) - (#Ok [state - (list (untemplate-list (map untemplate tokens)))])) + (case' tokens + (#Cons [template #Nil]) + (#Ok [state (list (untemplate template))]))) (defmacro (if tokens state) (case' tokens (#Cons [test (#Cons [then (#Cons [else #Nil])])]) (#Ok [state - (` (case' (~ test) - true (~ then) - false (~ else)))]))) + (list (` (case' (~ test) + true (~ then) + false (~ else))))]))) (def (filter p xs) (case' xs @@ -253,466 +259,506 @@ (#Error msg) (#Error msg)))) -#( +(def (first pair) + (case' pair + [f s] + f)) -## TODO: Full pattern-matching -## TODO: Type-related macros -## TODO: (Im|Ex)ports-related macros -## TODO: Macro-related macros +(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 (~ (#Ident "recur")) (~ (#Tuple (map first pairs))) + (~ body))) + (map second pairs)]))))))) -(def (apply-template env template) -(case template -(#Ident ident) -(if-let [subst (get ident env)] -subst -template) +## (defmacro (do tokens) +## (case tokens +## (list (#Tuple bindings) body) +## (let [output (fold (lambda [inner binding] +## (case binding +## [lhs rhs] +## (' (bind (lambda [(~ lhs)] (~ body)) +## (~ rhs))))) +## body +## (reverse (as-pairs bindings)))] +## (return (list output))))) -(#Tuple elems) -(#Tuple (map (apply-template env) elems)) +(defmacro (export tokens) + (return (map (lambda [t] (` (export' (~ t)))) + tokens))) -(#Form elems) -(#Form (map (apply-template env) elems)) +(defmacro (and tokens) + (let [as-if (case' tokens + #Nil + (` true) -(#Record members) -(#Record (map (lambda [kv] -(case kv -[slot value] -[(apply-template env slot) (apply-template env value)])) -members)) + (#Cons [init tests]) + (fold (lambda [prev next] + (` (if (~ prev) (~ next) false))) + init + tokens) + )] + (return (list as-if)))) -_ -template)) +(defmacro (or tokens) + (let [as-if (case' tokens + #Nil + (` false) -(def (do-template tokens) -(case tokens -(list+ bindings template data) -(let [bindings-list (tuple->list bindings) -data-lists (map tuple->list data)] -(return (map (lambda [env] (apply-template env template)) -(map (zip 2 bindings) data-lists)))))) -(declare-macro do-template) + (#Cons [init tests]) + (fold (lambda [prev next] + (` (if (~ prev) true (~ next)))) + init + tokens) + )] + (return (list as-if)))) -(def gen-ident -(lambda [state] -[(update@ #gen-seed inc state) -(#Ident ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))])) +(def (not x) + (case' x + true false + false true)) -(do-template [<name> <member>] -(def (<name> pair) -(case' pair -[f s] -<member>)) +(defmacro (|> tokens) + (case' tokens + (#Cons [init apps]) + (return (list (fold (lambda [acc app] + (case' app + (#Form parts) + (#Form (++ parts (list acc))) -[first f] -[second s]) + _ + (` ((~ app) (~ acc))))) + init + apps))))) -(def (loop tokens) -(case' tokens -(#Cons [bindings (#Cons [body #Nil])]) -(let [pairs (as-pairs bindings)] -(return (list (' ((lambda (~ (#Ident "recur")) (~ (#Tuple (map first pairs))) -(~ body)) -(~@ (map second pairs))))))))) -(declare-macro loop) +(defmacro ($ tokens) + (case' tokens + (#Cons [op (#Cons [init args])]) + (return (list (fold (lambda [acc elem] + (` ((~ op) (~ acc) (~ elem)))) + init + args))))) -(def (case tokens) -(case' tokens -(#Cons value branches) -(loop [kind #Pattern -pieces branches -new-pieces (list)] -(case' pieces -#Nil -(return (list (' (case' (~ value) (~@ new-pieces))))) +(def complement (. not)) -(#Cons piece pieces') -(let [[kind' expanded more-pieces] (case' kind -#Body -[#Pattern (list piece) #Nil] +(def (constant x) + (lambda [_] x)) -#Pattern -(do [expansion (macro-expand piece)] -(case' expansion -#Nil -[#Pattern #Nil #Nil] +(def (int> x y) + (jvm-lgt x y)) -(#Cons exp #Nil) -[#Body (list exp) #Nil] +(def (int< x y) + (jvm-llt x y)) -(#Cons exp exps) -[#Body (list exp) exps])) -)] -(recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) -))) -(declare-macro case) +(def inc (int+ 1)) +(def dec (int+ -1)) -(def (do tokens state) -(case tokens -(list (#Tuple bindings) body) -(let [output (fold (lambda [inner binding] -(case binding -[lhs rhs] -(' (bind (lambda [(~ lhs)] (~ body)) -(~ rhs))))) -body -(reverse (as-pairs bindings)))] -[(list output) state]))) -(declare-macro do) +(def (repeat n x) + (if (int> n 0) + (#Cons [x (repeat (dec n) x)]) + #Nil)) -(def (export tokens) -(return (map (lambda [t] -(' (export' (~ t)))) -tokens))) -(declare-macro export) +(def size + (fold (lambda [acc _] (inc acc)) 0)) -## (import "lux") -## (module-alias "lux" "l") -## (def-alias "lux;map" "map") +(def (last xs) + (case' xs + #Nil #None + (#Cons [x #Nil]) (#Some x) + (#Cons [_ xs']) (last xs'))) -## (def (require tokens) -## (case tokens -## ...)) +(def (init xs) + (case' xs + #Nil #None + (#Cons [_ #Nil]) (#Some #Nil) + (#Cons [x xs']) (case' (init xs') + (#Some xs'') + (#Some (#Cons [x xs''])) -## (require lux #as l #refer [map]) + _ + (#Some (#Cons [x #Nil]))))) -(def (type tokens) -(case tokens -(#Tuple elems) -(return (list (' (#Tuple (~ (map untemplate elems)))))) +(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)))))) -(#Record fields) -(return (list (' (#Record (~ (map (lambda [kv] -(case kv -[(#Tag tag) val] -[tag (untemplate val)])) -fields)))))) +(def (interleave xs ys) + (case' [xs ys] + [(#Cons [x xs']) (#Cons [y ys'])] + (list+ x y (interleave xs' ys')) -(#Form (list+ (#Ident "|") options)) -(do [options' (map% (lambda [opt] -(case opt -(#Tag tag) -[tag (#Tuple (list))] + _ + #Nil)) -(#Form (list (#Tag tag) value)) -[tag value] +(def (interpose sep xs) + (case' xs + #Nil + xs + + (#Cons [x #Nil]) + xs -_ -(fail ""))) -options)] -(#Variant options')) -)) -(declare-macro type) + (#Cons [x xs']) + (list+ x sep (interpose sep xs')))) -## (type (| #Nil -## (#Cons [a (List a)]))) +(def (empty? xs) + (case' xs + #Nil true + _ false)) -## (type [Int Bool Text]) +## (do-template [<name> <op>] +## (def (<name> p xs) +## (case xs +## #Nil true +## (#Cons [x xs']) (<op> (p x) (<name> p xs')))) -## (type {#id Int #alive? Bool #name Text}) +## [every? and] +## [any? or]) -(def (All tokens) -(let [[name args body] (case tokens -(list (#Tuple args) body) -["" args body] +(def (range from to) + (if (int< from to) + (#Cons [from (range (inc from) to)]) + #Nil)) -(list (#Ident name) (#Tuple args) body) -[name args body])] -(return (list (' (#All (~ name) [(~@ (map (lambda [arg] -(case arg -(#Ident arg') -(#Text arg'))) -args))] -(~ body))))))) -(declare-macro All) +## (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))))) -(def (Exists tokens) -(case tokens -(list (#Ident name) body) -(return (list (' (#Exists (~ name) (~ body))))))) -(declare-macro Exists) +## (#Cons piece pieces') +## (let [[kind' expanded more-pieces] (case' kind +## #Body +## [#Pattern (list piece) #Nil] -(def (deftype tokens) -(case tokens -(list (#Ident name) definition) -(return (list (' (def (~ (#Ident name)) -(type (~ definition)))))) +## #Pattern +## (do [expansion (macro-expand piece)] +## (case' expansion +## #Nil +## [#Pattern #Nil #Nil] -(list (#Form (list+ (#Ident name) args)) definition) -(let [name' (#Ident name)] -(return (list (' (def (~ name') -(All (~ name') [(~@ args)] -(type (~ definition)))))))) -)) -(declare-macro deftype) +## (#Cons exp #Nil) +## [#Body (list exp) #Nil] -(def (and tokens) -(let [as-if (case tokens -#Nil -(' true) +## (#Cons exp exps) +## [#Body (list exp) exps])) +## )] +## (recur kind' (++ expanded new-pieces) (++ more-pieces pieces)))) +## ))) -(#Cons init tests) -(fold (lambda [prev next] -(' (if (~ prev) (~ next) false))) -init -tokens) -)] -(return (list as-if)))) -(declare-macro and) +(def (tuple->list tuple) + (case' tuple + (#Tuple list) + list)) -(def (or tokens) -(let [as-if (case tokens -#Nil -(' false) +(def (zip xs ys) + (case' [xs ys] + [(#Cons [x xs']) (#Cons [y ys'])] + (#Cons [[x y] (zip xs' ys')]) -(#Cons init tests) -(fold (lambda [prev next] -(' (if (~ prev) true (~ next)))) -init -tokens) -)] -(return (list as-if)))) -(declare-macro or) + _ + #Nil)) -(def (not x) -(case x -true false -false true)) +(def (get key map) + (case' map + #Nil + #None -(def (get@ tokens) -(let [output (case tokens -(list (#Tag tag) record) -(' (get@' (~ (#Tag tag)) (~ record))) + (#Cons [[k v] map']) + (if (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object] + k [key]) + (#Some v) + (get key map')))) -(list (#Tag tag)) -(' (lambda [record] (get@' (~ (#Tag tag)) record))))] -(return (list output)))) -(declare-macro get@) +(def (get-ident x) + (case' x + (#Ident ident) + ident)) -(def (set@ tokens) -(let [output (case tokens -(list (#Tag tag) value record) -(' (set@' (~ (#Tag tag)) (~ value) (~ record))) +(def (text-++ x y) + (jvm-invokevirtual java.lang.String "concat" [java.lang.String] + x [y])) -(list (#Tag tag) value) -(' (lambda [record] (set@' (~ (#Tag tag)) (~ value) record))) +(def (show-env env) + (|> env (map first) (interpose ", ") (fold text-++ ""))) -(list (#Tag tag)) -(' (lambda [value record] (set@' (~ (#Tag tag)) value record))))] -(return (list output)))) -(declare-macro set@) +(def (apply-template env template) + (case' template + (#Ident ident) + (case' (get ident env) + (#Some subst) + subst -(def (update@ tokens) -(let [output (case tokens -(list tag func record) -(` (let [_record_ (~ record)] -(set@ (~ tag) _record_ ((~ func) (get@ (~ tag) _record_))))) + _ + template) + + (#Tuple elems) + (#Tuple (map (apply-template env) elems)) -(list (#Tag tag) func) -(' (lambda [record] -(` (set@ (~ tag) record ((~ func) (get@ (~ tag) record)))))) + (#Form elems) + (#Form (map (apply-template env) elems)) -(list (#Tag tag)) -(' (lambda [func record] -(set@ (~ tag) record (func (get@ (~ tag) record))))))] -(return (list output)))) -(declare-macro update@) + (#Record members) + (#Record (map (lambda [kv] + (case' kv + [slot value] + [(apply-template env slot) (apply-template env value)])) + members)) -(def (. f g) -(lambda [x] (f (g x)))) + _ + template)) -(def (|> tokens) -(case tokens -(list+ init apps) -(return (list (fold (lambda [acc app] -(case app -(#Form parts) -(#Form (++ parts (list acc))) +(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 (zip bindings-list))) + return)))) -_ -(` (~ app) (~ acc)))) -init -apps))))) +## (do-template [<name> <offset>] +## (def <name> (int+ <offset>)) -(def ($ tokens) -(case tokens -(list+ op init args) -(return (list (fold (lambda [acc elem] -(` (~ op) (~ acc) (~ elem))) -init -args))))) +## [inc 1] +## [dec -1]) -(def ($keys tokens) -(case tokens -(list (#Tuple fields)) -(let [record (#Record (map (lambda [slot] -(case slot -(#Tag name) -[(#Tag name) (#Ident name)])) -fields))] -(return (list record))))) +(def (int= x y) + (jvm-leq x y)) -(def ($or tokens) -(case tokens -(list (#Tuple patterns) body) -(return (flat-map (lambda [pattern] (list pattern body)) -patterns)))) +(def (int% x y) + (jvm-lrem x y)) -(def (-> tokens) -(case (reverse tokens) -(#Cons [f-return f-args]) -(fold (lambda [f-return f-arg] -(#Lambda [f-arg f-return])) -f-return f-args))) +(def (int>= x y) + (or (int= x y) + (int> x y))) -(def (defsyntax tokens) -...) +(do-template [<name> <cmp>] + (def (<name> x y) + (if (<cmp> x y) + x + y)) -(def (defsig tokens) -...) + [max int>] + [min int<]) -(def (defstruct tokens) -...) +(do-template [<name> <cmp>] + (def (<name> n) (<cmp> n 0)) -(def (with tokens) -...) + [neg? int<] + [pos? int>=]) -## (deftype (List a) -## (| #Nil -## (#Cons [a (List a)]))) +(def (even? n) + (int= 0 (int% n 0))) -(def (complement f) -(lambda [x] (not (f x)))) +(def (odd? n) + (not (even? n))) -(def (cond tokens) -(let [else (last tokens) -branches (as-pairs (init tokens))] -(return (list (fold (lambda [else branch] -(case branch -[test then] -(` (if (~ test) (~ then) (~ else))))) -else -branches))))) -(declare-macro cond) +(do-template [<name> <done> <step>] + (def (<name> n xs) + (if (int> n 0) + (case' xs + #Nil #Nil + (#Cons [x xs']) <step>) + <done>)) -(def (constant x) -(lambda [_] x)) + [take #Nil (list+ x (take (dec n) xs'))] + [drop xs (drop (dec n) xs')]) -(def (repeat n x) -(if (> n 0) -(list+ x (repeat (dec n) x)) -#Nil)) +(do-template [<name> <done> <step>] + (def (<name> f xs) + (case' xs + #Nil #Nil + (#Cons [x xs']) (if (f x) <step> #Nil))) -(def (size xs) -(case xs -#Nil 0 -(#Cons [_ xs']) (int+ 1 (size xs')))) + [take-while #Nil (list+ x (take-while f xs'))] + [drop-while xs (drop-while f xs')]) -(def (last xs) -(case xs -#Nil #None -(list x) (#Some x) -(list+ _ xs') (last xs'))) +(defmacro (get@ tokens) + (let [output (case' tokens + (#Cons [(#Tag tag) (#Cons [record #Nil])]) + (` (get@' (~ (#Tag tag)) (~ record))) -(def (init xs) -(case xs -#Nil #None -(list _) (#Some #Nil) -(#Cons [x xs']) (case (init xs') -(#Some xs'') -(#Cons [x xs'']) + (#Cons [(#Tag tag) #Nil]) + (` (lambda [record] (get@' (~ (#Tag tag)) record))))] + (return (list output)))) -_ -#None))) +(defmacro (set@ tokens) + (let [output (case' tokens + (#Cons [(#Tag tag) (#Cons [value (#Cons [record #Nil])])]) + (` (set@' (~ (#Tag tag)) (~ value) (~ record))) -(do-template [<name> <offset>] -(def <name> (int+ <offset>)) + (#Cons [(#Tag tag) (#Cons [value #Nil])]) + (` (lambda [record] (set@' (~ (#Tag tag)) (~ value) record))) -[inc 1] -[dec -1]) + (#Cons [(#Tag tag) #Nil]) + (` (lambda [value record] (set@' (~ (#Tag tag)) value record))))] + (return (list output)))) -(def (interleave xs ys) -(case [xs ys] -[(#Cons [x xs']) (#Cons [y ys'])] -(list+ x y (interleave xs' ys')) +(defmacro (update@ tokens) + (let [output (case' tokens + (#Cons [tag (#Cons [func (#Cons [record #Nil])])]) + (` (let [_record_ (~ record)] + (set@' (~ tag) _record_ ((~ func) (get@' (~ tag) _record_))))) -_ -#Nil)) + (#Cons [tag (#Cons [func #Nil])]) + (` (lambda [record] + (` (set@' (~ tag) record ((~ func) (get@' (~ tag) record)))))) -(def (interpose sep xs) -(case xs -(#Cons [x #Nil]) -xs + (#Cons [tag #Nil]) + (` (lambda [func record] + (set@' (~ tag) record (func (get@' (~ tag) record))))))] + (return (list output)))) -(#Cons [x xs']) -(list+ x sep (interpose sep xs')) +(def gen-ident + (lambda [state] + [(update@ #gen-seed inc state) + (#Ident ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))])) -_ -xs)) +## (do-template [<name> <member>] +## (def (<name> pair) +## (case' pair +## [f s] +## <member>)) -(def (flatten xss) -(fold ++ (list) xs)) +## [first f] +## [second s]) -(def (flat-map f xs) -(flatten (map f xs))) +(defmacro (type tokens) + (case tokens + (#Tuple elems) + (return (list (' (#Tuple (~ (map untemplate elems)))))) -(do-template [<name> <cmp>] -(def (<name> x y) -(if (<cmp> x y) -x -y)) + (#Record fields) + (return (list (' (#Record (~ (map (lambda [kv] + (case kv + [(#Tag tag) val] + [tag (untemplate val)])) + fields)))))) -[max >] -[min <]) + (#Form (list+ (#Ident "|") options)) + (do [options' (map% (lambda [opt] + (case opt + (#Tag tag) + [tag (#Tuple (list))] -(do-template [<name> <cmp>] -(def (<name> n) (<cmp> n 0)) + (#Form (list (#Tag tag) value)) + [tag value] -[neg? <] -[pos? >=]) + _ + (fail ""))) + options)] + (#Variant options')) + )) -(def (even? n) -(int= 0 (int% n 0))) +(defmacro (All tokens) + (let [[name args body] (case tokens + (list (#Tuple args) body) + ["" args body] -(def (odd? n) -(not (even? n))) + (list (#Ident name) (#Tuple args) body) + [name args body])] + (return (list (' (#All (~ name) [(~@ (map (lambda [arg] + (case arg + (#Ident arg') + (#Text arg'))) + args))] + (~ body))))))) -(do-template [<name> <done> <step>] -(def (<name> n xs) -(if (> n 0) -(case xs -#Nil #Nil -(list+ x xs') <step>) -<done>)) +(defmacro (Exists tokens) + (case tokens + (list (#Ident name) body) + (return (list (' (#Exists (~ name) (~ body))))))) -[take #Nil (list+ x (take (dec n) xs'))] -[drop xs (drop (dec n) xs')]) +(defmacro (deftype tokens) + (case tokens + (list (#Ident name) definition) + (return (list (' (def (~ (#Ident name)) + (type (~ definition)))))) -(do-template [<name> <done> <step>] -(def (<name> f xs) -(case xs -#Nil #Nil -(list+ x xs') (if (f x) <step> #Nil))) + (list (#Form (list+ (#Ident name) args)) definition) + (let [name' (#Ident name)] + (return (list (' (def (~ name') + (All (~ name') [(~@ args)] + (type (~ definition)))))))) + )) -[take-while #Nil (list+ x (take-while f xs'))] -[drop-while xs (drop-while f xs')]) +(defmacro ($keys tokens) + (case tokens + (list (#Tuple fields)) + (let [record (#Record (map (lambda [slot] + (case slot + (#Tag name) + [(#Tag name) (#Ident name)])) + fields))] + (return (list record))))) -(def (empty? xs) -(case xs -#Nil true -_ false)) +(defmacro ($or tokens) + (case tokens + (list (#Tuple patterns) body) + (return (flat-map (lambda [pattern] (list pattern body)) + patterns)))) -(do-template [<name> <op>] -(def (<name> p xs) -(case xs -#Nil true -(#Cons [x xs']) (<op> (p x) (<name> p xs')))) +(defmacro (-> tokens) + (case (reverse tokens) + (#Cons [f-return f-args]) + (fold (lambda [f-return f-arg] + (#Lambda [f-arg f-return])) + f-return f-args))) -[every? and] -[any? or]) +(def (defsyntax tokens) + ...) -(def (range from to) -(if (< from to) -(list+ from (range (inc from) to)) -#Nil)) +(def (defsig tokens) + ...) + +(def (defstruct tokens) + ...) + +## (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]) + +## (type (| #Nil +## (#Cons [a (List a)]))) + +## (type [Int Bool Text]) + +## (type {#id Int #alive? Bool #name Text}) + +## (deftype (List a) +## (| #Nil +## (#Cons [a (List a)]))) )# |
