From 6d803df4bdb4a68bba80cbbc4eeed02170813e96 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 3 May 2015 08:54:50 -0400 Subject: - The type syntax is finally complete ^_^ - Finally, the "case" macro has been implemented ^_^ - The macro-expand function is also alive! - Corrected the field-access special forms so they take their field as a symbol instead of text. - Macros are no longer stored inside the CompilerState as (Maybe Macro), but as Macro. - Void is implemented as - Fixed an error when parsing escaped characters in text. - Fixed an error in the reader in which parsing regex2 gave back a 2-vector instead of a 2-tuple. --- source/lux.lux | 292 +++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 182 insertions(+), 110 deletions(-) (limited to 'source') diff --git a/source/lux.lux b/source/lux.lux index 04ffcf91f..70ebaf67e 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -646,7 +646,7 @@ _ (fail "Wrong syntax for lambda")))) -(defmacro #export (def tokens) +(defmacro (def__ tokens) (case' tokens (#Cons [(#Meta [_ (#Tag ["" "export"])]) (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) @@ -693,7 +693,7 @@ (fail "Wrong syntax for def") )) -(def (as-pairs xs) +(def__ (as-pairs xs) (All' [a] (->' ($' List (B' a)) ($' List (#TupleT (list (B' a) (B' a)))))) (case' xs @@ -724,7 +724,7 @@ _ (fail "Wrong syntax for let"))) -(def #export (map f xs) +(def__ #export (map f xs) (All' [a b] (->' (->' (B' a) (B' b)) ($' List (B' a)) ($' List (B' b)))) (case' xs @@ -734,7 +734,7 @@ (#Cons [x xs']) (#Cons [(f x) (map f xs')]))) -(def #export (any? p xs) +(def__ #export (any? p xs) (All' [a] (->' (->' (B' a) Bool) ($' List (B' a)) Bool)) (case' xs @@ -746,7 +746,7 @@ true true false (any? p xs')))) -(def (spliced? token) +(def__ (spliced? token) (->' Syntax Bool) (case' token (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol ["" "~@"])]) (#Cons [_ #Nil])]))]) @@ -755,13 +755,13 @@ _ false)) -(def (wrap-meta content) +(def__ (wrap-meta content) (->' Syntax Syntax) (_meta (#Form (list (_meta (#Tag ["lux" "Meta"])) (_meta (#Tuple (list (_meta (#Tuple (list (_meta (#Text "")) (_meta (#Int -1)) (_meta (#Int -1))))) content))))))) -(def (untemplate-list tokens) +(def__ (untemplate-list tokens) (->' ($' List Syntax) Syntax) (case' tokens #Nil @@ -771,7 +771,7 @@ (_meta (#Form (list (_meta (#Tag ["lux" "Cons"])) (_meta (#Tuple (list token (untemplate-list tokens'))))))))) -(def (list:++ xs ys) +(def__ (list:++ xs ys) (All' [a] (->' ($' List (B' a)) ($' List (B' a)) ($' List (B' a)))) (case' xs (#Cons [x xs']) @@ -793,7 +793,7 @@ _ (fail "Wrong syntax for $"))) -(def (splice untemplate tag elems) +(def__ (splice untemplate tag elems) (->' (->' Syntax Syntax) Syntax ($' List Syntax) Syntax) (case' (any? spliced? elems) true @@ -816,7 +816,7 @@ false (wrap-meta ($form (list tag (untemplate-list (map untemplate elems))))))) -(def (untemplate token) +(def__ (untemplate token) (->' Syntax Syntax) (case' token (#Meta [_ (#Bool value)]) @@ -898,7 +898,7 @@ ## (deftype (Lux a) ## (-> CompilerState (Either Text (, CompilerState a)))) -(def #export Lux +(def__ #export Lux Type (All' [a] (->' CompilerState ($' Either Text (#TupleT (list CompilerState (B' a))))))) @@ -908,7 +908,7 @@ ## return) ## (: (All [a b] (-> (-> a (m b)) (m a) (m b))) ## bind)) -(def Monad +(def__ Monad Type (All' [m] (#RecordT (list ["lux;return" (All' [a] (->' (B' a) ($' (B' m) (B' a))))] @@ -916,7 +916,7 @@ ($' (B' m) (B' a)) ($' (B' m) (B' b))))])))) -(def Maybe:Monad +(def__ Maybe:Monad ($' Monad Maybe) {#lux;return (lambda return [x] @@ -928,7 +928,7 @@ #None #None (#Some a) (f a)))}) -(def Lux:Monad +(def__ Lux:Monad ($' Monad Lux) {#lux;return (lambda return [x] @@ -996,7 +996,7 @@ _ (fail "Wrong syntax for do"))) -(def (map% m f xs) +(def__ (map% m f xs) ## (All [m a b] ## (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) (All' [m a b] @@ -1016,13 +1016,13 @@ (;return (:' List (#Cons [y ys])))) ))) -(def #export (. f g) +(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) +(def__ (get-ident x) (-> Syntax ($' Maybe Text)) (case' x (#Meta [_ (#Symbol ["" sname])]) @@ -1031,7 +1031,7 @@ _ #None)) -(def (tuple->list tuple) +(def__ (tuple->list tuple) (-> Syntax ($' Maybe ($' List Syntax))) (case' tuple (#Meta [_ (#Tuple members)]) @@ -1040,11 +1040,11 @@ _ #None)) -(def RepEnv +(def__ RepEnv Type ($' List (, Text Syntax))) -(def (make-env xs ys) +(def__ (make-env xs ys) (-> ($' List Text) ($' List Syntax) RepEnv) (case' (:' (, ($' List Text) ($' List Syntax)) [xs ys]) @@ -1054,12 +1054,12 @@ _ #Nil)) -(def (text:= x y) +(def__ (text:= x y) (-> Text Text Bool) (jvm-invokevirtual java.lang.Object equals [java.lang.Object] x [y])) -(def (get-rep key env) +(def__ (get-rep key env) (-> Text RepEnv ($' Maybe Syntax)) (case' env #Nil @@ -1070,7 +1070,7 @@ (#Some v) (get-rep key env')))) -(def (apply-template env template) +(def__ (apply-template env template) (-> RepEnv Syntax Syntax) (case' template (#Meta [_ (#Symbol ["" sname])]) @@ -1097,7 +1097,7 @@ _ template)) -(def (join-map f xs) +(def__ (join-map f xs) (All' [a b] (-> (-> (B' a) ($' List (B' b))) ($' List (B' a)) ($' List (B' b)))) (case' xs @@ -1127,7 +1127,7 @@ (fail "Wrong syntax for do-template"))) (do-template [ ] - [(def #export ( x y) + [(def__ #export ( x y) (-> Bool) ( x y))] @@ -1140,7 +1140,7 @@ ) (do-template [ ] - [(def #export ( x y) + [(def__ #export ( x y) (-> ) ( x y))] @@ -1156,24 +1156,24 @@ [real:% jvm-drem Real] ) -(def (multiple? div n) +(def__ (multiple? div n) (-> Int Int Bool) (int:= 0 (int:% n div))) -(def #export (length list) +(def__ #export (length list) (-> List Int) (fold (lambda [acc _] (int:+ 1 acc)) 0 list)) -(def #export (not x) +(def__ #export (not x) (-> Bool Bool) (if x false true)) -(def (text:++ x y) +(def__ (text:++ x y) (-> Text Text Text) (jvm-invokevirtual java.lang.String concat [java.lang.String] x [y])) -(def (ident->text ident) +(def__ (ident->text ident) (-> Ident Text) (let [[module name] ident] ($ text:++ module ";" name))) @@ -1211,7 +1211,7 @@ (as-pairs tokens))] (;return (:' SyntaxList (list (` (#;RecordT (;list (~@ pairs)))))))))) -(def (replace-syntax reps syntax) +(def__ (replace-syntax reps syntax) (-> RepEnv Syntax Syntax) (case' syntax (#Meta [_ (#Symbol ["" name])]) @@ -1274,7 +1274,7 @@ (fail "Wrong syntax for All")) )) -(def (get k plist) +(def__ (get k plist) (All [a] (-> Text ($' List (, Text a)) ($' Maybe a))) (case' plist @@ -1286,7 +1286,7 @@ #Nil #None)) -(def #export (find-macro ident state) +(def__ #export (find-macro ident state) (-> Ident ($' Lux ($' Maybe Macro))) (let [[module name] ident] (case' state @@ -1303,12 +1303,12 @@ _ #None))])))) -(def (list:join xs) +(def__ (list:join xs) (All [a] (-> ($' List ($' List a)) ($' List a))) (fold list:++ #Nil xs)) -(def #export (normalize ident state) +(def__ #export (normalize ident state) (-> Ident ($' Lux Ident)) (case' ident ["" name] @@ -1326,40 +1326,63 @@ _ (#Right [state ident]))) -## (def #export (macro-expand syntax) -## (-> Syntax ($' Lux ($' List Syntax))) -## (case' syntax -## (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) -## (do Lux:Monad -## [macro-name' (normalize macro-name) -## ?macro (find-macro macro-name')] -## (case' (:' ($' Maybe Macro) ?macro) -## (#Some macro) -## (do Lux:Monad -## [expansion (macro args) -## expansion' (map% Lux:Monad macro-expand expansion)] -## (;return (:' SyntaxList (list:join expansion')))) - -## #None -## (do Lux:Monad -## [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] -## (;return (:' SyntaxList (list ($form (list:join parts')))))))) - -## ## (#Meta [_ (#Form (#Cons [harg targs]))]) -## ## (do Lux:Monad -## ## [harg+ (macro-expand harg) -## ## targs+ (map% Lux:Monad macro-expand targs)] -## ## (;return (:' SyntaxList (list:++ harg+ (list:join targs+))))) - -## (#Meta [_ (#Tuple members)]) -## (do Lux:Monad -## [members' (map% Lux:Monad macro-expand members)] -## (;return (:' SyntaxList (list ($tuple (list:join members')))))) - -## _ -## (return (:' SyntaxList (list syntax))))) - -(def #export (macro-expand syntax) +(def__ (->text x) + (-> (^ java.lang.Object) Text) + (jvm-invokevirtual java.lang.Object toString [] x [])) + +(def__ #export (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__ #export (syntax:show syntax) + (-> Syntax Text) + (case' syntax + (#Meta [_ (#Bool value)]) + (->text value) + + (#Meta [_ (#Int value)]) + (->text value) + + (#Meta [_ (#Real value)]) + (->text value) + + (#Meta [_ (#Char value)]) + ($ text:++ "#\"" (->text value) "\"") + + (#Meta [_ (#Text value)]) + value + + (#Meta [_ (#Symbol ident)]) + (ident->text ident) + + (#Meta [_ (#Tag ident)]) + (text:++ "#" (ident->text ident)) + + (#Meta [_ (#Tuple members)]) + ($ text:++ "[" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) "]") + + (#Meta [_ (#Form members)]) + ($ text:++ "(" (|> members (map syntax:show) (interpose " ") (fold text:++ "")) ")") + + (#Meta [_ (#Record slots)]) + ($ text:++ "(" (|> slots + (map (:' (-> (, Syntax Syntax) Text) + (lambda [slot] + (let [[k v] slot] + ($ text:++ (syntax:show k) " " (syntax:show v)))))) + (interpose " ") (fold text:++ "")) ")") + )) + +(def__ #export (macro-expand syntax) (-> Syntax ($' Lux ($' List Syntax))) (case' syntax (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) args]))]) @@ -1378,11 +1401,11 @@ [parts' (map% Lux:Monad macro-expand (list& ($symbol macro-name) args))] (;return (:' SyntaxList (list ($form (list:join parts')))))))) - ## (#Meta [_ (#Form (#Cons [harg targs]))]) - ## (do Lux:Monad - ## [harg+ (macro-expand harg) - ## targs+ (map% Lux:Monad macro-expand targs)] - ## (;return (:' SyntaxList (list:++ harg+ (list:join targs+))))) + (#Meta [_ (#Form (#Cons [harg targs]))]) + (do Lux:Monad + [harg+ (macro-expand harg) + targs+ (map% Lux:Monad macro-expand targs)] + (;return (:' SyntaxList (list ($form (list:++ harg+ (list:join (:' ($' List ($' List Syntax)) targs+)))))))) (#Meta [_ (#Tuple members)]) (do Lux:Monad @@ -1392,7 +1415,7 @@ _ (return (:' SyntaxList (list syntax))))) -(def (walk-type type) +(def__ (walk-type type) (-> Syntax Syntax) (case' type (#Meta [_ (#Form (#Cons [(#Meta [_ (#Tag tag)]) parts]))]) @@ -1450,36 +1473,37 @@ _ [false tokens])) - ## parts (: (Maybe (, Syntax (List Syntax) Syntax)) - ## (case' tokens' - ## (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) - ## (#Some [($symbol name) #Nil type]) + parts (: (Maybe (, Syntax (List Syntax) Syntax)) + (case' tokens' + (#Cons [(#Meta [_ (#Symbol name)]) (#Cons [type #Nil])]) + (#Some [($symbol name) #Nil type]) - ## (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) - ## (#Some [($symbol name) args type]) + (#Cons [(#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol name)]) args]))]) (#Cons [type #Nil])]) + (#Some [($symbol name) args type]) - ## _ - ## #None)) + _ + #None)) ] - (return (: (List Syntax) #Nil)) - ## (case' parts - ## (#Some [name args type]) - ## (let [with-export (: (List Syntax) - ## (if export? - ## (list (` (export' (~ name)))) - ## #Nil)) - ## type' (: Syntax - ## (case' args - ## #Nil - ## type - - ## _ - ## (` (;All (~ name) [(~@ args)] (~ type)))))] - ## (return (: (List Syntax) - ## (list& type' with-export)))) - - ## #None - ## (fail "Wrong syntax for deftype")) + ## (return (: (List Syntax) #Nil)) + (case' parts + (#Some [name args type]) + (let [with-export (: (List Syntax) + (if export? + (list (` (export' (~ name)))) + #Nil)) + type' (: Syntax + (case' args + #Nil + type + + _ + (` (;All (~ name) [(~@ args)] (~ type)))))] + (return (: (List Syntax) + (list& (` (def' (~ name) (;type` (~ type')))) + with-export)))) + + #None + (fail "Wrong syntax for deftype")) )) (deftype #export (IO a) @@ -1489,7 +1513,8 @@ (case' tokens (#Cons [value #Nil]) (let [blank ($symbol ["" ""])] - (return (list (` (lambda' (~ blank) (~ blank) (~ value)))))) + (return (: (List Syntax) + (list (` (lambda' (~ blank) (~ blank) (~ value))))))) _ (fail "Wrong syntax for io"))) @@ -1508,6 +1533,51 @@ _ (fail "Wrong syntax for exec"))) +(defmacro #export (def tokens) + (let [[export? tokens'] (: (, Bool (List Syntax)) + (case' tokens + (#Cons [(#Meta [_ (#Tag ["" "export"])]) tokens']) + [true tokens'] + + _ + [false tokens])) + parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) + (case' tokens' + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) + (#Some [name args (#Some type) body]) + + (#Cons [name (#Cons [type (#Cons [body #Nil])])]) + (#Some [name #Nil (#Some type) body]) + + (#Cons [(#Meta [_ (#Form (#Cons [name args]))]) (#Cons [body #Nil])]) + (#Some [name args #None body]) + + (#Cons [name (#Cons [body #Nil])]) + (#Some [name #Nil #None body]) + + _ + #None))] + (case' parts + (#Some [name args ?type body]) + (let [body' (: Syntax + (case' args + #Nil + body + + _ + (` (;lambda (~ name) [(~@ args)] (~ body))))) + body'' (: Syntax + (case' ?type + (#Some type) + (` (: (~ type) (~ body'))) + + #None + body'))] + (return (: (List Syntax) (list (` (def' (~ name) (~ body''))))))) + + #None + (fail "Wrong syntax for def")))) + (def (rejoin-pair pair) (-> (, Syntax Syntax) (List Syntax)) (let [[left right] pair] @@ -1515,24 +1585,26 @@ (defmacro #export (case tokens) (case' tokens - (#Cons value branches) + (#Cons [value branches]) (do Lux:Monad [expansions (map% Lux:Monad (: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax)))) (lambda expander [branch] (let [[pattern body] branch] (case' pattern - (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]) + (#Meta [_ (#Form (#Cons [(#Meta [_ (#Symbol macro-name)]) macro-args]))]) (do Lux:Monad - [expansion (macro-expand (list& ($symbol macro-name) body macro-args))] - (map% Lux:Monad expander (as-pairs expansion))) + [expansion (macro-expand ($form (list& ($symbol macro-name) body macro-args))) + expansions (map% Lux:Monad expander (as-pairs (: (List Syntax) expansion)))] + (;return (list:join (: (List (List (, Syntax Syntax))) expansions)))) _ (;return (: (List (, Syntax Syntax)) (list branch))))))) (as-pairs branches))] - (;return (: (List (, Syntax Syntax)) + (;return (: (List Syntax) (list (` (case' (~ value) - (~@ (|> expansions list:join (map rejoin-pair) list:join)))))))) + (~@ (|> (: (List (List (, Syntax Syntax))) expansions) list:join (map rejoin-pair) list:join)) + )))))) _ (fail "Wrong syntax for case"))) -- cgit v1.2.3