diff options
Diffstat (limited to '')
| -rw-r--r-- | source/lux.lux | 1299 |
1 files changed, 569 insertions, 730 deletions
diff --git a/source/lux.lux b/source/lux.lux index 641be09ca..7cafb2977 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -1,5 +1,5 @@ ## Base interfaces & classes -(jvm;interface Function +(jvm-interface Function (: apply (-> [java.lang.Object] java.lang.Object))) ## Base functions & macros @@ -18,9 +18,9 @@ (lambda' _ tokens (lambda' _ state (let' output (case' tokens - (#Cons [(#Form (#Cons [self (#Cons [arg args'])])) (#Cons [body #Nil])]) + (#Cons [(#Tuple (#Cons [arg args'])) (#Cons [body #Nil])]) (#Form (#Cons [(#Ident "lambda'") - (#Cons [self + (#Cons [(#Ident "") (#Cons [arg (#Cons [(case' args' #Nil @@ -28,7 +28,21 @@ _ (#Form (#Cons [(#Ident "lux;lambda") - (#Cons [(#Form (#Cons [(#Ident "_") args'])) + (#Cons [(#Tuple args') + (#Cons [body #Nil])])]))) + #Nil])])])])) + + (#Cons [(#Ident self) (#Cons [(#Tuple (#Cons [arg args'])) (#Cons [body #Nil])])]) + (#Form (#Cons [(#Ident "lambda'") + (#Cons [(#Ident self) + (#Cons [arg + (#Cons [(case' args' + #Nil + body + + _ + (#Form (#Cons [(#Ident "lux;lambda") + (#Cons [(#Tuple args') (#Cons [body #Nil])])]))) #Nil])])])]))) [(#Cons [output #Nil]) state]) @@ -36,7 +50,7 @@ (declare-macro lambda) (def' def - (lambda (_ tokens state) + (lambda [tokens state] (let' output (case' tokens (#Cons [(#Ident name) (#Cons [body #Nil])]) (#Form (#Cons [(#Ident "def'") tokens])) @@ -46,44 +60,48 @@ (#Form (#Cons [(#Ident "def'") (#Cons [(#Ident name) (#Cons [(#Form (#Cons [(#Ident "lux;lambda") - (#Cons [(#Form (#Cons [(#Ident name) args])) - (#Cons [body #Nil])])])) + (#Cons [(#Ident name) + (#Cons [(#Tuple args) + (#Cons [body #Nil])])])])) #Nil])])]))) [(#Cons [output #Nil]) state]))) (declare-macro def) -## (def (defmacro tokens state) -## (let' fn-def (case' tokens -## (#Cons [(#Form (#Cons [(#Ident ?name) (#Cons [(#Ident ?tokens) (#Cons [(#Ident ?state) #Nil])])])) -## (#Cons [body #Nil])]) -## (#Form (#Cons [(#Form (#Cons [(#Ident "lux;def") -## (#Cons [(#Ident ?name) -## (#Cons [(#Ident ?tokens) -## (#Cons [(#Ident ?state) -## #Nil])])])])) -## (#Cons [body -## #Nil])]))) -## (let' declaration [] -## [(#Cons [fn-def (#Cons [declaration #Nil])]) state]))) -## (declare-macro defmacro) - -(def (comment tokens state) +(def (defmacro tokens state) + (let' [fn-name fn-def] (case' tokens + (#Cons [(#Form (#Cons [(#Ident ?name) (#Cons [(#Ident ?tokens) (#Cons [(#Ident ?state) #Nil])])])) + (#Cons [body #Nil])]) + [?name + (#Form (#Cons [(#Ident "lux;def") + (#Cons [(#Form (#Cons [(#Ident ?name) + (#Cons [(#Ident ?tokens) + (#Cons [(#Ident ?state) + #Nil])])])) + (#Cons [body + #Nil])])]))]) + (let' declaration (#Form (#Cons [(#Ident "declare-macro") (#Cons [(#Ident fn-name) #Nil])])) + [(#Cons [fn-def (#Cons [declaration #Nil])]) state]))) +(declare-macro defmacro) + +(defmacro (comment tokens state) [#Nil state]) -(declare-macro comment) -(def (+ x y) - (jvm;iadd x y)) +(def (int+ x y) + (jvm-iadd 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])) + (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])) + (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object] + (jvm-getstatic java.lang.System "out") [x])) + +#( + (def (fold f init xs) (case' xs @@ -94,13 +112,14 @@ (fold f (f init x) xs'))) (def (reverse list) - (fold (lambda (_ tail head) (#Cons [head tail])) + (fold (lambda [tail head] + (#Cons [head tail])) #Nil list)) (def (list xs state) (let' xs' (reverse xs) - (let' output (fold (lambda (_ tail head) + (let' output (fold (lambda [tail head] (#Form (#Cons [(#Tag "Cons") (#Cons [(#Tuple (#Cons [head (#Cons [(#Form (#Cons [(#Tag "Cons") @@ -117,7 +136,8 @@ [#Nil state] (#Cons [last init']) - (let' output (fold (lambda (_ tail head) + (let' output (fold (lambda [tail head] + ## (#Form (list (#Tag "Cons") (#Tuple (list head tail)))) (#Form (#Cons [(#Tag "Cons") (#Cons [(#Tuple (#Cons [head (#Cons [tail #Nil])])) #Nil])]))) last init') @@ -135,7 +155,7 @@ (def (let tokens state) (case' tokens (#Cons [(#Tuple bindings) (#Cons [body #Nil])]) - (let' output (fold (lambda (_ body binding) + (let' output (fold (lambda [body binding] (case' binding [label value] (#Form (list (#Ident "let'") label value body)))) @@ -144,734 +164,553 @@ [(list output) state]))) (declare-macro let) -(def (++-list xs ys) +(def (++ xs ys) (case' xs #Nil ys (#Cons [x xs*]) - (#Cons [x (++-list xs* ys)]))) + (#Cons [x (++ xs* ys)]))) -(def (map-list f xs) +(def (map f xs) (case' xs #Nil #Nil (#Cons [x xs*]) - (#Cons [(f x) (map-list f xs*)]))) - -#( -(def (untemplate-list untemplate tokens) -(case tokens -#Nil -(#Tag "Nil") + (#Cons [(f x) (map f xs*)]))) -(#Cons token tokens') -(#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) +(def (filter p xs) + (case' xs + #Nil + #Nil -(def (untemplate token) -(case token -(#Bool elem) -(#Form (list (#Tag "Bool") (#Bool elem))) + (#Cons [x xs*]) + (if (p x) + (filter p xs*) + (#Cons [x (filter p xs*)])))) +)# -(#Int elem) -(#Form (list (#Tag "Int") (#Int elem))) +#((def (untemplate-list untemplate tokens) + (case tokens + #Nil + (#Tag "Nil") -(#Real elem) -(#Form (list (#Tag "Real") (#Real elem))) + (#Cons [token tokens']) + (#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens'))))) -(#Char elem) -(#Form (list (#Tag "Char") (#Char elem))) +(def (untemplate token) + (case token + (#Bool elem) + (#Form (list (#Tag "Bool") (#Bool elem))) -(#Text elem) -(#Form (list (#Tag "Text") (#Text elem))) + (#Int elem) + (#Form (list (#Tag "Int") (#Int elem))) -(#Tag elem) -(#Form (list (#Tag "Tag") (#Text elem))) + (#Real elem) + (#Form (list (#Tag "Real") (#Real elem))) -(#Ident elem) -(#Form (list (#Tag "Ident") (#Text elem))) + (#Char elem) + (#Form (list (#Tag "Char") (#Char elem))) -(#Form (#Cons (#Ident "~") (#Cons unquoted #Nil))) -unquoted + (#Text elem) + (#Form (list (#Tag "Text") (#Text elem))) -(#Tuple elems) -(#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) + (#Tag elem) + (#Form (list (#Tag "Tag") (#Text elem))) -(#Form elems) -(#Form (list (#Tag "Form") (untemplate-list untemplate elems))) -)) + (#Ident elem) + (#Form (list (#Tag "Ident") (#Text elem))) + (#Form (#Cons [(#Ident "~") (#Cons [unquoted #Nil])])) + unquoted -## I/O -(def (print x) -(jvm;invokevirtual java.io.PrintStream "print" [Object] -(jvm;getstatic System out) [x])) + (#Tuple elems) + (#Form (list (#Tag "Tuple") (untemplate-list untemplate elems))) -(def (println x) -(jvm;invokevirtual java.io.PrintStream "println" [Object] -(jvm;getstatic System out) [x])) + (#Form elems) + (#Form (list (#Tag "Form") (untemplate-list untemplate elems))) + )) -(def (' form) -(case form -(#Cons token #Nil) -(untemplate token))) +(def (' tokens state) + [(map untemplate tokens) state]) (declare-macro ') -(def (+ x y) -(jvm;iadd x y)) +## TODO: Full pattern-matching +## TODO: Type-related macros +## TODO: (Im|Ex)ports-related macros +## TODO: Macro-related macros -(def inc (+ 1)) +(def (return val) + (lambda [state] + [state val])) -(def length (fold (lambda' l (lambda' x (inc l))) 0)) +(def (bind f v) + (lambda [state] + (case (v state) + [state' x] + ((f x) state')))) -(def (rem dividend divisor) -(jvm;irem dividend divisor)) - -(def (= x y) -(jvm;invokevirtual Object "equals" [Object] -x [y])) - -(def (pairs list) -(case list -(#Cons x (#Cons y list*)) -(#Cons [x y] (pairs list*)) - -_ -#Nil)) - -(def (show x) -(jvm;invokevirtual Object "toString" [] -x [])) +(def (if tokens) + (case' tokens + (#Cons [test (#Cons [then (#Cons [else #Nil])])]) + (return (list (' (case' (~ test) + true (~ then) + false (~ else))))))) +(declare-macro if) + +(def (apply-template env template) + (case template + (#Ident ident) + (if-let [subst (get ident env)] + subst + template) + + (#Tuple elems) + (#Tuple (map (apply-template env) elems)) + + (#Form elems) + (#Form (map (apply-template env) elems)) + + (#Record members) + (#Record (map (lambda [kv] + (case kv + [slot value] + [(apply-template env slot) (apply-template env value)])) + members)) + + _ + template)) + +(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) + +(def gen-ident + (lambda [state] + [(update@ #gen-seed inc state) + (#Ident ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))])) + +(do-template [<name> <member>] + (def (<name> pair) + (case' pair + [f s] + <member>)) + + [first f] + [second s]) + +(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) + +(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))))) + + (#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)))) + ))) +(declare-macro case) + +(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 (export tokens) + (return (map (lambda [t] + (' (export' (~ t)))) + tokens))) +(declare-macro export) + +## (import "lux") +## (module-alias "lux" "l") +## (def-alias "lux;map" "map") + +## (def (require tokens) +## (case tokens +## ...)) + +## (require lux #as l #refer [map]) + +(def (type tokens) + (case tokens + (#Tuple elems) + (return (list (' (#Tuple (~ (map untemplate elems)))))) + + (#Record fields) + (return (list (' (#Record (~ (map (lambda [kv] + (case kv + [(#Tag tag) val] + [tag (untemplate val)])) + fields)))))) + + (#Form (list+ (#Ident "|") options)) + (do [options' (map% (lambda [opt] + (case opt + (#Tag tag) + [tag (#Tuple (list))] + + (#Form (list (#Tag tag) value)) + [tag value] + + _ + (fail ""))) + options)] + (#Variant options')) + )) +(declare-macro type) + +## (type (| #Nil +## (#Cons [a (List a)]))) + +## (type [Int Bool Text]) + +## (type {#id Int #alive? Bool #name Text}) + +(def (All tokens) + (let [[name args body] (case tokens + (list (#Tuple args) body) + ["" args body] + + (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) + +(def (Exists tokens) + (case tokens + (list (#Ident name) body) + (return (list (' (#Exists (~ name) (~ body))))))) +(declare-macro Exists) + +(def (deftype tokens) + (case tokens + (list (#Ident name) definition) + (return (list (' (def (~ (#Ident name)) + (type (~ definition)))))) + + (list (#Form (list+ (#Ident name) args)) definition) + (let [name' (#Ident name)] + (return (list (' (def (~ name') + (All (~ name') [(~@ args)] + (type (~ definition)))))))) + )) +(declare-macro deftype) + +(def (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)))) +(declare-macro and) + +(def (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)))) +(declare-macro or) + +(def (not x) + (case x + true false + false true)) + +(def (get@ tokens) + (let [output (case tokens + (list (#Tag tag) record) + (' (get@' (~ (#Tag tag)) (~ record))) + + (list (#Tag tag)) + (' (lambda [record] (get@' (~ (#Tag tag)) record))))] + (return (list output)))) +(declare-macro get@) + +(def (set@ tokens) + (let [output (case tokens + (list (#Tag tag) value record) + (' (set@' (~ (#Tag tag)) (~ value) (~ record))) + + (list (#Tag tag) value) + (' (lambda [record] (set@' (~ (#Tag tag)) (~ value) record))) + + (list (#Tag tag)) + (' (lambda [value record] (set@' (~ (#Tag tag)) value record))))] + (return (list output)))) +(declare-macro set@) + +(def (update@ tokens) + (let [output (case tokens + (list tag func record) + (` (let [_record_ (~ record)] + (set@ (~ tag) _record_ ((~ func) (get@ (~ tag) _record_))))) + + (list (#Tag tag) func) + (' (lambda [record] + (` (set@ (~ tag) record ((~ func) (get@ (~ tag) record)))))) + + (list (#Tag tag)) + (' (lambda [func record] + (set@ (~ tag) record (func (get@ (~ tag) record))))))] + (return (list output)))) +(declare-macro update@) + +(def (. f g) + (lambda [x] (f (g x)))) + +(def (|> tokens) + (case tokens + (list+ init apps) + (return (list (fold (lambda [acc app] + (case app + (#Form parts) + (#Form (++ parts (list acc))) + + _ + (` (~ app) (~ acc)))) + init + apps))))) + +(def ($ tokens) + (case tokens + (list+ op init args) + (return (list (fold (lambda [acc elem] + (` (~ op) (~ acc) (~ elem))) + init + args))))) + +(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 ($or tokens) + (case tokens + (list (#Tuple patterns) body) + (return (flat-map (lambda [pattern] (list pattern body)) + patterns)))) + +(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 (defsyntax tokens) + ...) + +(def (defsig tokens) + ...) + +(def (defstruct tokens) + ...) + +(def (with tokens) + ...) -(def (concat t1 t2) -(jvm;invokevirtual String "concat" [String] -t1 [t2])) +## (deftype (List a) +## (| #Nil +## (#Cons [a (List a)]))) + +(def (complement f) + (lambda [x] (not (f x)))) + +(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) + +(def (constant x) + (lambda [_] x)) + +(def (repeat n x) + (if (> n 0) + (list+ x (repeat (dec n) x)) + #Nil)) + +(def (size xs) + (case xs + #Nil 0 + (#Cons [_ xs']) (int+ 1 (size xs')))) + +(def (last xs) + (case xs + #Nil #None + (list x) (#Some x) + (list+ _ xs') (last xs'))) + +(def (init xs) + (case xs + #Nil #None + (list _) (#Some #Nil) + (#Cons [x xs']) (case (init xs') + (#Some xs'') + (#Cons [x xs'']) + + _ + #None))) + +(do-template [<name> <offset>] + (def <name> (int+ <offset>)) + + [inc 1] + [dec -1]) + +(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 + (#Cons [x #Nil]) + xs + + (#Cons [x xs']) + (list+ x sep (interpose sep xs')) + + _ + xs)) + +(def (flatten xss) + (fold ++ (list) xs)) + +(def (flat-map f xs) + (flatten (map f xs))) + +(do-template [<name> <cmp>] + (def (<name> x y) + (if (<cmp> x y) + x + y)) + + [max >] + [min <]) + +(do-template [<name> <cmp>] + (def (<name> n) (<cmp> n 0)) + + [neg? <] + [pos? >=]) + +(def (even? n) + (int= 0 (int% n 0))) + +(def (odd? n) + (not (even? n))) + +(do-template [<name> <done> <step>] + (def (<name> n xs) + (if (> n 0) + (case xs + #Nil #Nil + (list+ 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 + (list+ x xs') (if (f x) <step> #Nil))) + + [take-while #Nil (list+ x (take-while f xs'))] + [drop-while xs (drop-while f 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 (= from to) -#Nil -(#Cons from (range (inc from) to)))) - -(def (text->list text) -(let' length (jvm;invokevirtual String "length" [] -text []) -(map (lambda' idx -(jvm;invokevirtual String "charAt" [int] -text [idx])) -(range 0 length)))) - -(def (enumerate list) -(case (fold (lambda' state -(lambda' x -(case state -[idx list'] -[(inc idx) (#Cons [idx x] list')]))) -[0 #Nil] -list) -[_ list'] -(reverse list'))) - -(def list-map #Nil) - -(def (put key val map) -(case map -#Nil -(#Cons [key val] map) - -(#Cons [?key ?val] map') -(if (= key ?key) -(#Cons [?key val] map') -(#Cons [?key ?val] (put key val map'))))) - -(def (get key map) -(case map -#Nil -#None - -(#Cons [?key ?val] map') -(if (= key ?key) -(#Some ?val) -(get key map')))) - -(def (show-kv kv) -(case kv -[?key ?val] -(fold concat "" (list "#" ?key " " (show ?val))))) - -(def (interpose elem list) -(case list -(#Cons x (#Cons y list')) -(list+ x elem y (interpose elem list')) - -_ -list)) - -(def (show-list xs) -(case xs -#Nil -"#Nil" - -(#Cons x xs') -(fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")")))) - -(defsig (Equal x) -(: = (-> x x Bool))) - -(deftype Equal (All [x r] {#= (-> x x Bool) & r})) -(deftype Equal (All [x] {#= (-> x x Bool)})) -(deftype Equal (All [x] (Exists [r] {#= (-> x x Bool) & r}))) - -(defimpl (Equal Bool) -(def (= x y) -(case [x y] -[ true true] true -[false false] true -_ false))) - -(def Equal_Bool -(struct {#= [(-> Bool Bool Bool) -(lambda [x y] ...)]})) - -(: (~ g!Equal) (Equal Bool)) -(: (~ g!Equal) {#= (-> Bool Bool Bool)}) -(def (~ g!Equal) -{#= (lambda [x y] ...)}) - -(def Equal_List -(lambda [Equal_x] -(struct {#= }))) - -(: Equal_List -(All [x] (-> (Equal x) (Equal (List x))))) - -(defimpl (All [x] -(=> [(Equal x)] -(Equal (List x)))) -(def (= xs1 xs2) -(case [xs1 xs2] -[#Nil #Nil] -true - -[(#Cons x1 xs1') (#Cons x2 xs2')] -(and (Equal_x x1 x2) (= xs1' xs2'))))) - -(All [x] -(-> (Equal x) (Equal (List x)))) - -(EqualList EqualBool) => {#= ...} - -(: ops (List (Exists [a] [(-> Text a) (-> a [])]))) -(def ops (list [(lambda [_] 10) (lambda [_] [])] -[(lambda [_] "") (lambda [_] [])])) - -(case ops -#Nil -[] - -(#Cons [f1 f2] ops') -(f2 (f1 "E"))) - -(defsig (Add x) -(: + (-> x x x))) - -(defimpl AddInt (Add Int) -#defs -(def (+ x y) -(jvm;ladd x y))) - -(defimpl (Add Int) -(def (+ x y) -(jvm;ladd x y))) - -(: adder (All [x] (=> [(Add x)] -(-> x (-> x x))))) -(def (adder by) -(lambda [x] (+ by x))) - -(adder AddInt 1) -> (lambda [x] ((get@ #+ AddInt) 1 x)) -adder == (lambda [impl] -(case impl -{#+ +} -(lambda [x] (+ by x)))) - -(: calc (All [v] -(-> (-> v Int) -(| (#Add Int Int) (#Mul Int Int) & v) -Int))) -(def (calc backup expr) -(case expr -(#Add x y) (+ x y) -(#Mul x y) (* x y) -else (backup else))) - -(defsig Yolo -(: lol? (-> Text Bool)) -(: foo Int)) - -(defimpl Meme [Yolo] -(def (lol? _) true) -(def foo 10)) - -(defimpl Nyan [Yolo] -Meme -(def foo 20)) - -(list 1 2 3) == (#Cons 1 (#Cons 2 (#Cons 3 #Nil))) -(list+ 1 2 (list 3)) - -(defsig (Monoid a) -(: empty a) -(: ++ (BinaryOp a))) - -(: concat (All [a] -(=> [(Monoid a)] -(-> (List a) a)))) -(def (concat mon -xs) -(fold (:: mon #++) (:: mon #empty) xs)) - -(defstruct (Monoid Text) -(def empty "") -(def (++ x y) -...)) - -(defstruct (All [a] -(Monoid (List a))) -(def empty (list)) -(def (++ xs ys) -(case xs -#Nil -ys - -(#Cons x xs') -(#Cons x (++ xs' ys))))) - -(: map (All [a b] (-> (-> a b) (List a) (List b)))) - -(defsig (Collection c) -(: add (All [x] (-> x (c x) (c x)))) -(: length (All [x] (-> (c x) Int)))) - -(defclass (Stack s) -(: push (All [x] (-> x (s x) (s x)))) -(: pop (All [x] (-> (s x) (s x)))) -(: peek (All [x] (-> (s x) (Maybe x))))) - -(deftype (BinaryOp t) -(-> t t t)) - -(defclass (Number n) -(: + (BinaryOp n)) -(: - (BinaryOp n)) -(: * (BinaryOp n)) -(: / (BinaryOp n))) - -(def (flip f) -(lambda [x y] -(f y x))) - -(def (concat' xss) -(case (reverse xss) -#Nil -#Nil - -(#Cons xs xss') -(fold (flip ++) xs xss'))) - -n + n*m - -(with [AddInt] -(+ 10 20)) - -(:: AddInt (+ 10 20)) == ((get@ AddInt #=) 10 20) - -(defimpl (Stack List) -(def (push x xs) -(#Cons x xs)) - -(def (pop xs) -(case xs -#Nil #Nil -(#Cons _ xs') xs')) - -(def (peek xs) -(case xs -#Nil #None -(#Cons x _) (#Some x)))) - -(defsig (Functor f) -(: map (All [a b] (-> (-> a b) (f a) (f b))))) - -(def (Functor f) -{#map (All [a b] (-> (-> a b) (f a) (f b)))}) - -(defimpl ListFunctor (Functor List) -(def (map func fa) -(case fa -#Nil -#Nil - -(list a fa') -(list (func a) (map func fa'))))) - -(implicit ListFunctor -(map inc (list 1 2 3))) - -(defsig (=> [(Functor m)] -(Monad m)) -(: return (All [x] (-> x (m x)))) -(: bind (All [a b] (-> (m a) (-> a (m b)) (m b))))) - - - -(#User {#name Text #age Int}) -(deftype User {#name Text #age Int}) -(deftype User (& (#name Text) -(#age Int))) -(deftype User (All [r] -(& (#name Text) -(#age Int) -++ r))) -(def User (#Record (list ["name" Text] ["age" Int]))) - -(let [thunk (... (+ 5 6))] -(! thunk)) - -(Thunk Int) - - -(deftype Int&Bool [Int Bool]) - -(deftype (List a) -(| #Nil -(#Cons a (List a)))) - -(defclass (Equal a) -(: = (-> a a Bool))) -== -(deftype (Equal a) -{#= (-> a a Bool)}) - -(def Equals -(All [a] {#= (-> a a Bool)})) - -(defimpl EqualBool [(Equal Bool)] -(def (= x y) -(if x -y -(not y)))) - -(def ... {#= (lambda [x y] (if x -y -(not y)))}) - -(def Class (All [I] -(Exists [S] (& (#state S) -(#methods (I S)))))) - -(definterface Vector -(: translate (BinaryOp Vector))) - -(def Vector (Some [Vector] -(& (#translate (BinaryOp v))))) - -(defclass Vector2D -{#x Real, #y Real} -(def (new-Vector2D x y) -{#x x, #y y}) -Vector -(def (translate self offset) -(-> self -(update@ #x + (get@ offset #x)) -(update@ #y + (get@ offset #y))))) - -(def Vector2D -{#translate (: (lambda [self offset] -(-> self -(update@ #x +real (get@ offset #x)) -(update@ #y +real (get@ offset #y)))) -(BinaryOp {#x Real, #y Real}))}) - -(: new-Vector2D (-> Real Real [{#x Real, #y Real} (@class Vector2D)])) -(def (new-Vector2D x y) -[{#x x, #y y} Vector2D]) - -(defsig (Vector v) -(: translate (BinaryOp v)) -(: scale (BinaryOp v))) - -(def Vector (All Vector [v] -(& (#translate (BinaryOp v)) -(#scale (BinaryOp v))))) - -(defstruct Vector2D (Vector [Real Real]) -(def (translate [x1 y1] [x2 y2]) -[(+ x1 x2) (+ y1 y2)]) -(def (scale [x1 y1] [x2 y2]) -[(* x1 x2) (* y1 y2)])) - -(def Vector2D (: {#translate (lambda [[x1 y1] [x2 y2]] -[(+real x1 x2) (+real y1 y2)]) -#scale (lambda [[x1 y1] [x2 y2]] -[(*real x1 x2) (*real y1 y2)])} -(Vector [Real Real]))) - -(deftype (Stream a) -(| (#Cons a (Thunk (Stream a))))) - -(: iterate (All [a] (-> (-> a a) a (Stream a)))) -(def (iterate f init) -(list init (... (iterate f (f init))))) - -(def (take n stream) -(if (<= n 0) -#Nil -(case stream -(#Cons x stream') -(#Cons x (take (dec n) stream'))))) - -(deftype (Stream a) -(All [b] (-> (-> a (Stream a b) b) b))) - -(: iterate (All [a] (-> (-> a a) a (Stream a)))) -(def (iterate f init) -(lambda [k] -(k init (iterate f (f init))))) - -(def (repeat x) -(lambda [k] (k x (repeat x)))) - -(def (take n stream) -(if (<= n 0) -#Nil -(stream (lambda [x stream'] -(#Cons x (take (dec n) stream')))))) - -(defsig (Comonad w) -(: extract (All [a] (-> (w a) a))) -(: extend (All [a b] (-> (w a) (-> (w a) b) (w b))))) - -(defstruct Stream (Comonad w) -(def (extract stream) -(stream (lambda [x _] x))) -(def (extend w f) -...)) - -(: fibonacci (Stream Int)) -(def fibonacci ((lambda fibonacci [a b] -(lambda [k] (k a (fibonacci b (+ a b))))) -0 1)) - -(gen fibonacci [a 0 b 1] -(yield a (fibonacci b (+ a b)))) - -(defgen fibonacci [a 0 b 1] -(yield a (fibonacci b (+ a b)))) - -(gen fibonacci [a 0 b 1] -(yield a [b (+ a b)])) - -## The dual of do-notation should be be-notation - -(deftype (Stream a) -(| (#Cons a (Thunk (Stream a))))) - -(defstruct (Functor Stream) -(def (map f s) -(lambda [k] -(stream (lambda [x stream'] -(f s)))))) - -(deftype (Tape a) -(| (#Index (Thunk (Stream a)) a (Thunk (Stream a))))) - -(deftype (Area a) -(| (#Cursor (Tape a) (Surreal a)))) - -(def (ints offset n) -(#Index (... (iterate (lambda [n'] (- n' offset)) n)) -n -(... (iterate (+ offset) n)))) - -(def (reals offset x) -(#Cursor (ints offset x) -(reals (/ offset 10) 0))) + (if (< from to) + (list+ from (range (inc from) to)) + #Nil)) )# - -#( -(deftype (Session i o s) -(All [s' r] -(-> (-> i s' r) -(-> o s [i s']) -r)) - -(All [s' s''] (-> (-> c s' [p s'']) -(-> [] s [c s']) (Session c p s) -[p s''])) -(All [] (-> (-> c s p) -(-> p []))) -(All [r] (-> c (Session r p s) p))) - -(Session Int [] (Session Int (Session [] Int <END>))) - -(bind (session' []) -(lambda [x session'] -(bind (session' []) -(lambda [y session''] -(session'' (+ x y)))))) - -(defstruct SessionMonad -(Monad Session) -(def (return v) -(lambda [k session] -(k v session))) -(def (bind step m-value) -(lambda [k session] -(let [[v session'] (m-value [] session)] -(k (step v) session'))))) - -## Not really "do"; but oh, well... - -(deftype <NIL> -(| #Nil)) - -(deftype (HList h t) -(| (#Cons h t))) - -(deftype (Session c p s) -(All [r] (-> c (-> p s r) r))) - -(deftype (Session c p s) -(-> (-> p s c) c)) - -(deftype (? r s) -(Session r [] s)) - -(deftype (! w s) -(Session [] w s)) - -(deftype #rec <END> -(Session [] [] <END>)) - -(def << -(lambda [k session] -(k [] session))) - -(def (>> val) -(lambda [k session] -(session val k))) - -(<$> << (>> 5)) - -(def (<$> consumer producer) -(producer [] consumer)) - -(HList Int (HList Int <NIL>)) - -(<.> (? Int) (? Int) (! Int) <END>) -(def fn-session -(do [x << -y <<] -(>> (+ x y)))) - -(<.> (! Int) (! Int) (? Int) <END>) -(def call-session -(do [_ (>> 5) -_ (>> 10)] -<<)) - -(<$> fn-session call-session) - -(def << -(lambda [chan] -(chan (lambda [])))) - -(def (>> value) -(lambda [chan] -(chan value))) -)# - -## (defsig (Equal a) -## (: = (-> a a Bool))) - -## (: not= (All [a] (-> (Equal a) a a Bool))) -## (def (not= &Equal -## x x) -## (not (:: &Equal (= x x)))) - -## (defstruct Int -## [] -## (Equal Int) - -## (def (= x y) -## (zero? (- x y)))) - -## (defsig (Show a) -## (: show (-> a Text))) - -## (defstruct (ListShow x) -## [&show (Show a)] -## (Show (List a)) - -## (def (show xs) -## (<> "(" (interpose ", " (map (:: &show show) xs)) ")"))) - -## (def ListShow -## (: (lambda [&show] -## {#show (lambda show [xs] -## (<> "(" (interpose ", " (map (:: &show show) xs)) ")"))}) -## (-> (Show a) (Show (List a))))) - -## (deftype (Identity a) a) - -## (deftype (List a) -## (| #Nil -## (#Cons a (List a)))) - -## (def (ListT m) -## (All [a] (List (m a)))) - -## (ListT Identity) - -## (defsig (Monad m) -## (: return (All [a] (-> a (m a)))) -## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b))))) - -## (def Monad -## (All [m] -## (sig (: return (All [a] (-> a (m a)))) -## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b))))))) - -## (defstruct Monad<Identity> (Monad Identity) -## (def (return x) -## x) -## (def (bind f x) -## (f x))) - -## (: Monad<Identity> (Monad Identity)) -## (def Monad<Identity> -## (struct -## (def (return x) -## x) -## (def (bind f x) -## (f x)))) - -## (defstruct Monad<List> (All [m] (-> (Monad m) -## (Monad (ListT m)))) -## (def (return x) -## (list x)) -## (def (bind f xs) -## (case xs -## #Nil #Nil -## (#Cons x xs') (#Cons (f x) (bind f xs'))))) - -## (deftype #rec Type -## ($data #Any -## #Nothing -## (#Data Text (List Type)) -## (#Lambda Type Type) -## (#All (List [Text Type]) Text Text Type) -## (#Exists (List [Text Type]) Text Type) -## (#Lookup Text) -## (#Var Int))) |