aboutsummaryrefslogtreecommitdiff
path: root/source/lux.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux1008
1 files changed, 747 insertions, 261 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 63ab93a4c..4a53e088b 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -1,66 +1,66 @@
## Base interfaces & classes
-(jvm:interface Function
+(jvm;interface Function
(: apply (-> [java.lang.Object] java.lang.Object)))
-(jvm:class Tuple0 java.lang.Object
+(jvm;class Tuple0 java.lang.Object
[])
-(jvm:class Tuple1 java.lang.Object
+(jvm;class Tuple1 java.lang.Object
[[java.lang.Object _1]])
-(jvm:class Tuple2 java.lang.Object
+(jvm;class Tuple2 java.lang.Object
[[java.lang.Object _1] [java.lang.Object _2]])
-(jvm:class Tuple3 java.lang.Object
+(jvm;class Tuple3 java.lang.Object
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3]])
-(jvm:class Tuple4 java.lang.Object
+(jvm;class Tuple4 java.lang.Object
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]])
-(jvm:class Tuple5 java.lang.Object
+(jvm;class Tuple5 java.lang.Object
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]
[java.lang.Object _5]])
-(jvm:class Tuple6 java.lang.Object
+(jvm;class Tuple6 java.lang.Object
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]
[java.lang.Object _5] [java.lang.Object _6]])
-(jvm:class Tuple7 java.lang.Object
+(jvm;class Tuple7 java.lang.Object
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]
[java.lang.Object _5] [java.lang.Object _6]
[java.lang.Object _7]])
-(jvm:class Tuple8 java.lang.Object
+(jvm;class Tuple8 java.lang.Object
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]
[java.lang.Object _5] [java.lang.Object _6]
[java.lang.Object _7] [java.lang.Object _8]])
-(jvm:class Variant java.lang.Object
+(jvm;class Variant java.lang.Object
[[java.lang.String tag]])
-(jvm:class Variant0 lux.Variant
+(jvm;class Variant0 lux.Variant
[])
-(jvm:class Variant1 lux.Variant
+(jvm;class Variant1 lux.Variant
[[java.lang.Object _1]])
-(jvm:class Variant2 lux.Variant
+(jvm;class Variant2 lux.Variant
[[java.lang.Object _1] [java.lang.Object _2]])
-(jvm:class Variant3 lux.Variant
+(jvm;class Variant3 lux.Variant
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3]])
-(jvm:class Variant4 lux.Variant
+(jvm;class Variant4 lux.Variant
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]])
-(jvm:class Variant5 lux.Variant
+(jvm;class Variant5 lux.Variant
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]
[java.lang.Object _5]])
-(jvm:class Variant6 lux.Variant
+(jvm;class Variant6 lux.Variant
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]
[java.lang.Object _5] [java.lang.Object _6]])
-(jvm:class Variant7 lux.Variant
+(jvm;class Variant7 lux.Variant
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]
[java.lang.Object _5] [java.lang.Object _6]
[java.lang.Object _7]])
-(jvm:class Variant8 lux.Variant
+(jvm;class Variant8 lux.Variant
[[java.lang.Object _1] [java.lang.Object _2]
[java.lang.Object _3] [java.lang.Object _4]
[java.lang.Object _5] [java.lang.Object _6]
@@ -71,299 +71,785 @@
(def' lambda
(lambda' _ tokens
(lambda' _ state
- (let' output (case tokens
- (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)))
- (#Form (#Cons (#Ident "lambda'")
- (#Cons self
- (#Cons arg
- (#Cons (case args'
- #Nil
- body
-
- _
- (#Form (#Cons (#Ident "lux:lambda")
- (#Cons (#Tuple args')
- (#Cons body #Nil)))))
- #Nil)))))
-
- (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))
- (#Form (#Cons (#Ident "lambda'")
- (#Cons (#Ident "_")
- (#Cons arg
- (#Cons (case args'
- #Nil
- body
-
- _
- (#Form (#Cons (#Ident "lux:lambda")
- (#Cons (#Tuple args')
- (#Cons body #Nil)))))
- #Nil))))))
+ (let' output (case' tokens
+ (#Cons self (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil)))
+ (#Form (#Cons (#Ident "lambda'")
+ (#Cons self
+ (#Cons arg
+ (#Cons (case args'
+ #Nil
+ body
+
+ _
+ (#Form (#Cons (#Ident "lux;lambda")
+ (#Cons (#Tuple args')
+ (#Cons body #Nil)))))
+ #Nil)))))
+
+ (#Cons (#Tuple (#Cons arg args')) (#Cons body #Nil))
+ (#Form (#Cons (#Ident "lambda'")
+ (#Cons (#Ident "_")
+ (#Cons arg
+ (#Cons (case args'
+ #Nil
+ body
+
+ _
+ (#Form (#Cons (#Ident "lux;lambda")
+ (#Cons (#Tuple args')
+ (#Cons body #Nil)))))
+ #Nil))))))
[(#Cons output #Nil) state]))))
(annotate def Macro)
(def' def
(lambda [tokens state]
- (let' output (case tokens
- (#Cons (#Ident name) (#Cons body #Nil))
- (#Form (#Cons (#Ident "def'")
- (#Cons (#Ident name)
- (#Cons body #Nil))))
-
- (#Cons (#Form (#Cons (#Ident name) args))
- (#Cons body #Nil))
- (#Form (#Cons (#Ident "def'")
- (#Cons (#Ident name)
- (#Cons (#Form (#Cons (#Ident "lux:lambda")
- (#Cons (#Ident name)
- (#Cons (#Tuple args)
- (#Cons body #Nil)))))
- #Nil)))))
- [(#Cons output #Nil) state])))
+ (let' output (case' tokens
+ (#Cons (#Ident name) (#Cons body #Nil))
+ (#Form (#Cons (#Ident "def'")
+ (#Cons (#Ident name)
+ (#Cons body #Nil))))
+
+ (#Cons (#Form (#Cons (#Ident name) args))
+ (#Cons body #Nil))
+ (#Form (#Cons (#Ident "def'")
+ (#Cons (#Ident name)
+ (#Cons (#Form (#Cons (#Ident "lux:lambda")
+ (#Cons (#Ident name)
+ (#Cons (#Tuple args)
+ (#Cons body #Nil)))))
+ #Nil)))))
+ [(#Cons output #Nil) state])))
(def (+ x y)
- (jvm:iadd x y))
+ (jvm;iadd x y))
(def (id x)
x)
-(def (fold f init values)
- (case values
- #Nil
- init
-
- (#Cons x xs)
- (fold f (f init x) xs)))
+(def (print x)
+ (jvm;invokevirtual java.io.PrintStream "print" [Object]
+ (jvm;getstatic System out) [x]))
-(def (reverse list)
- (fold (lambda [tail head] (#Cons head tail))
+(def (println x)
+ (jvm;invokevirtual java.io.PrintStream "println" [Object]
+ (jvm;getstatic System out) [x]))
+
+(def (fold f init xs)
+ (do (print "fold ") (print init) (print " ") (println xs)
+ (case' xs
#Nil
- list))
+ init
+
+ (#Cons x xs')
+ (let' init' (f init x)
+ (do (print "init': ") (println init')
+ (fold f init' xs')))
+ #((fold f (f init x) xs'))#
+ )))
+
+(def (reverse list)
+ (do (print "reverse ") (println list)
+ (let' reversed (fold (lambda [tail head]
+ (do (print "reverse/0 ") (print "tail: ") (print tail) (print " head: ") (println head)
+ (#Cons head tail)))
+ #Nil
+ list)
+ (do (print "!reversed ") (println reversed)
+ reversed))))
(annotate list Macro)
(def (list xs state)
- (let' output (fold (lambda [tail head]
- (#Form (#Cons (#Tag "Cons")
- (#Cons head
- (#Cons tail #Nil)))))
- (#Tag "Nil")
- (reverse xs))
- [(#Cons output #Nil) state]))
+ (let' xs' (reverse xs)
+ (let' output (fold (lambda [tail head]
+ (do (print "tail: ") (print tail) (print " head: ") (println head)
+ (#Form (#Cons (#Tag "Cons")
+ (#Cons head
+ (#Cons tail #Nil))))))
+ (#Tag "Nil")
+ (do (print "REVERSED: ") (println xs')
+ xs'))
+ (do (print "output: ") (println output)
+ [(#Cons output #Nil) state]))))
(annotate list+ Macro)
(def (list+ xs state)
- (case (reverse xs)
+ (case' (reverse xs)
#Nil
[#Nil state]
(#Cons last init')
(let' output (fold (lambda [tail head]
- (#Form (#Cons (#Tag "Cons")
- (#Cons head tail))))
+ (#Form (#Cons (#Tag "Cons")
+ (#Cons head tail))))
last
init')
[(#Cons output #Nil) state])))
(def (->pairs xs)
- (case xs
+ (case' xs
(#Cons x (#Cons y xs'))
(#Cons [x y] (->pairs xs'))
_
#Nil))
-#((annotate let Macro)
- (def (let tokens state)
- (case tokens
- (#Cons (#Tuple bindings) (#Cons body #Nil))
- (let' output (fold (lambda [body binding]
- (case binding
- [label value]
- (#Form (list (#Ident "let'") label value body))))
- body
- (reverse (->pairs bindings)))
- [(list output) state]))))#
-
(annotate let Macro)
(def (let tokens state)
- (case tokens
- (#Cons (#Tuple bindings) (#Cons body #Nil))
- (let' output (fold (lambda [body binding]
- (case binding
- [label value]
- (#Form (#Cons (#Ident "let'") (#Cons label (#Cons value (#Cons body #Nil)))))))
- body
- (reverse (->pairs bindings)))
- [(list output) state])))
-
-(def (++ xs ys)
- (case xs
+ (case' tokens
+ (#Cons (#Tuple bindings) (#Cons body #Nil))
+ (let' output (fold (lambda [body binding]
+ (case binding
+ [label value]
+ (#Form (list (#Ident "let'") label value body))))
+ body
+ (reverse (->pairs bindings)))
+ [(list output) state])))
+
+(def (++-list xs ys)
+ (case' xs
#Nil
ys
(#Cons x xs*)
- (#Cons x (++ xs* ys))))
+ (#Cons x (++-list xs* ys))))
-(def (map f xs)
- (case xs
+(def (map-list f xs)
+ (case' xs
#Nil
#Nil
(#Cons x xs*)
- (#Cons (f x) (map f xs*))))
+ (#Cons (f x) (map-list f xs*))))
#(
- (def (untemplate-list untemplate tokens)
- (case tokens
- #Nil
- (#Tag "Nil")
+(def (untemplate-list untemplate tokens)
+(case tokens
+#Nil
+(#Tag "Nil")
+
+(#Cons token tokens')
+(#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens')))))
+
+(def (untemplate token)
+(case token
+(#Bool elem)
+(#Form (list (#Tag "Bool") (#Bool elem)))
+
+(#Int elem)
+(#Form (list (#Tag "Int") (#Int elem)))
+
+(#Real elem)
+(#Form (list (#Tag "Real") (#Real elem)))
+
+(#Char elem)
+(#Form (list (#Tag "Char") (#Char elem)))
- (#Cons token tokens')
- (#Form (list (#Tag "Cons") (untemplate token) (untemplate-list untemplate tokens')))))
+(#Text elem)
+(#Form (list (#Tag "Text") (#Text elem)))
- (def (untemplate token)
- (case token
- (#Bool elem)
- (#Form (list (#Tag "Bool") (#Bool elem)))
+(#Tag elem)
+(#Form (list (#Tag "Tag") (#Text elem)))
- (#Int elem)
- (#Form (list (#Tag "Int") (#Int elem)))
+(#Ident elem)
+(#Form (list (#Tag "Ident") (#Text elem)))
- (#Real elem)
- (#Form (list (#Tag "Real") (#Real elem)))
+(#Form (#Cons (#Ident "~") (#Cons unquoted #Nil)))
+unquoted
+
+(#Tuple elems)
+(#Form (list (#Tag "Tuple") (untemplate-list untemplate elems)))
+
+(#Form elems)
+(#Form (list (#Tag "Form") (untemplate-list untemplate elems)))
+))
+
+
+## I/O
+(def (print x)
+(jvm;invokevirtual java.io.PrintStream "print" [Object]
+(jvm;getstatic System out) [x]))
+
+(def (println x)
+(jvm;invokevirtual java.io.PrintStream "println" [Object]
+(jvm;getstatic System out) [x]))
+
+(annotate ' Macro)
+(def (' form)
+(case form
+(#Cons token #Nil)
+(untemplate token)))
+
+(def (+ x y)
+(jvm;iadd x y))
+
+(def inc (+ 1))
+
+(def length (fold (lambda' l (lambda' x (inc l))) 0))
+
+(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 (concat t1 t2)
+(jvm;invokevirtual String "concat" [String]
+t1 [t2]))
+
+(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
- (#Char elem)
- (#Form (list (#Tag "Char") (#Char elem)))
+(#Cons x xs')
+(#Cons x (++ xs' ys)))))
- (#Text elem)
- (#Form (list (#Tag "Text") (#Text elem)))
+(: map (All [a b] (-> (-> a b) (List a) (List b))))
- (#Tag elem)
- (#Form (list (#Tag "Tag") (#Text elem)))
-
- (#Ident elem)
- (#Form (list (#Tag "Ident") (#Text elem)))
-
- (#Form (#Cons (#Ident "~") (#Cons unquoted #Nil)))
- unquoted
-
- (#Tuple elems)
- (#Form (list (#Tag "Tuple") (untemplate-list untemplate elems)))
-
- (#Form elems)
- (#Form (list (#Tag "Form") (untemplate-list untemplate elems)))
- ))
-
-
- ## I/O
- (def (print x)
- (jvm:invokevirtual java.io.PrintStream "print" [Object]
- (jvm:getstatic System out) [x]))
-
- (def (println x)
- (jvm:invokevirtual java.io.PrintStream "println" [Object]
- (jvm:getstatic System out) [x]))
-
- (annotate ' Macro)
- (def (' form)
- (case form
- (#Cons token #Nil)
- (untemplate token)))
-
- (def (+ x y)
- (jvm:iadd x y))
-
- (def inc (+ 1))
-
- (def length (fold (lambda' l (lambda' x (inc l))) 0))
-
- (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 (concat t1 t2)
- (jvm:invokevirtual String "concat" [String]
- t1 [t2]))
-
- (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'))
- (#Cons x (#Cons elem (#Cons y list')))
-
- _
- list))
-
- (def (show-list xs)
- (case xs
- #Nil
- "#Nil"
- (#Cons x xs')
- (fold concat "" (list "(#Cons " (show x) " " (show-list xs') ")"))))
-
- )#
+(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)))
+)#
+
+#(
+(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)))
+)#
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 15:14:07 +0000