diff options
Diffstat (limited to 'source')
-rw-r--r-- | source/lux.lux | 1158 |
1 files changed, 464 insertions, 694 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))))))))) |