aboutsummaryrefslogtreecommitdiff
path: root/source
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux1299
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)))