From 38fe9e91f451d9682ff7edf65fc395b85ddde961 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 10 Feb 2015 02:04:46 -0400 Subject: Super refactoring that breaks the system: Part 1 --- source/lux.lux | 1008 +++++++++++++++++++++++++++++++++++------------- source/luxc/lexer.lux | 119 ++++++ source/luxc/parser.lux | 72 ++++ source/luxc/util.lux | 169 ++++++++ source/util.lux | 169 -------- 5 files changed, 1107 insertions(+), 430 deletions(-) create mode 100644 source/luxc/lexer.lux create mode 100644 source/luxc/parser.lux create mode 100644 source/luxc/util.lux delete mode 100644 source/util.lux (limited to 'source') 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 ))) + +(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)) + +(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 + (Session [] [] )) + +(def << + (lambda [k session] + (k [] session))) + +(def (>> val) + (lambda [k session] + (session val k))) + +(<$> << (>> 5)) + +(def (<$> consumer producer) + (producer [] consumer)) + +(HList Int (HList Int )) + +(<.> (? Int) (? Int) (! Int) ) +(def fn-session + (do [x << + y <<] + (>> (+ x y)))) + +(<.> (! Int) (! Int) (? Int) ) +(def call-session + (do [_ (>> 5) + _ (>> 10)] + <<)) + +(<$> fn-session call-session) + +(def << + (lambda [chan] + (chan (lambda [])))) + +(def (>> value) + (lambda [chan] + (chan value))) +)# diff --git a/source/luxc/lexer.lux b/source/luxc/lexer.lux new file mode 100644 index 000000000..ed86be68f --- /dev/null +++ b/source/luxc/lexer.lux @@ -0,0 +1,119 @@ +(use ./util #as &util #refer [do return fail try-all]) + +## [Utils] +(def (lex-regex regex) + ...) + +(def (lex-regex2 regex) + ...) + +(def (lex-prefix prefix) + ...) + +(def (escape-char escaped) + (case escaped + "\\t" (return "\t") + "\\b" (return "\b") + "\\n" (return "\n") + "\\r" (return "\r") + "\\f" (return "\f") + "\\\"" (return "\"") + "\\\\" (return "\\") + _ (fail (fold concat "" (list "[Lexer Error] Unknown escape character: " escaped))))) + +(defrec lex-text-body + (try-all (list (do [[prefix escaped] (lex-regex2 "(?s)^([^\\\"\\\\]*)(\\\\.)") + unescaped (escape-char escaped) + postfix lex-text-body] + (return (str prefix unescaped postfix))) + (lex-regex "(?s)^([^\\\"\\\\]*)^")))) + +(def +ident-re+ ...) + +## [Lexers] +(def lex-white-space + (do [white-space (lex-regex #"^(\s+)")] + (return (#White-Space white-space)))) + +(def lex-single-line-comment + (do [_ (lex-prefix "##") + comment (lex-regex #"^([^\n]*)") + _ (lex-regex #"^(\n?)")] + (return (#Comment comment)))) + +(def lex-multi-line-comment + (do [_ (lex-prefix "#(") + comment (try-all (list (lex-regex #"(?is)^((?!#\().)*?(?=\)#)") + (do [pre (lex-regex #"(?is)^(.+?(?=#\())") + [_ inner] lex-multi-line-comment + post (lex-regex #"(?is)^(.+?(?=\)#))")] + (return (fold concat "" (list pre "#(" inner ")#" post)))))) + _ (lex-prefix ")#")] + (return (#Comment comment)))) + +(def lex-comment + (try-all (list lex-single-line-comment + lex-multi-line-comment))) + +(do-template [ ] + (def + (do [token (lex-regex )] + (return ( token)))) + + lex-bool #Bool #"^(true|false)" + lex-real #Real #"^(0|[1-9][0-9]*)\.[0-9]+" + lex-int #Int #"^(0|[1-9][0-9]*)" + lex-ident #Ident +ident-re+) + +(def lex-char + (do [_ (lex-prefix "#\"") + token (try-all (list (do [escaped (lex-regex #"^(\\.)")] + (escape-char escaped)) + (lex-regex #"^(.)"))) + _ (lex-prefix "\"")] + (return (#Char token)))) + +(def lex-text + (do [_ (lex-prefix "\"") + token lex-text-body + _ (lex-prefix "\"")] + (return (#Text token)))) + +(def lex-tag + (do [_ (lex-prefix "#") + token (lex-regex +ident-re+)] + (return (#Tag token)))) + +(do-template [ ] + (def + (do [_ (lex-prefix )] + (return ))) + + lex-open-paren "(" #Open-Paren + lex-close-paren ")" #Close-Paren + lex-open-bracket "[" #Open-Bracket + lex-close-bracket "]" #Close-Bracket + lex-open-brace "{" #Open-Brace + lex-close-brace "}" #Close-Brace + ) + +(def lex-delimiter + (try-all (list lex-open-paren + lex-close-paren + lex-open-bracket + lex-close-bracket + lex-open-brace + lex-close-brace))) + +;; [Interface] +(def #export lex + (try-all (list lex-white-space + lex-comment + lex-bool + lex-real + lex-int + lex-char + lex-text + lex-ident + lex-tag + lex-delimiter))) diff --git a/source/luxc/parser.lux b/source/luxc/parser.lux new file mode 100644 index 000000000..35ec12b17 --- /dev/null +++ b/source/luxc/parser.lux @@ -0,0 +1,72 @@ +(use ./util #as &util #refer [do return fail try-all repeat]) +(use ./lexer #as &lexer) + +;; [Utils] +(do-template [ ] + (def ( parse) + (do [elems (repeat parse) + token &lexer:lex] + (case token + + (return (list ( (fold ++ (list) elems)))) + + _ + (fail (concat (list "[Parser Error] Unbalanced " ".")))))) + + parse-form #&lexer:Close-Paren "parantheses" #Form + parse-tuple #&lexer:Close-Bracket "brackets" #Tuple + ) + +(def (parse-record parse) + (do [elems* (repeat parse) + token &lexer:lex + #let [elems (fold ++ (list) elems*)]] + (case token + #&lexer:Close-Bracket + (if (odd? (size elems)) + (fail "[Parser Error] Records must have an even number of elements.") + (return (list (#Record elems)))) + + _ + (fail "[Parser Error] Unbalanced braces.")))) + +;; [Interface] +(def parse + (do [token &lexer/lex] + (match token + (#&lexer:White-Space _) + (return (list)) + + (#&lexer:Comment _) + (return (list)) + + (#&lexer:Bool ?value) + (return (list [#Bool (jvm:invokestatic Boolean "parseBoolean" [String] [?value])])) + + (#&lexer:Int ?value) + (return (list [#Int (jvm:invokestatic Integer "parseInt" [String] [?value])])) + + (#&lexer:Real ?value) + (return (list [#Real (jvm:invokestatic Float "parseFloat" [String] [?value])])) + + (#&lexer:Char ?value) + (return (list [#Char (jvm:invokevirtual String "charAt" [int] ?value [0])])) + + (#&lexer:Text ?value) + (return (list [#Text ?value])) + + (#&lexer:Ident ?value) + (return (list [#Ident ?value])) + + (#&lexer:Tag ?value) + (return (list [#Tag ?value])) + + #&lexer:Open-Paren + (parse-form parse) + + #&lexer:Open-Bracket + (parse-tuple parse) + + #&lexer:Open-Brace + (parse-record parse) + ))) diff --git a/source/luxc/util.lux b/source/luxc/util.lux new file mode 100644 index 000000000..88b035571 --- /dev/null +++ b/source/luxc/util.lux @@ -0,0 +1,169 @@ +(def (fail* message) + (#Failure message)) + +(def (return* state value) + (#Ok [state value])) + +(def (fail message) + (lambda [state] + (#Failure message))) + +(def (return value) + (lambda [state] + (#Ok [state value]))) + +(def (bind m-value step) + (lambda [state] + (let inputs (m-value state) + (case inputs + (#Ok [?state ?datum]) + (step ?datum ?state) + + _ + inputs)))) + +## Ideally, this is what I want... +## (exec [yolo lol +## #let [foo (bar 1 2 3)]] +## (meme yolo foo)) + +(defmacro (exec tokens) + (case tokens + (#Cons (#Tuple steps) (#Cons value #Nil)) + (fold (lambda [inner pair] + (case pair + [label computation] + (' (bind (~ computation) (lambda [(~ label)] (~ inner)))))) + value + (pairs steps)))) + +(def (try-m monad) + (lambda [state] + (case (monad state) + (#Ok [?state ?datum]) + (return* ?state (#Just ?datum)) + + (#Failure _) + (return* state #Nothing)))) + +(def (repeat-m monad) + (lambda [state] + (case (monad state) + (#Ok [?state ?head]) + (case ((repeat-m monad) ?state) + (#Ok [?state* ?tail]) + (return* ?state* (#Cons ?head ?tail))) + + (#Failure ?message) + (return* state #Nil)))) + +(def (try-all-m monads) + (lambda [state] + (case monads + #Nil + (fail* "No alternative worked!") + (#Cons monad monads') + (let output (monad state) + (case output + (#Ok _) + output + + (#Failure _) + (case monads' + #Nil + output + (#Cons _ _) + ((try-all-m monads') state)) + )) + ))) + +(def (map-m f inputs) + (case inputs + #Nil + (return #Nil) + (#Cons input inputs') + (exec [output (f input) + outputs (map-m f inputs')] + (return (#Cons output outputs))))) + +(def (fold-m f init inputs) + (case inputs + #Nil (return init) + (#Cons x inputs') (exec [init* (f init x)] + (fold-m f init* inputs')))) + +(def (apply-m monad call-state) + (lambda [state] + (let output (monad call-state) + (case output + (#Ok [?state ?datum]) + (#Ok [state ?datum]) + + _ + output)))) + +(def (assert test message) + (if test + (return []) + (fail message))) + +(def (pass %value) + (lambda [state] + %value)) + +(def get-state + (lambda [state] + (return* state state))) + +(def (normalize-char char) + (case char + #"*" "_ASTER_" + #"+" "_PLUS_" + #"-" "_DASH_" + #"/" "_SLASH_" + #"_" "_UNDERS_" + #"%" "_PERCENT_" + #"$" "_DOLLAR_" + #"'" "_QUOTE_" + #"`" "_BQUOTE_" + #"@" "_AT_" + #"^" "_CARET_" + #"&" "_AMPERS_" + #"=" "_EQ_" + #"!" "_BANG_" + #"?" "_QM_" + #":" "_COLON_" + #";" "_SCOLON_" + #"." "_PERIOD_" + #"," "_COMMA_" + #"<" "_LT_" + #">" "_GT_" + #"~" "_TILDE_" + ##;;#"\" "_BSLASH_" + _ (show char) + )) + +(def (normalize-ident ident) + (fold concat "" (map normalize-char (text->list ident)))) + +(def (within slot monad) + (lambda [state] + (let =return (monad (get slot state)) + (case =return + (#Ok ?state ?value) + (#Ok (put slot ?state state) ?value) + + _ + =return)))) + +(def (run-state monad state) + (monad state)) + +(def (fresh-class-loader path) + (let file (jvm/new java.io.File [String] [path]) + (let url (jvm/invokevirtual java.io.File "toURL" [] + file []) + (let urls (jvm/new-array java.net.URL 1) + (do (jvm/aastore urls 0 url) + (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))) + )) diff --git a/source/util.lux b/source/util.lux deleted file mode 100644 index 88b035571..000000000 --- a/source/util.lux +++ /dev/null @@ -1,169 +0,0 @@ -(def (fail* message) - (#Failure message)) - -(def (return* state value) - (#Ok [state value])) - -(def (fail message) - (lambda [state] - (#Failure message))) - -(def (return value) - (lambda [state] - (#Ok [state value]))) - -(def (bind m-value step) - (lambda [state] - (let inputs (m-value state) - (case inputs - (#Ok [?state ?datum]) - (step ?datum ?state) - - _ - inputs)))) - -## Ideally, this is what I want... -## (exec [yolo lol -## #let [foo (bar 1 2 3)]] -## (meme yolo foo)) - -(defmacro (exec tokens) - (case tokens - (#Cons (#Tuple steps) (#Cons value #Nil)) - (fold (lambda [inner pair] - (case pair - [label computation] - (' (bind (~ computation) (lambda [(~ label)] (~ inner)))))) - value - (pairs steps)))) - -(def (try-m monad) - (lambda [state] - (case (monad state) - (#Ok [?state ?datum]) - (return* ?state (#Just ?datum)) - - (#Failure _) - (return* state #Nothing)))) - -(def (repeat-m monad) - (lambda [state] - (case (monad state) - (#Ok [?state ?head]) - (case ((repeat-m monad) ?state) - (#Ok [?state* ?tail]) - (return* ?state* (#Cons ?head ?tail))) - - (#Failure ?message) - (return* state #Nil)))) - -(def (try-all-m monads) - (lambda [state] - (case monads - #Nil - (fail* "No alternative worked!") - (#Cons monad monads') - (let output (monad state) - (case output - (#Ok _) - output - - (#Failure _) - (case monads' - #Nil - output - (#Cons _ _) - ((try-all-m monads') state)) - )) - ))) - -(def (map-m f inputs) - (case inputs - #Nil - (return #Nil) - (#Cons input inputs') - (exec [output (f input) - outputs (map-m f inputs')] - (return (#Cons output outputs))))) - -(def (fold-m f init inputs) - (case inputs - #Nil (return init) - (#Cons x inputs') (exec [init* (f init x)] - (fold-m f init* inputs')))) - -(def (apply-m monad call-state) - (lambda [state] - (let output (monad call-state) - (case output - (#Ok [?state ?datum]) - (#Ok [state ?datum]) - - _ - output)))) - -(def (assert test message) - (if test - (return []) - (fail message))) - -(def (pass %value) - (lambda [state] - %value)) - -(def get-state - (lambda [state] - (return* state state))) - -(def (normalize-char char) - (case char - #"*" "_ASTER_" - #"+" "_PLUS_" - #"-" "_DASH_" - #"/" "_SLASH_" - #"_" "_UNDERS_" - #"%" "_PERCENT_" - #"$" "_DOLLAR_" - #"'" "_QUOTE_" - #"`" "_BQUOTE_" - #"@" "_AT_" - #"^" "_CARET_" - #"&" "_AMPERS_" - #"=" "_EQ_" - #"!" "_BANG_" - #"?" "_QM_" - #":" "_COLON_" - #";" "_SCOLON_" - #"." "_PERIOD_" - #"," "_COMMA_" - #"<" "_LT_" - #">" "_GT_" - #"~" "_TILDE_" - ##;;#"\" "_BSLASH_" - _ (show char) - )) - -(def (normalize-ident ident) - (fold concat "" (map normalize-char (text->list ident)))) - -(def (within slot monad) - (lambda [state] - (let =return (monad (get slot state)) - (case =return - (#Ok ?state ?value) - (#Ok (put slot ?state state) ?value) - - _ - =return)))) - -(def (run-state monad state) - (monad state)) - -(def (fresh-class-loader path) - (let file (jvm/new java.io.File [String] [path]) - (let url (jvm/invokevirtual java.io.File "toURL" [] - file []) - (let urls (jvm/new-array java.net.URL 1) - (do (jvm/aastore urls 0 url) - (jvm/new java.net.URLClassLoader [(Array java.net.URL)] [urls])))) - )) -- cgit v1.2.3