diff options
Diffstat (limited to '')
| -rw-r--r-- | source/lux/meta/ast.lux | 113 | ||||
| -rw-r--r-- | source/lux/meta/lux.lux | 304 | ||||
| -rw-r--r-- | source/lux/meta/macro.lux | 54 | ||||
| -rw-r--r-- | source/lux/meta/syntax.lux | 208 | ||||
| -rw-r--r-- | source/lux/meta/type.lux | 193 |
5 files changed, 623 insertions, 249 deletions
diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux new file mode 100644 index 000000000..a9bc8b588 --- /dev/null +++ b/source/lux/meta/ast.lux @@ -0,0 +1,113 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux (control (show #as S #refer #all) + (eq #as E #refer #all)) + (data bool + (number int + real) + char + (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid)) + ident + (list #refer #all #open ("" List/Functor List/Fold)) + ))) + +## [Types] +## (deftype (AST' w) +## (| (#;BoolS Bool) +## (#;IntS Int) +## (#;RealS Real) +## (#;CharS Char) +## (#;TextS Text) +## (#;SymbolS Text Text) +## (#;TagS Text Text) +## (#;FormS (List (w (AST' w)))) +## (#;TupleS (List (w (AST' w)))) +## (#;RecordS (List (, (w (AST' w)) (w (AST' w))))))) + +## (deftype AST +## (Meta Cursor (AST' (Meta Cursor)))) + +## [Utils] +(def _cursor Cursor ["" -1 -1]) + +## [Functions] +(do-template [<name> <type> <tag>] + [(def #export (<name> x) + (-> <type> AST) + [_cursor (<tag> x)])] + + [bool$ Bool #;BoolS] + [int$ Int #;IntS] + [real$ Real #;RealS] + [char$ Char #;CharS] + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS] + [tag$ Ident #;TagS] + [form$ (List AST) #;FormS] + [tuple$ (List AST) #;TupleS] + [record$ (List (, AST AST)) #;RecordS] + ) + +## [Structures] +(defstruct #export AST/Show (Show AST) + (def (show ast) + (case ast + (\template [<tag> <struct>] + [[_ (<tag> value)] + (:: <struct> (show value))]) + [[#;BoolS Bool/Show] + [#;IntS Int/Show] + [#;RealS Real/Show] + [#;CharS Char/Show] + [#;TextS Text/Show]] + + (\template [<tag> <prefix>] + [[_ (<tag> ident)] + (text:++ <prefix> (:: Ident/Show (show ident)))]) + [[#;SymbolS ""] [#;TagS "#"]] + + (\template [<tag> <open> <close>] + [[_ (<tag> members)] + ($ text:++ <open> (|> members (map show) (interpose "") (foldL text:++ text:unit)) <close>)]) + [[#;FormS "(" ")"] [#;TupleS "[" "]"]] + + [_ (#;RecordS pairs)] + ($ text:++ "{" (|> pairs (map (lambda [[left right]] ($ text:++ (show left) " " (show right)))) (interpose "") (foldL text:++ text:unit)) "}") + ))) + +(defstruct #export AST/Eq (Eq AST) + (def (= x y) + (case [x y] + (\template [<tag> <struct>] + [[[_ (<tag> x')] [_ (<tag> y')]] + (:: <struct> (= x' y'))]) + [[#;BoolS Bool/Eq] + [#;IntS Int/Eq] + [#;RealS Real/Eq] + [#;CharS Char/Eq] + [#;TextS Text/Eq] + [#;SymbolS Ident/Eq] + [#;TagS Ident/Eq]] + + (\template [<tag>] + [[[_ (<tag> xs')] [_ (<tag> ys')]] + (and (:: Int/Eq (= (size xs') (size ys'))) + (foldL (lambda [old [x' y']] + (and old (= x' y'))) + true + (zip2 xs' ys')))]) + [[#;FormS] [#;TupleS]] + + [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] + (and (:: Int/Eq (= (size xs') (size ys'))) + (foldL (lambda [old [[xl' xr'] [yl' yr']]] + (and old (= xl' yl') (= xr' yr'))) + true + (zip2 xs' ys'))) + + _ + false))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index 19b7dd9df..b6ff09f59 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -1,21 +1,19 @@ -## 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. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (.. macro) + (.. ast) (lux/control (monoid #as m) (functor #as F) - (monad #as M #refer (#only do))) - (lux/data list - maybe - (show #as S) - (number #as N) - (text #as T #open ("text:" Text/Monoid Text/Eq)))) + (monad #as M #refer (#only do)) + (show #as S)) + (lux/data (list #refer #all #open ("list:" List/Monoid List/Functor)) + (text #as T #open ("text:" Text/Monoid Text/Eq)) + (number/int #as I #open ("i" Int/Number)) + (tuple #as t) + ident)) ## [Types] ## (deftype (Lux a) @@ -29,7 +27,7 @@ ## [Structures] (defstruct #export Lux/Functor (F;Functor Lux) - (def (F;map f fa) + (def (map f fa) (lambda [state] (case (fa state) (#;Left msg) @@ -39,11 +37,11 @@ (#;Right [state' (f a)]))))) (defstruct #export Lux/Monad (M;Monad Lux) - (def M;_functor Lux/Functor) - (def (M;wrap x) + (def _functor Lux/Functor) + (def (wrap x) (lambda [state] (#;Right [state x]))) - (def (M;join mma) + (def (join mma) (lambda [state] (case (mma state) (#;Left msg) @@ -69,7 +67,7 @@ #;Nil #;None - (#;Cons [[k' v] plist']) + (#;Cons [k' v] plist') (if (text:= k k') (#;Some v) (get k plist')))) @@ -77,20 +75,27 @@ (def (find-macro' modules current-module module name) (-> (List (, Text (Module Compiler))) Text Text Text (Maybe Macro)) - (do Maybe/Monad - [$module (get module modules) - gdef (|> (: (Module Compiler) $module) (get@ #;defs) (get name))] - (case (: (, Bool (DefData' Macro)) gdef) - [exported? (#;MacroD macro')] - (if (or exported? (text:= module current-module)) - (#;Some macro') + (case (get module modules) + (#;Some $module) + (case (|> (: (Module Compiler) $module) (get@ #;defs) (get name)) + (#;Some gdef) + (case (: Definition gdef) + [exported? (#;MacroD macro')] + (if (or exported? (text:= module current-module)) + (#;Some macro') + #;None) + + [_ (#;AliasD [r-module r-name])] + (find-macro' modules current-module r-module r-name) + + _ #;None) - - [_ (#;AliasD [r-module r-name])] - (find-macro' modules current-module r-module r-name) _ - #;None))) + #;None) + + _ + #;None)) (def #export (find-macro ident) (-> Ident (Lux (Maybe Macro))) @@ -107,15 +112,15 @@ ["" name] (do Lux/Monad [module-name get-module-name] - (M;wrap (: Ident [module-name name]))) + (wrap [module-name name])) _ - (:: Lux/Monad (M;wrap ident)))) + (:: Lux/Monad (wrap ident)))) (def #export (macro-expand syntax) - (-> Syntax (Lux (List Syntax))) + (-> AST (Lux (List AST))) (case syntax - (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))]) + [_ (#;FormS (#;Cons [[_ (#;SymbolS macro-name)] args]))] (do Lux/Monad [macro-name' (normalize macro-name) ?macro (find-macro macro-name')] @@ -124,31 +129,51 @@ (do Lux/Monad [expansion (macro args) expansion' (M;map% Lux/Monad macro-expand expansion)] - (M;wrap (:: List/Monad (M;join expansion')))) + (wrap (:: List/Monad (join expansion')))) + + #;None + (:: Lux/Monad (wrap (@list syntax))))) + + _ + (:: Lux/Monad (wrap (@list syntax))))) + +(def #export (macro-expand-all syntax) + (-> AST (Lux (List AST))) + (case syntax + [_ (#;FormS (#;Cons [[_ (#;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)] + (wrap (:: List/Monad (join expansion')))) #;None (do Lux/Monad - [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))] - (M;wrap (list (form$ (:: List/Monad (M;join parts')))))))) + [parts' (M;map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))] + (wrap (@list (form$ (:: List/Monad (join parts')))))))) - (#;Meta [_ (#;FormS (#;Cons [harg targs]))]) + [_ (#;FormS (#;Cons [harg targs]))] (do Lux/Monad - [harg+ (macro-expand harg) - targs+ (M;map% Lux/Monad macro-expand targs)] - (M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+)))))))) + [harg+ (macro-expand-all harg) + targs+ (M;map% Lux/Monad macro-expand-all targs)] + (wrap (@list (form$ (list:++ harg+ (:: List/Monad (join (: (List (List AST)) targs+)))))))) - (#;Meta [_ (#;TupleS members)]) + [_ (#;TupleS members)] (do Lux/Monad - [members' (M;map% Lux/Monad macro-expand members)] - (M;wrap (list (tuple$ (:: List/Monad (M;join members')))))) + [members' (M;map% Lux/Monad macro-expand-all members)] + (wrap (@list (tuple$ (:: List/Monad (join members')))))) _ - (:: Lux/Monad (M;wrap (list syntax))))) + (:: Lux/Monad (wrap (@list syntax))))) (def #export (gensym prefix state) - (-> Text (Lux Syntax)) - (#;Right [(update@ #;seed inc state) - (symbol$ ["__gensym__" (:: N;Int/Show (S;show (get@ #;seed state)))])])) + (-> Text (Lux AST)) + (#;Right [(update@ #;seed (i+ 1) state) + (symbol$ ["" ($ text:++ "__gensym__" prefix (:: I;Int/Show (show (get@ #;seed state))))])])) (def #export (emit datum) (All [a] @@ -163,12 +188,12 @@ (#;Left msg))) (def #export (macro-expand-1 token) - (-> Syntax (Lux Syntax)) + (-> AST (Lux AST)) (do Lux/Monad [token+ (macro-expand token)] (case token+ - (\ (list token')) - (M;wrap token') + (\ (@list token')) + (wrap token') _ (fail "Macro expanded to more than 1 element.")))) @@ -187,34 +212,18 @@ (case (get module (get@ #;modules state)) (#;Some =module) (using List/Monad - (#;Right [state (join (:: _functor (F;map (: (-> (, Text (, Bool (DefData' Macro))) - (List Text)) - (lambda [gdef] - (let [[name [export? _]] gdef] - (if export? - (list name) - (list))))) - (get@ #;defs =module))))])) + (#;Right [state (join (map (: (-> (, Text Definition) + (List Text)) + (lambda [gdef] + (let [[name [export? _]] gdef] + (if export? + (@list name) + (@list))))) + (get@ #;defs =module)))])) #;None (#;Left ($ text:++ "Unknown module: " module)))) -(def (show-envs envs) - (-> (List (Env Text (, LuxVar Type))) Text) - (|> envs - (F;map (lambda [env] - (case env - {#;name name #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure _} - ($ text:++ name ": " (|> locals - (F;map (: (All [a] (-> (, Text a) Text)) - (lambda [b] (let [[label _] b] label)))) - (:: List/Functor) - (interpose " ") - (foldL text:++ text:unit)))))) - (:: List/Functor) - (interpose "\n") - (foldL text:++ text:unit))) - (def (try-both f x1 x2) (All [a b] (-> (-> a (Maybe b)) a a (Maybe b))) @@ -222,56 +231,71 @@ #;None (f x2) (#;Some y) (#;Some y))) -(def (find-in-env name state) - (-> Ident Compiler (Maybe Type)) - (let [vname' (ident->text name)] - (case state - {#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} - (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) - (lambda [env] - (case env - {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} - (try-both (some (: (-> (, Text (, LuxVar Type)) (Maybe Type)) - (lambda [binding] - (let [[bname [_ type]] binding] - (if (text:= vname' bname) - (#;Some type) - #;None))))) - locals - closure)))) - envs)))) - -(def (find-in-defs name state) - (-> Ident Compiler (Maybe Type)) +(def #export (find-in-env name state) + (-> Text Compiler (Maybe Type)) + (case state + {#;source source #;modules modules + #;envs envs #;type-vars types #;host host + #;seed seed #;eval? eval? #;expected expected + #;cursor cursor} + (some (: (-> (Env Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) + (lambda [env] + (case env + {#;name _ #;inner-closures _ #;locals {#;counter _ #;mappings locals} #;closure {#;counter _ #;mappings closure}} + (try-both (some (: (-> (, Text (Meta (, Type Cursor) Analysis)) (Maybe Type)) + (lambda [binding] + (let [[bname [[type _] _]] binding] + (if (text:= name bname) + (#;Some type) + #;None))))) + locals + closure)))) + envs))) + +(def (find-in-defs' name state) + (-> Ident Compiler (Maybe Definition)) (let [[v-prefix v-name] name {#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] + #;envs envs #;type-vars types #;host host + #;seed seed #;eval? eval? #;expected expected + #;cursor cursor} state] (case (get v-prefix modules) #;None #;None - (#;Some {#;defs defs #;module-aliases _ #;imports _}) + (#;Some {#;defs defs #;module-aliases _ #;imports _ #;tags _ #;types _}) (case (get v-name defs) #;None #;None - (#;Some [_ def-data]) - (case def-data - #;TypeD (#;Some Type) - (#;ValueD type) (#;Some type) - (#;MacroD m) (#;Some Macro) - (#;AliasD name') (find-in-defs name' state)))))) + (#;Some def) + (case def + [_ (#;AliasD name')] (find-in-defs' name' state) + _ (#;Some def) + ))) + )) + +(def #export (find-in-defs name state) + (-> Ident Compiler (Maybe Type)) + (case (find-in-defs' name state) + (#;Some [_ def-data]) + (case def-data + (#;ValueD [type value]) (#;Some type) + (#;MacroD _) (#;Some Macro) + (#;TypeD _) (#;Some Type) + _ #;None) + + #;None + #;None)) (def #export (find-var-type name) (-> Ident (Lux Type)) (do Lux/Monad - [name' (normalize name)] + [#let [[_ _name] name] + name' (normalize name)] (: (Lux Type) (lambda [state] - (case (find-in-env name state) + (case (find-in-env _name state) (#;Some struct-type) (#;Right [state struct-type]) @@ -281,8 +305,62 @@ (#;Right [state struct-type]) _ - (let [{#;source source #;modules modules - #;envs envs #;types types #;host host - #;seed seed #;eval? eval?} state] - (#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))) + (#;Left ($ text:++ "Unknown var: " (ident->text name))))))) )) + +(def #export (find-type name) + (-> Ident (Lux Type)) + (do Lux/Monad + [name' (normalize name)] + (: (Lux Type) + (lambda [state] + (case (find-in-defs' name' state) + (#;Some def-data) + (case def-data + [_ (#;TypeD type)] (#;Right [state type]) + _ (#;Left ($ text:++ "Definition is not a type: " (ident->text name)))) + + _ + (#;Left ($ text:++ "Unknown var: " (ident->text name)))))) + )) + +(def #export (defs module-name state) + (-> Text (Lux (List (, Text Definition)))) + (case (get module-name (get@ #;modules state)) + #;None (#;Left ($ text:++ "Unknown module: " module-name)) + (#;Some module) (#;Right [state (get@ #;defs module)]) + )) + +(def #export (exports module-name) + (-> Text (Lux (List (, Text Definition)))) + (do Lux/Monad + [defs (defs module-name)] + (wrap (filter (lambda [[name [exported? data]]] exported?) + defs)))) + +(def #export (modules state) + (Lux (List Text)) + (|> state + (get@ #;modules) + (list:map t;first) + (#;Right state))) + +(def #export (find-module name state) + (-> Text (Lux (Module Compiler))) + (case (get name (get@ #;modules state)) + (#;Some module) + (#;Right state module) + + _ + (#;Left ($ text:++ "Unknown module: " name)))) + +(def #export (tags-for [module name]) + (-> Ident (Lux (Maybe (List Ident)))) + (do Lux/Monad + [module (find-module module)] + (case (get name (get@ #;types module)) + (#;Some [tags _]) + (wrap (#;Some tags)) + + _ + (wrap #;None)))) diff --git a/source/lux/meta/macro.lux b/source/lux/meta/macro.lux deleted file mode 100644 index 22aeaf874..000000000 --- a/source/lux/meta/macro.lux +++ /dev/null @@ -1,54 +0,0 @@ -## 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) - -## [Utils] -(def (_meta x) - (-> (Syntax' (Meta Cursor)) Syntax) - (#;Meta [["" -1 -1] x])) - -## [Syntax] -(def #export (defmacro tokens state) - Macro - (case tokens - (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - (#;Cons [(#;Meta [_ (#;TagS ["" "export"])]) (#;Cons [(#;Meta [_ (#;FormS (#;Cons [name args]))]) (#;Cons [body #;Nil])])]) - (#;Right [state (#;Cons [(` ((~ (_meta (#;SymbolS ["lux" "def"]))) (~ (_meta (#;TagS ["" "export"]))) ((~ name) (~@ args)) - (~ (_meta (#;SymbolS ["lux" "Macro"]))) - (~ body))) - (#;Cons [(` ((~ (_meta (#;SymbolS ["" "_lux_declare-macro"]))) (~ name))) - #;Nil])])]) - - _ - (#;Left "Wrong syntax for defmacro"))) -(_lux_declare-macro defmacro) - -## [Functions] -(do-template [<name> <type> <tag>] - [(def #export (<name> x) - (-> <type> Syntax) - (#;Meta [["" -1 -1] (<tag> x)]))] - - [bool$ Bool #;BoolS] - [int$ Int #;IntS] - [real$ Real #;RealS] - [char$ Char #;CharS] - [text$ Text #;TextS] - [symbol$ Ident #;SymbolS] - [tag$ Ident #;TagS] - [form$ (List Syntax) #;FormS] - [tuple$ (List Syntax) #;TupleS] - [record$ (List (, Syntax Syntax)) #;RecordS] - ) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index 63ab81475..641dfba0d 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -1,21 +1,20 @@ -## 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. +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (.. (macro #as m #refer #all) + (.. ast (lux #as l #refer (#only Lux/Monad gensym))) (lux (control (functor #as F) - (monad #as M #refer (#only do))) - (data (eq #as E) - (bool #as b) + (monad #as M #refer (#only do)) + (eq #as E)) + (data (bool #as b) (char #as c) (text #as t #open ("text:" Text/Monoid Text/Eq)) - list))) + (list #refer #all #open ("" List/Functor List/Fold)) + (number (int #open ("i" Int/Ord)) + (real #open ("r" Real/Eq)))))) ## [Utils] (def (first xy) @@ -27,15 +26,19 @@ (All [a] (-> (List (, a a)) (List a))) (case pairs #;Nil #;Nil - (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs')))) + (#;Cons [[x y] pairs']) (@list& x y (join-pairs pairs')))) -## Types +(def (pair->tuple [left right]) + (-> (, AST AST) AST) + (tuple$ (@list left right))) + +## [Types] (deftype #export (Parser a) - (-> (List Syntax) (Maybe (, (List Syntax) a)))) + (-> (List AST) (Maybe (, (List AST) a)))) -## Structures +## [Structures] (defstruct #export Parser/Functor (F;Functor Parser) - (def (F;map f ma) + (def (map f ma) (lambda [tokens] (case (ma tokens) #;None @@ -45,12 +48,12 @@ (#;Some [tokens' (f a)]))))) (defstruct #export Parser/Monad (M;Monad Parser) - (def M;_functor Parser/Functor) + (def _functor Parser/Functor) - (def (M;wrap x tokens) + (def (wrap x tokens) (#;Some [tokens x])) - (def (M;join mma) + (def (join mma) (lambda [tokens] (case (mma tokens) #;None @@ -59,9 +62,9 @@ (#;Some [tokens' ma]) (ma tokens'))))) -## Parsers +## [Parsers] (def #export (id^ tokens) - (Parser Syntax) + (Parser AST) (case tokens #;Nil #;None (#;Cons [t tokens']) (#;Some [tokens' t]))) @@ -70,7 +73,7 @@ [(def #export (<name> tokens) (Parser <type>) (case tokens - (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) + (#;Cons [[_ (<tag> x)] tokens']) (#;Some [tokens' x]) _ @@ -85,11 +88,24 @@ [ tag^ Ident #;TagS] ) +(def #export (assert v tokens) + (-> Bool (Parser (,))) + (if v + (#;Some [tokens []]) + #;None)) + +(def #export nat^ + (Parser Int) + (do Parser/Monad + [n int^ + _ (assert (i>= n 0))] + (wrap n))) + (do-template [<name> <tag>] [(def #export (<name> tokens) (Parser Text) (case tokens - (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens']) + (#;Cons [[_ (<tag> ["" x])] tokens']) (#;Some [tokens' x]) _ @@ -108,32 +124,51 @@ (do-template [<name> <type> <tag> <eq>] [(def #export (<name> v tokens) - (-> <type> (Parser (,))) + (-> <type> (Parser Bool)) (case tokens - (#;Cons [(#;Meta [_ (<tag> x)]) tokens']) - (if (<eq> v x) - (#;Some [tokens' []]) - #;None) + (#;Cons [[_ (<tag> x)] tokens']) + (#;Some [tokens' (<eq> v x)]) _ - #;None))] + (#;Some [tokens false])))] - [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)] + [ bool?^ Bool #;BoolS (:: b;Bool/Eq =)] [ int?^ Int #;IntS i=] [ real?^ Real #;RealS r=] - [ char?^ Char #;CharS (:: c;Char/Eq E;=)] - [ text?^ Text #;TextS (:: t;Text/Eq E;=)] + [ char?^ Char #;CharS (:: c;Char/Eq =)] + [ text?^ Text #;TextS (:: t;Text/Eq =)] [symbol?^ Ident #;SymbolS ident:=] [ tag?^ Ident #;TagS ident:=] ) +(do-template [<name> <type> <tag> <eq>] + [(def #export (<name> v tokens) + (-> <type> (Parser Unit)) + (case tokens + (#;Cons [[_ (<tag> x)] tokens']) + (if (<eq> v x) + (#;Some [tokens' []]) + #;None) + + _ + #;None))] + + [ bool!^ Bool #;BoolS (:: b;Bool/Eq =)] + [ int!^ Int #;IntS i=] + [ real!^ Real #;RealS r=] + [ char!^ Char #;CharS (:: c;Char/Eq =)] + [ text!^ Text #;TextS (:: t;Text/Eq =)] + [symbol!^ Ident #;SymbolS ident:=] + [ tag!^ Ident #;TagS ident:=] + ) + (do-template [<name> <tag>] [(def #export (<name> p tokens) (All [a] (-> (Parser a) (Parser a))) (case tokens - (#;Cons [(#;Meta [_ (<tag> form)]) tokens']) - (case (p form) + (#;Cons [[_ (<tag> members)] tokens']) + (case (p members) (#;Some [#;Nil x]) (#;Some [tokens' x]) _ #;None) @@ -144,6 +179,18 @@ [tuple^ #;TupleS] ) +(def #export (record^ p tokens) + (All [a] + (-> (Parser a) (Parser a))) + (case tokens + (#;Cons [[_ (#;RecordS pairs)] tokens']) + (case (p (map pair->tuple pairs)) + (#;Some [#;Nil x]) (#;Some [tokens' x]) + _ #;None) + + _ + #;None)) + (def #export (?^ p tokens) (All [a] (-> (Parser a) (Parser (Maybe a)))) @@ -153,17 +200,17 @@ (def (run-parser p tokens) (All [a] - (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a)))) + (-> (Parser a) (List AST) (Maybe (, (List AST) a)))) (p tokens)) (def #export (*^ p tokens) (All [a] (-> (Parser a) (Parser (List a)))) (case (p tokens) - #;None (#;Some [tokens (list)]) + #;None (#;Some [tokens (@list)]) (#;Some [tokens' x]) (run-parser (do Parser/Monad [xs (*^ p)] - (M;wrap (list& x xs))) + (wrap (@list& x xs))) tokens'))) (def #export (+^ p) @@ -172,7 +219,7 @@ (do Parser/Monad [x p xs (*^ p)] - (M;wrap (list& x xs)))) + (wrap (@list& x xs)))) (def #export (&^ p1 p2) (All [a b] @@ -180,17 +227,18 @@ (do Parser/Monad [x1 p1 x2 p2] - (M;wrap [x1 x2]))) + (wrap [x1 x2]))) (def #export (|^ p1 p2 tokens) (All [a b] - (-> (Parser a) (Parser b) (Parser (Either b)))) + (-> (Parser a) (Parser b) (Parser (Either a b)))) (case (p1 tokens) (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)]) #;None (run-parser (do Parser/Monad [x2 p2] - (M;wrap (#;Right x2))) - tokens))) + (wrap (#;Right x2))) + tokens) + )) (def #export (||^ ps tokens) (All [a] @@ -208,55 +256,51 @@ #;Nil (#;Some [tokens []]) _ #;None)) -## Syntax +## [Syntax] (defmacro #export (defsyntax tokens) - (let [[exported? tokens] (: (, Bool (List Syntax)) - (case tokens - (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens')) - [true tokens'] + (let [[exported? tokens] (case tokens + (\ (@list& [_ (#;TagS ["" "export"])] tokens')) + [true tokens'] - _ - [false tokens]))] + _ + [false tokens])] (case tokens - (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))]) - body)) + (\ (@list [_ (#;FormS (@list& [_ (#;SymbolS ["" name])] args))] + body)) (do Lux/Monad - [names+parsers (M;map% Lux/Monad - (: (-> Syntax (Lux (, Syntax Syntax))) - (lambda [arg] - (case arg - (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)]) - parser))])) - (M;wrap [(symbol$ var-name) parser]) - - (\ (#;Meta [_ (#;SymbolS var-name)])) - (M;wrap [(symbol$ var-name) (` id^)]) - - _ - (l;fail "Syntax pattern expects 2-tuples or symbols.")))) - args) + [vars+parsers (M;map% Lux/Monad + (: (-> AST (Lux (, AST AST))) + (lambda [arg] + (case arg + (\ [_ (#;TupleS (@list var parser))]) + (wrap [var parser]) + + (\ [_ (#;SymbolS var-name)]) + (wrap [(symbol$ var-name) (` id^)]) + + _ + (l;fail "Syntax pattern expects 2-tuples or symbols.")))) + args) g!tokens (gensym "tokens") g!_ (gensym "_") - #let [names (:: List/Functor (F;map first names+parsers)) - error-msg (text$ (text:++ "Wrong syntax for " name)) - body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax) + #let [error-msg (text$ (text:++ "Wrong syntax for " name)) + body' (foldL (: (-> AST (, AST AST) AST) (lambda [body name+parser] (let [[name parser] name+parser] - (` (_lux_case ((~ parser) (~ g!tokens)) - (#;Some [(~ g!tokens) (~ name)]) - (~ body) + (` (;_lux_case ((~ parser) (~ g!tokens)) + (#;Some [(~ g!tokens) (~ name)]) + (~ body) - (~ g!_) - (l;fail (~ error-msg))))))) + (~ g!_) + (l;fail (~ error-msg))))))) body - (: (List (, Syntax Syntax)) (list& [(symbol$ ["" ""]) (` end^)] (reverse names+parsers)))) - macro-def (: Syntax - (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) - (~ body'))))]] - (M;wrap (list& macro-def - (if exported? - (list (` (_lux_export (~ (symbol$ ["" name]))))) - (list))))) + (: (List (, AST AST)) (@list& [(symbol$ ["" ""]) (` end^)] (reverse vars+parsers)))) + macro-def (` (defmacro ((~ (symbol$ ["" name])) (~ g!tokens)) + (~ body')))]] + (wrap (@list& macro-def + (if exported? + (@list (` (;_lux_export (~ (symbol$ ["" name]))))) + (@list))))) _ (l;fail "Wrong syntax for defsyntax")))) diff --git a/source/lux/meta/type.lux b/source/lux/meta/type.lux new file mode 100644 index 000000000..0938d104d --- /dev/null +++ b/source/lux/meta/type.lux @@ -0,0 +1,193 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux (control show + eq + monad) + (data (char #as c) + (text #as t #open ("text:" Text/Monoid Text/Eq)) + (number/int #open ("int:" Int/Number Int/Ord Int/Show)) + maybe + (list #refer #all #open ("list:" List/Monad List/Monoid List/Fold))) + )) + +(open List/Fold) + +## [Utils] +(def (unravel-fun type) + (-> Type (, Type (List Type))) + (case type + (#;LambdaT in out') + (let [[out ins] (unravel-fun out')] + [out (@list& in ins)]) + + _ + [type (@list)])) + +(def (unravel-app type) + (-> Type (, Type (List Type))) + (case type + (#;AppT left' right) + (let [[left rights] (unravel-app left')] + [left (list:++ rights (@list right))]) + + _ + [type (@list)])) + +## [Structures] +(defstruct #export Type/Show (Show Type) + (def (show type) + (case type + (#;DataT name params) + (case params + #;Nil + ($ text:++ "(^ " name ")") + + _ + ($ text:++ "(^ " name " " (|> params (list:map show) (interpose " ") (list:foldL text:++ "")) ")")) + + (#;TupleT members) + (case members + #;Nil + "(,)" + + _ + ($ text:++ "(, " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) + + (#;VariantT members) + (case members + #;Nil + "(|)" + + _ + ($ text:++ "(| " (|> members (list:map show) (interpose " ") (foldL text:++ "")) ")")) + + (#;LambdaT input output) + (let [[out ins] (unravel-fun type)] + ($ text:++ "(-> " (|> ins (list:map show) (interpose " ") (foldL text:++ "")) " " (show out) ")")) + + (#;VarT id) + ($ text:++ "⌈" (int:show id) "⌋") + + (#;BoundT idx) + (int:show idx) + + (#;ExT id) + ($ text:++ "⟨" (int:show id) "⟩") + + (#;AppT fun param) + (let [[type-fun type-args] (unravel-app type)] + ($ text:++ "(" (show type-fun) " " (|> type-args (list:map show) (interpose " ") (foldL text:++ "")) ")")) + + (#;UnivQ env body) + ($ text:++ "(All " (show body) ")") + + (#;ExQ env body) + ($ text:++ "(Ex " (show body) ")") + + (#;NamedT [module name] type) + ($ text:++ module ";" name) + ))) + +(defstruct #export Type/Eq (Eq Type) + (def (= x y) + (case [x y] + [(#;DataT xname xparams) (#;DataT yname yparams)] + (and (text:= xname yname) + (int:= (size xparams) (size yparams)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + true + (zip2 xparams yparams))) + + (\or [(#;VarT xid) (#;VarT yid)] + [(#;ExT xid) (#;ExT yid)] + [(#;BoundT xid) (#;BoundT yid)]) + (int:= xid yid) + + (\or [(#;LambdaT xleft xright) (#;LambdaT yleft yright)] + [(#;AppT xleft xright) (#;AppT yleft yright)]) + (and (= xleft yleft) + (= xright yright)) + + [(#;NamedT [xmodule xname] xtype) (#;NamedT [ymodule yname] ytype)] + (and (text:= xmodule ymodule) + (text:= xname yname) + (= xtype ytype)) + + (\or [(#;TupleT xmembers) (#;TupleT ymembers)] + [(#;VariantT xmembers) (#;VariantT ymembers)]) + (and (int:= (size xmembers) (size ymembers)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + true + (zip2 xmembers ymembers))) + + (\or [(#;UnivQ xenv xbody) (#;UnivQ yenv ybody)] + [(#;ExQ xenv xbody) (#;ExQ yenv ybody)]) + (and (int:= (size xenv) (size yenv)) + (foldL (lambda [prev [x y]] + (and prev (= x y))) + (= xbody ybody) + (zip2 xenv yenv))) + + _ + false + ))) + +## [Functions] +(def #export (beta-reduce env type) + (-> (List Type) Type Type) + (case type + (\template [<tag>] + [(<tag> members) + (<tag> (list:map (beta-reduce env) members))]) + [[#;VariantT] + [#;TupleT]] + + (\template [<tag>] + [(<tag> left right) + (<tag> (beta-reduce env left) (beta-reduce env right))]) + [[#;LambdaT] + [#;AppT]] + + (\template [<tag>] + [(<tag> env def) + (case env + #;Nil + (<tag> env def) + + _ + type)]) + [[#;UnivQ] + [#;ExQ]] + + (#;BoundT idx) + (? type (@ idx env)) + + (#;NamedT name type) + (beta-reduce env type) + + _ + type + )) + +(def #export (apply-type type-fun param) + (-> Type Type (Maybe Type)) + (case type-fun + (#;UnivQ env body) + (#;Some (beta-reduce (@list& type-fun param env) body)) + + (#;AppT F A) + (do Maybe/Monad + [type-fn* (apply-type F A)] + (apply-type type-fn* param)) + + (#;NamedT name type) + (apply-type type param) + + _ + #;None)) |