diff options
Diffstat (limited to '')
| -rw-r--r-- | source/lux.lux | 561 | ||||
| -rw-r--r-- | source/lux/codata/function.lux | 4 | ||||
| -rw-r--r-- | source/lux/codata/stream.lux | 3 | ||||
| -rw-r--r-- | source/lux/control/hash.lux | 14 | ||||
| -rw-r--r-- | source/lux/data/bool.lux | 12 | ||||
| -rw-r--r-- | source/lux/data/list.lux | 83 | ||||
| -rw-r--r-- | source/lux/meta/lux.lux | 34 | ||||
| -rw-r--r-- | source/program.lux | 1 |
8 files changed, 431 insertions, 281 deletions
diff --git a/source/lux.lux b/source/lux.lux index dc186fb3d..3670a9e52 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -32,29 +32,29 @@ (_lux_def Void (#VariantT #Nil)) (_lux_export Void) -(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])]))) +(_lux_def Ident (#TupleT (#Cons Text (#Cons Text #Nil)))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil -## (#Cons (, a (List a))))) +## (#Cons a (List a)))) (_lux_def List - (#AllT [(#Some #Nil) "lux;List" "a" - (#VariantT (#Cons [["lux;Nil" (#TupleT #Nil)] - (#Cons [["lux;Cons" (#TupleT (#Cons [(#BoundT "a") - (#Cons [(#AppT [(#BoundT "lux;List") (#BoundT "a")]) - #Nil])]))] - #Nil])]))])) + (#AllT (#Some #Nil) "lux;List" "a" + (#VariantT (#Cons ["lux;Nil" (#TupleT #Nil)] + (#Cons ["lux;Cons" (#TupleT (#Cons (#BoundT "a") + (#Cons (#AppT (#BoundT "lux;List") (#BoundT "a")) + #Nil)))] + #Nil))))) (_lux_export List) ## (deftype (Maybe a) ## (| #None ## (#Some a))) (_lux_def Maybe - (#AllT [(#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons [["lux;None" (#TupleT #Nil)] - (#Cons [["lux;Some" (#BoundT "a")] - #Nil])]))])) + (#AllT (#Some #Nil) "lux;Maybe" "a" + (#VariantT (#Cons ["lux;None" (#TupleT #Nil)] + (#Cons ["lux;Some" (#BoundT "a")] + #Nil))))) (_lux_export Maybe) ## (deftype #rec Type @@ -62,29 +62,29 @@ ## (#TupleT (List Type)) ## (#VariantT (List (, Text Type))) ## (#RecordT (List (, Text Type))) -## (#LambdaT (, Type Type)) +## (#LambdaT Type Type) ## (#BoundT Text) ## (#VarT Int) -## (#AllT (, (Maybe (List (, Text Type))) Text Text Type)) -## (#AppT (, Type Type)))) +## (#AllT (Maybe (List (, Text Type))) Text Text Type) +## (#AppT Type Type))) (_lux_def Type - (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")]) + (_lux_case (#AppT (#BoundT "Type") (#BoundT "_")) Type - (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))]) + (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil)))) TypeEnv - (#AppT [(#AllT [(#Some #Nil) "Type" "_" - (#VariantT (#Cons [["lux;DataT" Text] - (#Cons [["lux;TupleT" (#AppT [List Type])] - (#Cons [["lux;VariantT" TypeEnv] - (#Cons [["lux;RecordT" TypeEnv] - (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;BoundT" Text] - (#Cons [["lux;VarT" Int] - (#Cons [["lux;AllT" (#TupleT (#Cons [(#AppT [Maybe TypeEnv]) (#Cons [Text (#Cons [Text (#Cons [Type #Nil])])])]))] - (#Cons [["lux;AppT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))] - (#Cons [["lux;ExT" Int] - #Nil])])])])])])])])])]))]) - Void])))) + (#AppT (#AllT (#Some #Nil) "Type" "_" + (#VariantT (#Cons ["lux;DataT" Text] + (#Cons ["lux;TupleT" (#AppT List Type)] + (#Cons ["lux;VariantT" TypeEnv] + (#Cons ["lux;RecordT" TypeEnv] + (#Cons ["lux;LambdaT" (#TupleT (#Cons Type (#Cons Type #Nil)))] + (#Cons ["lux;BoundT" Text] + (#Cons ["lux;VarT" Int] + (#Cons ["lux;AllT" (#TupleT (#Cons (#AppT Maybe TypeEnv) (#Cons Text (#Cons Text (#Cons Type #Nil)))))] + (#Cons ["lux;AppT" (#TupleT (#Cons Type (#Cons Type #Nil)))] + (#Cons ["lux;ExT" Int] + #Nil)))))))))))) + Void)))) (_lux_export Type) ## (deftype (Bindings k v) @@ -125,7 +125,7 @@ (_lux_export Cursor) ## (deftype (Meta m v) -## (| (#Meta (, m v)))) +## (| (#Meta m v))) (_lux_def Meta (#AllT [(#Some #Nil) "lux;Meta" "m" (#AllT [#None "" "v" @@ -141,8 +141,8 @@ ## (#RealS Real) ## (#CharS Char) ## (#TextS Text) -## (#SymbolS (, Text Text)) -## (#TagS (, Text Text)) +## (#SymbolS Text Text) +## (#TagS Text Text) ## (#FormS (List (w (Syntax' w)))) ## (#TupleS (List (w (Syntax' w)))) ## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w))))))) @@ -267,7 +267,8 @@ ## #types (Bindings Int Type) ## #host HostState ## #seed Int -## #eval? Bool)) +## #eval? Bool +## #expected Type)) (_lux_def Compiler (#AppT [(#AllT [(#Some #Nil) "lux;Compiler" "" (#RecordT (#Cons [["lux;source" Reader] @@ -280,7 +281,8 @@ (#Cons [["lux;host" HostState] (#Cons [["lux;seed" Int] (#Cons [["lux;eval?" Bool] - #Nil])])])])])])]))]) + (#Cons [["lux;expected" Type] + #Nil])])])])])])])]))]) Void])) (_lux_export Compiler) @@ -348,6 +350,11 @@ (_lux_lambda _ text (_meta (#TextS text))))) +(_lux_def int$ + (_lux_: (#LambdaT [Int Syntax]) + (_lux_lambda _ value + (_meta (#IntS value))))) + (_lux_def symbol$ (_lux_: (#LambdaT [Ident Syntax]) (_lux_lambda _ ident @@ -1039,6 +1046,15 @@ (f (g x)))) (def''' (get-ident x) + (-> Syntax ($' Maybe Ident)) + (_lux_case x + (#Meta [_ (#SymbolS sname)]) + (#Some sname) + + _ + #None)) + +(def''' (get-name x) (-> Syntax ($' Maybe Text)) (_lux_case x (#Meta [_ (#SymbolS ["" sname])]) @@ -1127,7 +1143,7 @@ (_lux_case tokens (#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])]) (_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax)))) - [(map% Maybe/Monad get-ident bindings) + [(map% Maybe/Monad get-name bindings) (map% Maybe/Monad tuple->list data)]) [(#Some bindings') (#Some data')] (let' [apply (_lux_: (-> RepEnv ($' List Syntax)) @@ -1245,7 +1261,7 @@ ["" tokens]))] (_lux_case tokens' (#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])]) - (_lux_case (map% Maybe/Monad get-ident args) + (_lux_case (map% Maybe/Monad get-name args) (#Some idents) (_lux_case idents #Nil @@ -1297,8 +1313,8 @@ ($' Lux Text) (_lux_case state {#source source #modules modules - #envs envs #types types #host host - #seed seed #eval? eval?} + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected} (_lux_case (reverse envs) #Nil (#Left "Can't get the module name without a module!") @@ -1337,7 +1353,7 @@ (_lux_case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (#Right [state (find-macro' modules current-module module name)])))))) (def''' (list:join xs) @@ -1367,11 +1383,16 @@ [ident (normalize ident)] (;return (`' [(~ (text$ (ident->text ident))) (;,)]))) - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))]) + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))]) (do Lux/Monad - [ident (normalize ident)] - (;return (`' [(~ (text$ (ident->text ident))) (~ value)]))) - + [ident (normalize ident) + #let [case-body (_lux_: Syntax + (_lux_case values + #Nil (`' Unit) + (#Cons value #Nil) value + _ (`' (, (~@ values)))))]] + (;return (`' [(~ (text$ (ident->text ident))) (~ case-body)]))) + _ (fail "Wrong syntax for |")))) tokens)] @@ -1412,9 +1433,9 @@ (#Cons [x xs']) (list& x sep (interpose sep xs')))) -(def''' (macro-expand syntax) +(def''' (macro-expand token) (-> Syntax ($' Lux ($' List Syntax))) - (_lux_case syntax + (_lux_case token (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) (do Lux/Monad [macro-name' (normalize macro-name) @@ -1427,19 +1448,39 @@ (;return (list:join expansion'))) #None + (return (list token)))) + + _ + (return (list token)))) + +(def''' (macro-expand-all syntax) + (-> Syntax ($' Lux ($' List Syntax))) + (_lux_case syntax + (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (_lux_case ?macro + (#Some macro) (do Lux/Monad - [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + [expansion (macro args) + expansion' (map% Lux/Monad macro-expand-all expansion)] + (;return (list:join expansion'))) + + #None + (do Lux/Monad + [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (;return (list (form$ (list:join parts'))))))) (#Meta [_ (#FormS (#Cons [harg targs]))]) (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (map% Lux/Monad macro-expand targs)] + [harg+ (macro-expand-all harg) + targs+ (map% Lux/Monad macro-expand-all targs)] (;return (list (form$ (list:++ harg+ (list:join targs+)))))) (#Meta [_ (#TupleS members)]) (do Lux/Monad - [members' (map% Lux/Monad macro-expand members)] + [members' (map% Lux/Monad macro-expand-all members)] (;return (list (tuple$ (list:join members'))))) _ @@ -1464,11 +1505,11 @@ (defmacro #export (type tokens) (_lux_case tokens - (#Cons [type #Nil]) + (#Cons type #Nil) (do Lux/Monad - [type+ (macro-expand type)] + [type+ (macro-expand-all type)] (_lux_case type+ - (#Cons [type' #Nil]) + (#Cons type' #Nil) (;return (list (walk-type type'))) _ @@ -1479,7 +1520,7 @@ (defmacro #export (: tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) + (#Cons type (#Cons value #Nil)) (return (list (`' (_lux_: (;type (~ type)) (~ value))))) _ @@ -1487,7 +1528,7 @@ (defmacro #export (:! tokens) (_lux_case tokens - (#Cons [type (#Cons [value #Nil])]) + (#Cons type (#Cons value #Nil)) (return (list (`' (_lux_:! (;type (~ type)) (~ value))))) _ @@ -1502,30 +1543,30 @@ (defmacro #export (deftype tokens) (let' [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) [rec? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "rec")) tokens') [true tokens'] _ [false tokens'])) parts (: (Maybe (, Text (List Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])]) - (#Some [name #Nil type]) + (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil)) + (#Some name #Nil type) - (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])]) - (#Some [name args type]) + (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil)) + (#Some name args type) _ #None))] (_lux_case parts - (#Some [name args type]) + (#Some name args type) (let' [with-export (: (List Syntax) (if export? (list (`' (_lux_export (~ (symbol$ ["" name]))))) @@ -1570,12 +1611,12 @@ ## (#Some [(symbol$ name) #Nil type]) ## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])]) -## (#Some [(symbol$ name) args type]) +## (#Some (symbol$ name) args type) ## _ ## #None))] ## (_lux_case parts -## (#Some [name args type]) +## (#Some name args type]) ## (let' [with-export (: (List Syntax) ## (if export? ## (list (`' (_lux_export (~ name)))) @@ -1596,7 +1637,7 @@ (defmacro #export (exec tokens) (_lux_case (reverse tokens) - (#Cons [value actions]) + (#Cons value actions) (let' [dummy (symbol$ ["" ""])] (return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post)))) value @@ -1608,29 +1649,29 @@ (defmacro (def' tokens) (let' [[export? tokens'] (: (, Bool (List Syntax)) (_lux_case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (_lux_case tokens' - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])]) - (#Some [name args (#Some type) body]) + (#Cons (#Meta _ (#FormS (#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 name (#Cons type (#Cons body #Nil))) + (#Some name #Nil (#Some type) body) - (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])]) - (#Some [name args #None body]) + (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil)) + (#Some name args #None body) - (#Cons [name (#Cons [body #Nil])]) - (#Some [name #Nil #None body]) + (#Cons name (#Cons body #Nil)) + (#Some name #Nil #None body) _ #None))] (_lux_case parts - (#Some [name args ?type body]) + (#Some name args ?type body) (let' [body' (: Syntax (_lux_case args #Nil @@ -1660,16 +1701,16 @@ (defmacro #export (case tokens) (_lux_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] (_lux_case pattern - (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))]) + (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args))) (do Lux/Monad - [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args))) + [expansion (macro-expand-all (form$ (list& (symbol$ macro-name) body macro-args))) expansions (map% Lux/Monad expander (as-pairs expansion))] (;return (list:join expansions))) @@ -1684,11 +1725,11 @@ (defmacro #export (\ tokens) (case tokens - (#Cons [body (#Cons [pattern #Nil])]) + (#Cons body (#Cons pattern #Nil)) (do Lux/Monad - [pattern+ (macro-expand pattern)] + [pattern+ (macro-expand-all pattern)] (case pattern+ - (#Cons [pattern' #Nil]) + (#Cons pattern' #Nil) (;return (list pattern' body)) _ @@ -1699,14 +1740,14 @@ (defmacro #export (\or tokens) (case tokens - (#Cons [body patterns]) + (#Cons body patterns) (case patterns #Nil (fail "\\or can't have 0 patterns") _ (do Lux/Monad - [patterns' (map% Lux/Monad macro-expand patterns)] + [patterns' (map% Lux/Monad macro-expand-all patterns)] (;return (list:join (map (lambda' [pattern] (list pattern body)) (list:join patterns')))))) @@ -1726,7 +1767,7 @@ (def' (symbol? ast) (-> Syntax Bool) (case ast - (#Meta [_ (#SymbolS _)]) + (#Meta _ (#SymbolS _)) true _ @@ -1734,7 +1775,7 @@ (defmacro #export (let tokens) (case tokens - (\ (list (#Meta [_ (#TupleS bindings)]) body)) + (\ (list (#Meta _ (#TupleS bindings)) body)) (if (multiple? 2 (length bindings)) (|> bindings as-pairs reverse (foldL (: (-> Syntax (, Syntax Syntax) Syntax) @@ -1754,7 +1795,7 @@ (def' (ast:show ast) (-> Syntax Text) (case ast - (#Meta [_ ast]) + (#Meta _ ast) (case ast (\or (#BoolS val) (#IntS val) (#RealS val)) (->text val) @@ -1771,10 +1812,10 @@ (#TupleS parts) ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]") - (#SymbolS [prefix name]) + (#SymbolS prefix name) ($ text:++ prefix ";" name) - (#TagS [prefix name]) + (#TagS prefix name) ($ text:++ "#" prefix ";" name) (#RecordS kvs) @@ -1790,15 +1831,15 @@ (defmacro #export (lambda tokens) (case (: (Maybe (, Ident Syntax (List Syntax) Syntax)) (case tokens - (\ (list (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) - (#Some [["" ""] head tail body]) + (\ (list (#Meta _ (#TupleS (#Cons head tail))) body)) + (#Some ["" ""] head tail body) - (\ (list (#Meta [_ (#SymbolS ident)]) (#Meta [_ (#TupleS (#Cons [head tail]))]) body)) - (#Some [ident head tail body]) + (\ (list (#Meta _ (#SymbolS ident)) (#Meta _ (#TupleS (#Cons head tail))) body)) + (#Some ident head tail body) _ #None)) - (#Some [ident head tail body]) + (#Some ident head tail body) (let [g!blank (symbol$ ["" ""]) g!name (symbol$ ident) body+ (: Syntax (foldL (: (-> Syntax Syntax Syntax) @@ -1819,29 +1860,29 @@ (defmacro #export (def tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens']) + (#Cons (#Meta _ (#TagS "" "export")) tokens') [true tokens'] _ [false tokens])) parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax)) (case tokens' - (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) type body)) - (#Some [name args (#Some type) body]) + (\ (list (#Meta _ (#FormS (#Cons name args))) type body)) + (#Some name args (#Some type) body) (\ (list name type body)) - (#Some [name #Nil (#Some type) body]) + (#Some name #Nil (#Some type) body) - (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) body)) - (#Some [name args #None body]) + (\ (list (#Meta _ (#FormS (#Cons name args))) body)) + (#Some name args #None body) (\ (list name body)) - (#Some [name #Nil #None body]) + (#Some name #Nil #None body) _ #None))] (case parts - (#Some [name args ?type body]) + (#Some name args ?type body) (let [body (: Syntax (case args #Nil @@ -1869,22 +1910,11 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} - (#Right [{#source source #modules modules - #envs envs #types types #host host - #seed (i+ 1 seed) #eval? eval?} - (symbol$ ["__gensym__" (->text seed)])]))) - -(def (macro-expand-1 token) - (-> Syntax (Lux Syntax)) - (do Lux/Monad - [token+ (macro-expand token)] - (case token+ - (\ (list token')) - (;return token') - - _ - (fail "Macro expanded to more than 1 element.")))) + #seed seed #eval? eval? #expected expected} + (#Right {#source source #modules modules + #envs envs #types types #host host + #seed (i+ 1 seed) #eval? eval? #expected expected} + (symbol$ ["__gensym__" (->text seed)])))) (defmacro #export (sig tokens) (do Lux/Monad @@ -1893,7 +1923,7 @@ (: (-> Syntax (Lux (, Ident Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))])) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) (do Lux/Monad [name' (normalize name)] (;return (: (, Ident Syntax) [name' type]))) @@ -1911,23 +1941,23 @@ (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs)) - (#Some [name args sigs]) + (\ (list& (#Meta _ (#FormS (list& name args))) sigs)) + (#Some name args sigs) (\ (list& name sigs)) - (#Some [name #Nil sigs]) + (#Some name #Nil sigs) _ #None))] (case ?parts - (#Some [name args sigs]) + (#Some name args sigs) (let [sigs' (: Syntax (case args #Nil @@ -1950,7 +1980,7 @@ (: (-> Syntax (Lux (, Syntax Syntax))) (lambda [token] (case token - (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))])) + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS name)) value)))) (do Lux/Monad [name' (normalize name)] (;return (: (, Syntax Syntax) [(tag$ name') value]))) @@ -1963,23 +1993,23 @@ (defmacro #export (defstruct tokens) (let [[export? tokens'] (: (, Bool (List Syntax)) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "export")) tokens')) [true tokens'] _ [false tokens])) ?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax))) (case tokens' - (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs)) - (#Some [name args type defs]) + (\ (list& (#Meta _ (#FormS (list& name args))) type defs)) + (#Some name args type defs) (\ (list& name type defs)) - (#Some [name #Nil type defs]) + (#Some name #Nil type defs) _ #None))] (case ?parts - (#Some [name args type defs]) + (#Some name args type defs) (let [defs' (: Syntax (case args #Nil @@ -2031,7 +2061,7 @@ (: (-> Syntax (Lux Text)) (lambda [def] (case def - (#Meta [_ (#SymbolS ["" name])]) + (#Meta _ (#SymbolS "" name)) (return name) _ @@ -2041,7 +2071,7 @@ (def (parse-alias tokens) (-> (List Syntax) (Lux (, (Maybe Text) (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens')) + (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens')) (return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens'])) _ @@ -2050,17 +2080,17 @@ (def (parse-referrals tokens) (-> (List Syntax) (Lux (, Referrals (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens')) + (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens')) (case referral - (#Meta [_ (#TagS ["" "all"])]) + (#Meta _ (#TagS "" "all")) (return (: (, Referrals (List Syntax)) [#All tokens'])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Only defs') tokens']))) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs)))) (do Lux/Monad [defs' (extract-defs defs)] (return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens']))) @@ -2074,7 +2104,7 @@ (def (extract-symbol syntax) (-> Syntax (Lux Ident)) (case syntax - (#Meta [_ (#SymbolS ident)]) + (#Meta _ (#SymbolS ident)) (return ident) _ @@ -2083,10 +2113,10 @@ (def (parse-openings tokens) (-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax)))) (case tokens - (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens')) + (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens')) (do Lux/Monad [structs' (map% Lux/Monad extract-symbol structs)] - (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens']))) + (return (: (, (Maybe Openings) (List Syntax)) [(#Some prefix structs') tokens']))) _ (return (: (, (Maybe Openings) (List Syntax)) [#None tokens])))) @@ -2097,10 +2127,10 @@ (: (-> Syntax (Lux Syntax)) (lambda [token] (case token - (#Meta [_ (#SymbolS ["" sub-name])]) + (#Meta _ (#SymbolS "" sub-name)) (return (symbol$ ["" ($ text:++ super-name "/" sub-name)])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts)))) (return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts))) _ @@ -2114,10 +2144,10 @@ (: (-> Syntax (Lux (List Import))) (lambda [token] (case token - (#Meta [_ (#SymbolS ["" m-name])]) + (#Meta _ (#SymbolS "" m-name)) (;return (list [m-name #None #All #None])) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra)))) (do Lux/Monad [alias+extra (parse-alias extra) #let [[alias extra] alias+extra] @@ -2141,13 +2171,13 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (case (get module modules) (#Some =module) - (#Right [state true]) + (#Right state true) #None - (#Right [state false])) + (#Right state false)) )) (def (exported-defs module state) @@ -2155,7 +2185,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (case (get module modules) (#Some =module) (let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax)))))) @@ -2167,7 +2197,7 @@ (list))))) (let [{#module-aliases _ #defs defs #imports _} =module] defs))] - (#Right [state (list:join to-alias)])) + (#Right state (list:join to-alias))) #None (#Left ($ text:++ "Unknown module: " module))) @@ -2195,18 +2225,18 @@ (def (split-module-contexts module) (-> Text (List Text)) - (#Cons [module (let [idx (last-index-of "/" module)] - (if (i< idx 0) - #Nil - (split-module-contexts (substring2 0 idx module))))])) + (#Cons module (let [idx (last-index-of "/" module)] + (if (i< idx 0) + #Nil + (split-module-contexts (substring2 0 idx module)))))) (def (split-module module) (-> Text (List Text)) (let [idx (index-of "/" module)] (if (i< idx 0) - (#Cons [module #Nil]) - (#Cons [(substring2 0 idx module) - (split-module (substring1 (i+ 1 idx) module))])))) + (#Cons module #Nil) + (#Cons (substring2 0 idx module) + (split-module (substring1 (i+ 1 idx) module)))))) (def (@ idx xs) (All [a] @@ -2215,7 +2245,7 @@ #Nil #None - (#Cons [x xs']) + (#Cons x xs') (if (i= idx 0) (#Some x) (@ (i- idx 1) xs') @@ -2228,7 +2258,7 @@ #Nil [ys xs] - (#Cons [x xs']) + (#Cons x xs') (if (p x) (split-with' p (list& x ys) xs') [ys xs]))) @@ -2267,9 +2297,9 @@ #;Nil (list) - (#;Cons [x xs']) + (#;Cons x xs') (if (p x) - (#;Cons [x (filter p xs')]) + (#;Cons x (filter p xs')) (filter p xs')))) (def (is-member? cases name) @@ -2335,7 +2365,7 @@ #None (list) - (#Some [prefix structs]) + (#Some prefix structs) (map (: (-> Ident Syntax) (lambda [struct] (let [[_ name] struct] @@ -2367,7 +2397,7 @@ #Nil #None - (#Cons [x xs']) + (#Cons x xs') (case (f x) #None (some f xs') @@ -2433,7 +2463,7 @@ (foldL text:++ "")) ")")) - (#LambdaT [input output]) + (#LambdaT input output) ($ text:++ "(-> " (type:show input) " " (type:show output) ")") (#VarT id) @@ -2445,10 +2475,10 @@ (#ExT ?id) ($ text:++ "⟨" (->text ?id) "⟩") - (#AppT [?lambda ?param]) + (#AppT ?lambda ?param) ($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")") - (#AllT [?env ?name ?arg ?body]) + (#AllT ?env ?name ?arg ?body) ($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")") )) @@ -2472,19 +2502,19 @@ (#TupleT ?members) (#TupleT (map (beta-reduce env) ?members)) - (#AppT [?type-fn ?type-arg]) - (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)]) + (#AppT ?type-fn ?type-arg) + (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - (#AllT [?local-env ?local-name ?local-arg ?local-def]) + (#AllT ?local-env ?local-name ?local-arg ?local-def) (case ?local-env #None - (#AllT [(#Some env) ?local-name ?local-arg ?local-def]) + (#AllT (#Some env) ?local-name ?local-arg ?local-def) (#Some _) type) - (#LambdaT [?input ?output]) - (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)]) + (#LambdaT ?input ?output) + (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) (#BoundT ?name) (case (get ?name env) @@ -2501,7 +2531,7 @@ (def (apply-type type-fn param) (-> Type Type (Maybe Type)) (case type-fn - (#AllT [env name arg body]) + (#AllT env name arg body) (#Some (beta-reduce (|> (case env (#Some env) env _ (list)) @@ -2509,7 +2539,7 @@ (put arg param)) body)) - (#AppT [F A]) + (#AppT F A) (do Maybe/Monad [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -2523,10 +2553,10 @@ (#RecordT slots) (#Some type) - (#AppT [fun arg]) + (#AppT fun arg) (apply-type fun arg) - (#AllT [_ _ _ body]) + (#AllT _ _ _ body) (resolve-struct-type body) _ @@ -2545,7 +2575,7 @@ (case state {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} + #seed seed #eval? eval? #expected expected} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -2579,7 +2609,7 @@ (let [[v-prefix v-name] name {#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} state] + #seed seed #eval? eval? #expected expected} state] (case (get v-prefix modules) #None #None @@ -2589,7 +2619,7 @@ #None #None - (#Some [_ def-data]) + (#Some _ def-data) (case def-data #TypeD (#Some Type) (#ValueD type) (#Some type) @@ -2602,7 +2632,7 @@ ## (let [[v-prefix v-name] name ## {#source source #modules modules ## #envs envs #types types #host host -## #seed seed #eval? eval?} state] +## #seed seed #eval? eval? #expected expected} state] ## (do Maybe/Monad ## [module (get v-prefix modules) ## #let [{#defs defs #module-aliases _ #imports _} module] @@ -2621,24 +2651,32 @@ (lambda [state] (case (find-in-env name state) (#Some struct-type) - (#Right [state struct-type]) + (#Right state struct-type) _ (case (find-in-defs name' state) (#Some struct-type) - (#Right [state struct-type]) + (#Right state struct-type) _ (let [{#source source #modules modules #envs envs #types types #host host - #seed seed #eval? eval?} state] + #seed seed #eval? eval? #expected expected} state] (#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))) +(def expected-type + (Lux Type) + (lambda [state] + (let [{#source source #modules modules + #envs envs #types types #host host + #seed seed #eval? eval? #expected expected} state] + (#Right state expected)))) + (defmacro #export (using tokens) (case tokens (\ (list struct body)) (case struct - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [struct-type (find-var-type name)] (case (resolve-struct-type struct-type) @@ -2687,9 +2725,9 @@ (defmacro #export (get@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) record)) + (\ (list (#Meta _ (#TagS slot')) record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name) g!blank (gensym "") @@ -2724,10 +2762,10 @@ (defmacro #export (open tokens) (case tokens - (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens')) + (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) (do Lux/Monad [#let [prefix (case tokens' - (\ (list (#Meta [_ (#TextS prefix)]))) + (\ (list (#Meta _ (#TextS prefix)))) prefix _ @@ -2754,7 +2792,7 @@ (-> (Monad m) (-> a b (m a)) a (List b) (m a))) (case ys - (#Cons [y ys']) + (#Cons y ys') (do M [x' (f x y)] (foldL% M f x' ys')) @@ -2770,10 +2808,10 @@ (: (-> Syntax Syntax (Lux Syntax)) (lambda [so-far part] (case part - (#Meta [_ (#SymbolS slot)]) + (#Meta _ (#SymbolS slot)) (return (` (get@ (~ (tag$ slot)) (~ so-far)))) - (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))])) + (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args)))) (return (` ((get@ (~ (tag$ slot)) (~ so-far)) (~@ args)))) @@ -2787,9 +2825,9 @@ (defmacro #export (set@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) value record)) + (\ (list (#Meta _ (#TagS slot')) value record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) @@ -2835,9 +2873,9 @@ (defmacro #export (update@ tokens) (case tokens - (\ (list (#Meta [_ (#TagS slot')]) fun record)) + (\ (list (#Meta _ (#TagS slot')) fun record)) (case record - (#Meta [_ (#SymbolS name)]) + (#Meta _ (#SymbolS name)) (do Lux/Monad [type (find-var-type name)] (case (resolve-struct-type type) @@ -2883,12 +2921,12 @@ (defmacro #export (\template tokens) (case tokens - (\ (list (#Meta [_ (#TupleS data)]) - (#Meta [_ (#TupleS bindings)]) - (#Meta [_ (#TupleS templates)]))) + (\ (list (#Meta _ (#TupleS data)) + (#Meta _ (#TupleS bindings)) + (#Meta _ (#TupleS templates)))) (case (: (Maybe (List Syntax)) (do Maybe/Monad - [bindings' (map% Maybe/Monad get-ident bindings) + [bindings' (map% Maybe/Monad get-name bindings) data' (map% Maybe/Monad tuple->list data)] (let [apply (: (-> RepEnv (List Syntax)) (lambda [env] (map (apply-template env) templates)))] @@ -2904,28 +2942,109 @@ _ (fail "Wrong syntax for \\template"))) -(def #export complement - (All [a] (-> (-> a Bool) (-> a Bool))) - (. not)) - -## (defmacro #export (loop tokens) -## (case tokens -## (\ (list bindings body)) -## (let [pairs (as-pairs bindings) -## vars (map first pairs) -## inits (map second pairs)] -## (if (every? symbol? inits) -## (do Lux/Monad -## [inits' (map% Maybe/Monad get-ident inits) -## init-types (map% Maybe/Monad find-var-type inits')] -## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)] -## (~ body)) -## (~@ inits)))))) -## (do Lux/Monad -## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)] -## (return (list (` (let [(~@ (interleave aliases inits))] -## (loop [(~@ (interleave vars aliases))] -## (~ body))))))))) - -## _ -## (fail "Wrong syntax for loop"))) +(do-template [<name> <type> <value>] + [(def (<name> [x y]) + (All [a b] (-> (, a b) <type>)) + <value>)] + + [first a x] + [second b y]) + +(def (interleave xs ys) + (All [a] (-> (List a) (List a) (List a))) + (case xs + #Nil + #Nil + + (#Cons x xs') + (case ys + #Nil + #Nil + + (#Cons y ys') + (list& x y (interleave xs' ys'))))) + +(do-template [<name> <init> <op>] + [(def (<name> p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))] + + [every? true and]) + +(def (type->syntax type) + (-> Type Syntax) + (case type + (#DataT name) + (` (#DataT (~ (text$ name)))) + + (#TupleT parts) + (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) + + (#VariantT cases) + (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + cases))))) + + (#RecordT fields) + (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + fields))))) + + (#LambdaT in out) + (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) + + (#BoundT name) + (` (#BoundT (~ (text$ name)))) + + (#VarT id) + (` (#VarT (~ (int$ id)))) + + (#ExT id) + (` (#ExT (~ (int$ id)))) + + (#AllT env name arg type) + (let [env' (: Syntax + (case env + #None (` #None) + (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) Syntax) + (lambda [[label type]] + (tuple$ (list (text$ label) (type->syntax type))))) + _env)))))))] + (` (#AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) + + (#AppT fun arg) + (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))))) + +(defmacro #export (loop tokens) + (case tokens + (\ (list (#Meta _ (#TupleS bindings)) body)) + (let [pairs (as-pairs bindings) + vars (map first pairs) + inits (map second pairs)] + (if (every? symbol? inits) + (do Lux/Monad + [inits' (: (Lux (List Ident)) + (case (map% Maybe/Monad get-ident inits) + (#Some inits') (return inits') + #None (fail "Wrong syntax for loop"))) + init-types (map% Lux/Monad find-var-type inits') + expected expected-type] + (return (list (` ((: (-> (~@ (map type->syntax init-types)) + (~ (type->syntax expected))) + (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)] + (~ body))) + (~@ inits)))))) + (do Lux/Monad + [aliases (map% Lux/Monad + (: (-> Syntax (Lux Syntax)) + (lambda [_] (gensym ""))) + inits)] + (return (list (` (let [(~@ (interleave aliases inits))] + (loop [(~@ (interleave vars aliases))] + (~ body))))))))) + + _ + (fail "Wrong syntax for loop"))) diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux index 3c40df188..7898e998d 100644 --- a/source/lux/codata/function.lux +++ b/source/lux/codata/function.lux @@ -10,6 +10,10 @@ (lux/control (monoid #as m))) ## [Functions] +(def #export (const x y) + (All [a b] (-> a (-> b a))) + x) + (def #export (flip f) (All [a b c] (-> (-> a b c) (-> b a c))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 2c854a61c..3bce9ee77 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -14,7 +14,8 @@ macro syntax) (data (list #as l #refer (#only list list& List/Monad)) - (number (int #open ("i" Int/Number Int/Ord)))) + (number (int #open ("i" Int/Number Int/Ord))) + bool) (codata (lazy #as L #refer #all)))) ## [Types] diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux new file mode 100644 index 000000000..bfb8e99c0 --- /dev/null +++ b/source/lux/control/hash.lux @@ -0,0 +1,14 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## The use and distribution terms for this software are covered by the +## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +## which can be found in the file epl-v10.html at the root of this distribution. +## By using this software in any fashion, you are agreeing to be bound by +## the terms of this license. +## You must not remove this notice, or any other, from this software. + +(;import lux) + +## [Signatures] +(defsig #export (Hash a) + (: (-> a Int) + hash)) diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index 5f4427a2c..92f5486ef 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -7,9 +7,10 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control (monoid #as m) - (eq #as E) - (show #as S))) + (lux (control (monoid #as m) + (eq #as E) + (show #as S)) + (codata function))) ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) @@ -31,3 +32,8 @@ [ Or/Monoid false or] [And/Monoid true and] ) + +## [Functions] +(def #export complement + (All [a] (-> (-> a Bool) (-> a Bool))) + (. not)) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 8d6296b14..2bbbe66cc 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -12,7 +12,8 @@ (monad #as M #refer #all) (eq #as E) (dict #as D #refer #all)) - (data/number (int #open ("i" Int/Number Int/Ord Int/Eq))) + (data (number (int #open ("i" Int/Number Int/Ord Int/Eq))) + bool) meta/macro)) ## Types @@ -23,43 +24,6 @@ (deftype #export (PList k v) (| (#PList (, (E;Eq k) (List (, k v)))))) -## [Utils] -(def (pl-get eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (Maybe v))) - (case kvs - #;Nil - #;None - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Some v') - (pl-get eq k kvs')))) - -(def (pl-put eq k v kvs) - (All [k v] - (-> (E;Eq k) k v (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - (#;Cons [[k v] kvs]) - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - (#;Cons [[k v] kvs']) - (#;Cons [[k' v'] (pl-put eq k v kvs')])))) - -(def (pl-remove eq k kvs) - (All [k v] - (-> (E;Eq k) k (List (, k v)) (List (, k v)))) - (case kvs - #;Nil - kvs - - (#;Cons [[k' v'] kvs']) - (if (:: eq (E;= k k')) - kvs' - (#;Cons [[k' v'] (pl-remove eq k kvs')])))) - ## [Constructors] (def #export (plist eq) (All [k v] @@ -316,14 +280,35 @@ (foldL ++ unit mma)))) (defstruct #export PList/Dict (Dict PList) - (def (D;get k plist) - (let [(#PList [eq kvs]) plist] - (pl-get eq k kvs))) - - (def (D;put k v plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-put eq k v kvs)]))) - - (def (D;remove k plist) - (let [(#PList [eq kvs]) plist] - (#PList [eq (pl-remove eq k kvs)])))) + (def (D;get k (#PList [eq kvs])) + (loop [kvs kvs] + (case kvs + #;Nil + #;None + + (#;Cons [k' v'] kvs') + (if (:: eq (E;= k k')) + (#;Some v') + (recur kvs'))))) + + (def (D;put k v (#PList [eq kvs])) + (#PList [eq (loop [kvs kvs] + (case kvs + #;Nil + (#;Cons [k v] kvs) + + (#;Cons [k' v'] kvs') + (if (:: eq (E;= k k')) + (#;Cons [k v] kvs') + (#;Cons [k' v'] (recur kvs')))))])) + + (def (D;remove k (#PList [eq kvs])) + (#PList [eq (loop [kvs kvs] + (case kvs + #;Nil + kvs + + (#;Cons [[k' v'] kvs']) + (if (:: eq (E;= k k')) + kvs' + (#;Cons [[k' v'] (recur kvs')]))))]))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 13dcae284..66e4cc341 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -133,19 +133,39 @@ (M;wrap (:: List/Monad (M;join expansion')))) #;None + (:: Lux/Monad (M;wrap (list syntax))))) + + _ + (:: Lux/Monad (M;wrap (list syntax))))) + +(def #export (macro-expand-all syntax) + (-> Syntax (Lux (List Syntax))) + (case syntax + (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + (do Lux/Monad + [macro-name' (normalize macro-name) + ?macro (find-macro macro-name')] + (case ?macro + (#;Some macro) + (do Lux/Monad + [expansion (macro args) + expansion' (M;map% Lux/Monad macro-expand-all expansion)] + (M;wrap (:: List/Monad (M;join expansion')))) + + #;None (do Lux/Monad - [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] + [parts' (M;map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))] (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (M;map% Lux/Monad macro-expand targs)] + [harg+ (macro-expand-all harg) + targs+ (M;map% Lux/Monad macro-expand-all targs)] (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) (#;Meta [_ (#;TupleS members)]) (do Lux/Monad - [members' (M;map% Lux/Monad macro-expand members)] + [members' (M;map% Lux/Monad macro-expand-all members)] (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) _ @@ -234,7 +254,7 @@ (case state {#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} + #;seed seed #;eval? eval? #;expected expected} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) (lambda [env] (case env @@ -254,7 +274,7 @@ (let [[v-prefix v-name] name {#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] + #;seed seed #;eval? eval? #;expected expected} state] (case (get v-prefix modules) #;None #;None @@ -289,6 +309,6 @@ _ (let [{#;source source #;modules modules #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] + #;seed seed #;eval? eval? #;expected expected} state] (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) )) diff --git a/source/program.lux b/source/program.lux index b9f737480..ae3421078 100644 --- a/source/program.lux +++ b/source/program.lux @@ -14,6 +14,7 @@ bounded dict eq + hash ord show number) |