aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2015-05-01 16:38:41 -0400
committerEduardo Julian2015-05-01 16:38:41 -0400
commitf3cc638b9dd31d06b9cf3e51dff8fb6352f22c7c (patch)
tree0c8dfba719163a102571bbdc637ef0e956ae079b
parent10081333a9e116d087825ec7be31099ab4bbe97d (diff)
- declare-macro has returned.
- Method-invocation special forms now take the wanted method as an unprefixed symbol, instead of as text. - Some fixes in lux.analyser.host. - Lambda analysis now just returns the origin exo-type instead of the endo-type. - Made some changes to the type of the CompilerState.
Diffstat (limited to '')
-rw-r--r--source/lux.lux1158
-rw-r--r--src/lux/analyser.clj15
-rw-r--r--src/lux/analyser/host.clj11
-rw-r--r--src/lux/analyser/lux.clj44
-rw-r--r--src/lux/analyser/module.clj32
-rw-r--r--src/lux/compiler/lux.clj13
-rw-r--r--src/lux/host.clj1
-rw-r--r--src/lux/type.clj108
8 files changed, 621 insertions, 761 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 32fde1d8a..8e004913b 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -118,41 +118,6 @@
#Nil]))])]))
(export' Meta)
-## (def' Reader
-## (List (Meta Cursor Text)))
-(def' Reader
- (#AppT [List
- (#AppT [(#AppT [Meta Cursor])
- Text])]))
-(export' Reader)
-
-## (deftype HostState
-## (& #writer (^ org.objectweb.asm.ClassWriter)
-## #loader (^ java.net.URLClassLoader)
-## #eval-ctor Int))
-(def' HostState
- (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
- (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
- (#Cons [["lux;eval-ctor" Int]
- #Nil])])])))
-
-## (deftype CompilerState
-## (& #source (Maybe Reader)
-## #modules (List Void)
-## #module-aliases (List Void)
-## #envs (List (Env Text Void))
-## #types (Bindings Int Type)
-## #host HostState))
-(def' CompilerState
- (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])]
- (#Cons [["lux;modules" (#AppT [List Void])]
- (#Cons [["lux;module-aliases" (#AppT [List Void])]
- (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) Void])])]
- (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
- (#Cons [["lux;host" HostState]
- #Nil])])])])])])))
-(export' CompilerState)
-
## (deftype (Syntax' w)
## (| (#Bool Bool)
## (#Int Int)
@@ -211,16 +176,78 @@
#Nil])]))])]))
(export' Either)
+## (deftype (StateE s a)
+## (-> s (Either Text (, s a))))
+(def' StateE
+ (#AllT [#None "StateE" "s"
+ (#AllT [#None "" "a"
+ (#LambdaT [(#BoundT "s")
+ (#AppT [(#AppT [Either Text])
+ (#TupleT (#Cons [(#BoundT "s")
+ (#Cons [(#BoundT "a")
+ #Nil])]))])])])]))
+
+## (def' Reader
+## (List (Meta Cursor Text)))
+(def' Reader
+ (#AppT [List
+ (#AppT [(#AppT [Meta Cursor])
+ Text])]))
+(export' Reader)
+
+## (deftype HostState
+## (& #writer (^ org.objectweb.asm.ClassWriter)
+## #loader (^ java.net.URLClassLoader)
+## #eval-ctor Int))
+(def' HostState
+ (#RecordT (#Cons [["lux;writer" (#DataT "org.objectweb.asm.ClassWriter")]
+ (#Cons [["lux;loader" (#DataT "java.lang.ClassLoader")]
+ (#Cons [["lux;eval-ctor" Int]
+ #Nil])])])))
+
+## (deftype (DefData' m)
+## (| #TypeD
+## (#ValueD Type)
+## (#MacroD m)))
+(def' DefData'
+ (#AllT [#None "DefData'" ""
+ (#VariantT (#Cons [["lux;TypeD" (#TupleT #Nil)]
+ (#Cons [["lux;ValueD" Type]
+ (#Cons [["lux;MacroD" (#BoundT "")]
+ #Nil])])]))]))
+
+## (deftype #rec CompilerState
+## (& #source (Maybe Reader)
+## #modules (List (, Text (List (, Text (DefData' (-> (List Syntax) (StateE CompilerState (List Syntax))))))))
+## #module-aliases (List Void)
+## #envs (List (Env Text Void))
+## #types (Bindings Int Type)
+## #host HostState))
+(def' CompilerState
+ (#AppT [(#AllT [#None "CompilerState" ""
+ (#RecordT (#Cons [["lux;source" (#AppT [Maybe Reader])]
+ (#Cons [["lux;modules" (#AppT [List (#TupleT (#Cons [Text
+ (#Cons [(#AppT [List (#TupleT (#Cons [Text
+ (#Cons [(#AppT [DefData' (#LambdaT [SyntaxList
+ (#AppT [(#AppT [StateE (#AppT [(#BoundT "CompilerState")
+ (#BoundT "")])])
+ SyntaxList])])])
+ #Nil])]))])
+ #Nil])]))])]
+ (#Cons [["lux;module-aliases" (#AppT [List Void])]
+ (#Cons [["lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) Void])])]
+ (#Cons [["lux;types" (#AppT [(#AppT [Bindings Int]) Type])]
+ (#Cons [["lux;host" HostState]
+ #Nil])])])])])]))])
+ Void]))
+(export' CompilerState)
+
## (deftype Macro
-## (-> (List Syntax) CompilerState
-## (Either Text (, CompilerState (List Syntax)))))
+## (-> (List Syntax) (StateE CompilerState (List Syntax))))
(def' Macro
(#LambdaT [SyntaxList
- (#LambdaT [CompilerState
- (#AppT [(#AppT [Either Text])
- (#TupleT (#Cons [CompilerState
- (#Cons [SyntaxList
- #Nil])]))])])]))
+ (#AppT [(#AppT [StateE CompilerState])
+ SyntaxList])]))
(export' Macro)
## Base functions & macros
@@ -275,33 +302,39 @@
(def' $text
(:' (#LambdaT [Text Syntax])
(lambda' _ text
- (_meta (#Text text)))))
+ (_meta (#Text text)))))
(export' $text)
(def' $symbol
(:' (#LambdaT [Ident Syntax])
(lambda' _ ident
- (_meta (#Symbol ident)))))
+ (_meta (#Symbol ident)))))
(export' $symbol)
(def' $tag
(:' (#LambdaT [Ident Syntax])
(lambda' _ ident
- (_meta (#Tag ident)))))
+ (_meta (#Tag ident)))))
(export' $tag)
(def' $form
(:' (#LambdaT [(#AppT [List Syntax]) Syntax])
(lambda' _ tokens
- (_meta (#Form tokens)))))
+ (_meta (#Form tokens)))))
(export' $form)
(def' $tuple
(:' (#LambdaT [(#AppT [List Syntax]) Syntax])
(lambda' _ tokens
- (_meta (#Tuple tokens)))))
+ (_meta (#Tuple tokens)))))
(export' $tuple)
+(def' $record
+ (:' (#LambdaT [(#AppT [List (#TupleT (#Cons [Syntax (#Cons [Syntax #Nil])]))]) Syntax])
+ (lambda' _ tokens
+ (_meta (#Record tokens)))))
+(export' $record)
+
(def' let'
(:' Macro
(lambda' _ tokens
@@ -314,6 +347,7 @@
_
(fail "Wrong syntax for let'")))))
+(declare-macro' let')
(def' lambda_
(:' Macro
@@ -353,6 +387,7 @@
_
(fail "Wrong syntax for lambda")))))
+(declare-macro' lambda_)
(def' def_
(:' Macro
@@ -416,33 +451,37 @@
_
(fail "Wrong syntax for def")
))))
+(declare-macro' def_)
(def_ #export (defmacro tokens)
Macro
(case' tokens
- (#Cons [usage (#Cons [body #Nil])])
+ (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])
(return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [($symbol ["lux" "def_"])
- (#Cons [usage
- (#Cons [($symbol ["lux" "Macro"])
- (#Cons [body
- #Nil])])
- ])])))
- #Nil])))
-
- (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [usage (#Cons [body #Nil])])])
+ (#Cons [($form (#Cons [($symbol ["lux" "def_"])
+ (#Cons [($form (#Cons [name args]))
+ (#Cons [($symbol ["lux" "Macro"])
+ (#Cons [body
+ #Nil])])
+ ])]))
+ (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])]))
+ #Nil])])))
+
+ (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])])])
(return (:' SyntaxList
- (#Cons [(_meta (#Form (#Cons [($symbol ["lux" "def_"])
- (#Cons [($tag ["" "export"])
- (#Cons [usage
- (#Cons [($symbol ["lux" "Macro"])
- (#Cons [body
- #Nil])])
- ])])])))
- #Nil])))
+ (#Cons [($form (#Cons [($symbol ["lux" "def_"])
+ (#Cons [($tag ["" "export"])
+ (#Cons [($form (#Cons [name args]))
+ (#Cons [($symbol ["lux" "Macro"])
+ (#Cons [body
+ #Nil])])
+ ])])]))
+ (#Cons [($form (#Cons [($symbol ["" "declare-macro'"]) (#Cons [name #Nil])]))
+ #Nil])])))
_
(fail "Wrong syntax for defmacro")))
+(declare-macro' defmacro)
(defmacro #export (comment tokens)
(return (:' SyntaxList #Nil)))
@@ -730,6 +769,15 @@
(_meta (#Form (list (_meta (#Tag ["lux" "Cons"]))
(_meta (#Tuple (list token (untemplate-list tokens')))))))))
+(def (list:++ xs ys)
+ (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a))))
+ (case' xs
+ (#Cons [x xs'])
+ (#Cons [x (list:++ xs' ys)])
+
+ #Nil
+ ys))
+
(defmacro #export ($ tokens)
(case' tokens
(#Cons [op (#Cons [init args])])
@@ -743,15 +791,6 @@
_
(fail "Wrong syntax for $")))
-(def (list:++ xs ys)
- (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a))))
- (case' xs
- (#Cons [x xs'])
- (#Cons [x (list:++ xs' ys)])
-
- #Nil
- ys))
-
(def (splice untemplate tag elems)
(->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax)
(case' (any? spliced? elems)
@@ -826,6 +865,24 @@
_
(fail "Wrong syntax for `")))
+(defmacro #export (|> tokens)
+ (case' tokens
+ (#Cons [init apps])
+ (return (:' SyntaxList
+ (list (fold (:' (->' Syntax Syntax Syntax)
+ (lambda [acc app]
+ (case' app
+ (#Meta [_ (#Form parts)])
+ ($form (list:++ parts (list acc)))
+
+ _
+ (` ((~ app) (~ acc))))))
+ init
+ apps))))
+
+ _
+ (fail "Wrong syntax for |>")))
+
(defmacro #export (if tokens)
(case' tokens
(#Cons [test (#Cons [then (#Cons [else #Nil])])])
@@ -952,6 +1009,163 @@
(;return (:' List (#Cons [y ys]))))
)))
+(def #export (. f g)
+ (All' [a b c]
+ (-> (-> (B' b) (B' c)) (-> (B' a) (B' b)) (-> (B' a) (B' c))))
+ (lambda [x]
+ (f (g x))))
+
+(def (get-ident x)
+ (-> Syntax ($' Maybe Text))
+ (case' x
+ (#Meta [_ (#Symbol ["" sname])])
+ (#Some sname)
+
+ _
+ #None))
+
+(def (tuple->list tuple)
+ (-> Syntax ($' Maybe ($' List Syntax)))
+ (case' tuple
+ (#Meta [_ (#Tuple members)])
+ (#Some members)
+
+ _
+ #None))
+
+(def RepEnv
+ Type
+ ($' List (, Text Syntax)))
+
+(def (make-env xs ys)
+ (-> ($' List Text) ($' List Syntax) RepEnv)
+ (case' (:' (, ($' List Text) ($' List Syntax))
+ [xs ys])
+ [(#Cons [x xs']) (#Cons [y ys'])]
+ (#Cons [[x y] (make-env xs' ys')])
+
+ _
+ #Nil))
+
+(def (text:= x y)
+ (-> Text Text Bool)
+ (jvm-invokevirtual java.lang.Object equals [java.lang.Object]
+ x [y]))
+
+(def (get-rep key env)
+ (-> Text RepEnv ($' Maybe Syntax))
+ (case' env
+ #Nil
+ #None
+
+ (#Cons [[k v] env'])
+ (if (text:= k key)
+ (#Some v)
+ (get-rep key env'))))
+
+(def (apply-template env template)
+ (-> RepEnv Syntax Syntax)
+ (case' template
+ (#Meta [_ (#Symbol ["" sname])])
+ (case' (get-rep sname env)
+ (#Some subst)
+ subst
+
+ _
+ template)
+
+ (#Meta [_ (#Tuple elems)])
+ ($tuple (map (apply-template env) elems))
+
+ (#Meta [_ (#Form elems)])
+ ($form (map (apply-template env) elems))
+
+ (#Meta [_ (#Record members)])
+ ($record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax))
+ (lambda [kv]
+ (let [[slot value] kv]
+ [(apply-template env slot) (apply-template env value)])))
+ members))
+
+ _
+ template))
+
+(def (join-map f xs)
+ (All' [a b]
+ (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b))))
+ (case' xs
+ #Nil
+ #Nil
+
+ (#Cons [x xs'])
+ (list:++ (f x) (join-map f xs'))))
+
+(defmacro (do-template tokens)
+ (case' tokens
+ (#Cons [(#Meta [_ (#Tuple bindings)]) (#Cons [(#Meta [_ (#Tuple templates)]) data])])
+ (case' (:' (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax))))
+ [(map% Maybe:Monad get-ident bindings)
+ (map% Maybe:Monad tuple->list data)])
+ [(#Some bindings') (#Some data')]
+ (let [apply (:' (-> RepEnv ($' List Syntax))
+ (lambda [env] (map (apply-template env) templates)))]
+ (|> data'
+ (join-map (. apply (make-env bindings')))
+ return))
+
+ _
+ (fail "All the do-template bindigns must be symbols."))
+
+ _
+ (fail "Wrong syntax for do-template")))
+
+(do-template [<name> <cmp> <type>]
+ [(def #export (<name> x y)
+ (-> <type> <type> Bool)
+ (<cmp> x y))]
+
+ [int:= jvm-leq Int]
+ [int:> jvm-lgt Int]
+ [int:< jvm-llt Int]
+ [real:= jvm-deq Real]
+ [real:> jvm-dgt Real]
+ [real:< jvm-dlt Real]
+ )
+
+(do-template [<name> <cmp> <type>]
+ [(def #export (<name> x y)
+ (-> <type> <type> <type>)
+ (<cmp> x y))]
+
+ [int:+ jvm-ladd Int]
+ [int:- jvm-lsub Int]
+ [int:* jvm-lmul Int]
+ [int:/ jvm-ldiv Int]
+ [int:% jvm-lrem Int]
+ [real:+ jvm-dadd Real]
+ [real:- jvm-dsub Real]
+ [real:* jvm-dmul Real]
+ [real:/ jvm-ddiv Real]
+ [real:% jvm-drem Real]
+ )
+
+(def (multiple? div n)
+ (-> Int Int Bool)
+ (int:= 0 (int:% n div)))
+
+(def #export (length list)
+ (-> List Int)
+ (fold (lambda [acc _] (int:+ 1 acc)) 0 list))
+
+(def #export (not x)
+ (-> Bool Bool)
+ (if x false true))
+
+(def (text:++ x y)
+ (-> Text Text Text)
+ (jvm-invokevirtual java.lang.String concat [java.lang.String]
+ x [y]))
+
(def (ident->text ident)
(-> Ident Text)
(let [[module name] ident]
@@ -975,61 +1189,98 @@
(;return (:' SyntaxList (list (` (#VariantT (list (~@ pairs)))))))))
(defmacro #export (& tokens)
- (if (not (int:= 2 (length tokens)))
+ (if (not (multiple? 2 (length tokens)))
(fail "& expects an even number of arguments.")
(do Lux:Monad
[pairs (map% Lux:Monad
- (lambda [pair]
- (case' pair
- [(#Meta [_ (#Tag ident)]) value]
- (;return (:' Syntax (` [(~ ($text (ident->text ident))) (~ value)])))
-
- _
- (fail "Wrong syntax for &")))
+ (:' (-> (, Syntax Syntax) ($' Lux Syntax))
+ (lambda [pair]
+ (case' pair
+ [(#Meta [_ (#Tag ident)]) value]
+ (;return (:' Syntax (` [(~ ($text (ident->text ident))) (~ value)])))
+
+ _
+ (fail "Wrong syntax for &"))))
(as-pairs tokens))]
(;return (:' SyntaxList (list (` (#RecordT (list (~@ pairs))))))))))
-## (defmacro #export (All tokens)
-## (case' (:' (, Ident SyntaxList)
-## (case' tokens
-## (#Cons [(#Meta [_ (#Symbol self-ident)]) tokens'])
-## [self-ident tokens']
-
-## _
-## [["" ""] tokens]))
-## [self-ident tokens']
-## (case' tokens'
-## (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
-## (do Lux:Monad
-## [idents (map% Lux:Monad get-ident args)]
-## (case' idents
-## #Nil
-## (return (list body))
+(def (replace-syntax reps syntax)
+ (-> RepEnv Syntax Syntax)
+ (case' syntax
+ (#Meta [_ (#Symbol ["" name])])
+ (case' (get-rep name reps)
+ (#Some replacement)
+ replacement
+
+ #None
+ syntax)
+
+ (#Meta [_ (#Form parts)])
+ (#Meta [_ (#Form (map (replace-syntax reps) parts))])
+
+ (#Meta [_ (#Tuple members)])
+ (#Meta [_ (#Tuple (map (replace-syntax reps) members))])
+
+ (#Meta [_ (#Record slots)])
+ (#Meta [_ (#Record (map (:' (-> (, Syntax Syntax) (, Syntax Syntax))
+ (lambda [slot]
+ (let [[k v] slot]
+ [(replace-syntax reps k) (replace-syntax reps v)])))
+ slots))])
+
+ _
+ syntax)
+ )
+
+(defmacro #export (All tokens)
+ (let [[self-ident tokens'] (:' (, Text SyntaxList)
+ (case' tokens
+ (#Cons [(#Meta [_ (#Symbol ["" self-ident])]) tokens'])
+ [self-ident tokens']
+
+ _
+ ["" tokens]))]
+ (case' tokens'
+ (#Cons [(#Meta [_ (#Tuple args)]) (#Cons [body #Nil])])
+ (case' (map% Maybe:Monad get-ident args)
+ (#Some idents)
+ (case' idents
+ #Nil
+ (return (:' SyntaxList (list body)))
-## (#Cons [harg targs])
-## (let [replacements (map (:' (-> Ident (, Ident Syntax))
-## (lambda [ident]
-## (let [[module name] ident]
-## [ident (_meta (#Bound ($ text:++ module ";" name)))])))
-## (list& self-ident idents))
-## body' (fold (lambda [body' arg']
-## (let [[module name] arg']
-## (` (#AllT [#None "" (~ ($text ($ text:++ module ";" name)))
-## (~ body')]))))
-## (replace-syntax replacements body)
-## (reverse targs))
-## [smodule sname] self-ident
-## [amodule aname] harg]
-## (return (list (` (#AllT [#None (~ ($text ($ text:++ smodule ";" sname)))
-## (~ ($text ($ text:++ amodule ";" aname)))
-## (~ body')])))))))
-
-## _
-## (fail "Wrong syntax for All"))
-## ))
+ (#Cons [harg targs])
+ (let [replacements (map (:' (-> Text (, Text Syntax))
+ (lambda [ident] [ident (` (#BoundT (~ ($text ident))))]))
+ (list& self-ident idents))
+ body' (fold (:' (-> Syntax Text Syntax)
+ (lambda [body' arg']
+ (` (#AllT [#None "" (~ ($text arg')) (~ body')]))))
+ (replace-syntax replacements body)
+ (reverse targs))]
+ (return (:' SyntaxList
+ (list (` (#AllT [#None (~ ($text self-ident)) (~ ($text harg)) (~ body')])))))))
+
+ #None
+ (fail "'All' arguments must be symbols."))
+
+ _
+ (fail "Wrong syntax for All"))
+ ))
+
+(def (get k plist)
+ (All [a]
+ (-> Text ($' List (, Text a)) ($' Maybe a)))
+ (case' plist
+ (#Cons [[k' v] plist'])
+ (if (text:= k k')
+ (#Some v)
+ (get k plist'))
+
+ #Nil
+ #None))
## (def #export (find-macro ident state)
-## (->' Ident ($' Lux Macro))
+## (-> Ident ($' Lux Macro))
## (let [[module name] ident]
## (case' state
## {#source source #modules modules #module-aliases module-aliases
@@ -1040,99 +1291,75 @@
## gdef (get name bindings)]
## (case' gdef
## (#MacroD macro')
-## macro'
-
+## (#Some macro')
+
## _
## #None)))
## (#Some macro)
## (#Right [state macro])
-
+
## #None
## (#Left ($ text:++ "There is no macro by the name: " module ";" name))))))
-## ## (def (id x)
-## ## (All [a] (-> a a))
-## ## x)
-## ## (export' id)
-
-## ## (def (text:= x y)
-## ## (-> Text Text Bool)
-## ## (jvm-invokevirtual java.lang.Object "equals" [java.lang.Object]
-## ## x [y]))
-
-## ## (def (replace-ident ident value syntax)
-## ## (-> (, Text Text) Syntax Syntax 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)))
-
-## ## (defsig (Eq a)
-## ## (: (-> a a Bool)
-## ## =))
-
-## ## (defstruct Text:Eq (Eq Text)
-## ## (def = text=))
-
-## ## (defstruct Ident:Eq (Eq Ident)
-## ## (def (= x y)
-## ## (let [[m1 n1] x
-## ## [m2 n2] y]
-## ## (and (text:= m1 m2)
-## ## (text:= n1 n2)))))
-
-## ## (deftype (Dict k v)
-## ## (: (-> k v (Dict k v) (Dict k v))
-## ## put)
-## ## (: (-> k (Dict k v) (Maybe v))
-## ## get)
-## ## (: (-> k (Dict k v) (Dict k v))
-## ## remove))
-
-## ## (deftype (PList k v)
-## ## (| (#PList (, (Eq k) (List (, k v))))))
-
-## ## (def (some f xs)
-## ## (All [a b]
-## ## (-> (-> a (Maybe b)) (List a) (Maybe b)))
-## ## (case' xs
-## ## #Nil
-## ## #None
-
-## ## (#Cons [x xs'])
-## ## (if-let [y (f x)]
-## ## (#Some y)
-## ## (some f xs'))
-## ## ))
-
-## ## (defstruct PList:Dict (Dict PList)
-## ## (def (get k plist)
-## ## (let [(#PList [{#= =} kvs]) plist]
-## ## (some (:' (-> (, ))
-## ## (lambda [kv]
-## ## (let [[k' v'] kv]
-## ## (when (= k k')
-## ## v'))))
-## ## kvs))))
+(def #export (find-macro ident state)
+ (-> Ident ($' Lux Macro))
+ (let [[module name] ident]
+ (case' state
+ {#source source #modules modules #module-aliases module-aliases
+ #envs envs #types types #host host}
+ (case' (:' ($' Maybe Macro)
+ (case' (get module modules)
+ (#Some bindings)
+ (case' (get name bindings)
+ (#Some gdef)
+ (case' gdef
+ (#MacroD macro')
+ (#Some macro')
+
+ _
+ #None)
+
+ #None
+ #None)
+
+ #None
+ #None))
+ (#Some macro)
+ (#Right [state macro])
+
+ #None
+ (#Left ($ text:++ "There is no macro by the name: " module ";" name))))))
+
+(def (join-list xs)
+ (All [a]
+ (-> ($' List ($' List a)) ($' List a)))
+ (fold list:++ #Nil xs))
+
+(def #export (macro-expand syntax state)
+ (-> Syntax ($' Lux ($' List Syntax)))
+ (case' syntax
+ (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))])
+ (do Lux:Monad
+ [macro' (find-macro macro-name)]
+ (case' macro'
+ (#Some macro)
+ (do Lux:Monad
+ [expansion (macro args)
+ expansion' (map% Lux:Monad macro-expand expansion)]
+ (return (:' SyntaxList (join-list expansion'))))
+
+ #None
+ (do Lux:Monad
+ [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))]
+ (return (:' Syntax (list ($form (join-list parts'))))))))
+
+ (#Meta [_ (#Tuple members)])
+ (do Lux:Monad
+ [members' (map% Lux:Monad macro-expand members)]
+ (return (:' Syntax (list ($tuple (join-list members'))))))
+
+ _
+ (return (:' SyntaxList (list syntax)))))
## ## (def (walk-type type)
## ## (-> Syntax ($' Lux Syntax))
@@ -1191,16 +1418,6 @@
## ## _
## ## (fail "Wrong syntax for :!")))
-## ## (def (print x)
-## ## (-> (^ java.lang.Object) [])
-## ## (jvm-invokevirtual java.io.PrintStream "print" [java.lang.Object]
-## ## (jvm-getstatic java.lang.System "out") [x]))
-
-## ## (def (println x)
-## ## (-> (^ java.lang.Object) [])
-## ## (jvm-invokevirtual java.io.PrintStream "println" [java.lang.Object]
-## ## (jvm-getstatic java.lang.System "out") [x]))
-
## ## (deftype (IO a)
## ## (-> (,) a))
@@ -1209,341 +1426,43 @@
## ## (#Cons [value #Nil])
## ## (return (list (` (lambda [_] (~ value)))))))
-## ## (def (. f g)
-## ## (All [a b c]
-## ## (-> (-> b c) (-> a b) (-> a c)))
-## ## (lambda [x]
-## ## (f (g x))))
-
-## ## (def concat
-## ## (All [a]
-## ## (-> (List (List a)) (List a)))
-## ## (fold ++ #Nil))
-
-## ## (def flat-map
-## ## (All [a b]
-## ## (-> (-> a (List b)) (List a) (List b)))
-## ## (. concat map))
-
-## ## (def (filter p xs)
-## ## (All [a]
-## ## (-> (-> a Bool) (List a) (List a)))
-## ## (case' xs
-## ## #Nil
-## ## #Nil
-
-## ## (#Cons [x xs'])
-## ## (if (p x)
-## ## (#Cons [x (filter p xs')])
-## ## (filter p xs'))))
-
-## ## (deftype (Lux a)
-## ## (-> CompilerState (Either Text (, CompilerState a))))
-
-## ## (def (first pair)
-## ## (All [a b] (-> (, a b) a))
-## ## (case' pair
-## ## [f s]
-## ## f))
-
-## ## (def (second pair)
-## ## (All [a b] (-> (, a b) b))
-## ## (case' pair
-## ## [f s]
-## ## s))
+## (defmacro #export (exec tokens)
+## (case' (reverse tokens)
+## (#Cons [value actions])
+## (let [dummy ($symbol ["" ""])]
+## (return (:' SyntaxList
+## (list (fold (:' (-> Syntax Syntax Syntax)
+## (lambda [post pre]
+## (` (case' (~ pre) (~ dummy) (~ post)))))
+## value
+## actions)))))
+
+## _
+## (fail "Wrong syntax for exec")))
+
+## (def #export (print x)
+## (-> Text (IO (,)))
+## (io (jvm-invokevirtual java.io.PrintStream print [java.lang.Object]
+## (jvm-getstatic java.lang.System out) [x])))
+
+## (def #export (println x)
+## (-> Text (IO (,)))
+## (print (text:++ x "\n")))
## ## (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)))
+## ## (return (list (#Form (#Cons [(` (lambda (~ (#Symbol ["" "recur"])) (~ (#Tuple (map first pairs)))
## ## (~ body)))
## ## (map second pairs)])))))))
-## ## (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)
-## ## (-> Bool Bool)
-## ## (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)))))
-
-## ## (def (const x)
-## ## (All [a b]
-## ## (-> a (-> b a)))
-## ## (lambda [_]
-## ## x))
-
-## ## (def (int> x y)
-## ## (-> Int Int Bool)
-## ## (jvm-lgt x y))
-
-## ## (def (int< x y)
-## ## (-> Int Int Bool)
-## ## (jvm-llt x y))
-
-## ## (def inc
-## ## (-> Int Int)
-## ## (int+ 1))
-
-## ## (def dec
-## ## (-> Int Int)
-## ## (int+ -1))
-
-## ## (def (repeat n x)
-## ## (All [a] (-> Int a (List a)))
-## ## (if (int> n 0)
-## ## (#Cons [x (repeat (dec n) x)])
-## ## #Nil))
-
-## ## (def size
-## ## (All [a]
-## ## (-> (List a) Int))
-## ## (fold (lambda [acc _] (inc acc)) 0))
-
-## ## (def (last xs)
-## ## (All [a]
-## ## (-> (List a) (Maybe a)))
-## ## (case' xs
-## ## #Nil #None
-## ## (#Cons [x #Nil]) (#Some x)
-## ## (#Cons [_ xs']) (last xs')))
-
-## ## (def (init xs)
-## ## (All [a]
-## ## (-> (List a) (Maybe (List a))))
-## ## (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)
-## ## (All [a]
-## ## (-> (List a) (List a) (List a)))
-## ## (case' [xs ys]
-## ## [(#Cons [x xs']) (#Cons [y ys'])]
-## ## (list+ x y (interleave xs' ys'))
-
-## ## _
-## ## #Nil))
-
-## ## (def (interpose sep xs)
-## ## (All [a]
-## ## (-> a (List a) (List a)))
-## ## (case' xs
-## ## #Nil
-## ## xs
-
-## ## (#Cons [x #Nil])
-## ## xs
-
-## ## (#Cons [x xs'])
-## ## (list+ x sep (interpose sep xs'))))
-
-## ## (def (empty? xs)
-## ## (All [a]
-## ## (-> (List a) Bool))
-## ## (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 (tuple->list tuple)
-## ## (-> Syntax (List Syntax))
-## ## (case' tuple
-## ## (#Meta [_ (#Tuple list)])
-## ## list))
-
-## ## (def (zip2 xs ys)
-## ## (All [a b]
-## ## (-> (List a) (List b) (List (, a b))))
-## ## (case' [xs ys]
-## ## [(#Cons [x xs']) (#Cons [y ys'])]
-## ## (#Cons [[x y] (zip2 xs' ys')])
-
-## ## _
-## ## #Nil))
-
-## ## (def (get-ident x)
-## ## (-> Syntax Text)
-## ## (case' x
-## ## (#Meta [_ (#Symbol [_ ident])])
-## ## ident))
-
-## ## (def (text-++ x y)
-## ## (-> Text Text Text)
-## ## (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-templates tokens)
-## ## (case' tokens
-## ## (#Cons [bindings (#Cons [(#Meta [_ (#Tuple templates)]) data])])
-## ## (let [bindings-list (map get-ident (tuple->list bindings))
-## ## data-lists (map tuple->list data)
-## ## apply (lambda [env] (map (apply-template env) templates))]
-## ## (|> data-lists
-## ## (map (. apply (zip2 bindings-list)))
-## ## return))))
-
## ## ## (do-template [<name> <offset>]
## ## ## (def <name> (int+ <offset>))
## ## ## [inc 1]
## ## ## [dec -1])
-## ## (def (int= x y)
-## ## (-> Int Int Bool)
-## ## (jvm-leq x y))
-
-## ## (def (int% x y)
-## ## (-> Int Int Int)
-## ## (jvm-lrem x y))
-
-## ## (def (int>= x y)
-## ## (-> Int Int Bool)
-## ## (or (int= x y)
-## ## (int> x y)))
-
-## ## (do-templates [<name> <cmp>]
-## ## [(def (<name> x y)
-## ## (-> Int Int Int)
-## ## (if (<cmp> x y)
-## ## x
-## ## y))]
-
-## ## [max int>]
-## ## [min int<])
-
-## ## (do-templates [<name> <cmp>]
-## ## [(def (<name> n)
-## ## (-> Int Bool)
-## ## (<cmp> n 0))]
-
-## ## [neg? int<]
-## ## [pos? int>=])
-
-## ## (def (even? n)
-## ## (-> Int Bool)
-## ## (int= 0 (int% n 0)))
-
-## ## (def (odd? n)
-## ## (-> Int Bool)
-## ## (not (even? n)))
-
-## ## (do-templates [<name> <done> <step>]
-## ## [(def (<name> n xs)
-## ## (All [a]
-## ## (-> Int (List a) (List a)))
-## ## (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-templates [<name> <done> <step>]
-## ## [(def (<name> f xs)
-## ## (All [a]
-## ## (-> (-> a Bool) (List a) (List a)))
-## ## (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])])
@@ -1591,72 +1510,14 @@
## ## [(update@ [#gen-seed] inc state)
## ## (_meta (#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)
-## ## (-> Syntax Text)
-## ## (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 ($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 (macro-expand syntax)
-## ## (-> Syntax (LuxStateM (List Syntax)))
-## ## (case' syntax
-## ## (#Form (#Cons [(#Symbol macro-name) args]))
-## ## (do [macro (get-macro macro-name)]
-## ## ((:'! macro Macro) args))))
+## ## (do-template [<name> <member>]
+## ## (def (<name> pair)
+## ## (case' pair
+## ## [f s]
+## ## <member>))
+
+## ## [first f]
+## ## [second s])
## ## (defmacro (case tokens)
## ## (case' tokens
@@ -1687,94 +1548,3 @@
## ## )]
## ## (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))))))))
-
-## ## ## (def (with tokens)
-## ## ## ...)
-
-## ## (import' lux)
-## ## (module-alias' lux l)
-## ## (import lux #as l #use [map])
-
-## ## (defsyntax #export (All [name (%? %name)] [args %args] body)
-## ## (let [name' (case name
-## ## #None ""
-## ## (#Some name) name)
-## ## arg-replacements (map (lambda [arg]
-## ## [(#Symbol ["" arg]) (` (#Bound (~ arg)))])
-## ## args)
-## ## args' (map (lambda [arg]
-## ## (#Symbol ["" arg]))
-## ## args)
-## ## body' (replace-syntax arg-replacements body)]
-## ## (return (list (` (#AllT [#None (~ name') (#Tuple (list (~@ args')))
-## ## (~ body')]))))))
-
-## ## (def (walk-syntax type)
-## ## (case type
-## ## (#Meta [_ (#Form (\list& op args))])
-## ## (case op
-## ## (#Meta [_ (#Symbol ident)])
-## ## (do' [macro?? (find-macro ident)]
-## ## (case macro??
-## ## (#Some macro)
-## ## (do' [expansion (macro args)]
-## ## (flat-map% walk-syntax expansion))
-
-## ## #None
-## ## (do' [flat-map% (map% walk-syntax args)]
-## ## (return (list (fold (lambda [fun arg]
-## ## (` (#AppT [(~ fun) (~ arg)])))
-## ## op
-## ## args))))))
-
-## ## _
-## ## (do' [flat-map% (map% walk-syntax args)]
-## ## (return (list (_meta (#Form (list op args')))))))
-
-## ## _
-## ## (return (list type))))
-
-## ## (defsyntax #export (type type-syntax)
-## ## (walk-syntax type-syntax))
-
-## ## (defsyntax #export (deftype [[name args] %usage] body)
-## ## (return (list (` (def (~ name)
-## ## (:' Type
-## ## (type (All [(~@ args)]
-## ## (~ body)))))))))
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index e4511fdeb..938f6df2f 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -90,6 +90,11 @@
;; (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;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?name]]]]
+ ["lux;Nil" _]]]]]]]]]
+ (&&lux/analyse-declare-macro analyse ?name)
+
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" "import'"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?path]]]
["lux;Nil" _]]]]]]]]]
@@ -256,7 +261,7 @@
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" "jvm-invokestatic"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?method]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
["lux;Nil" _]]]]]]]]]]]]]]]
@@ -264,7 +269,7 @@
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" "jvm-invokevirtual"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?method]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
["lux;Cons" [?object
["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
@@ -272,8 +277,8 @@
(&&host/analyse-jvm-invokevirtual analyse ?class ?method ?classes ?object ?args)
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" "jvm-invokeinterface"]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?method]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?class]]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
["lux;Cons" [?object
["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
@@ -282,7 +287,7 @@
[["lux;Meta" [meta ["lux;Form" ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" "jvm-invokespecial"]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" [_ ?class]]]]
- ["lux;Cons" [["lux;Meta" [_ ["lux;Text" ?method]]]
+ ["lux;Cons" [["lux;Meta" [_ ["lux;Symbol" ["" ?method]]]]
["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?classes]]]
["lux;Cons" [?object
["lux;Cons" [["lux;Meta" [_ ["lux;Tuple" ?args]]]
diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj
index 7d9aaae2f..466058f4e 100644
--- a/src/lux/analyser/host.clj
+++ b/src/lux/analyser/host.clj
@@ -2,7 +2,7 @@
(:require (clojure [template :refer [do-template]])
[clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
- (lux [base :as & :refer [|do return fail]]
+ (lux [base :as & :refer [|let |do return fail]]
[parser :as &parser]
[type :as &type]
[host :as &host])
@@ -102,16 +102,19 @@
(do-template [<name> <tag>]
(defn <name> [analyse ?class ?method ?classes ?object ?args]
- ;; (prn '<name> ?class ?method)
+ (prn '<name> ?class ?method)
(|do [=class (&host/full-class-name ?class)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=class =class)]
=classes (&/map% &host/extract-jvm-param ?classes)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=classes =classes)]
=return (&host/lookup-virtual-method =class ?method =classes)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=return =return)]
- =object (&&/analyse-1 analyse ?object)
+ =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object)
;; :let [_ (prn 'analyse-jvm-invokevirtual/=object =object)]
- =args (&/flat-map% analyse ?args)
+ =args (&/map% (fn [c+o]
+ (|let [[?c ?o] c+o]
+ (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)))
+ (&/zip2 =classes ?args))
;; :let [_ (prn 'analyse-jvm-invokevirtual/=args =args)]
]
(return (&/|list (&/V "Expression" (&/T (&/V <tag> (&/T =class ?method =classes =object =args)) =return))))))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index b9a3ffbf2..7c9b9b5f0 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -38,6 +38,12 @@
(return (&/|list (&/V "Expression" (&/T (&/V "tuple" =elems)
exo-type)))))
+ [["lux;AllT" _]]
+ (&type/with-var
+ (fn [$var]
+ (|do [exo-type** (&type/apply-type exo-type* $var)]
+ (analyse-tuple analyse exo-type** ?elems))))
+
[_]
(fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))))
@@ -315,13 +321,39 @@
(if ?
(|do [dtype (&type/deref ?id)]
(fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))
- (return output)))))))
+ (matchv ::M/objects [output]
+ [["Expression" [_expr _]]]
+ ;; (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _arg))]
+ ;; (return (&/V "Expression" (&/T _expr exo-type))))
+ (return (&/V "Expression" (&/T _expr exo-type)))
+ )))))))
[_]
(|do [exo-type* (&type/actual-type exo-type)]
(analyse-lambda* analyse exo-type* ?self ?arg ?body))
))
+;; (defn analyse-lambda** [analyse exo-type ?self ?arg ?body]
+;; ;; (prn 'analyse-lambda**/&& (aget exo-type 0))
+;; (matchv ::M/objects [exo-type]
+;; [["lux;AllT" [_env _self _arg _body]]]
+;; (&type/with-var
+;; (fn [$var]
+;; (|do [exo-type* (&type/apply-type exo-type $var)
+;; output (analyse-lambda** analyse exo-type* ?self ?arg ?body)]
+;; (matchv ::M/objects [$var]
+;; [["lux;VarT" ?id]]
+;; (|do [? (&type/bound? ?id)]
+;; (if ?
+;; (|do [dtype (&type/deref ?id)]
+;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))
+;; (return output)))))))
+
+;; [_]
+;; (|do [exo-type* (&type/actual-type exo-type)]
+;; (analyse-lambda* analyse exo-type* ?self ?arg ?body))
+;; ))
+
(defn analyse-lambda [analyse exo-type ?self ?arg ?body]
(|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)]
(return (&/|list output))))
@@ -341,10 +373,7 @@
:let [_ (prn 'analyse-def/TYPE ?name ;; (&type/show-type =value-type)
)
_ (println)
- def-data (cond (&type/type= &type/Macro =value-type)
- (&/V "lux;MacroD" (&/V "lux;None" nil))
-
- (&type/type= &type/Type =value-type)
+ def-data (cond (&type/type= &type/Type =value-type)
(&/V "lux;TypeD" nil)
:else
@@ -354,6 +383,11 @@
]
(return (&/|list (&/V "Statement" (&/V "def" (&/T ?name =value def-data)))))))))
+(defn analyse-declare-macro [analyse ?name]
+ (|do [module-name &/get-module-name
+ _ (&&module/declare-macro module-name ?name)]
+ (return (&/|list))))
+
(defn analyse-import [analyse exo-type ?path]
(return (&/|list)))
diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj
index ac5968026..6f82d9b6f 100644
--- a/src/lux/analyser/module.clj
+++ b/src/lux/analyser/module.clj
@@ -2,7 +2,8 @@
(:require [clojure.core.match :as M :refer [matchv]]
clojure.core.match.array
(lux [base :as & :refer [|do return return* fail fail*]]
- [type :as &type])
+ [type :as &type]
+ [host :as &host])
[lux.analyser.base :as &&]))
;; [Exports]
@@ -54,6 +55,35 @@
(return true))
(return false))))
+(defn declare-macro [module name]
+ (fn [state]
+ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))]
+ (if-let [$def (&/|get name $module)]
+ (matchv ::M/objects [$def]
+ [["lux;ValueD" ?type]]
+ (do ;; (prn 'declare-macro/?type (aget ?type 0))
+ (&/run-state (|do [_ (&type/check &type/Macro ?type)
+ loader &/loader
+ :let [macro (-> (.loadClass loader (&host/location (&/|list module name)))
+ (.getField "_datum")
+ (.get nil))]]
+ (fn [state*]
+ (return* (&/update$ &/$MODULES
+ (fn [$modules]
+ (&/|put module (&/|put name (&/V "lux;MacroD" (&/V "lux;Some" macro)) $module)
+ $modules))
+ state*)
+ nil)))
+ state))
+
+ [["lux;MacroD" _]]
+ (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name)))
+
+ [["lux;TypeD" _]]
+ (fail* (str "[Analyser Error] Definition doesn't have macro type: " module ";" name)))
+ (fail* (str "[Analyser Error] Definition doesn't exist: " (str module &/+name-separator+ name))))
+ (fail* (str "[Analyser Error] Module doesn't exist: " module)))))
+
(defn install-macro [module name macro]
(fn [state]
(if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))]
diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj
index 5ceeca1bc..1553d3975 100644
--- a/src/lux/compiler/lux.clj
+++ b/src/lux/compiler/lux.clj
@@ -163,16 +163,5 @@
;; :let [_ (prn 'compile-def/_1 ?name current-class)]
_ (&&/save-class! current-class (.toByteArray =class))
;; :let [_ (prn 'compile-def/_2 ?name)]
- loader &/loader
- :let [full-macro-name (&host/location (&/|list module-name ?name))]
- _ (if-let [macro (matchv ::M/objects [?def-data]
- [["lux;MacroD" ["lux;None" _]]]
- (-> (.loadClass loader full-macro-name)
- (.getField "_datum")
- (.get nil))
-
- [_]
- nil)]
- (&a-module/install-macro module-name ?name macro)
- (return nil))]
+ ]
(return nil)))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 5b02c8192..26a270199 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -4,7 +4,6 @@
[clojure.core.match :as M :refer [match matchv]]
clojure.core.match.array
(lux [base :as & :refer [|do return* return fail fail* |let]]
- [parser :as &parser]
[type :as &type])))
;; [Constants]
diff --git a/src/lux/type.clj b/src/lux/type.clj
index e5c96d7bd..217a167a4 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -76,28 +76,6 @@
(&/V "lux;VariantT" (&/|list (&/T "lux;Meta" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m")
(&/V "lux;BoundT" "v")))))))))
-(def Reader
- (&/V "lux;AppT" (&/T List
- (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Meta Cursor))
- Text)))))
-
-(def HostState
- (&/V "lux;RecordT"
- (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter"))
- (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader"))
- (&/T "lux;eval-ctor" Int))))
-
-(def CompilerState
- (&/V "lux;RecordT"
- (&/|list (&/T "lux;source" (&/V "lux;AppT" (&/T Maybe Reader)))
- (&/T "lux;modules" (&/V "lux;AppT" (&/T List $Void)))
- (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List $Void)))
- (&/T "lux;envs" (&/V "lux;AppT" (&/T List
- (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text))
- $Void)))))
- (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type)))
- (&/T "lux;host" HostState))))
-
(def Syntax*
(let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w")
(&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Syntax'")
@@ -121,20 +99,64 @@
(let [w (&/V "lux;AppT" (&/T Meta Cursor))]
(&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T Syntax* w))))))
+(def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax)))
+
(def Either
(fAll "_" "l"
(fAll "" "r"
(&/V "lux;VariantT" (&/|list (&/T "lux;Left" (&/V "lux;BoundT" "l"))
(&/T "lux;Right" (&/V "lux;BoundT" "r")))))))
+(def StateE
+ (fAll "StateE" "s"
+ (fAll "" "a"
+ (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s")
+ (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text))
+ (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "s")
+ (&/V "lux;BoundT" "a"))))))))))
+
+(def Reader
+ (&/V "lux;AppT" (&/T List
+ (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Meta Cursor))
+ Text)))))
+
+(def HostState
+ (&/V "lux;RecordT"
+ (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter"))
+ (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader"))
+ (&/T "lux;eval-ctor" Int))))
+
+(def DefData*
+ (fAll "DefData'" ""
+ (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit)
+ (&/T "lux;ValueD" Type)
+ (&/T "lux;MacroD" (&/V "lux;BoundT" ""))))))
+
+(def CompilerState
+ (&/V "lux;AppT" (&/T (fAll "CompilerState" ""
+ (&/V "lux;RecordT"
+ (&/|list (&/T "lux;source" (&/V "lux;AppT" (&/T Maybe Reader)))
+ (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT"
+ (&/|list Text
+ (&/V "lux;AppT" (&/T List (&/V "lux;TupleT"
+ (&/|list Text
+ (&/V "lux;AppT" (&/T DefData*
+ (&/V "lux;LambdaT" (&/T SyntaxList
+ (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "CompilerState")
+ (&/V "lux;BoundT" "")))))
+ SyntaxList)))))))))))))))
+ (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List $Void)))
+ (&/T "lux;envs" (&/V "lux;AppT" (&/T List
+ (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text))
+ $Void)))))
+ (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type)))
+ (&/T "lux;host" HostState))))
+ $Void)))
+
(def Macro
- (let [SyntaxList (&/V "lux;AppT" (&/T List Syntax))]
- (&/V "lux;LambdaT" (&/T SyntaxList
- (&/V "lux;LambdaT" (&/T CompilerState
- (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text))
- (&/V "lux;TupleT" (&/|list CompilerState
- SyntaxList))))))))
- ))
+ (&/V "lux;LambdaT" (&/T SyntaxList
+ (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE CompilerState))
+ SyntaxList)))))
(defn bound? [id]
(fn [state]
@@ -145,7 +167,7 @@
[["lux;None" _]]
(return* state false))
- (fail* (str "[Type Error] Unknown type-var: " id)))))
+ (fail* (str "[Type Error] <bound?> Unknown type-var: " id)))))
(defn deref [id]
(fn [state]
@@ -159,7 +181,7 @@
[["lux;None" _]]
(fail* (str "[Type Error] Unbound type-var: " id))))
- (fail* (str "[Type Error] Unknown type-var: " id)))))))
+ (fail* (str "[Type Error] <deref> Unknown type-var: " id)))))))
(defn set-var [id type]
(fn [state]
@@ -175,7 +197,7 @@
ts))
state)
nil))))
- (fail* (str "[Type Error] Unknown type-var: " id)))))
+ (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length))))))
;; [Exports]
;; Type vars
@@ -196,20 +218,23 @@
(if (= id ?id)
(return binding)
(matchv ::M/objects [?type]
+ [["lux;None" _]]
+ (return binding)
+
[["lux;Some" ?type*]]
(matchv ::M/objects [?type*]
[["lux;VarT" ?id*]]
(if (= id ?id*)
(return (&/T ?id (&/V "lux;None" nil)))
- (|do [?type** (clean* id ?type*)]
- (return (&/T ?id (&/V "lux;Some" ?type**)))))
+ (return binding)
+ ;; (|do [?type** (clean* id ?type*)]
+ ;; (return (&/T ?id (&/V "lux;Some" ?type**))))
+ )
[_]
(|do [?type** (clean* id ?type*)]
(return (&/T ?id (&/V "lux;Some" ?type**)))))
-
- [["lux;None" _]]
- (return binding)))))
+ ))))
(->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))]
(fn [state]
(return* (&/update$ &/$TYPES #(->> %
@@ -237,6 +262,7 @@
(if (= ?tid ?id)
(&/try-all% (&/|list (deref ?id)
(return type)))
+ ;; (deref ?id)
(return type))
[["lux;LambdaT" [?arg ?return]]]
@@ -349,6 +375,9 @@
[_]
[args body*]))]
(str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")"))
+
+ [_]
+ (assert false (prn-str 'show-type (aget type 0) (class (aget type 1))))
))
(defn type= [x y]
@@ -604,7 +633,7 @@
[["lux;AppT" [F A]] _]
(let [fp-pair (&/T expected actual)
;; _ (prn 'LEFT_APP (&/|length fixpoints))
- _ (when (> (&/|length fixpoints) 20)
+ _ (when (> (&/|length fixpoints) 40)
(println 'FIXPOINTS (->> (&/|keys fixpoints)
(&/|map (fn [pair]
(|let [[e a] pair]
@@ -660,7 +689,8 @@
(check* fixpoints expected actual*))))
[["lux;DataT" e!name] ["lux;DataT" a!name]]
- (if (= e!name a!name)
+ (if (or (= e!name a!name)
+ (.isAssignableFrom (Class/forName e!name) (Class/forName a!name)))
(return (&/T fixpoints nil))
(fail (str "[Type Error] Names don't match: " e!name " & " a!name)))