aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--source/lux/control/enum.lux2
-rw-r--r--source/lux/control/monad.lux1
-rw-r--r--source/lux/data/id.lux14
-rw-r--r--source/lux/data/list.lux27
-rw-r--r--source/lux/data/number/int.lux7
-rw-r--r--source/lux/data/number/real.lux7
-rw-r--r--source/lux/meta/ast.lux14
-rw-r--r--src/lux/compiler/lambda.clj69
-rw-r--r--src/lux/compiler/lux.clj80
-rw-r--r--src/lux/type.clj64
10 files changed, 154 insertions, 131 deletions
diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux
index 34910c837..c54eab75b 100644
--- a/source/lux/control/enum.lux
+++ b/source/lux/control/enum.lux
@@ -10,7 +10,7 @@
(defsig #export (Enum e)
(: (Ord e) _ord)
(: (-> e e) succ)
- (: (-> e e) pre))
+ (: (-> e e) pred))
## [Functions]
(def #export (range' <= succ from to)
diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux
index 883875a03..0c7827c34 100644
--- a/source/lux/control/monad.lux
+++ b/source/lux/control/monad.lux
@@ -60,7 +60,6 @@
_
(` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join)))
- ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join)))
))))
body
(reverse (as-pairs bindings)))]
diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux
index 6b996cf1e..e4f2a775f 100644
--- a/source/lux/data/id.lux
+++ b/source/lux/data/id.lux
@@ -10,20 +10,18 @@
## [Types]
(deftype #export (Id a)
- (| (#Id a)))
+ a)
## [Structures]
(defstruct #export Id/Functor (Functor Id)
- (def (map f fa)
- (let [(#Id a) fa]
- (#Id (f a)))))
+ (def map id))
(defstruct #export Id/Monad (Monad Id)
(def _functor Id/Functor)
- (def (wrap a) (#Id a))
- (def (join mma) (let [(#Id ma) mma] ma)))
+ (def wrap id)
+ (def join id))
(defstruct #export Id/CoMonad (CoMonad Id)
(def _functor Id/Functor)
- (def (unwrap wa) (let [(#Id a) wa] a))
- (def (split wa) (#Id wa)))
+ (def unwrap id)
+ (def split id))
diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux
index a6ca4e0f7..8a7f97698 100644
--- a/source/lux/data/list.lux
+++ b/source/lux/data/list.lux
@@ -311,19 +311,20 @@
## (#;Left "Wrong syntax for zip-with")))
## [Structures]
-## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a))))
-## (def (= xs ys)
-## (case [xs ys]
-## [#;Nil #;Nil]
-## true
-
-## [(#;Cons x xs') (#;Cons y ys')]
-## (and (:: eq (E;= x y))
-## (= xs' ys'))
-
-## [_ _]
-## false
-## )))
+(defstruct #export (List/Eq eq)
+ (All [a] (-> (E;Eq a) (E;Eq (List a))))
+ (def (= xs ys)
+ (case [xs ys]
+ [#;Nil #;Nil]
+ true
+
+ [(#;Cons x xs') (#;Cons y ys')]
+ (and (:: eq (E;= x y))
+ (= xs' ys'))
+
+ [_ _]
+ false
+ )))
(defstruct #export List/Monoid (All [a]
(Monoid (List a)))
diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux
index 2d94ad43b..20ea5fced 100644
--- a/source/lux/data/number/int.lux
+++ b/source/lux/data/number/int.lux
@@ -8,6 +8,7 @@
(monoid #as m)
(eq #as E)
(ord #as O)
+ (enum #as EN)
(bounded #as B)
(show #as S)))
@@ -56,6 +57,12 @@
[ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt])
+## Enum
+(defstruct Int/Enum (EN;Enum Int)
+ (def _ord Int/Ord)
+ (def succ (lambda [n] (:: Int/Number (N;+ n 1))))
+ (def pred (lambda [n] (:: Int/Number (N;- n 1)))))
+
## Bounded
(do-template [<name> <type> <top> <bottom>]
[(defstruct #export <name> (B;Bounded <type>)
diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux
index 2b7090265..7301f2932 100644
--- a/source/lux/data/number/real.lux
+++ b/source/lux/data/number/real.lux
@@ -8,6 +8,7 @@
(monoid #as m)
(eq #as E)
(ord #as O)
+ (enum #as EN)
(bounded #as B)
(show #as S)))
@@ -56,6 +57,12 @@
[Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt])
+## Enum
+(defstruct Real/Enum (EN;Enum Real)
+ (def _ord Real/Ord)
+ (def succ (lambda [n] (:: Real/Number (N;+ n 1.0))))
+ (def pred (lambda [n] (:: Real/Number (N;- n 1.0)))))
+
## Bounded
(do-template [<name> <type> <top> <bottom>]
[(defstruct #export <name> (B;Bounded <type>)
diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux
index 78882c854..8d649cf4a 100644
--- a/source/lux/meta/ast.lux
+++ b/source/lux/meta/ast.lux
@@ -10,9 +10,9 @@
(number int
real)
char
- (text #refer #all #open ("text:" Text/Monoid))
+ (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid))
ident
- (list #refer (#only List interpose) #open ("" List/Functor List/Fold))
+ (list #refer #all #open ("" List/Functor))
)))
## [Types]
@@ -80,11 +80,11 @@
)))
## (defstruct #export AST/Eq (Eq AST)
-## (def (eq x y)
+## (def (= x y)
## (case [x y]
## (\template [<tag> <struct>]
-## [[(<tag> x') (<tag> y')]
-## (:: <struct> (E;eq x' y'))])
+## [[[_ (<tag> x')] [_ (<tag> y')]]
+## (:: <struct> (E;= x' y'))])
## [[#;BoolS Bool/Eq]
## [#;IntS Int/Eq]
## [#;RealS Real/Eq]
@@ -94,7 +94,7 @@
## [#;TagS Ident/Eq]]
## (\template [<tag>]
-## [[(<tag> xs') (<tag> ys')]
+## [[[_ (<tag> xs')] [_ (<tag> ys')]]
## (and (:: Int/Eq (E;= (size xs') (size ys')))
## (foldL (lambda [old [x' y']]
## (and old (= x' y')))
@@ -102,7 +102,7 @@
## (zip2 xs' ys')))])
## [[#;FormS] [#;TupleS]]
-## [(#;RecordS xs') (#;RecordS ys')]
+## [[_ (#;RecordS xs')] [_ (#;RecordS ys')]]
## (and (:: Int/Eq (E;= (size xs') (size ys')))
## (foldL (lambda [old [[xl' xr'] [yl' yr']]]
## (and old (= xl' yl') (= xr' yr')))
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
index 8fefab156..86bc08534 100644
--- a/src/lux/compiler/lambda.clj
+++ b/src/lux/compiler/lambda.clj
@@ -60,19 +60,20 @@
(.visitMaxs 0 0)
(.visitEnd)))
-(defn ^:private add-lambda-impl [class compile impl-signature impl-body]
- (&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil)
- (.visitCode))
- (|do [^MethodVisitor *writer* &/get-writer
- :let [$start (new Label)
- $end (new Label)]
- ret (compile impl-body)
- :let [_ (doto *writer*
- (.visitLabel $end)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return ret))))
+(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)]
+ (defn ^:private add-lambda-impl [class compile impl-signature impl-body]
+ (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" impl-signature nil nil)
+ (.visitCode))
+ (|do [^MethodVisitor *writer* &/get-writer
+ :let [$start (new Label)
+ $end (new Label)]
+ ret (compile impl-body)
+ :let [_ (doto *writer*
+ (.visitLabel $end)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return ret)))))
(defn ^:private instance-closure [compile lambda-class closed-over init-signature]
(|do [^MethodVisitor *writer* &/get-writer
@@ -88,23 +89,25 @@
(return nil)))
;; [Exports]
-(defn compile-lambda [compile ?scope ?env ?body]
- ;; (prn 'compile-lambda (->> ?scope &/->seq))
- (|do [:let [name (&host/location (&/|tail ?scope))
- class-name (str (&host/->module-class (&/|head ?scope)) "/" name)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- class-name nil "java/lang/Object" (into-array [&&/function-class]))
- (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil)
- (.visitEnd))
- (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
- (|case ?name+?captured
- [?name [(&a/$captured _ ?captured-id ?source) _]])
- (doseq [?name+?captured (&/->seq ?env)])))
- (add-lambda-apply class-name ?env)
- (add-lambda-<init> class-name ?env)
- )]
- _ (add-lambda-impl =class compile lambda-impl-signature ?body)
- :let [_ (.visitEnd =class)]
- _ (&&/save-class! name (.toByteArray =class))]
- (instance-closure compile class-name ?env (lambda-<init>-signature ?env))))
+(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)]
+ (defn compile-lambda [compile ?scope ?env ?body]
+ ;; (prn 'compile-lambda (->> ?scope &/->seq))
+ (|do [:let [name (&host/location (&/|tail ?scope))
+ class-name (str (&host/->module-class (&/|head ?scope)) "/" name)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 lambda-flags
+ class-name nil "java/lang/Object" (into-array [&&/function-class]))
+ (-> (doto (.visitField datum-flags captured-name clo-field-sig nil nil)
+ (.visitEnd))
+ (->> (let [captured-name (str &&/closure-prefix ?captured-id)])
+ (|case ?name+?captured
+ [?name [(&a/$captured _ ?captured-id ?source) _]])
+ (doseq [?name+?captured (&/->seq ?env)])))
+ (add-lambda-apply class-name ?env)
+ (add-lambda-<init> class-name ?env)
+ )]
+ _ (add-lambda-impl =class compile lambda-impl-signature ?body)
+ :let [_ (.visitEnd =class)]
+ _ (&&/save-class! name (.toByteArray =class))]
+ (instance-closure compile class-name ?env (lambda-<init>-signature ?env)))))
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index c17d10494..e85af8b0d 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -175,45 +175,47 @@
(return nil)))
)))
-(defn compile-def [compile ?name ?body]
- (|do [:let [=value-type (&a/expr-type* ?body)
- def-type (cond (&type/type= &type/Type =value-type)
- "type"
-
- :else
- "value")]
- ^ClassWriter *writer* &/get-writer
- module-name &/get-module-name
- :let [datum-sig "Ljava/lang/Object;"
- def-name (&/normalize-name ?name)
- current-class (str (&host/->module-class module-name) "/" def-name)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- current-class nil "java/lang/Object" (into-array [&&/function-class]))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/name-field "Ljava/lang/String;" nil ?name)
- (doto (.visitEnd)))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/datum-field datum-sig nil nil)
- (doto (.visitEnd)))
- (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/meta-field datum-sig nil nil)
- (doto (.visitEnd))))]
- _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (|do [^MethodVisitor **writer** &/get-writer
- :let [_ (.visitCode **writer**)]
- _ (compile ?body)
- :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)]
- _ (compile-def-type compile current-class ?body def-type)
- :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
- :let [_ (doto **writer**
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]]
- (return nil)))
- :let [_ (.visitEnd *writer*)]
- _ (&&/save-class! def-name (.toByteArray =class))
- class-loader &/loader
- :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))]
- _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)]
- (return nil)))
+(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)]
+ (defn compile-def [compile ?name ?body]
+ (|do [:let [=value-type (&a/expr-type* ?body)
+ def-type (cond (&type/type= &type/Type =value-type)
+ "type"
+
+ :else
+ "value")]
+ ^ClassWriter *writer* &/get-writer
+ module-name &/get-module-name
+ :let [datum-sig "Ljava/lang/Object;"
+ def-name (&/normalize-name ?name)
+ current-class (str (&host/->module-class module-name) "/" def-name)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 class-flags
+ current-class nil "java/lang/Object" (into-array [&&/function-class]))
+ (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/datum-field datum-sig nil nil)
+ (doto (.visitEnd)))
+ (-> (.visitField field-flags &/meta-field datum-sig nil nil)
+ (doto (.visitEnd))))]
+ _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
+ (|do [^MethodVisitor **writer** &/get-writer
+ :let [_ (.visitCode **writer**)]
+ _ (compile ?body)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)]
+ _ (compile-def-type compile current-class ?body def-type)
+ :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)]
+ :let [_ (doto **writer**
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]]
+ (return nil)))
+ :let [_ (.visitEnd *writer*)]
+ _ (&&/save-class! def-name (.toByteArray =class))
+ class-loader &/loader
+ :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))]
+ _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)]
+ (return nil))))
(defn compile-ann [compile *type* ?value-ex ?type-ex]
(compile ?value-ex))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 889d4fc47..4672b18d4 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -739,35 +739,35 @@
(check* class-loader fixpoints eA aA)
(fail (check-error expected actual)))
- [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)]
- (fn [state]
- (|case ((|do [F1 (deref ?eid)]
- (fn [state]
- (|case ((|do [F2 (deref ?aid)]
- (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2)))
- state)
- (&/$Right state* output)
- (return* state* output)
-
- (&/$Left _)
- ((check* class-loader fixpoints (App$ F1 A1) actual)
- state))))
- state)
- (&/$Right state* output)
- (return* state* output)
-
- (&/$Left _)
- (|case ((|do [F2 (deref ?aid)]
- (check* class-loader fixpoints expected (App$ F2 A2)))
- state)
- (&/$Right state* output)
- (return* state* output)
-
- (&/$Left _)
- ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid))
- [fixpoints** _] (check* class-loader fixpoints* A1 A2)]
- (return (&/T fixpoints** nil)))
- state))))
+ ;; [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)]
+ ;; (fn [state]
+ ;; (|case ((|do [F1 (deref ?eid)]
+ ;; (fn [state]
+ ;; (|case ((|do [F2 (deref ?aid)]
+ ;; (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2)))
+ ;; state)
+ ;; (&/$Right state* output)
+ ;; (return* state* output)
+
+ ;; (&/$Left _)
+ ;; ((check* class-loader fixpoints (App$ F1 A1) actual)
+ ;; state))))
+ ;; state)
+ ;; (&/$Right state* output)
+ ;; (return* state* output)
+
+ ;; (&/$Left _)
+ ;; (|case ((|do [F2 (deref ?aid)]
+ ;; (check* class-loader fixpoints expected (App$ F2 A2)))
+ ;; state)
+ ;; (&/$Right state* output)
+ ;; (return* state* output)
+
+ ;; (&/$Left _)
+ ;; ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid))
+ ;; [fixpoints** _] (check* class-loader fixpoints* A1 A2)]
+ ;; (return (&/T fixpoints** nil)))
+ ;; state))))
;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid))
;; _ (check* class-loader fixpoints A1 A2)]
@@ -788,6 +788,7 @@
[fixpoints** _] (check* class-loader fixpoints* e* a*)]
(return (&/T fixpoints** nil)))
state)))
+
;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]]
;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2)
;; e* (apply-type F2 A1)
@@ -810,6 +811,7 @@
[fixpoints** _] (check* class-loader fixpoints* e* a*)]
(return (&/T fixpoints** nil)))
state)))
+
;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]]
;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id))
;; e* (apply-type F1 A1)
@@ -817,6 +819,10 @@
;; [fixpoints** _] (check* class-loader fixpoints* e* a*)]
;; (return (&/T fixpoints** nil)))
+ ;; [(&/$AppT eF eA) (&/$AppT aF aA)]
+ ;; (|do [_ (check* class-loader fixpoints eF aF)]
+ ;; (check* class-loader fixpoints eA aA))
+
[(&/$AppT F A) _]
(let [fp-pair (&/T expected actual)
_ (when (> (&/|length fixpoints) 40)