aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux2020
-rw-r--r--src/lux.clj1
-rw-r--r--src/lux/analyser.clj44
-rw-r--r--src/lux/analyser/host.clj30
-rw-r--r--src/lux/analyser/lux.clj63
-rw-r--r--src/lux/base.clj14
-rw-r--r--src/lux/compiler.clj11
-rw-r--r--src/lux/compiler/host.clj12
-rw-r--r--src/lux/compiler/lambda.clj2
-rw-r--r--src/lux/compiler/lux.clj93
-rw-r--r--src/lux/host.clj14
-rw-r--r--src/lux/type.clj598
12 files changed, 1582 insertions, 1320 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 34b15fd49..db579f2d8 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -1,4 +1,4 @@
-## Base interfaces & classes
+## First things first, must define functions
(jvm-interface Function
(: apply (-> [java.lang.Object] java.lang.Object)))
@@ -22,938 +22,1118 @@
## (jvm-invokevirtual lux.Function "apply2" [java.lang.Object java.lang.Object]
## this [arg1 arg2]) [arg3]))]))
-## Base functions & macros
-(def' _meta
- (lambda' _ data
- (#Meta [["" -1 -1] data])))
-
-(def' let'
- (lambda' _ tokens
- (lambda' _ state
- (case' tokens
- (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
- (#Right [state
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "case'"]))
- (#Cons [rhs
- (#Cons [lhs
- (#Cons [body
- #Nil])])])])))
- #Nil])]))
- )))
-(declare-macro let')
-
-(def' lambda
- (lambda' _ tokens
- (lambda' _ state
- (let' output (case' tokens
- (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])
- (_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"]))
- (#Cons [(_meta (#Symbol ["" ""]))
- (#Cons [arg
- (#Cons [(case' args'
- #Nil
- body
-
- _
- (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
- (#Cons [(_meta (#Tuple args'))
- (#Cons [body #Nil])])]))))
- #Nil])])])])))
-
- (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])])
- (_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"]))
- (#Cons [(_meta (#Symbol self))
- (#Cons [arg
- (#Cons [(case' args'
- #Nil
- body
-
- _
- (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
- (#Cons [(_meta (#Tuple args'))
- (#Cons [body #Nil])])]))))
- #Nil])])])]))))
- (#Right [state (#Cons [output #Nil])]))
- )))
-(declare-macro lambda)
-
-(def' def
- (lambda [tokens state]
- (let' output (case' tokens
- (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [body #Nil])])
- (_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) tokens])))
-
- (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))])
- (#Cons [body #Nil])])
- (_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
- (#Cons [(_meta (#Symbol name))
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
- (#Cons [(_meta (#Symbol name))
- (#Cons [(_meta (#Tuple args))
- (#Cons [body #Nil])])])])))
- #Nil])])]))))
- (#Right [state (#Cons [output #Nil])]))))
-(declare-macro def)
-
-(def (defmacro tokens state)
- (let' [fn-name fn-def] (case' tokens
- (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol fn-name)]) args]))])
- (#Cons [body #Nil])])
- [fn-name
- (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "def"]))
- (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol fn-name)) args])))
- (#Cons [body
- #Nil])])])))])
- (let' declaration (_meta (#Form (#Cons [(_meta (#Symbol ["" "declare-macro"])) (#Cons [(_meta (#Symbol fn-name)) #Nil])])))
- (#Right [state (#Cons [fn-def (#Cons [declaration #Nil])])]))))
-(declare-macro defmacro)
-
-(defmacro (comment tokens state)
- (#Right [state #Nil]))
-
-(def (int+ x y)
- (jvm-ladd 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]))
-
-(def (println x)
- (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object]
- (jvm-getstatic java.lang.System "out") [x]))
-
-(def (fold f init xs)
- (case' xs
- #Nil
- init
-
- (#Cons [x xs'])
- (fold f (f init x) xs')))
-
-(def (reverse list)
- (fold (lambda [tail head]
- (#Cons [head tail]))
- #Nil
- list))
-
-(defmacro (list xs state)
- (let' xs' (reverse xs)
- (let' output (fold (lambda [tail head]
- (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"]))
- (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])])))
- #Nil])]))))
- (_meta (#Tag ["lux" "Nil"]))
- xs')
- (#Right [state (#Cons [output #Nil])]))))
-
-(defmacro (list+ xs state)
- (case' (reverse xs)
- #Nil
- [#Nil state]
-
- (#Cons [last init'])
- (let' output (fold (lambda [tail head]
- (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) (_meta (#Tuple (list head tail)))))))
- last
- init')
- (#Right [state (#Cons [output #Nil])]))))
-
-(def (as-pairs xs)
- (case' xs
- (#Cons [x (#Cons [y xs'])])
- (#Cons [[x y] (as-pairs xs')])
-
- _
- #Nil))
-
-(defmacro (let tokens state)
- (case' tokens
- (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])
- (let' output (fold (lambda [body binding]
- (case' binding
- [label value]
- (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))
- body
- (reverse (as-pairs bindings)))
- (#Right [state (list output)]))))
-
-(def (. f g)
- (lambda [x] (f (g x))))
-
-(def (++ xs ys)
- (case' xs
- #Nil
- ys
-
- (#Cons [x xs'])
- (#Cons [x (++ xs' ys)])))
-
-(def concat
- (fold ++ #Nil))
-
-(def (map f xs)
- (case' xs
- #Nil
- #Nil
-
- (#Cons [x xs'])
- (#Cons [(f x) (map f xs')])))
-
-(def flat-map (. concat map))
-
-(def (wrap-meta content)
- (_meta (#Form (list (_meta (#Tag ["lux" "Meta"]))
- (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text "")))))
- (_meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int -1)))))
- (_meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int -1))))))))
- (_meta content))))))))
-
-(def (untemplate-list tokens)
- (case' tokens
- #Nil
- (_meta (#Tag ["lux" "Nil"]))
-
- (#Cons [token tokens'])
- (_meta (#Form (list (_meta (#Tag ["lux" "Cons"]))
- (_meta (#Tuple (list token (untemplate-list tokens')))))))))
-
-(def (untemplate token)
- (case' token
- (#Meta [_ (#Bool value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value)))))
-
- (#Meta [_ (#Int value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value)))))
-
- (#Meta [_ (#Real value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value)))))
-
- (#Meta [_ (#Char value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value)))))
-
- (#Meta [_ (#Text value)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value)))))
-
- (#Meta [_ (#Tag [module name])])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
-
- (#Meta [_ (#Symbol [module name])])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
-
- (#Meta [_ (#Tuple elems)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tuple"])) (untemplate-list (map untemplate elems)))))
-
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol [_ "~"])]) (#Cons [(#Meta [_ unquoted]) #Nil])]))])
- (_meta unquoted)
-
- (#Meta [_ (#Form elems)])
- (wrap-meta (#Form (list (_meta (#Tag ["lux" "Form"])) (untemplate-list (map untemplate elems)))))
- ))
-
-(defmacro (` tokens state)
- (case' tokens
- (#Cons [template #Nil])
- (#Right [state (list (untemplate template))])))
-
-(defmacro (if tokens state)
- (case' tokens
- (#Cons [test (#Cons [then (#Cons [else #Nil])])])
- (#Right [state
- (list (` (case' (~ test)
- true (~ then)
- false (~ else))))])))
-
-(def (filter p xs)
- (case' xs
- #Nil
- #Nil
-
- (#Cons [x xs'])
- (if (p x)
- (#Cons [x (filter p xs')])
- (filter p xs'))))
-
-(def (return val)
- (lambda [state]
- (#Right [state val])))
-
-(def (fail msg)
- (lambda [_]
- (#Left msg)))
-
-(def (bind f v)
- (lambda [state]
- (case' (v state)
- (#Right [state' x])
- (f x state')
-
- (#Left msg)
- (#Left msg))))
-
-(def (first pair)
- (case' pair
- [f s]
- f))
-
-(def (second pair)
- (case' pair
- [f s]
- s))
-
-(defmacro (loop tokens)
- (case' tokens
- (#Cons [bindings (#Cons [body #Nil])])
- (let [pairs (as-pairs bindings)]
- (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["lux" "recur"])) (~ (#Tuple (map first pairs)))
- (~ body)))
- (map second pairs)])))))))
-
-(defmacro (export tokens)
- (return (map (lambda [t] (` (export' (~ t))))
- tokens)))
-
-(defmacro (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))))
-
-(defmacro (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))))
-
-(def (not x)
- (case' x
- true false
- false true))
-
-(defmacro (|> tokens)
- (case' tokens
- (#Cons [init apps])
- (return (list (fold (lambda [acc app]
- (case' app
- (#Form parts)
- (#Form (++ parts (list acc)))
-
- _
- (` ((~ app) (~ acc)))))
- init
- apps)))))
-
-(defmacro ($ tokens)
- (case' tokens
- (#Cons [op (#Cons [init args])])
- (return (list (fold (lambda [acc elem]
- (` ((~ op) (~ acc) (~ elem))))
- init
- args)))))
-
-(def (const x)
- (lambda [_] x))
-
-(def (int> x y)
- (jvm-lgt x y))
-
-(def (int< x y)
- (jvm-llt x y))
-
-(def inc (int+ 1))
-(def dec (int+ -1))
-
-(def (repeat n x)
- (if (int> n 0)
- (#Cons [x (repeat (dec n) x)])
- #Nil))
-
-(def size
- (fold (lambda [acc _] (inc acc)) 0))
-
-(def (last xs)
- (case' xs
- #Nil #None
- (#Cons [x #Nil]) (#Some x)
- (#Cons [_ xs']) (last xs')))
-
-(def (init xs)
- (case' xs
- #Nil #None
- (#Cons [_ #Nil]) (#Some #Nil)
- (#Cons [x xs']) (case' (init xs')
- (#Some xs'')
- (#Some (#Cons [x xs'']))
-
- _
- (#Some (#Cons [x #Nil])))))
-
-(defmacro (cond tokens)
- (case' (reverse tokens)
- (#Cons [else branches'])
- (return (list (fold (lambda [else branch]
- (case' branch
- [test then]
- (` (if (~ test) (~ then) (~ else)))))
- else
- (|> branches' reverse as-pairs))))))
-
-(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
- #Nil
- xs
-
- (#Cons [x #Nil])
- xs
-
- (#Cons [x xs'])
- (list+ x sep (interpose sep 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 (int< from to)
- (#Cons [from (range (inc from) to)])
- #Nil))
-
-(def (tuple->list tuple)
- (case' tuple
- (#Meta [_ (#Tuple list)])
- list))
-
-(def (zip2 xs ys)
- (case' [xs ys]
- [(#Cons [x xs']) (#Cons [y ys'])]
- (#Cons [[x y] (zip2 xs' ys')])
-
- _
- #Nil))
-
-(def (get key map)
- (case' map
- #Nil
- #None
-
- (#Cons [[k v] map'])
- (if (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object]
- k [key])
- (#Some v)
- (get key map'))))
-
-(def (get-ident x)
- (case' x
- (#Meta [_ (#Symbol [_ ident])])
- ident))
-
-(def (text-++ x y)
- (jvm-invokevirtual java.lang.String "concat" [java.lang.String]
- x [y]))
-
-(def (show-env env)
- (|> env (map first) (interpose ", ") (fold text-++ "")))
-
-(def (apply-template env template)
- (case' template
- (#Meta [_ (#Symbol [_ ident])])
- (case' (get ident env)
- (#Some subst)
- subst
-
- _
- template)
-
- (#Meta [_ (#Tuple elems)])
- (_meta (#Tuple (map (apply-template env) elems)))
-
- (#Meta [_ (#Form elems)])
- (_meta (#Form (map (apply-template env) elems)))
-
- (#Meta [_ (#Record members)])
- (_meta (#Record (map (lambda [kv]
- (case' kv
- [slot value]
- [(apply-template env slot) (apply-template env value)]))
- members)))
-
- _
- template))
-
-(defmacro (do-template tokens)
- (case' tokens
- (#Cons [bindings (#Cons [template data])])
- (let [bindings-list (map get-ident (tuple->list bindings))
- data-lists (map tuple->list data)
- apply (lambda [env] (apply-template env template))]
- (|> data-lists
- (map (. apply (zip2 bindings-list)))
- return))))
-
-## ## ## (do-template [<name> <offset>]
-## ## ## (def <name> (int+ <offset>))
-
-## ## ## [inc 1]
-## ## ## [dec -1])
-
-(def (int= x y)
- (jvm-leq x y))
-
-(def (int% x y)
- (jvm-lrem x y))
-
-(def (int>= x y)
- (or (int= x y)
- (int> x y)))
-
-(do-template [<name> <cmp>]
- (def (<name> x y)
- (if (<cmp> x y)
- x
- y))
-
- [max int>]
- [min int<])
-
-(do-template [<name> <cmp>]
- (def (<name> n) (<cmp> n 0))
-
- [neg? int<]
- [pos? int>=])
-
-(def (even? n)
- (int= 0 (int% n 0)))
-
-(def (odd? n)
- (not (even? n)))
-
-(do-template [<name> <done> <step>]
- (def (<name> n xs)
- (if (int> n 0)
- (case' xs
- #Nil #Nil
- (#Cons [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
- (#Cons [x xs']) (if (f x) <step> #Nil)))
-
- [take-while #Nil (list+ x (take-while f xs'))]
- [drop-while xs (drop-while f xs')])
-
-(defmacro (get@ tokens)
- (let [output (case' tokens
- (#Cons [tag (#Cons [record #Nil])])
- (` (get@' (~ tag) (~ record)))
-
- (#Cons [tag #Nil])
- (` (lambda [record] (get@' (~ tag) record))))]
- (return (list output))))
-
-(defmacro (set@ tokens)
- (let [output (case' tokens
- (#Cons [tag (#Cons [value (#Cons [record #Nil])])])
- (` (set@' (~ tag) (~ value) (~ record)))
-
- (#Cons [tag (#Cons [value #Nil])])
- (` (lambda [record] (set@' (~ tag) (~ value) record)))
-
- (#Cons [tag #Nil])
- (` (lambda [value record] (set@' (~ tag) value record))))]
- (return (list output))))
-
-(defmacro (update@ tokens)
- (let [output (case' tokens
- (#Cons [tag (#Cons [func (#Cons [record #Nil])])])
- (` (let [_record_ (~ record)]
- (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_)))
-
- (#Cons [tag (#Cons [func #Nil])])
- (` (lambda [record]
- (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record))))
-
- (#Cons [tag #Nil])
- (` (lambda [func record]
- (set@' (~ tag) (func (get@' (~ tag) record)) record))))]
- (return (list output))))
-
-(def (show-int int)
- (jvm-invokevirtual java.lang.Object "toString" []
- int []))
-## (def gensym
-## (lambda [state]
-## [(update@ #gen-seed inc state)
-## (#Symbol ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))]))
-
-## (do-template [<name> <member>]
-## (def (<name> pair)
-## (case' pair
-## [f s]
-## <member>))
-
-## [first f]
-## [second s])
-
-(def (show-syntax syntax)
- (case' syntax
- (#Meta [_ (#Bool value)])
- (jvm-invokevirtual java.lang.Object "toString" []
- value [])
-
- (#Meta [_ (#Int value)])
- (jvm-invokevirtual java.lang.Object "toString" []
- value [])
-
- (#Meta [_ (#Real value)])
- (jvm-invokevirtual java.lang.Object "toString" []
- value [])
-
- (#Meta [_ (#Char value)])
- (jvm-invokevirtual java.lang.Object "toString" []
- value [])
-
- (#Meta [_ (#Text value)])
- (jvm-invokevirtual java.lang.Object "toString" []
- value [])
-
- (#Meta [_ (#Symbol [module name])])
- ($ text-++ module ";" name)
-
- (#Meta [_ (#Tag [module name])])
- ($ text-++ "#" module ";" name)
-
- (#Meta [_ (#Tuple members)])
- ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]")
-
- (#Meta [_ (#Form members)])
- ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")")
- ))
-
-(defmacro (do tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])
- (let [output (fold (lambda [body binding]
- (case' binding
- [lhs rhs]
- (` (bind (lambda [(~ lhs)] (~ body))
- (~ rhs)))))
- body
- (reverse (as-pairs bindings)))]
- (return (list output)))))
-
-(def (map% f xs)
- (case' xs
- #Nil
- (return xs)
-
- (#Cons [x xs'])
- (do [y (f x)
- ys (map% f xs')]
- (return (#Cons [y ys])))))
-
-(defmacro ($keys tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Tuple fields)]) #Nil])
- (return (list (_meta (#Record (map (lambda [slot]
- (case' slot
- (#Meta [_ (#Tag [module name])])
- [($ text-++ module ";" name) (_meta (#Symbol [module name]))]))
- fields)))))))
-
-(defmacro ($or tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Tuple patterns)]) (#Cons [body #Nil])])
- (return (flat-map (lambda [pattern] (list pattern body))
- patterns))))
-
-(def null jvm-null)
-
-(defmacro (^ tokens)
- (case' tokens
- (#Cons [(#Meta [_ (#Symbol [_ class-name])]) #Nil])
- (return (list (` (#TData [(~ (_meta (#Text class-name))) (list)]))))
-
- (#Cons [(#Meta [_ (#Symbol [_ class-name])]) (#Cons [(#Meta [_ (#Tuple params)]) #Nil])])
- (return (list (` (#TData [(~ (_meta (#Text class-name))) (~ (untemplate-list params))]))))))
-
-(defmacro (, members)
- (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "TTuple"])) (untemplate-list members)))))))
-
-(defmacro (| members)
- (let [members' (map (lambda [m]
- (case' m
- (#Meta [_ (#Tag [module name])])
- [($ text-++ module ";" name) (` (#Tuple (list)))]
-
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))])
- [($ text-++ module ";" name) (` (#Tuple (~ value)))]))
- members)]
- (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "TVariant"])) (untemplate-list members))))))))
-
-(defmacro (& members)
- (let [members' (map (lambda [m]
- (case' m
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))])
- [($ text-++ module ";" name) (` (#Tuple (~ value)))]))
- members)]
- (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "TRecord"])) (untemplate-list members))))))))
-
-(defmacro (-> tokens)
- (case' (reverse tokens)
- (#Cons [f-return f-args])
- (fold (lambda [f-return f-arg]
- (` (#TLambda [(~ f-arg) (~ f-return)])))
- f-return
- f-args)))
-
-(def (text= x y)
- (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object]
- x [y]))
-
-(def (replace-ident ident value syntax)
- (let [[module name] ident]
- (case' syntax
- (#Meta [_ (#Symbol [?module ?name])])
- (if (and (text= module ?module)
- (text= name ?name))
- value
- syntax)
-
- (#Meta [_ (#Form members)])
- (_meta (#Form (map (replace-ident ident value) members)))
-
- (#Meta [_ (#Tuple members)])
- (_meta (#Tuple (map (replace-ident ident value) members)))
-
- (#Meta [_ (#Record members)])
- (_meta (#Record (map (lambda [kv]
- (case' kv
- [k v]
- [k (replace-ident ident value v)]))
- members)))
-
- _
- syntax)))
-
-(defmacro (All tokens)
- (let [[name args body] (case' tokens
- (#Cons [(#Meta [_ (#Symbol [_ name])]) (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])])
- [name args body]
-
- (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
- ["" args body])
- rolled (fold (lambda [body arg]
- (case' arg
- (#Meta [_ (#Symbol [arg-module arg-name])])
- (` (#TAll (list) "" (~ (_meta (#Text arg-name))) (~ (replace-ident [arg-module arg-name]
- (` (#TBound (~ (#Text arg-name))))
- body))))))
- body
- args)]
- (case' rolled
- (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ["lux" "TAll"])]) (#Cons [env (#Cons [(#Meta [_ (#Text "")]) (#Cons [(#Meta [_ (#Text arg-name)]) (#Cons [body #Nil])])])])]))])
- (return (list (` (#TAll (~ env) (~ (#Text name)) (~ (#Text arg-name))
- (~ (replace-ident arg-name (` (#TBound (~ (#Text name))))
- body)))))))))
-
-(defmacro (Exists tokens)
- (case' tokens
- (#Cons [args (#Cons [body #Nil])])
- (return (list (` (All (~ args) (~ body)))))))
-
-(def Any #TAny)
-(def Nothing #TNothing)
-(def Bool (^ java.lang.Boolean))
-(def Int (^ java.lang.Long))
-(def Real (^ java.lang.Double))
-(def Char (^ java.lang.Character))
-(def Text (^ java.lang.String))
+## Basic types
+(def' Any #AnyT)
+(def' Bool (#DataT ["java.lang.Boolean" #Nil]))
+(def' Int (#DataT ["java.lang.Long" #Nil]))
+(def' Real (#DataT ["java.lang.Double" #Nil]))
+(def' Char (#DataT ["java.lang.Character" #Nil]))
+(def' Text (#DataT ["java.lang.String" #Nil]))
## (deftype (List a)
## (| #Nil
## (#Cons (, a (List a)))))
+(def' List
+ (#AllT [#Nil "List" "a"
+ (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)]
+ (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a")
+ (#Cons [(#AppT [(#BoundT "List") (#BoundT "a")])
+ #Nil])]))]
+ #Nil])]))]))
## (deftype #rec Type
-## (| #TAny
-## #TNothing
-## (#TData Text)
-## (#TTuple (List Type))
-## (#TVariant (List (, Text Type)))
-## (#TRecord (List (, Text Type)))
-## (#TLambda (, Type Type))
-## (#TBound Text)
-## (#TVar Int)
-## (#TAll (, (List (, Text Type)) Text Text Type))
-## (#TApp (, Type Type))))
-
-## (deftype (Either l r)
-## (| (#Left l)
-## (#Right r)))
+## (| #AnyT
+## #NothingT
+## (#DataT Text)
+## (#TupleT (List Type))
+## (#VariantT (List (, Text Type)))
+## (#RecordT (List (, Text Type)))
+## (#LambdaT (, Type Type))
+## (#BoundT Text)
+## (#VarT Int)
+## (#AllT (, (List (, Text Type)) Text Text Type))
+## (#AppT (, Type Type))))
+(def' Type
+ (case' (#AppT [(#BoundT "Type") (#BoundT "")])
+ Type
+ (case' (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))])
+ TypeEnv
+ (#AppT [(#AllT [#Nil "Type" ""
+ (#VariantT (#Cons [["lux;AnyT" (#TupleT #Nil)]
+ (#Cons [["lux;NothingT" (#TupleT #Nil)]
+ (#Cons [["lux;DataT" (#TupleT (#Cons [Text (#Cons [(#AppT [List Type]) #Nil])]))]
+ (#Cons [["lux;TupleT" (#AppT [List (#AppT [(#BoundT "Type") (#BoundT "")])])]
+ (#Cons [["lux;VariantT" TypeEnv]
+ (#Cons [["lux;RecordT" TypeEnv]
+ (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
+ (#Cons [["lux;BoundT" Text]
+ (#Cons [["lux;VarT" Int]
+ (#Cons [["lux;AllT" (#TupleT (#Cons [TypeEnv (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))]
+ (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
+ #Nil])])])])])])])])])])]))])
+ #NothingT]))))
+
+## (deftype (Maybe a)
+## (| #None
+## (#Some a)))
+(def' Maybe
+ (#AllT [#Nil "Maybe" "a"
+ (#VariantT (#Cons [["lux;None" (#TupleT #Nil)]
+ (#Cons [["lux;Some" (#BoundT "a")]
+ #Nil])]))]))
+
+## (deftype (Bindings k v)
+## (& #counter Int
+## #mappings (List (, k v))))
+(def' Bindings
+ (#AllT [#Nil "Bindings" "k"
+ (#AllT [#Nil "" "v"
+ (#RecordT (#Cons [["lux;counter" Int]
+ (#Cons [["lux;mappings" (#AppT [List
+ (#TupleT (#Cons [(#BoundT "k")
+ (#Cons [(#BoundT "v")
+ #Nil])]))])]
+ #Nil])]))])]))
+
+## (deftype (Env k v)
+## (& #name Text
+## #inner-closures Int
+## #locals (Bindings k v)
+## #closure (Bindings k v)))
+(def' Env
+ (#AllT [#Nil "Env" "k"
+ (#AllT [#Nil "" "v"
+ (#RecordT (#Cons [["lux;name" Text]
+ (#Cons [["lux;inner-closures" Int]
+ (#Cons [["lux;locals" (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])]
+ (#Cons [["lux;closure" (#AppT [(#AppT [Bindings (#BoundT "k")])
+ (#BoundT "v")])]
+ #Nil])])])]))])]))
+
+## (deftype Cursor
+## (, Text Int Int))
+(def' Cursor
+ (#TupleT (#Cons [Text (#Cons [Int (#Cons [Int #Nil])])])))
+
+## (deftype (Meta m v)
+## (| (#Meta (, m v))))
+(def' Meta
+ (#AllT [#Nil "Meta" "m"
+ (#AllT [#Nil "" "v"
+ (#VariantT (#Cons [["lux;Meta" (#TupleT (#Cons [(#BoundT "m")
+ (#Cons [(#BoundT "v")
+ #Nil])]))]
+ #Nil]))])]))
+
+## (def' Reader
+## (List (Meta Cursor Text)))
+(def' Reader
+ (#AppT [List
+ (#AppT [(#AppT [Meta Cursor])
+ Text])]))
+
+## (deftype CompilerState
+## (& #source (Maybe Reader)
+## #modules (List Any)
+## #module-aliases (List Any)
+## #global-env (Maybe (Env Text Any))
+## #local-envs (List (Env Text Any))
+## #types (Bindings Int Type)
+## #writer (^ org.objectweb.asm.ClassWriter)
+## #loader (^ java.net.URLClassLoader)
+## #eval-ctor Int))
+(def' CompilerState
+ (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])]
+ (#Cons [["lux;modules" (#AppT [List Any])]
+ (#Cons [["lux;module-aliases" (#AppT [List Any])]
+ (#Cons [["lux;global-env" (#AppT [Maybe (#AppT [(#AppT [Env Text]) Any])])]
+ (#Cons [["lux;local-envs" (#AppT [List (#AppT [(#AppT [Env Text]) Any])])]
+ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
+ (#Cons [["lux;writer" (#DataT ["org.objectweb.asm.ClassWriter" #Nil])]
+ (#Cons [["lux;loader" (#DataT ["java.lang.ClassLoader" #Nil])]
+ (#Cons [["lux;eval-ctor" Int]
+ #Nil])])])])])])])])])))
## (deftype #rec Syntax
-## (| (#Bool Bool)
-## (#Int Int)
-## (#Real Real)
-## (#Char Char)
-## (#Text Text)
-## (#Form (List Syntax))
-## (#Tuple (List Syntax))
-## (#Record (List (, Text Syntax)))))
+## (Meta Cursor (| (#Bool Bool)
+## (#Int Int)
+## (#Real Real)
+## (#Char Char)
+## (#Text Text)
+## (#Form (List Syntax))
+## (#Tuple (List Syntax))
+## (#Record (List (, Text Syntax))))))
+(def' Syntax
+ (case' (#AppT [(#BoundT "Syntax") (#BoundT "")])
+ Syntax
+ (case' (#AppT [List Syntax])
+ SyntaxList
+ (#AppT [(#AllT [#Nil "Syntax" ""
+ (#VariantT (#Cons [["lux;Bool" Bool]
+ (#Cons [["lux;Int" Int]
+ (#Cons [["lux;Real" Real]
+ (#Cons [["lux;Char" Char]
+ (#Cons [["lux;Text" Text]
+ (#Cons [["lux;Form" SyntaxList]
+ (#Cons [["lux;Tuple" SyntaxList]
+ (#Cons [["lux;Record" (#AppT [List (#TupleT (#Cons [Text (#Cons [Syntax #Nil])]))])]
+ #Nil])])])])])])])]))])
+ #NothingT]))))
## (deftype Macro
## (-> (List Syntax) CompilerState
-## (Either Text (, CompilerState (List Syntax)))))
+## [CompilerState (List Syntax)]))
+(def' Macro
+ (case' (#AppT [List Syntax])
+ SyntaxList
+ (#LambdaT [SyntaxList
+ (#LambdaT [CompilerState
+ (#TupleT (#Cons [CompilerState (#Cons [SyntaxList #Nil])]))])])))
+
+## Base functions & macros
+## (def (_meta data)
+## (All [a] (-> a (Meta Cursor a)))
+## (#Meta [["" -1 -1] data]))
+(def' _meta
+ (check' (#AllT [#Nil "" "a"
+ (#LambdaT [(#BoundT "a")
+ (#AppT [(#AppT [Meta Cursor])
+ (#BoundT "a")])])])
+ (lambda' _ data
+ (#Meta [["" -1 -1] data]))))
+
+## (def' let'
+## (check' Macro
+## (lambda' _ tokens
+## (lambda' _ state
+## (case' tokens
+## (#Cons [lhs (#Cons [rhs (#Cons [body #Nil])])])
+## (#Right [state
+## (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["" "case'"]))
+## (#Cons [rhs
+## (#Cons [lhs
+## (#Cons [body
+## #Nil])])])])))
+## #Nil])]))
+## ))))
+## (declare-macro let')
+
+## (def' lambda
+## (check' Macro
+## (lambda' _ tokens
+## (lambda' _ state
+## (let' output (case' tokens
+## (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])
+## (_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"]))
+## (#Cons [(_meta (#Symbol ["" ""]))
+## (#Cons [arg
+## (#Cons [(case' args'
+## #Nil
+## body
+
+## _
+## (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
+## (#Cons [(_meta (#Tuple args'))
+## (#Cons [body #Nil])])]))))
+## #Nil])])])])))
+
+## (#Cons [(#Meta [_ (#Symbol self)]) (#Cons [(#Meta [_ (#Tuple (#Cons [arg args']))]) (#Cons [body #Nil])])])
+## (_meta (#Form (#Cons [(_meta (#Symbol ["" "lambda'"]))
+## (#Cons [(_meta (#Symbol self))
+## (#Cons [arg
+## (#Cons [(case' args'
+## #Nil
+## body
+
+## _
+## (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
+## (#Cons [(_meta (#Tuple args'))
+## (#Cons [body #Nil])])]))))
+## #Nil])])])]))))
+## (#Right [state (#Cons [output #Nil])]))
+## ))))
+## (declare-macro lambda)
+
+## (def' def
+## (check' Macro
+## (lambda [tokens state]
+## (let' output (case' tokens
+## (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [body #Nil])])
+## (_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"])) tokens])))
+
+## (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))])
+## (#Cons [body #Nil])])
+## (_meta (#Form (#Cons [(_meta (#Symbol ["" "def'"]))
+## (#Cons [(_meta (#Symbol name))
+## (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol ["lux" "lambda"]))
+## (#Cons [(_meta (#Symbol name))
+## (#Cons [(_meta (#Tuple args))
+## (#Cons [body #Nil])])])])))
+## #Nil])])]))))
+## (#Right [state (#Cons [output #Nil])])))))
+## (declare-macro def)
+
+## (def (defmacro tokens state)
+## (let' [fn-name fn-def] (case' tokens
+## (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol fn-name)]) args]))])
+## (#Cons [body #Nil])])
+## [fn-name
+## (_meta (#Form (#Cons [(_meta (#Symbol ["lux" "def"]))
+## (#Cons [(_meta (#Form (#Cons [(_meta (#Symbol fn-name)) args])))
+## (#Cons [body
+## #Nil])])])))])
+## (let' declaration (_meta (#Form (#Cons [(_meta (#Symbol ["" "declare-macro"])) (#Cons [(_meta (#Symbol fn-name)) #Nil])])))
+## (#Right [state (#Cons [fn-def (#Cons [declaration #Nil])])]))))
+## (declare-macro defmacro)
+
+## (defmacro (comment tokens state)
+## (#Right [state #Nil]))
+
+## (def (int+ x y)
+## (jvm-ladd 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]))
+
+## (def (println x)
+## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object]
+## (jvm-getstatic java.lang.System "out") [x]))
+
+## (def (fold f init xs)
+## (case' xs
+## #Nil
+## init
+
+## (#Cons [x xs'])
+## (fold f (f init x) xs')))
+
+## (def (reverse list)
+## (fold (lambda [tail head]
+## (#Cons [head tail]))
+## #Nil
+## list))
+
+## (defmacro (list xs state)
+## (let' xs' (reverse xs)
+## (let' output (fold (lambda [tail head]
+## (_meta (#Form (#Cons [(_meta (#Tag ["lux" "Cons"]))
+## (#Cons [(_meta (#Tuple (#Cons [head (#Cons [tail #Nil])])))
+## #Nil])]))))
+## (_meta (#Tag ["lux" "Nil"]))
+## xs')
+## (#Right [state (#Cons [output #Nil])]))))
+
+## (defmacro (list+ xs state)
+## (case' (reverse xs)
+## #Nil
+## [#Nil state]
+
+## (#Cons [last init'])
+## (let' output (fold (lambda [tail head]
+## (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) (_meta (#Tuple (list head tail)))))))
+## last
+## init')
+## (#Right [state (#Cons [output #Nil])]))))
+
+## (def (as-pairs xs)
+## (case' xs
+## (#Cons [x (#Cons [y xs'])])
+## (#Cons [[x y] (as-pairs xs')])
+
+## _
+## #Nil))
+
+## (defmacro (let tokens state)
+## (case' tokens
+## (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])
+## (let' output (fold (lambda [body binding]
+## (case' binding
+## [label value]
+## (_meta (#Form (list (_meta (#Symbol ["lux" "let'"])) label value body)))))
+## body
+## (reverse (as-pairs bindings)))
+## (#Right [state (list output)]))))
+
+## (def (. f g)
+## (lambda [x] (f (g x))))
+
+## (def (++ xs ys)
+## (case' xs
+## #Nil
+## ys
+
+## (#Cons [x xs'])
+## (#Cons [x (++ xs' ys)])))
+
+## (def concat
+## (fold ++ #Nil))
+
+## (def (map f xs)
+## (case' xs
+## #Nil
+## #Nil
+
+## (#Cons [x xs'])
+## (#Cons [(f x) (map f xs')])))
+
+## (def flat-map (. concat map))
+
+## (def (wrap-meta content)
+## (_meta (#Form (list (_meta (#Tag ["lux" "Meta"]))
+## (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text "")))))
+## (_meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int -1)))))
+## (_meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int -1))))))))
+## (_meta content))))))))
+
+## (def (untemplate-list tokens)
+## (case' tokens
+## #Nil
+## (_meta (#Tag ["lux" "Nil"]))
+
+## (#Cons [token tokens'])
+## (_meta (#Form (list (_meta (#Tag ["lux" "Cons"]))
+## (_meta (#Tuple (list token (untemplate-list tokens')))))))))
+
+## (def (untemplate token)
+## (case' token
+## (#Meta [_ (#Bool value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Bool"])) (_meta (#Bool value)))))
+
+## (#Meta [_ (#Int value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Int"])) (_meta (#Int value)))))
+
+## (#Meta [_ (#Real value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Real"])) (_meta (#Real value)))))
+
+## (#Meta [_ (#Char value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Char"])) (_meta (#Char value)))))
+
+## (#Meta [_ (#Text value)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Text"])) (_meta (#Text value)))))
+
+## (#Meta [_ (#Tag [module name])])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tag"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
+
+## (#Meta [_ (#Symbol [module name])])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Symbol"])) (_meta (#Tuple (list (_meta (#Text module)) (_meta (#Text name))))))))
+
+## (#Meta [_ (#Tuple elems)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Tuple"])) (untemplate-list (map untemplate elems)))))
+
+## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol [_ "~"])]) (#Cons [(#Meta [_ unquoted]) #Nil])]))])
+## (_meta unquoted)
+
+## (#Meta [_ (#Form elems)])
+## (wrap-meta (#Form (list (_meta (#Tag ["lux" "Form"])) (untemplate-list (map untemplate elems)))))
+## ))
+
+## (defmacro (` tokens state)
+## (case' tokens
+## (#Cons [template #Nil])
+## (#Right [state (list (untemplate template))])))
+
+## (defmacro (if tokens state)
+## (case' tokens
+## (#Cons [test (#Cons [then (#Cons [else #Nil])])])
+## (#Right [state
+## (list (` (case' (~ test)
+## true (~ then)
+## false (~ else))))])))
+
+## (def (filter p xs)
+## (case' xs
+## #Nil
+## #Nil
+
+## (#Cons [x xs'])
+## (if (p x)
+## (#Cons [x (filter p xs')])
+## (filter p xs'))))
+
+## (def (return val)
+## (lambda [state]
+## (#Right [state val])))
+
+## (def (fail msg)
+## (lambda [_]
+## (#Left msg)))
-## (def (macro-expand syntax)
+## (def (bind f v)
+## (lambda [state]
+## (case' (v state)
+## (#Right [state' x])
+## (f x state')
+
+## (#Left msg)
+## (#Left msg))))
+
+## (def (first pair)
+## (case' pair
+## [f s]
+## f))
+
+## (def (second pair)
+## (case' pair
+## [f s]
+## s))
+
+## (defmacro (loop tokens)
+## (case' tokens
+## (#Cons [bindings (#Cons [body #Nil])])
+## (let [pairs (as-pairs bindings)]
+## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["lux" "recur"])) (~ (#Tuple (map first pairs)))
+## (~ body)))
+## (map second pairs)])))))))
+
+## (defmacro (export tokens)
+## (return (map (lambda [t] (` (export' (~ t))))
+## tokens)))
+
+## (defmacro (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))))
+
+## (defmacro (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))))
+
+## (def (not x)
+## (case' x
+## true false
+## false true))
+
+## (defmacro (|> tokens)
+## (case' tokens
+## (#Cons [init apps])
+## (return (list (fold (lambda [acc app]
+## (case' app
+## (#Form parts)
+## (#Form (++ parts (list acc)))
+
+## _
+## (` ((~ app) (~ acc)))))
+## init
+## apps)))))
+
+## (defmacro ($ tokens)
+## (case' tokens
+## (#Cons [op (#Cons [init args])])
+## (return (list (fold (lambda [acc elem]
+## (` ((~ op) (~ acc) (~ elem))))
+## init
+## args)))))
+
+## (def (const x)
+## (lambda [_] x))
+
+## (def (int> x y)
+## (jvm-lgt x y))
+
+## (def (int< x y)
+## (jvm-llt x y))
+
+## (def inc (int+ 1))
+## (def dec (int+ -1))
+
+## (def (repeat n x)
+## (if (int> n 0)
+## (#Cons [x (repeat (dec n) x)])
+## #Nil))
+
+## (def size
+## (fold (lambda [acc _] (inc acc)) 0))
+
+## (def (last xs)
+## (case' xs
+## #Nil #None
+## (#Cons [x #Nil]) (#Some x)
+## (#Cons [_ xs']) (last xs')))
+
+## (def (init xs)
+## (case' xs
+## #Nil #None
+## (#Cons [_ #Nil]) (#Some #Nil)
+## (#Cons [x xs']) (case' (init xs')
+## (#Some xs'')
+## (#Some (#Cons [x xs'']))
+
+## _
+## (#Some (#Cons [x #Nil])))))
+
+## (defmacro (cond tokens)
+## (case' (reverse tokens)
+## (#Cons [else branches'])
+## (return (list (fold (lambda [else branch]
+## (case' branch
+## [test then]
+## (` (if (~ test) (~ then) (~ else)))))
+## else
+## (|> branches' reverse as-pairs))))))
+
+## (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
+## #Nil
+## xs
+
+## (#Cons [x #Nil])
+## xs
+
+## (#Cons [x xs'])
+## (list+ x sep (interpose sep 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 (int< from to)
+## (#Cons [from (range (inc from) to)])
+## #Nil))
+
+## (def (tuple->list tuple)
+## (case' tuple
+## (#Meta [_ (#Tuple list)])
+## list))
+
+## (def (zip2 xs ys)
+## (case' [xs ys]
+## [(#Cons [x xs']) (#Cons [y ys'])]
+## (#Cons [[x y] (zip2 xs' ys')])
+
+## _
+## #Nil))
+
+## (def (get key map)
+## (case' map
+## #Nil
+## #None
+
+## (#Cons [[k v] map'])
+## (if (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object]
+## k [key])
+## (#Some v)
+## (get key map'))))
+
+## (def (get-ident x)
+## (case' x
+## (#Meta [_ (#Symbol [_ ident])])
+## ident))
+
+## (def (text-++ x y)
+## (jvm-invokevirtual java.lang.String "concat" [java.lang.String]
+## x [y]))
+
+## (def (show-env env)
+## (|> env (map first) (interpose ", ") (fold text-++ "")))
+
+## (def (apply-template env template)
+## (case' template
+## (#Meta [_ (#Symbol [_ ident])])
+## (case' (get ident env)
+## (#Some subst)
+## subst
+
+## _
+## template)
+
+## (#Meta [_ (#Tuple elems)])
+## (_meta (#Tuple (map (apply-template env) elems)))
+
+## (#Meta [_ (#Form elems)])
+## (_meta (#Form (map (apply-template env) elems)))
+
+## (#Meta [_ (#Record members)])
+## (_meta (#Record (map (lambda [kv]
+## (case' kv
+## [slot value]
+## [(apply-template env slot) (apply-template env value)]))
+## members)))
+
+## _
+## template))
+
+## (defmacro (do-template tokens)
+## (case' tokens
+## (#Cons [bindings (#Cons [template data])])
+## (let [bindings-list (map get-ident (tuple->list bindings))
+## data-lists (map tuple->list data)
+## apply (lambda [env] (apply-template env template))]
+## (|> data-lists
+## (map (. apply (zip2 bindings-list)))
+## return))))
+
+## ## ## ## (do-template [<name> <offset>]
+## ## ## ## (def <name> (int+ <offset>))
+
+## ## ## ## [inc 1]
+## ## ## ## [dec -1])
+
+## (def (int= x y)
+## (jvm-leq x y))
+
+## (def (int% x y)
+## (jvm-lrem x y))
+
+## (def (int>= x y)
+## (or (int= x y)
+## (int> x y)))
+
+## (do-template [<name> <cmp>]
+## (def (<name> x y)
+## (if (<cmp> x y)
+## x
+## y))
+
+## [max int>]
+## [min int<])
+
+## (do-template [<name> <cmp>]
+## (def (<name> n) (<cmp> n 0))
+
+## [neg? int<]
+## [pos? int>=])
+
+## (def (even? n)
+## (int= 0 (int% n 0)))
+
+## (def (odd? n)
+## (not (even? n)))
+
+## (do-template [<name> <done> <step>]
+## (def (<name> n xs)
+## (if (int> n 0)
+## (case' xs
+## #Nil #Nil
+## (#Cons [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
+## (#Cons [x xs']) (if (f x) <step> #Nil)))
+
+## [take-while #Nil (list+ x (take-while f xs'))]
+## [drop-while xs (drop-while f xs')])
+
+## (defmacro (get@ tokens)
+## (let [output (case' tokens
+## (#Cons [tag (#Cons [record #Nil])])
+## (` (get@' (~ tag) (~ record)))
+
+## (#Cons [tag #Nil])
+## (` (lambda [record] (get@' (~ tag) record))))]
+## (return (list output))))
+
+## (defmacro (set@ tokens)
+## (let [output (case' tokens
+## (#Cons [tag (#Cons [value (#Cons [record #Nil])])])
+## (` (set@' (~ tag) (~ value) (~ record)))
+
+## (#Cons [tag (#Cons [value #Nil])])
+## (` (lambda [record] (set@' (~ tag) (~ value) record)))
+
+## (#Cons [tag #Nil])
+## (` (lambda [value record] (set@' (~ tag) value record))))]
+## (return (list output))))
+
+## (defmacro (update@ tokens)
+## (let [output (case' tokens
+## (#Cons [tag (#Cons [func (#Cons [record #Nil])])])
+## (` (let [_record_ (~ record)]
+## (set@' (~ tag) ((~ func) (get@' (~ tag) _record_)) _record_)))
+
+## (#Cons [tag (#Cons [func #Nil])])
+## (` (lambda [record]
+## (` (set@' (~ tag) ((~ func) (get@' (~ tag) record)) record))))
+
+## (#Cons [tag #Nil])
+## (` (lambda [func record]
+## (set@' (~ tag) (func (get@' (~ tag) record)) record))))]
+## (return (list output))))
+
+## (def (show-int int)
+## (jvm-invokevirtual java.lang.Object "toString" []
+## int []))
+
+## ## (def gensym
+## ## (lambda [state]
+## ## [(update@ #gen-seed inc state)
+## ## (#Symbol ($ text-++ "__" (show-int (get@ #gen-seed state)) "__"))]))
+
+## ## (do-template [<name> <member>]
+## ## (def (<name> pair)
+## ## (case' pair
+## ## [f s]
+## ## <member>))
+
+## ## [first f]
+## ## [second s])
+
+## (def (show-syntax syntax)
## (case' syntax
-## (#Form (#Cons [(#Symbol macro-name) args]))
-## (do [macro (get-macro macro-name)]
-## ((coerce macro Macro) args))))
+## (#Meta [_ (#Bool value)])
+## (jvm-invokevirtual java.lang.Object "toString" []
+## value [])
+
+## (#Meta [_ (#Int value)])
+## (jvm-invokevirtual java.lang.Object "toString" []
+## value [])
+
+## (#Meta [_ (#Real value)])
+## (jvm-invokevirtual java.lang.Object "toString" []
+## value [])
-## (defmacro (case tokens)
+## (#Meta [_ (#Char value)])
+## (jvm-invokevirtual java.lang.Object "toString" []
+## value [])
+
+## (#Meta [_ (#Text value)])
+## (jvm-invokevirtual java.lang.Object "toString" []
+## value [])
+
+## (#Meta [_ (#Symbol [module name])])
+## ($ text-++ module ";" name)
+
+## (#Meta [_ (#Tag [module name])])
+## ($ text-++ "#" module ";" name)
+
+## (#Meta [_ (#Tuple members)])
+## ($ text-++ "[" (fold text-++ "" (interpose " " (map show-syntax members))) "]")
+
+## (#Meta [_ (#Form members)])
+## ($ text-++ "(" (fold text-++ "" (interpose " " (map show-syntax members))) ")")
+## ))
+
+## (defmacro (do tokens)
+## (case' tokens
+## (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [body #Nil])])
+## (let [output (fold (lambda [body binding]
+## (case' binding
+## [lhs rhs]
+## (` (bind (lambda [(~ lhs)] (~ body))
+## (~ rhs)))))
+## body
+## (reverse (as-pairs bindings)))]
+## (return (list output)))))
+
+## (def (map% f xs)
+## (case' xs
+## #Nil
+## (return xs)
+
+## (#Cons [x xs'])
+## (do [y (f x)
+## ys (map% f xs')]
+## (return (#Cons [y ys])))))
+
+## (defmacro ($keys tokens)
+## (case' tokens
+## (#Cons [(#Meta [_ (#Tuple fields)]) #Nil])
+## (return (list (_meta (#Record (map (lambda [slot]
+## (case' slot
+## (#Meta [_ (#Tag [module name])])
+## [($ text-++ module ";" name) (_meta (#Symbol [module name]))]))
+## fields)))))))
+
+## (defmacro ($or tokens)
+## (case' tokens
+## (#Cons [(#Meta [_ (#Tuple patterns)]) (#Cons [body #Nil])])
+## (return (flat-map (lambda [pattern] (list pattern body))
+## patterns))))
+
+## (def null jvm-null)
+
+## (defmacro (^ tokens)
+## (case' tokens
+## (#Cons [(#Meta [_ (#Symbol [_ class-name])]) #Nil])
+## (return (list (` (#DataT [(~ (_meta (#Text class-name))) (list)]))))
+
+## (#Cons [(#Meta [_ (#Symbol [_ class-name])]) (#Cons [(#Meta [_ (#Tuple params)]) #Nil])])
+## (return (list (` (#DataT [(~ (_meta (#Text class-name))) (~ (untemplate-list params))]))))))
+
+## (defmacro (, members)
+## (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "TupleT"])) (untemplate-list members)))))))
+
+## (defmacro (| members)
+## (let [members' (map (lambda [m]
+## (case' m
+## (#Meta [_ (#Tag [module name])])
+## [($ text-++ module ";" name) (` (#Tuple (list)))]
+
+## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))])
+## [($ text-++ module ";" name) (` (#Tuple (~ value)))]))
+## members)]
+## (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "VariantT"])) (untemplate-list members))))))))
+
+## (defmacro (& members)
+## (let [members' (map (lambda [m]
+## (case' m
+## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag [module name])]) (#Cons [value #Nil])]))])
+## [($ text-++ module ";" name) (` (#Tuple (~ value)))]))
+## members)]
+## (return (list (_meta (#Form (list+ (_meta (#Tag ["lux" "RecordT"])) (untemplate-list members))))))))
+
+## (defmacro (-> tokens)
+## (case' (reverse tokens)
+## (#Cons [f-return f-args])
+## (fold (lambda [f-return f-arg]
+## (` (#LambdaT [(~ f-arg) (~ f-return)])))
+## f-return
+## f-args)))
+
+## (def (text= x y)
+## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object]
+## x [y]))
+
+## (def (replace-ident ident value syntax)
+## (let [[module name] ident]
+## (case' syntax
+## (#Meta [_ (#Symbol [?module ?name])])
+## (if (and (text= module ?module)
+## (text= name ?name))
+## value
+## syntax)
+
+## (#Meta [_ (#Form members)])
+## (_meta (#Form (map (replace-ident ident value) members)))
+
+## (#Meta [_ (#Tuple members)])
+## (_meta (#Tuple (map (replace-ident ident value) members)))
+
+## (#Meta [_ (#Record members)])
+## (_meta (#Record (map (lambda [kv]
+## (case' kv
+## [k v]
+## [k (replace-ident ident value v)]))
+## members)))
+
+## _
+## syntax)))
+
+## (defmacro (All tokens)
+## (let [[name args body] (case' tokens
+## (#Cons [(#Meta [_ (#Symbol [_ name])]) (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])])
+## [name args body]
+
+## (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
+## ["" args body])
+## rolled (fold (lambda [body arg]
+## (case' arg
+## (#Meta [_ (#Symbol [arg-module arg-name])])
+## (` (#AllT (list) "" (~ (_meta (#Text arg-name))) (~ (replace-ident [arg-module arg-name]
+## (` (#BoundT (~ (#Text arg-name))))
+## body))))))
+## body
+## args)]
+## (case' rolled
+## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag ["lux" "AllT"])]) (#Cons [env (#Cons [(#Meta [_ (#Text "")]) (#Cons [(#Meta [_ (#Text arg-name)]) (#Cons [body #Nil])])])])]))])
+## (return (list (` (#AllT (~ env) (~ (#Text name)) (~ (#Text arg-name))
+## (~ (replace-ident arg-name (` (#BoundT (~ (#Text name))))
+## body)))))))))
+
+## (defmacro (Exists 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))))
-## )))
-
-## (def (defsyntax tokens)
-## ...)
-
-## (deftype (State s a)
-## (-> s (, s a)))
-
-## (deftype (Parser a)
-## (State (List Syntax) a))
-
-## (def (parse-ctor tokens)
-## (Parser (, Syntax (List Syntax)))
-## (case tokens
-## (list+ (#Symbol name) tokens')
-## [tokens' [(#Symbol name) (list)]]
-
-## (list+ (#Form (list+ (#Symbol name) args)) tokens')
-## [tokens' [(#Symbol name) args]]))
-
-## (defsyntax (defsig
-## [[name args] parse-ctor]
-## [anns ($+ $1)])
-## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body))))
-## (` (#Record (~ (untemplate-list ...))))
-## args)]
-## (return (list (` (def (~ name) (~ def-body)))))))
-
-## (defsyntax (defstruct
-## [[name args] parse-ctor]
-## signature
-## [defs ($+ $1)])
-## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body))))
-## (` (#Record (~ (untemplate-list ...))))
-## args)]
-## (return (list (` (def (~ name)
-## (: (~ def-body) (~ signature))))))))
-
-## (defsig (Monad m)
-## (: return (All [a] (-> a (m a))))
-## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b)))))
-
-## (defstruct ListMonad (Monad List)
-## (def (return x)
-## (list x))
-
-## (def bind (. concat map)))
-
-## (defsig (Eq a)
-## (: = (-> a a Bool)))
-
-## (defstruct (List_Eq A_Eq)
-## (All [a] (-> (Eq a) (Eq (List a))))
-
-## (def (= xs ys)
-## (and (= (length xs) (length ys))
-## (map (lambda [[x y]]
-## (with A_Eq
-## (= x y)))
-## (zip2 xs ys)))))
-
-## (def (with tokens)
-## ...)
-
-## TODO: Full pattern-matching
-## TODO: Type-related macros
-## TODO: (Im|Ex)ports-related macros
-## TODO: Macro-related macros
-
-## (import "lux")
-## (module-alias "lux" "l")
-## (def-alias "lux;map" "map")
-
-## (def (require tokens)
-## (case tokens
-## ...))
-
-## (require lux #as l #refer [map])
+## (#Cons [args (#Cons [body #Nil])])
+## (return (list (` (All (~ args) (~ body)))))))
+
+## (def Any #AnyT)
+## (def Nothing #NothingT)
+## (def Bool (^ java.lang.Boolean))
+## (def Int (^ java.lang.Long))
+## (def Real (^ java.lang.Double))
+## (def Char (^ java.lang.Character))
+## (def Text (^ java.lang.String))
+
+## ## (deftype (List a)
+## ## (| #Nil
+## ## (#Cons (, a (List a)))))
+
+## ## (deftype #rec Type
+## ## (| #AnyT
+## ## #NothingT
+## ## (#DataT Text)
+## ## (#TupleT (List Type))
+## ## (#VariantT (List (, Text Type)))
+## ## (#RecordT (List (, Text Type)))
+## ## (#LambdaT (, Type Type))
+## ## (#BoundT Text)
+## ## (#VarT Int)
+## ## (#AllT (, (List (, Text Type)) Text Text Type))
+## ## (#AppT (, Type Type))))
+
+## ## (deftype (Either l r)
+## ## (| (#Left l)
+## ## (#Right r)))
+
+## ## (deftype #rec Syntax
+## ## (| (#Bool Bool)
+## ## (#Int Int)
+## ## (#Real Real)
+## ## (#Char Char)
+## ## (#Text Text)
+## ## (#Form (List Syntax))
+## ## (#Tuple (List Syntax))
+## ## (#Record (List (, Text Syntax)))))
+
+## ## (deftype Macro
+## ## (-> (List Syntax) CompilerState
+## ## (Either Text (, CompilerState (List Syntax)))))
+
+## ## (def (macro-expand syntax)
+## ## (case' syntax
+## ## (#Form (#Cons [(#Symbol macro-name) args]))
+## ## (do [macro (get-macro macro-name)]
+## ## ((coerce macro Macro) args))))
+
+## ## (defmacro (case tokens)
+## ## (case' tokens
+## ## (#Cons value branches)
+## ## (loop [kind #Pattern
+## ## pieces branches
+## ## new-pieces (list)]
+## ## (case' pieces
+## ## #Nil
+## ## (return (list (' (case' (~ value) (~@ new-pieces)))))
+
+## ## (#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))))
+## ## )))
+
+## ## (def (defsyntax tokens)
+## ## ...)
+
+## ## (deftype (State s a)
+## ## (-> s (, s a)))
+
+## ## (deftype (Parser a)
+## ## (State (List Syntax) a))
+
+## ## (def (parse-ctor tokens)
+## ## (Parser (, Syntax (List Syntax)))
+## ## (case tokens
+## ## (list+ (#Symbol name) tokens')
+## ## [tokens' [(#Symbol name) (list)]]
+
+## ## (list+ (#Form (list+ (#Symbol name) args)) tokens')
+## ## [tokens' [(#Symbol name) args]]))
+
+## ## (defsyntax (defsig
+## ## [[name args] parse-ctor]
+## ## [anns ($+ $1)])
+## ## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body))))
+## ## (` (#Record (~ (untemplate-list ...))))
+## ## args)]
+## ## (return (list (` (def (~ name) (~ def-body)))))))
+
+## ## (defsyntax (defstruct
+## ## [[name args] parse-ctor]
+## ## signature
+## ## [defs ($+ $1)])
+## ## (let [def-body (fold (lambda [body arg] (` (lambda [(~ arg)] (~ body))))
+## ## (` (#Record (~ (untemplate-list ...))))
+## ## args)]
+## ## (return (list (` (def (~ name)
+## ## (: (~ def-body) (~ signature))))))))
+
+## ## (defsig (Monad m)
+## ## (: return (All [a] (-> a (m a))))
+## ## (: bind (All [a b] (-> (-> a (m b)) (m a) (m b)))))
+
+## ## (defstruct ListMonad (Monad List)
+## ## (def (return x)
+## ## (list x))
+
+## ## (def bind (. concat map)))
+
+## ## (defsig (Eq a)
+## ## (: = (-> a a Bool)))
+
+## ## (defstruct (List_Eq A_Eq)
+## ## (All [a] (-> (Eq a) (Eq (List a))))
+
+## ## (def (= xs ys)
+## ## (and (= (length xs) (length ys))
+## ## (map (lambda [[x y]]
+## ## (with A_Eq
+## ## (= x y)))
+## ## (zip2 xs ys)))))
+
+## ## (def (with tokens)
+## ## ...)
+
+## ## TODO: Full pattern-matching
+## ## TODO: Type-related macros
+## ## TODO: (Im|Ex)ports-related macros
+## ## TODO: Macro-related macros
+
+## ## (import "lux")
+## ## (module-alias "lux" "l")
+## ## (def-alias "lux;map" "map")
+
+## ## (def (require tokens)
+## ## (case tokens
+## ## ...))
+
+## ## (require lux #as l #refer [map])
diff --git a/src/lux.clj b/src/lux.clj
index 6d79b52bf..7bee8df16 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -15,6 +15,7 @@
;; Finish total-locals
(time (&compiler/compile-all (&/|list "lux")))
+ (System/gc)
(time (&compiler/compile-all (&/|list "lux" "test2")))
;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index e73423ffc..9ed75b83d 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -35,19 +35,19 @@
(matchv ::M/objects [token]
;; Standard special forms
[["lux;Meta" [meta ["lux;Bool" ?value]]]]
- (return (&/|list (&/V "Expression" (&/T (&/V "bool" ?value) (&/V "lux;TData" (&/T "java.lang.Boolean" (&/V "lux;Nil" nil)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "bool" ?value) (&/V "lux;DataT" (&/T "java.lang.Boolean" (&/V "lux;Nil" nil)))))))
[["lux;Meta" [meta ["lux;Int" ?value]]]]
- (return (&/|list (&/V "Expression" (&/T (&/V "int" ?value) (&/V "lux;TData" (&/T "java.lang.Long" (&/V "lux;Nil" nil)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "int" ?value) (&/V "lux;DataT" (&/T "java.lang.Long" (&/V "lux;Nil" nil)))))))
[["lux;Meta" [meta ["lux;Real" ?value]]]]
- (return (&/|list (&/V "Expression" (&/T (&/V "real" ?value) (&/V "lux;TData" (&/T "java.lang.Double" (&/V "lux;Nil" nil)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "real" ?value) (&/V "lux;DataT" (&/T "java.lang.Double" (&/V "lux;Nil" nil)))))))
[["lux;Meta" [meta ["lux;Char" ?value]]]]
- (return (&/|list (&/V "Expression" (&/T (&/V "char" ?value) (&/V "lux;TData" (&/T "java.lang.Character" (&/V "lux;Nil" nil)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "char" ?value) (&/V "lux;DataT" (&/T "java.lang.Character" (&/V "lux;Nil" nil)))))))
[["lux;Meta" [meta ["lux;Text" ?value]]]]
- (return (&/|list (&/V "Expression" (&/T (&/V "text" ?value) (&/V "lux;TData" (&/T "java.lang.String" (&/V "lux;Nil" nil)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "text" ?value) (&/V "lux;DataT" (&/T "java.lang.String" (&/V "lux;Nil" nil)))))))
[["lux;Meta" [meta ["lux;Tuple" ?elems]]]]
(&&lux/analyse-tuple analyse ?elems)
@@ -56,13 +56,13 @@
(&&lux/analyse-record analyse ?elems)
[["lux;Meta" [meta ["lux;Tag" [?module ?name]]]]]
- (let [tuple-type (&/V "lux;Tuple" (&/V "lux;Nil" nil))
+ (let [tuple-type (&/V "lux;TupleT" (&/V "lux;Nil" nil))
?tag (str ?module ";" ?name)]
(return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag (&/V "Expression" (&/T (&/V "tuple" (&/|list)) tuple-type))))
- (&/V "lux;TVariant" (&/V "lux;Cons" (&/T (&/T ?tag tuple-type) (&/V "lux;Nil" nil)))))))))
+ (&/V "lux;VariantT" (&/V "lux;Cons" (&/T (&/T ?tag tuple-type) (&/V "lux;Nil" nil)))))))))
[["lux;Meta" [meta ["lux;Symbol" [_ "jvm-null"]]]]]
- (return (&/|list (&/V "Expression" (&/T (&/V "jvm-null" nil) (&/V "lux;TData" (&/T "null" (&/V "lux;Nil" nil)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-null" nil) (&/V "lux;DataT" (&/T "null" (&/V "lux;Nil" nil)))))))
[["lux;Meta" [meta ["lux;Symbol" ?ident]]]]
(&&lux/analyse-ident analyse ?ident)
@@ -78,18 +78,6 @@
["lux;Nil" _]]]]]]]]]]]]]
(&&lux/analyse-lambda analyse ?self ?arg ?body)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "get@'"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?slot]]]
- ["lux;Cons" [?record ["lux;Nil" _]]]]]]]]]]]
- (&&lux/analyse-get analyse ?slot ?record)
-
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "set@'"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Tag" ?slot]]]
- ["lux;Cons" [?value
- ["lux;Cons" [?record
- ["lux;Nil" _]]]]]]]]]]]]]
- (&&lux/analyse-set analyse ?slot ?value ?record)
-
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "def'"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?name]]]]
["lux;Cons" [?value
@@ -98,7 +86,7 @@
;; (prn "if" (&/show-ast ?value)))
(&&lux/analyse-def analyse ?name ?value))
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "declare-macro"]]]]
+ [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "declare-macro'"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ?ident]]]
["lux;Nil" _]]]]]]]]]
(&&lux/analyse-declare-macro ?ident)
@@ -108,23 +96,19 @@
["lux;Nil" _]]]]]]]]]
(&&lux/analyse-import analyse ?path)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ":"]]]]
- ["lux;Cons" [?value
- ["lux;Cons" [?type
+ [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "check'"]]]]
+ ["lux;Cons" [?type
+ ["lux;Cons" [?value
["lux;Nil" _]]]]]]]]]]]
(&&lux/analyse-check analyse eval! ?type ?value)
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "coerce"]]]]
+ [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "coerce'"]]]]
["lux;Cons" [?type
["lux;Cons" [?value
["lux;Nil" _]]]]]]]]]]]
(&&lux/analyse-coerce analyse eval! ?type ?value)
;; Host special forms
- [["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "exec"]]]]
- ?exprs]]]]]]
- (&&host/analyse-exec analyse ?exprs)
-
;; Integer arithmetic
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ "jvm-iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]]]]
(&&host/analyse-jvm-iadd analyse ?x ?y)
@@ -448,7 +432,7 @@
;; :let [_ (prn 'POST-ASSERT)]
=value (&&/analyse-1 (analyse-ast eval!) (&/|head ?values))
=value-type (&&/expr-type =value)]
- (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag =value)) (&/V "lux;TVariant" (&/V "lux;Cons" (&/T (&/T ?tag =value-type) (&/V "lux;Nil" nil)))))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "variant" (&/T ?tag =value)) (&/V "lux;VariantT" (&/V "lux;Cons" (&/T (&/T ?tag =value-type) (&/V "lux;Nil" nil)))))))))
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [?fn ?args]]]]]]
(fn [state]
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index b8963f73f..cfc79c0b3 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -20,8 +20,8 @@
;; [Resources]
(do-template [<name> <output-tag> <input-class> <output-class>]
- (let [input-type (&/V "lux;TData" (to-array [<input-class> (&/V "lux;Nil" nil)]))
- output-type (&/V "lux;TData" (to-array [<output-class> (&/V "lux;Nil" nil)]))]
+ (let [input-type (&/V "lux;DataT" (to-array [<input-class> (&/V "lux;Nil" nil)]))
+ output-type (&/V "lux;DataT" (to-array [<output-class> (&/V "lux;Nil" nil)]))]
(defn <name> [analyse ?x ?y]
(exec [[=x =y] (&&/analyse-2 analyse ?x ?y)
=x-type (&&/expr-type =x)
@@ -126,17 +126,17 @@
(defn analyse-jvm-null? [analyse ?object]
(exec [=object (&&/analyse-1 analyse ?object)]
- (return (&/|list (&/V "Expression" (&/T (&/V "jvm-null?" =object) (&/V "lux;TData" (&/T "java.lang.Boolean" (&/V "lux;Nil" nil)))))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-null?" =object) (&/V "lux;DataT" (&/T "java.lang.Boolean" (&/V "lux;Nil" nil)))))))))
(defn analyse-jvm-new [analyse ?class ?classes ?args]
(exec [=class (&host/full-class-name ?class)
=classes (&/map% &host/extract-jvm-param ?classes)
=args (&/flat-map% analyse ?args)]
- (return (&/|list (&/V "Expression" (&/T (&/V "jvm-new" (&/T =class =classes =args)) (&/V "lux;TData" (&/T =class (&/V "lux;Nil" nil)))))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-new" (&/T =class =classes =args)) (&/V "lux;DataT" (&/T =class (&/V "lux;Nil" nil)))))))))
(defn analyse-jvm-new-array [analyse ?class ?length]
(exec [=class (&host/full-class-name ?class)]
- (return (&/|list (&/V "Expression" (&/T (&/V "jvm-new-array" (&/T =class ?length)) (&/V "array" (&/T (&/V "lux;TData" (to-array [=class (&/V "lux;Nil" nil)]))
+ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-new-array" (&/T =class ?length)) (&/V "array" (&/T (&/V "lux;DataT" (to-array [=class (&/V "lux;Nil" nil)]))
(&/V "lux;Nil" nil)))))))))
(defn analyse-jvm-aastore [analyse ?array ?idx ?elem]
@@ -195,16 +195,10 @@
$module &/get-module-name]
(return (&/|list (&/V "Statement" (&/V "jvm-interface" (&/T $module ?name =methods)))))))
-(defn analyse-exec [analyse ?exprs]
- (exec [_ (&/assert! (count ?exprs) "\"exec\" expressions can't have empty bodies.")
- =exprs (&/flat-map% analyse ?exprs)
- =exprs-types (&/map% &&/expr-type =exprs)]
- (return (&/|list (&/V "Expression" (&/T (&/V "exec" =exprs) (&/|head (&/|reverse =exprs-types))))))))
-
(defn analyse-jvm-try [analyse ?body [?catches ?finally]]
(exec [=body (&&/analyse-1 analyse ?body)
=catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]]
- (&&env/with-local ?ex-arg (&/V "lux;TData" (&/T ?ex-class (&/V "lux;Nil" nil)))
+ (&&env/with-local ?ex-arg (&/V "lux;DataT" (&/T ?ex-class (&/V "lux;Nil" nil)))
(exec [=catch-body (&&/analyse-1 analyse ?catch-body)]
(return [?ex-class ?ex-arg =catch-body]))))
?catches)
@@ -214,20 +208,20 @@
(defn analyse-jvm-throw [analyse ?ex]
(exec [=ex (&&/analyse-1 analyse ?ex)]
- (return (&/|list (&/V "Expression" (&/T (&/V "jvm-throw" =ex) (&/V "lux;TNothing" nil)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-throw" =ex) (&/V "lux;NothingT" nil)))))))
(defn analyse-jvm-monitorenter [analyse ?monitor]
(exec [=monitor (&&/analyse-1 analyse ?monitor)]
- (return (&/|list (&/V "Expression" (&/T (&/V "jvm-monitorenter" =monitor) (&/V "lux;TTuple" (&/V "lux;Nil" nil))))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-monitorenter" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))))
(defn analyse-jvm-monitorexit [analyse ?monitor]
(exec [=monitor (&&/analyse-1 analyse ?monitor)]
- (return (&/|list (&/V "Expression" (&/T (&/V "jvm-monitorexit" =monitor) (&/V "lux;TTuple" (&/V "lux;Nil" nil))))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "jvm-monitorexit" =monitor) (&/V "lux;TupleT" (&/V "lux;Nil" nil))))))))
(do-template [<name> <tag> <from-class> <to-class>]
(defn <name> [analyse ?value]
(exec [=value (&&/analyse-1 analyse ?value)]
- (return (&/|list (&/V "Expression" (&/T (&/V <tag> =value) (&/V "lux;TData" (&/T <to-class> (&/V "lux;Nil" nil)))))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V <tag> =value) (&/V "lux;DataT" (&/T <to-class> (&/V "lux;Nil" nil)))))))))
analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float"
analyse-jvm-d2i "jvm-d2i" "java.lang.Double" "java.lang.Integer"
@@ -252,7 +246,7 @@
(do-template [<name> <tag> <from-class> <to-class>]
(defn <name> [analyse ?value]
(exec [=value (&&/analyse-1 analyse ?value)]
- (return (&/|list (&/V "Expression" (&/T (&/V <tag> =value) (&/V "lux;TData" (&/T <to-class> (&/V "lux;Nil" nil)))))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V <tag> =value) (&/V "lux;DataT" (&/T <to-class> (&/V "lux;Nil" nil)))))))))
analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer"
analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer"
@@ -267,6 +261,6 @@
)
(defn analyse-jvm-program [analyse ?args ?body]
- (exec [=body (&&env/with-local ?args (&/V "lux;TAny" nil)
+ (exec [=body (&&env/with-local ?args (&/V "lux;AnyT" nil)
(&&/analyse-1 analyse ?body))]
(return (&/|list (&/V "Statement" (&/V "jvm-program" =body))))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index e6dd0d1d0..aa205bf06 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -19,7 +19,7 @@
=elems-types (&/map% &&/expr-type =elems)
;; :let [_ (prn 'analyse-tuple =elems)]
]
- (return (&/|list (&/V "Expression" (&/T (&/V "tuple" =elems) (&/V "lux;TTuple" =elems-types)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "tuple" =elems) (&/V "lux;TupleT" =elems-types)))))))
(defn analyse-record [analyse ?elems]
(exec [=elems (&/map% (fn [kv]
@@ -36,7 +36,7 @@
=elems)
;; :let [_ (prn 'analyse-tuple =elems)]
]
- (return (&/|list (&/V "Expression" (&/T (&/V "lux;record" =elems) (&/V "lux;TRecord" =elems-types)))))))
+ (return (&/|list (&/V "Expression" (&/T (&/V "lux;record" =elems) (&/V "lux;RecordT" =elems-types)))))))
(defn ^:private resolve-global [ident state]
(|let [[?module ?name] ident
@@ -160,7 +160,7 @@
;; :let [_ (prn '=bodies =bodies)]
;; :let [_ (prn 'analyse-case/=bodies =bodies)]
=body-types (&/map% &&/expr-type =bodies)
- =case-type (&/fold% &type/merge (&/V "lux;TNothing" nil) =body-types)
+ =case-type (&/fold% &type/merge (&/V "lux;NothingT" nil) =body-types)
:let [=branches (&/zip2 (&/|map &/|first branches) =bodies)]]
(return (&/|list (&/V "Expression" (&/T (&/V "case" (&/T =value base-register max-locals =branches))
=case-type))))))
@@ -169,39 +169,36 @@
;; (prn 'analyse-lambda ?self ?arg ?body)
(exec [=lambda-type* &type/fresh-lambda]
(matchv ::M/objects [=lambda-type*]
- [["lux;TLambda" [=arg =return]]]
+ [["lux;LambdaT" [=arg =return]]]
(exec [[=scope =captured =body] (&&lambda/with-lambda ?self =lambda-type*
?arg =arg
(&&/analyse-1 analyse ?body))
=body-type (&&/expr-type =body)
;; _ =body-type
- =lambda-type (exec [_ (&type/solve =return =body-type)
- =lambda-type** (&type/clean =return =lambda-type*)]
- (&type/clean =arg =lambda-type**))
+ =lambda-type (exec [_ (&type/solve &type/init-fixpoints =return =body-type)]
+ (&type/clean =return =lambda-type*))
+ =bound-arg (&type/lookup =arg)
+ =lambda-type (matchv ::M/objects [=arg =bound-arg]
+ [["lux;VarT" id] ["lux;Some" bound]]
+ (&type/clean =arg =lambda-type)
+
+ [["lux;VarT" id] ["lux;None" _]]
+ (let [var-name (str (gensym ""))
+ bound (&/V "lux;BoundT" var-name)]
+ (exec [_ (&type/reset id bound)
+ lambda-type (&type/clean =arg =lambda-type)]
+ (return (&/V "lux;AllT" (&/T (&/|list) "" var-name lambda-type))))))
;; :let [_ (prn '=lambda-type =lambda-type)]
]
(return (&/|list (&/V "Expression" (&/T (&/V "lambda" (&/T =scope =captured ?arg =body)) =lambda-type))))))))
-(defn analyse-get [analyse ?slot ?record]
- (exec [=record (&&/analyse-1 analyse ?record)
- =record-type (&&/expr-type =record)
- =slot-type (&type/slot-type =record-type ?slot)]
- (return (&/|list (&/V "Expression" (&/T (&/V "get" (?slot =record)) =slot-type))))))
-
-(defn analyse-set [analyse ?slot ?value ?record]
- (exec [=value (&&/analyse-1 analyse ?value)
- =record (&&/analyse-1 analyse ?record)
- =record-type (&&/expr-type =record)
- =slot-type (&type/slot-type =record-type ?slot)
- _ (&type/solve =slot-type =value)]
- (return (&/|list (&/V "Expression" (&/T (&/V "set" (&/T ?slot =value =record)) =slot-type))))))
-
(defn analyse-def [analyse ?name ?value]
;; (prn 'analyse-def ?name ?value)
(exec [module-name &/get-module-name]
(&/if% (&&def/defined? module-name ?name)
(fail (str "[Analyser Error] Can't redefine " ?name))
- (exec [=value (&&/analyse-1 analyse ?value)
+ (exec [=value (&/with-scope ?name
+ (&&/analyse-1 analyse ?value))
=value-type (&&/expr-type =value)
_ (&&def/define module-name ?name =value-type)]
(return (&/|list (&/V "Statement" (&/V "def" (&/T ?name =value)))))))))
@@ -219,22 +216,32 @@
(return (&/|list)))
(defn analyse-check [analyse eval! ?type ?value]
+ (println "analyse-check#0")
(exec [=type (&&/analyse-1 analyse ?type)
+ :let [_ (println "analyse-check#1")]
=type-type (&&/expr-type =type)
- _ (&type/solve &type/+type+ =type-type)
+ :let [_ (println "analyse-check#2")
+ _ (println 1 (&type/show-type &type/Type))
+ _ (println 2 (&type/show-type =type-type))]
+ _ (&type/solve &type/init-fixpoints &type/Type =type-type)
+ :let [_ (println "analyse-check#3")]
==type (eval! =type)
- =value (&&/analyse-1 analyse ?value)]
+ :let [_ (println "analyse-check#4" (&type/show-type ==type))]
+ =value (&&/analyse-1 analyse ?value)
+ :let [_ (println "analyse-check#5")]]
(matchv ::M/objects [=value]
[["Expression" [?expr ?expr-type]]]
- (exec [_ (&type/solve ==type ?expr-type)]
- (return (&/V "Expression" (&/T ?expr ==type)))))))
+ (exec [:let [_ (println "analyse-check#6" (&type/show-type ?expr-type))]
+ _ (&type/solve &type/init-fixpoints ==type ?expr-type)
+ :let [_ (println "analyse-check#7")]]
+ (return (&/|list (&/V "Expression" (&/T ?expr ==type))))))))
(defn analyse-coerce [analyse eval! ?type ?value]
(exec [=type (&&/analyse-1 analyse ?type)
=type-type (&&/expr-type =type)
- _ (&type/solve &type/+type+ =type-type)
+ _ (&type/solve &type/init-fixpoints &type/Type =type-type)
==type (eval! =type)
=value (&&/analyse-1 analyse ?value)]
(matchv ::M/objects [=value]
[["Expression" [?expr ?expr-type]]]
- (return (&/V "Expression" (&/T ?expr ==type))))))
+ (return (&/|list (&/V "Expression" (&/T ?expr ==type)))))))
diff --git a/src/lux/base.clj b/src/lux/base.clj
index 089d1bf8a..29ecfd123 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -132,15 +132,23 @@
(V "lux;Right" (T state value))))
(defn bind [m-value step]
+ (when (not (fn? m-value))
+ (prn 'bind (aget m-value 0)))
+ (when (not (fn? step))
+ (prn 'bind (aget step 0)))
;; (prn 'bind m-value step)
(fn [state]
(let [inputs (m-value state)]
;; (prn 'bind/inputs (aget inputs 0))
(matchv ::M/objects [inputs]
[["lux;Right" [?state ?datum]]]
- ((step ?datum) ?state)
+ (let [next-fn (step ?datum)]
+ (when (not (fn? next-fn))
+ (prn 'bind (aget next-fn 0)
+ (aget next-fn 1)))
+ (next-fn ?state))
- [_]
+ [["lux;Left" _]]
inputs))))
(defmacro exec [steps return]
@@ -598,7 +606,7 @@
(exec [module get-current-module-env]
(return (get$ "lux;name" module))))
-(defn ^:private with-scope [name body]
+(defn with-scope [name body]
(fn [state]
(let [output (body (update$ "lux;local-envs" #(|cons (env name) %) state))]
(matchv ::M/objects [output]
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 53787473b..bf724c768 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -76,12 +76,6 @@
[["lambda" [?scope ?env ?args ?body]]]
(&&lambda/compile-lambda compile-expression ?scope ?env ?args ?body)
- [["get" [?slot ?record]]]
- (&&lux/compile-get compile-expression ?type ?slot ?record)
-
- [["set" [?slot ?value ?record]]]
- (&&lux/compile-set compile-expression ?type ?slot ?value ?record)
-
;; Integer arithmetic
[["jvm-iadd" [?x ?y]]]
(&&host/compile-jvm-iadd compile-expression ?type ?x ?y)
@@ -334,9 +328,10 @@
(fail "[Compiler Error] Can't compile expressions as top-level forms.")))
(defn ^:private eval! [expr]
+ (prn 'eval! (aget expr 0))
+ ;; (assert false)
(exec [eval-ctor &/get-eval-ctor
:let [class-name (str eval-ctor)
- class-file (str class-name ".class")
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
class-name nil "java/lang/Object" nil)
@@ -354,7 +349,7 @@
(return nil)))
:let [bytecode (.toByteArray (doto =class
.visitEnd))]
- _ (&&/save-class! class-file bytecode)
+ _ (&&/save-class! class-name bytecode)
loader &/loader]
(-> (.loadClass loader class-name)
(.getField "_eval")
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
index c46684622..40ad7bb6d 100644
--- a/src/lux/compiler/host.clj
+++ b/src/lux/compiler/host.clj
@@ -40,22 +40,22 @@
char-class "java.lang.Character"]
(defn prepare-return! [*writer* *type*]
(matchv ::M/objects [*type*]
- [["lux;TNothing" nil]]
+ [["lux;NothingT" nil]]
(.visitInsn *writer* Opcodes/ACONST_NULL)
- [["lux;TData" ["char" _]]]
+ [["lux;DataT" ["char" _]]]
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class)))
- [["lux;TData" ["int" _]]]
+ [["lux;DataT" ["int" _]]]
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class integer-class) "valueOf" (str "(I)" (&host/->type-signature integer-class)))
- [["lux;TData" ["long" _]]]
+ [["lux;DataT" ["long" _]]]
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class)))
- [["lux;TData" ["boolean" _]]]
+ [["lux;DataT" ["boolean" _]]]
(.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class)))
- [["lux;TData" [_ _]]]
+ [["lux;DataT" [_ _]]]
nil)
*writer*))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 7d53fa739..cce87e978 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -65,7 +65,7 @@
$start (new Label)
$end (new Label)
_ (doto *writer*
- (-> (.visitLocalVariable (str &&/local-prefix idx) (&host/->java-sig (&/V "lux;TAny" nil)) nil $start $end (+ 2 idx))
+ (-> (.visitLocalVariable (str &&/local-prefix idx) (&host/->java-sig (&/V "lux;AnyT" nil)) nil $start $end (+ 2 idx))
(->> (dotimes [idx num-locals])))
(.visitLabel $start))]
ret (compile impl-body)
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 412055956..a761f431a 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -132,99 +132,6 @@
:let [_ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE (&host/->class &host/function-class) "apply" &&/apply-signature)]]
(return nil)))
-(defn compile-get [compile *type* ?slot ?record]
- (exec [*writer* &/get-writer
- _ (compile ?record)
- :let [$then (new Label)
- $test-else (new Label)
- $end (new Label)
- $start (new Label)
- _ (doto *writer* ;; record
- (.visitInsn Opcodes/DUP) ;; record, record
- (.visitInsn Opcodes/ARRAYLENGTH) ;; record, length
- (.visitInsn Opcodes/ICONST_2) ;; record, length, 2
- (.visitInsn Opcodes/ISUB) ;; record, length--
-
- (.visitLabel $start)
- (.visitInsn Opcodes/DUP) ;; record, length, length
- (.visitLdcInsn (int -2)) ;; record, length, length, -2
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; record, length
- ;;;
- (.visitInsn Opcodes/DUP2) ;; record, length, record, length
- (.visitInsn Opcodes/AALOAD) ;; record, length, aslot
- (.visitLdcInsn ?slot) ;; record, length, aslot, eslot
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z")) ;; record, length, Z
- (.visitJumpInsn Opcodes/IFEQ $test-else) ;; record, length
- (.visitInsn Opcodes/ICONST_1) ;; record, length, 1
- (.visitInsn Opcodes/IADD) ;; record, length+
- (.visitInsn Opcodes/AALOAD) ;; value
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $test-else)
- (.visitInsn Opcodes/ICONST_2) ;; record, length, 2
- (.visitInsn Opcodes/ISUB) ;; record, length--
- (.visitJumpInsn Opcodes/GOTO $start)
- ;;;
- (.visitLabel $then)
- (.visitInsn Opcodes/POP) ;; record
- (.visitInsn Opcodes/POP) ;;
- (.visitInsn Opcodes/ACONST_NULL) ;; null
- (.visitLabel $end))]]
- (return nil)))
-
-(let [o-sig (&host/->type-signature "java.lang.Object")]
- (defn compile-set [compile *type* ?slot ?value ?record]
- (exec [*writer* &/get-writer
- _ (compile ?record)
- :let [$then (new Label)
- $test-else (new Label)
- $end (new Label)
- $start (new Label)
- _ (doto *writer* ;; record1
- ;;;
- (.visitInsn Opcodes/DUP) ;; record1, record1
- (.visitInsn Opcodes/ARRAYLENGTH) ;; record1, length1
- (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class "java.lang.Object")) ;; record1, record2
- (.visitInsn Opcodes/DUP_X1) ;; record2, record1, record2
- (.visitInsn Opcodes/ICONST_0) ;; record2, record1, record2, 0
- (.visitInsn Opcodes/SWAP) ;; record2, record1, 0, record2
- (.visitInsn Opcodes/DUP) ;; record2, record1, 0, record2, record2
- (.visitInsn Opcodes/ARRAYLENGTH) ;; record2, record1, 0, record2, length2
- (.visitInsn Opcodes/ICONST_0) ;; record2, record1, 0, record2, length2, 0
- (.visitInsn Opcodes/SWAP) ;; record2, record1, 0, record2, 0, length2
- (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class "java.lang.System") "arraycopy" (str "(" o-sig "I" o-sig "I" "I" ")V")) ;; record2
- ;;;
- (.visitInsn Opcodes/DUP) ;; record, record
- (.visitInsn Opcodes/ARRAYLENGTH) ;; record, length
- (.visitInsn Opcodes/ICONST_2) ;; record, length, 2
- (.visitInsn Opcodes/ISUB) ;; record, length--
-
- (.visitLabel $start)
- (.visitInsn Opcodes/DUP) ;; record, length, length
- (.visitLdcInsn (int -2)) ;; record, length, length, -2
- (.visitJumpInsn Opcodes/IF_ICMPEQ $then) ;; record, length
- ;;;
- (.visitInsn Opcodes/DUP2) ;; record, length, record, length
- (.visitInsn Opcodes/AALOAD) ;; record, length, aslot
- (.visitLdcInsn ?slot) ;; record, length, aslot, eslot
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (&host/->class "java.lang.Object") "equals" (str "(" (&host/->type-signature "java.lang.Object") ")Z")) ;; record, length, Z
- (.visitJumpInsn Opcodes/IFEQ $test-else) ;; record, length
- (.visitInsn Opcodes/DUP2) ;; record, length, record, length
- (.visitInsn Opcodes/ICONST_1) ;; record, length, record, length, 1
- (.visitInsn Opcodes/IADD) ;; record, length, record, length+
- (do (compile ?value)) ;; record, length, record, length+, value
- (.visitInsn Opcodes/AASTORE) ;; record, length
- (.visitInsn Opcodes/POP) ;; record
- (.visitJumpInsn Opcodes/GOTO $end)
- (.visitLabel $test-else)
- (.visitInsn Opcodes/ICONST_2) ;; record, length, 2
- (.visitInsn Opcodes/ISUB) ;; record, length--
- (.visitJumpInsn Opcodes/GOTO $start)
- ;;;
- (.visitLabel $then)
- (.visitInsn Opcodes/POP) ;; record
- (.visitLabel $end))]]
- (return nil))))
-
(defn compile-def [compile ?name ?body]
(exec [*writer* &/get-writer
module-name &/get-module-name
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 6432a6d5f..1dda5de5d 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -19,8 +19,8 @@
"")
(.getSimpleName class)))]
(if (= "void" base)
- (return (&/V "lux;TNothing" nil))
- (let [base* (&/V "lux;TData" (&/T base (&/V "lux;Nil" nil)))]
+ (return (&/V "lux;NothingT" nil))
+ (let [base* (&/V "lux;DataT" (&/T base (&/V "lux;Nil" nil)))]
(if arr-level
(return (reduce (fn [inner _]
(&/V "array" (&/V "lux;Cons" (&/T inner (&/V "lux;Nil" nil)))))
@@ -81,19 +81,19 @@
(defn ->java-sig [type]
(matchv ::M/objects [type]
- [["lux;TAny" _]]
+ [["lux;AnyT" _]]
(->type-signature "java.lang.Object")
- [["lux;TNothing" _]]
+ [["lux;NothingT" _]]
"V"
- [["lux;TData" ["array" ["lux;Cons" [?elem ["lux;Nil" _]]]]]]
+ [["lux;DataT" ["array" ["lux;Cons" [?elem ["lux;Nil" _]]]]]]
(str "[" (->java-sig ?elem))
- [["lux;TData" [?name ?params]]]
+ [["lux;DataT" [?name ?params]]]
(->type-signature ?name)
- [["lux;TLambda" [_ _]]]
+ [["lux;LambdaT" [_ _]]]
(->type-signature function-class)))
(defn extract-jvm-param [token]
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 68fb13b3d..7d05d65b4 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -2,12 +2,23 @@
(:refer-clojure :exclude [deref apply merge])
(:require [clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- [lux.base :as & :refer [exec return* return fail fail* assert!]]))
+ [lux.base :as & :refer [exec return* return fail fail* assert! |let]]))
;; [Util]
(def ^:private success (return nil))
-(defn ^:private deref [id]
+(defn lookup [type]
+ (matchv ::M/objects [type]
+ [["lux;VarT" id]]
+ (fn [state]
+ (if-let [type* (->> state (&/get$ "lux;types") (&/get$ "lux;mappings") (&/|get id))]
+ (return* state type*)
+ (fail* (str "Unknown type-var: " id))))
+
+ [_]
+ (fail "[Type Error] Can't lookup non-vars.")))
+
+(defn deref [id]
(fn [state]
(if-let [type* (->> state (&/get$ "lux;types") (&/get$ "lux;mappings") (&/|get id))]
(matchv ::M/objects [type*]
@@ -18,7 +29,7 @@
(fail* (str "Unbound type-var: " id)))
(fail* (str "Unknown type-var: " id)))))
-(defn ^:private reset [id type]
+(defn reset [id type]
(fn [state]
(if-let [_ (->> state (&/get$ "lux;types") (&/get$ "lux;mappings") (&/|get id))]
(return* (&/update$ "lux;types" (fn [ts] (&/update$ "lux;mappings" #(&/|put id (&/V "lux;Some" type) %)
@@ -35,147 +46,79 @@
(&/update$ "lux;counter" inc)
(&/update$ "lux;mappings" (fn [ms] (&/|put id (&/V "lux;None" nil) ms))))
state)
- (&/V "lux;TVar" id)))))
+ (&/V "lux;VarT" id)))))
(def fresh-lambda
(exec [=arg fresh-var
=return fresh-var]
- (return (&/V "lux;TLambda" (&/T =arg =return)))))
-
-(defn ^:private ->type [pseudo-type]
- (match pseudo-type
- [::Any]
- (&/V "lux;TAny" nil)
-
- [::Nothing]
- (&/V "lux;TNothing" nil)
-
- [::Data ?name ?elems]
- (&/V "lux;TData" (&/T ?name ?elems))
-
- [::Tuple ?members]
- (&/V "lux;TTuple" (&/|map ->type ?members))
-
- [::Variant ?members]
- (&/V "lux;TVariant" (&/|map (fn [[k v]] (&/T k (->type v)))
- ?members))
-
- [::Record ?members]
- (&/V "lux;TRecord" (&/|map (fn [[k v]] (&/T k (->type v)))
- ?members))
-
- [::Lambda ?input ?output]
- (&/V "lux;TLambda" (&/T (->type ?input) (->type ?output)))
-
- [::App ?lambda ?param]
- (&/V "lux;TApp" (&/T (->type ?lambda) (->type ?param)))
-
- [::Bound ?name]
- (&/V "lux;TBound" ?name)
-
- [::Var ?id]
- (&/V "lux;TVar" ?id)
-
- [::All ?env ?name ?arg ?body]
- (&/V "lux;TAll" (&/T (&/|map (fn [[k v]] (&/T k (->type v)))
- ?env)
- ?name
- ?arg
- (->type ?body)))
- ))
-
-(def +list+
- [::All (&/|list) "List" "a"
- [::Variant (&/|list ["lux;Cons" [::Tuple (&/|list [::Bound "a"] [::App [::Bound "List"] [::Bound "a"]])]]
- ["lux;Nil" [::Tuple (&/|list)]])]])
-
-(def +type+
- (let [text [::Data "java.lang.String" (&/|list)]
- type [::App [::Bound "Type"] [::Any]]
- list-of-types [::App +list+ type]
- string=>type [::App +list+ [::Tuple (&/|list text type)]]]
- (->type [::All (&/|list) "Type" "_"
- [::Variant (&/|list ["lux;TAny" [::Tuple (&/|list)]]
- ["lux;TNothing" [::Tuple (&/|list)]]
- ["lux;TData" [::Tuple (&/|list text list-of-types)]]
- ["lux;TTuple" list-of-types]
- ["lux;TVariant" string=>type]
- ["lux;TRecord" string=>type]
- ["lux;TLambda" [::Tuple (&/|list type
- type)]]
- ["lux;TApp" [::Tuple (&/|list type
- type)]]
- ["lux;TBound" text]
- ["lux;TVar" [::Data "java.lang.Long" (&/|list)]]
- ["lux;TAll" [::Tuple (&/|list string=>type text text type)]]
- )]])))
+ (return (&/V "lux;LambdaT" (&/T =arg =return)))))
(defn clean [tvar type]
(matchv ::M/objects [tvar]
- [["lux;TVar" ?tid]]
+ [["lux;VarT" ?tid]]
(matchv ::M/objects [type]
- [["lux;TVar" ?id]]
+ [["lux;VarT" ?id]]
(if (= ?tid ?id)
(&/try-all% (&/|list (exec [=type (deref ?id)]
(clean tvar =type))
(return type)))
(return type))
- [["lux;TLambda" [?arg ?return]]]
+ [["lux;LambdaT" [?arg ?return]]]
(exec [=arg (clean tvar ?arg)
=return (clean tvar ?return)]
- (return (&/V "lux;TLambda" (to-array [=arg =return]))))
+ (return (&/V "lux;LambdaT" (to-array [=arg =return]))))
- [["lux;TApp" [?lambda ?param]]]
+ [["lux;AppT" [?lambda ?param]]]
(exec [=lambda (clean tvar ?lambda)
=param (clean tvar ?param)]
- (return (&/V "lux;TApp" (to-array [=lambda =param]))))
+ (return (&/V "lux;AppT" (to-array [=lambda =param]))))
- [["lux;TTuple" ?members]]
+ [["lux;TupleT" ?members]]
(exec [=members (&/map% (partial clean tvar) ?members)]
- (return (&/V "lux;TTuple" =members)))
+ (return (&/V "lux;TupleT" =members)))
- [["lux;TVariant" ?members]]
+ [["lux;VariantT" ?members]]
(exec [=members (&/map% (fn [[k v]]
(exec [=v (clean tvar v)]
(return (to-array [k =v]))))
?members)]
- (return (&/V "lux;TVariant" =members)))
+ (return (&/V "lux;VariantT" =members)))
- [["lux;TRecord" ?members]]
+ [["lux;RecordT" ?members]]
(exec [=members (&/map% (fn [[k v]]
(exec [=v (clean tvar v)]
(return (to-array [k =v]))))
?members)]
- (return (&/V "lux;TRecord" =members)))
+ (return (&/V "lux;RecordT" =members)))
- [["lux;TAll" [?env ?name ?arg ?body]]]
+ [["lux;AllT" [?env ?name ?arg ?body]]]
(exec [=env (&/map% (fn [[k v]]
(exec [=v (clean tvar v)]
(return (to-array [k =v]))))
?env)]
- (return (&/V "lux;TAll" (to-array [=env ?name ?arg ?body]))))
+ (return (&/V "lux;AllT" (to-array [=env ?name ?arg ?body]))))
[_]
(return type)
)))
(defn show-type [type]
- (prn 'show-type (aget type 0))
+ ;; (prn 'show-type (aget type 0))
(matchv ::M/objects [type]
- [["lux;TAny" _]]
+ [["lux;AnyT" _]]
"Any"
- [["lux;TNothing" _]]
+ [["lux;NothingT" _]]
"Nothing"
- [["lux;TData" [name params]]]
+ [["lux;DataT" [name params]]]
(str "(^ " name " [" (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) "])")
- [["lux;TTuple" elems]]
+ [["lux;TupleT" elems]]
(str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")
- [["lux;TVariant" cases]]
+ [["lux;VariantT" cases]]
(str "(| " (->> cases
(&/|map (fn [kv]
(matchv ::M/objects [kv]
@@ -188,7 +131,7 @@
(&/fold str "")) ")")
- [["lux;TRecord" fields]]
+ [["lux;RecordT" fields]]
(str "(& " (->> fields
(&/|map (fn [kv]
(matchv ::M/objects [kv]
@@ -197,140 +140,146 @@
(&/|interpose " ")
(&/fold str "")) ")")
- [["lux;TLambda" [input output]]]
+ [["lux;LambdaT" [input output]]]
(str "(-> " (show-type input) " " (show-type output) ")")
- [["lux;TVar" id]]
+ [["lux;VarT" id]]
(str "⌈" id "⌋")
- [["lux;TBound" name]]
+ [["lux;BoundT" name]]
name
- [["lux;TApp" [?lambda ?param]]]
+ [["lux;AppT" [?lambda ?param]]]
(str "(" (show-type ?lambda) " " (show-type ?param) ")")
- [["lux;TAll" [?env ?name ?arg ?body]]]
+ [["lux;AllT" [?env ?name ?arg ?body]]]
(str "(All " ?name " " ?arg " " (show-type ?body) ")")
))
+(defn type= [x y]
+ (matchv ::M/objects [x y]
+ [["lux;AnyT" _] ["lux;AnyT" _]]
+ true
+
+ [["lux;NothingT" _] ["lux;NothingT" _]]
+ true
+
+ [["lux;DataT" [xname xparams]] ["lux;DataT" [yname yparams]]]
+ (&/fold (fn [old xy] (and old (type= (aget xy 0) (aget xy 1))))
+ (= xname yname)
+ (&/zip2 xparams yparams))
+
+ [["lux;TupleT" xelems] ["lux;TupleT" yelems]]
+ (&/fold (fn [old xy] (and old (type= (aget xy 0) (aget xy 1))))
+ true
+ (&/zip2 xelems yelems))
+
+ [["lux;VariantT" xcases] ["lux;VariantT" ycases]]
+ (&/fold (fn [old cases]
+ (matchv ::M/objects [cases]
+ [[[xtag xtype] [ytag ytype]]]
+ (and (= xtag ytag)
+ (type= xtype ytype))))
+ true (&/zip2 xcases ycases))
+
+
+ [["lux;RecordT" xfields] ["lux;RecordT" yfields]]
+ (&/fold (fn [old cases]
+ (matchv ::M/objects [cases]
+ [[[xtag xtype] [ytag ytype]]]
+ (and (= xtag ytag)
+ (type= xtype ytype))))
+ true (&/zip2 xfields yfields))
+
+ [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]]
+ (and (type= xinput yinput)
+ (type= xoutput youtput))
+
+ [["lux;VarT" xid] ["lux;VarT" yid]]
+ (= xid yid)
+
+ [["lux;BoundT" xname] ["lux;BoundT" yname]]
+ (= xname yname)
+
+ [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]]
+ (and (type= xlambda ylambda)
+ (type= xparam yparam))
+
+ [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]]
+ (and (&/fold (fn [old cases]
+ (matchv ::M/objects [cases]
+ [[[xtag xtype] [ytag ytype]]]
+ (and (= xtag ytag)
+ (type= xtype ytype))))
+ true (&/zip2 xenv yenv))
+ (= xname yname)
+ (= xarg yarg)
+ (type= xbody ybody))
+
+ [_ _]
+ (do (prn 'type= (show-type x) (show-type y))
+ false)
+ ))
+
+(defn ^:private fp-get [k xs]
+ (matchv ::M/objects [k]
+ [[e a]]
+ (matchv ::M/objects [xs]
+ [["lux;Nil" _]]
+ (&/V "lux;None" nil)
+
+ [["lux;Cons" [[[e* a*] v*] xs*]]]
+ (if (and (type= e e*)
+ (type= a a*))
+ (&/V "lux;Some" v*)
+ (fp-get k xs*))
+ )))
+
+(defn ^:private fp-put [k v fixpoints]
+ (&/|cons (&/T k v) fixpoints))
+
(defn ^:private solve-error [expected actual]
(str "Type " (show-type expected) " does not subsume type " (show-type actual)))
-(defn solve [expected actual]
- ;; (prn 'solve expected actual)
- ;; (prn 'solve (aget expected 0) (aget actual 0))
- success
- ;; (matchv ::M/objects [expected actual]
- ;; [["Any" _] _]
- ;; success
-
- ;; [_ ["Nothing" _]]
- ;; success
-
- ;; [["Data" [e!name e!params]] ["Data" [a!name a!params]]]
- ;; (if (or (= e!name a!name)
- ;; (.isAssignableFrom (Class/forName e!name) (Class/forName a!name)))
- ;; success
- ;; (fail (str "not (" actual " <= " expected ")")))
-
- ;; [["Tuple" e!elems] ["Tuple" a!elems]]
- ;; (exec [_ (assert! (= (&/|length e!elems) (&/|length a!elems))
- ;; "Tuples must have matching element sizes.")
- ;; _ (&/map% (fn [n g] (solve n g))
- ;; (&/zip2 e!elems a!elems))]
- ;; success)
-
- ;; [["Variant" e!cases] ["Variant" a!cases]]
- ;; (exec [_ (&/map% (fn [slot]
- ;; (solve (&/|get e!cases slot) (&/|get a!cases slot)))
- ;; (&/|keys a!cases))]
- ;; success)
-
- ;; [["Record" e!fields] ["Record" a!fields]]
- ;; (exec [_ (&/map% (fn [slot]
- ;; (solve (&/|get e!fields slot) (&/|get a!fields slot)))
- ;; (&/|keys e!fields))]
- ;; success)
-
- ;; [["Lambda" [e!input e!output]] ["Lambda" [a!input a!output]]]
- ;; (exec [_ (solve a!input e!input)]
- ;; (solve e!output a!output))
-
- ;; [["Var" e!id] _]
- ;; (&/try-all% (&/|list (exec [=e!type (deref e!id)
- ;; _ (solve =e!type actual)
- ;; _ (reset e!id =e!type)]
- ;; success)
- ;; (exec [_ (reset e!id actual)]
- ;; success)))
-
- ;; [_ ["Var" a!id]]
- ;; (&/try-all% (&/|list (exec [=a!type (deref a!id)
- ;; _ (solve expected =a!type)
- ;; _ (reset a!id =a!type)]
- ;; success)
- ;; (exec [_ (reset a!id expected)]
- ;; success)))
-
- ;; [_ _]
- ;; (solve-error expected actual)
- ;; )
- )
+(defn beta-reduce [env type]
+ ;; (prn 'beta-reduce (aget type 0))
+ (matchv ::M/objects [type]
+ [["lux;VariantT" ?cases]]
+ (&/V "lux;VariantT" (&/|map (fn [kv]
+ (|let [[k v] kv]
+ (&/T k (beta-reduce env v))))
+ ?cases))
-(let [&& #(and %1 %2)]
- (defn merge [x y]
- (matchv ::M/objects [x y]
- [_ ["lux;TAny" _]]
- (return y)
+ [["lux;RecordT" ?fields]]
+ (&/V "lux;RecordT" (&/|map (fn [kv]
+ (|let [[k v] kv]
+ (&/T k (beta-reduce env v))))
+ ?fields))
- [["lux;TAny" _] _]
- (return x)
+ [["lux;TupleT" ?members]]
+ (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members))
- [_ ["lux;TNothing" _]]
- (return x)
+ [["lux;DataT" [?name ?params]]]
+ (&/V "lux;DataT" (&/T ?name (&/|map (partial beta-reduce env) ?params)))
- [["lux;TNothing" _] _]
- (return y)
+ [["lux;AppT" [?type-fn ?type-arg]]]
+ (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)))
- ;;;
-
- [_ _]
- (return x)
+ [["lux;AllT" [?local-env ?local-name ?local-arg ?local-def]]]
+ (&/V "lux;AllT" (&/T (&/|merge ?local-env env) ?local-name ?local-arg ?local-def))
- ;; [["Variant" x!cases] ["Variant" y!cases]]
- ;; (if (and (reduce && true
- ;; (for [[xslot xtype] (keys x!cases)]
- ;; (if-let [ytype (get y!cases xslot)]
- ;; (= xtype ytype)
- ;; true)))
- ;; (reduce && true
- ;; (for [[yslot ytype] (keys y!cases)]
- ;; (if-let [xtype (get x!cases yslot)]
- ;; (= xtype ytype)
- ;; true))))
- ;; (return (&/V "Variant" (clojure.core/merge x!cases y!cases)))
- ;; (fail (str "Incompatible variants: " (pr-str x) " and " (pr-str y))))
-
- ;; [["Record" x!fields] ["Record" y!fields]]
- ;; (if (and (= (keys x!fields) (keys y!fields))
- ;; (->> (keys x!fields)
- ;; (map #(= (get x!fields %) (get y!fields %)))
- ;; (reduce && true)))
- ;; (return x)
- ;; (fail (str "Incompatible records: " (pr-str x) " and " (pr-str y))))
-
- [_ _]
- (fail (str "[Type System] Can't merge types: " (pr-str x) " and " (pr-str y))))))
+ [["lux;LambdaT" [?input ?output]]]
+ (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output)))
-(defn apply-lambda [func param]
- (matchv ::M/objects [func]
- [["lux;TLambda" [input output]]]
- (exec [_ (solve input param)]
- (return output))
+ [["lux;BoundT" ?name]]
+ (if-let [bound (&/|get ?name env)]
+ (do ;; (prn 'beta-reduce "lux;BoundT" ?name (->> (&/|keys env) (&/|interpose " ") (&/fold str ""))
+ ;; (show-type bound))
+ (beta-reduce env bound))
+ type)
[_]
- (return (&/V "lux;TAny" nil))
- ;; (fail (str "[Type System] Can't apply type " (str func) " to type " (str param)))
+ type
))
(defn slot-type [record slot]
@@ -342,4 +291,241 @@
[["lux;Right" type]]
(return* state type))))
-(def +dont-care+ (&/V "lux;TAny" nil))
+(def +dont-care+ (&/V "lux;AnyT" nil))
+
+(defn apply-type [type-fn param]
+ (prn 'apply-type (aget type-fn 0) (aget param 0))
+ (matchv ::M/objects [type-fn]
+ [["lux;AllT" [local-env local-name local-arg local-def]]]
+ (return (beta-reduce (->> local-env
+ (&/|put local-name type-fn)
+ (&/|put local-arg param))
+ local-def))
+
+ [["lux;AppT" [F A]]]
+ (exec [type-fn* (apply-type F A)]
+ (apply-type type-fn* param))
+
+ [_]
+ (fail (str "[Type System] Can't apply type function " (show-type type-fn) " to type " (show-type param)))))
+
+(def init-fixpoints (&/|list))
+
+(defn solve [fixpoints expected actual]
+ (prn 'solve (aget expected 0) (aget actual 0))
+ ;; (prn 'solve (show-type expected) (show-type actual))
+ (matchv ::M/objects [expected actual]
+ [["Any" _] _]
+ success
+
+ [_ ["Nothing" _]]
+ success
+
+ [["lux;VarT" ?id] _]
+ (&/try-all% (&/|list (exec [bound (deref ?id)]
+ (solve fixpoints bound actual))
+ (reset ?id actual)))
+
+ [_ ["lux;VarT" ?id]]
+ (&/try-all% (&/|list (exec [bound (deref ?id)]
+ (solve fixpoints expected bound))
+ (reset ?id expected)))
+
+ [["lux;AppT" [F A]] _]
+ (exec [expected* (apply-type F A)
+ :let [fp-pair (&/T expected actual)]]
+ (matchv ::M/objects [(fp-get fp-pair fixpoints)]
+ [["lux;Some" ?]]
+ (if ?
+ success
+ (fail (solve-error expected actual)))
+
+ [["lux;None" _]]
+ (solve (fp-put fp-pair true fixpoints) expected* actual)))
+
+ [_ ["lux;AppT" [F A]]]
+ (exec [actual* (apply-type F A)]
+ (solve fixpoints expected actual*))
+
+ [["lux;AllT" _] _]
+ (exec [$var fresh-var
+ expected* (apply-type expected $var)]
+ (solve fixpoints expected* actual))
+
+ [_ ["lux;AllT" _]]
+ (exec [$var fresh-var
+ actual* (apply-type actual $var)]
+ (solve fixpoints expected actual*))
+
+ [["lux;DataT" [e!name e!params]] ["lux;DataT" [a!name a!params]]]
+ (cond (not= e!name a!name)
+ (fail (str "[Type Error] Names don't match: " e!name " & " a!name))
+
+ (not= (&/|length e!params) (&/|length a!params))
+ (fail "[Type Error] Params don't match in size.")
+
+ :else
+ (exec [_ (&/map% (fn [ea]
+ (|let [[e a] ea]
+ (solve fixpoints e a)))
+ (&/zip2 e!params a!params))]
+ success))
+
+ [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]]
+ (exec [_ (solve fixpoints aI eI)]
+ (solve fixpoints eO aO))
+
+ [["lux;TupleT" e!members] ["lux;TupleT" a!members]]
+ (if (= (&/|length e!members) (&/|length a!members))
+ (exec [_ (&/map% (fn [ea]
+ (|let [[e a] ea]
+ (do (prn "lux;TupleT" 'ITER (show-type e) (show-type a))
+ (solve fixpoints e a))))
+ (&/zip2 e!members a!members))
+ :let [_ (prn "lux;TupleT" 'DONE)]]
+ success)
+ (do ;; (prn "lux;TupleT" (&/|length e!members) (&/|length a!members))
+ ;; (prn "lux;TupleT"
+ ;; (&/fold str "" (&/|interpose " " (&/|map show-type e!members)))
+ ;; (&/fold str "" (&/|interpose " " (&/|map show-type a!members))))
+ ;; (prn "lux;TupleT#fail" (fail "[Type Error] Tuples don't match in size."))
+ (fail "[Type Error] Tuples don't match in size.")))
+
+ [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]]
+ (exec [_ (&/map% (fn [kv]
+ (|let [[k av] kv]
+ (if-let [ev (&/|get k e!cases)]
+ (solve fixpoints ev av)
+ (fail (str "[Type Error] The expected variant cannot handle case: #" k)))))
+ a!cases)]
+ success)
+
+ [["lux;RecordT" e!fields] ["lux;RecordT" a!fields]]
+ (if (= (&/|length e!fields) (&/|length a!fields))
+ (exec [_ (&/map% (fn [slot]
+ (if-let [e!type (&/|get e!fields slot)]
+ (if-let [a!type (&/|get a!fields slot)]
+ (solve fixpoints e!type a!type)
+ (fail (solve-error expected actual)))
+ (fail (solve-error expected actual))))
+ (&/|keys e!fields))]
+ success)
+ (fail "[Type Error] Records don't match in size."))
+
+ [["lux;BoundT" name] _]
+ (do (prn "lux;BoundT" name)
+ (assert false))
+ ;; ...
+
+ ;; [_ ["lux;BoundT" name]]
+ ;; ...
+ ))
+
+(defn apply-lambda [func param]
+ (matchv ::M/objects [func]
+ [["lux;LambdaT" [input output]]]
+ (exec [_ (solve init-fixpoints input param)]
+ (return output))
+
+ [_]
+ (fail (str "[Type System] Can't apply type " (show-type func) " to type " (show-type param)))
+ ))
+
+(def Any (&/V "lux;AnyT" nil))
+(def Int (&/V "lux;DataT" (&/T "java.lang.Long" (&/|list))))
+(def Text (&/V "lux;DataT" (&/T "java.lang.String" (&/|list))))
+
+(def List
+ (&/V "lux;AllT" (&/T (&/|table) "List" "a"
+ (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" (&/V "lux;TupleT" (&/|list)))
+ (&/T "lux;Cons" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a")
+ (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "List")
+ (&/V "lux;BoundT" "a")))))))))))
+
+(def Type
+ (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "")))
+ TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type))))
+ Unit (&/V "lux;TupleT" (&/|list))
+ TypeList (&/V "lux;AppT" (&/T List Type))
+ TypePair (&/V "lux;TupleT" (&/|list Type Type))]
+ (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/|list) "Type" ""
+ (&/V "lux;VariantT" (&/|list (&/T "lux;AnyT" Unit)
+ (&/T "lux;NothingT" Unit)
+ (&/T "lux;DataT" (&/V "lux;TupleT" (&/|list Text TypeList)))
+ (&/T "lux;TupleT" TypeList)
+ (&/T "lux;VariantT" TypeEnv)
+ (&/T "lux;RecordT" TypeEnv)
+ (&/T "lux;LambdaT" TypePair)
+ (&/T "lux;BoundT" Text)
+ (&/T "lux;VarT" Int)
+ (&/T "lux;AllT" (&/V "lux;TupleT" (&/|list TypeEnv Text Text Type)))
+ (&/T "lux;AppT" TypePair)
+ ))))
+ (&/V "lux;NothingT" nil)))))
+
+(let [&& #(and %1 %2)]
+ (defn merge [x y]
+ (matchv ::M/objects [x y]
+ [_ ["lux;AnyT" _]]
+ (return y)
+
+ [["lux;AnyT" _] _]
+ (return x)
+
+ [_ ["lux;NothingT" _]]
+ (return x)
+
+ [["lux;NothingT" _] _]
+ (return y)
+
+ [["lux;VariantT" x!cases] ["lux;VariantT" y!cases]]
+ (exec [cases (&/fold% (fn [cases kv]
+ (matchv ::M/objects [kv]
+ [[k v]]
+ (if-let [cv (&/|get k cases)]
+ (exec [_ (solve init-fixpoints cv v)]
+ (return cases))
+ (return (&/|put k v cases)))))
+ x!cases
+ y!cases)]
+ (return (&/V "lux;VariantT" cases)))
+
+ [["lux;RecordT" x!fields] ["lux;RecordT" y!fields]]
+ (if (= (&/|length x!fields) (&/|length y!fields))
+ (exec [fields (&/fold% (fn [fields kv]
+ (matchv ::M/objects [kv]
+ [[k v]]
+ (if-let [cv (&/|get k fields)]
+ (exec [_ (solve init-fixpoints cv v)]
+ (return fields))
+ (fail (str "[Type System Error] Incompatible records: " (show-type x) " and " (show-type y))))))
+ x!fields
+ y!fields)]
+ (return (&/V "lux;RecordT" fields)))
+ (fail (str "[Type System Error] Incompatible records: " (show-type x) " and " (show-type y))))
+
+ [_ _]
+ (fail (str "[Type System Error] Can't merge types: " (show-type x) " and " (show-type y))))))
+
+(comment
+ (do (def Real (&/V "lux;DataT" (&/T "java.lang.Long" (&/|list))))
+ (def RealT (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" (&/V "lux;TupleT" (&/|list Text
+ (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" (&/V "lux;TupleT" (&/|list)))))))))))
+ )
+
+ (matchv ::M/objects [((solve init-fixpoints Type RealT)
+ (&/init-state nil))]
+ [["lux;Left" ?msg]]
+ (assert false ?msg)
+
+ [_]
+ (println "YEAH!"))
+
+ (matchv ::M/objects [((solve init-fixpoints List (&/V "lux;AppT" (&/T List Real)))
+ (&/init-state nil))]
+ [["lux;Left" ?msg]]
+ (assert false ?msg)
+
+ [_]
+ (println "YEAH!"))
+ )
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-08 21:33:38 +0000