From 1b48e9e06cb90187b28381bcadbeeba60806964d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 17 Aug 2015 16:59:18 -0400 Subject: - Finished turning tags into indices. - As an unexpected bonus, the compiler has become 2.5x faster. - Fixed some minor bugs. - Tag declarations now include associated types. - Tag declarations info is now stored twice (one from the perspective of tags, the other from the perspective of types). - Changed the named of the "types" member of the Compiler type, to "type-vars" to avoid collision with the "types" member of the Module type. --- source/lux.lux | 752 +++++++++++++++++++++++++++++++-------------------------- 1 file changed, 416 insertions(+), 336 deletions(-) (limited to 'source/lux.lux') diff --git a/source/lux.lux b/source/lux.lux index b6d71e893..4120b262c 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -10,70 +10,68 @@ (_jvm_interface "Function" [] ("apply" ["java.lang.Object"] "java.lang.Object" ["public" "abstract"])) -(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT]) -(_lux_declare-tags [#None #Some]) -(_lux_declare-tags [#Nil #Cons]) - ## Basic types -(_lux_def Bool (#NamedT ["lux" "Bool"] - (#DataT "java.lang.Boolean"))) +(_lux_def Bool (9 ["lux" "Bool"] + (0 "java.lang.Boolean"))) (_lux_export Bool) -(_lux_def Int (#NamedT ["lux" "Int"] - (#DataT "java.lang.Long"))) +(_lux_def Int (9 ["lux" "Int"] + (0 "java.lang.Long"))) (_lux_export Int) -(_lux_def Real (#NamedT ["lux" "Real"] - (#DataT "java.lang.Double"))) +(_lux_def Real (9 ["lux" "Real"] + (0 "java.lang.Double"))) (_lux_export Real) -(_lux_def Char (#NamedT ["lux" "Char"] - (#DataT "java.lang.Character"))) +(_lux_def Char (9 ["lux" "Char"] + (0 "java.lang.Character"))) (_lux_export Char) -(_lux_def Text (#NamedT ["lux" "Text"] - (#DataT "java.lang.String"))) +(_lux_def Text (9 ["lux" "Text"] + (0 "java.lang.String"))) (_lux_export Text) -(_lux_def Unit (#NamedT ["lux" "Unit"] - (#TupleT #Nil))) +(_lux_def Unit (9 ["lux" "Unit"] + (2 (0)))) (_lux_export Unit) -(_lux_def Void (#NamedT ["lux" "Void"] - (#VariantT #Nil))) +(_lux_def Void (9 ["lux" "Void"] + (1 (0)))) (_lux_export Void) -(_lux_def Ident (#NamedT ["lux" "Ident"] - (#TupleT (#Cons Text (#Cons Text #Nil))))) +(_lux_def Ident (9 ["lux" "Ident"] + (2 (1 Text (1 Text (0)))))) (_lux_export Ident) ## (deftype (List a) ## (| #Nil ## (#Cons a (List a)))) (_lux_def List - (#NamedT ["lux" "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)))))) + (9 ["lux" "List"] + (7 (1 (0)) "lux;List" "a" + (1 (1 ## "lux;Nil" + (2 (0)) + (1 ## "lux;Cons" + (2 (1 (4 "a") + (1 (8 (4 "lux;List") (4 "a")) + (0)))) + (0))))))) (_lux_export List) +(_lux_declare-tags [#Nil #Cons] List) ## (deftype (Maybe a) ## (| #None -## (#Some a))) +## (1 a))) (_lux_def Maybe - (#NamedT ["lux" "Maybe"] - (#AllT (#Some #Nil) "lux;Maybe" "a" - (#VariantT (#Cons ## "lux;None" - (#TupleT #Nil) - (#Cons ## "lux;Some" - (#BoundT "a") - #Nil)))))) + (9 ["lux" "Maybe"] + (7 (1 (0)) "lux;Maybe" "a" + (1 (1 ## "lux;None" + (2 (0)) + (1 ## "lux;Some" + (4 "a") + (0))))))) (_lux_export Maybe) +(_lux_declare-tags [#None #Some] Maybe) ## (deftype #rec Type ## (| (#DataT Text) @@ -87,37 +85,38 @@ ## (#NamedT Ident Type) ## )) (_lux_def Type - (#NamedT ["lux" "Type"] - (_lux_case (#AppT (#BoundT "Type") (#BoundT "_")) - Type - (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil)))) - TypeEnv - (_lux_case (#AppT List Type) - TypeList - (#AppT (#AllT (#Some #Nil) "Type" "_" - (#VariantT (#Cons ## "lux;DataT" - Text - (#Cons ## "lux;VariantT" - TypeList - (#Cons ## "lux;TupleT" - TypeList - (#Cons ## "lux;LambdaT" - (#TupleT (#Cons Type (#Cons Type #Nil))) - (#Cons ## "lux;BoundT" - Text - (#Cons ## "lux;VarT" - Int - (#Cons ## "lux;ExT" - 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;NamedT" - (#TupleT (#Cons Ident (#Cons Type #Nil))) - #Nil)))))))))))) - Void)))))) + (9 ["lux" "Type"] + (_lux_case (8 (4 "Type") (4 "_")) + Type + (_lux_case (8 List (2 (1 Text (1 Type (0))))) + TypeEnv + (_lux_case (8 List Type) + TypeList + (8 (7 (1 (0)) "Type" "_" + (1 (1 ## "lux;DataT" + Text + (1 ## "lux;VariantT" + TypeList + (1 ## "lux;TupleT" + TypeList + (1 ## "lux;LambdaT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;BoundT" + Text + (1 ## "lux;VarT" + Int + (1 ## "lux;ExT" + Int + (1 ## "lux;AllT" + (2 (1 (8 Maybe TypeEnv) (1 Text (1 Text (1 Type (0)))))) + (1 ## "lux;AppT" + (2 (1 Type (1 Type (0)))) + (1 ## "lux;NamedT" + (2 (1 Ident (1 Type (0)))) + (0))))))))))))) + Void)))))) (_lux_export Type) +(_lux_declare-tags [#DataT #VariantT #TupleT #LambdaT #BoundT #VarT #ExT #AllT #AppT #NamedT] Type) ## (deftype (Bindings k v) ## (& #counter Int @@ -135,7 +134,7 @@ #Nil])]))]) #Nil)))])]))) (_lux_export Bindings) -(_lux_declare-tags [#counter #mappings]) +(_lux_declare-tags [#counter #mappings] Bindings) ## (deftype (Env k v) ## (& #name Text @@ -158,7 +157,7 @@ (#BoundT "v")) #Nil))))))))) (_lux_export Env) -(_lux_declare-tags [#name #inner-closures #locals #closure]) +(_lux_declare-tags [#name #inner-closures #locals #closure] Env) ## (deftype Cursor ## (, Text Int Int)) @@ -179,7 +178,7 @@ #Nil))) #Nil)))))) (_lux_export Meta) -(_lux_declare-tags [#Meta]) +(_lux_declare-tags [#Meta] Meta) ## (deftype (AST' w) ## (| (#BoolS Bool) @@ -225,7 +224,7 @@ ))))))))) )))))) (_lux_export AST') -(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS]) +(_lux_declare-tags [#BoolS #IntS #RealS #CharS #TextS #SymbolS #TagS #FormS #TupleS #RecordS] AST') ## (deftype AST ## (Meta Cursor (AST' (Meta Cursor)))) @@ -251,7 +250,7 @@ (#BoundT "r") #Nil))))))) (_lux_export Either) -(_lux_declare-tags [#Left #Right]) +(_lux_declare-tags [#Left #Right] Either) ## (deftype (StateE s a) ## (-> s (Either Text (, s a)))) @@ -286,7 +285,7 @@ (#Cons [## "lux;classes" (#DataT "clojure.lang.Atom") #Nil])])])))) -(_lux_declare-tags [#writer #loader #classes]) +(_lux_declare-tags [#writer #loader #classes] Host) ## (deftype (DefData' m) ## (| (#TypeD Type) @@ -294,20 +293,21 @@ ## (#MacroD m) ## (#AliasD Ident))) (_lux_def DefData' - (#AllT [(#Some #Nil) "lux;DefData'" "" - (#VariantT (#Cons [## "lux;TypeD" - Type - (#Cons [## "lux;ValueD" - (#TupleT (#Cons [Type - (#Cons [Unit - #Nil])])) - (#Cons [## "lux;MacroD" - (#BoundT "") - (#Cons [## "lux;AliasD" - Ident - #Nil])])])]))])) + (#NamedT ["lux" "DefData'"] + (#AllT [(#Some #Nil) "lux;DefData'" "" + (#VariantT (#Cons [## "lux;ValueD" + (#TupleT (#Cons [Type + (#Cons [Unit + #Nil])])) + (#Cons [## "lux;TypeD" + Type + (#Cons [## "lux;MacroD" + (#BoundT "") + (#Cons [## "lux;AliasD" + Ident + #Nil])])])]))]))) (_lux_export DefData') -(_lux_declare-tags [#TypeD #ValueD #MacroD #AliasD]) +(_lux_declare-tags [#ValueD #TypeD #MacroD #AliasD] DefData') ## (deftype LuxVar ## (| (#Local Int) @@ -320,44 +320,54 @@ Ident #Nil])])))) (_lux_export LuxVar) -(_lux_declare-tags [#Local #Global]) +(_lux_declare-tags [#Local #Global] LuxVar) ## (deftype (Module Compiler) ## (& #module-aliases (List (, Text Text)) ## #defs (List (, Text (, Bool (DefData' (-> (List AST) (StateE Compiler (List AST))))))) ## #imports (List Text) -## #tags (List (, Text (, Int (List Ident)))) +## #tags (List (, Text (, Int (List Ident) Type))) +## #types (List (, Text (, (List Ident) Type))) ## )) (_lux_def Module - (#AllT [(#Some #Nil) "lux;Module" "Compiler" - (#TupleT (#Cons [## "lux;module-aliases" - (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) - (#Cons [## "lux;defs" - (#AppT [List (#TupleT (#Cons [Text - (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList - (#AppT [(#AppT [StateE (#BoundT "Compiler")]) - ASTList])])]) - #Nil])])) - #Nil])]))]) - (#Cons [## "lux;imports" - (#AppT [List Text]) - (#Cons [## "lux;tags" - (#AppT [List - (#TupleT (#Cons Text - (#Cons (#TupleT (#Cons Int - (#Cons (#AppT [List Ident]) - #Nil))) - #Nil)))]) - #Nil])])])]))])) + (#NamedT ["lux" "Module"] + (#AllT [(#Some #Nil) "lux;Module" "Compiler" + (#TupleT (#Cons [## "lux;module-aliases" + (#AppT [List (#TupleT (#Cons [Text (#Cons [Text #Nil])]))]) + (#Cons [## "lux;defs" + (#AppT [List (#TupleT (#Cons [Text + (#Cons [(#TupleT (#Cons [Bool (#Cons [(#AppT [DefData' (#LambdaT [ASTList + (#AppT [(#AppT [StateE (#BoundT "Compiler")]) + ASTList])])]) + #Nil])])) + #Nil])]))]) + (#Cons [## "lux;imports" + (#AppT [List Text]) + (#Cons [## "lux;tags" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons Int + (#Cons (#AppT [List Ident]) + (#Cons Type + #Nil)))) + #Nil)))]) + (#Cons [## "lux;types" + (#AppT [List + (#TupleT (#Cons Text + (#Cons (#TupleT (#Cons (#AppT [List Ident]) + (#Cons Type + #Nil))) + #Nil)))]) + #Nil])])])])]))]))) (_lux_export Module) -(_lux_declare-tags [#module-aliases #defs #imports #tags]) +(_lux_declare-tags [#module-aliases #defs #imports #tags #types] Module) ## (deftype #rec Compiler ## (& #source Source ## #cursor Cursor ## #modules (List (, Text (Module Compiler))) ## #envs (List (Env Text (, LuxVar Type))) -## #types (Bindings Int Type) +## #type-vars (Bindings Int Type) ## #expected Type ## #seed Int ## #eval? Bool @@ -377,7 +387,7 @@ (#Cons [## "lux;envs" (#AppT [List (#AppT [(#AppT [Env Text]) (#TupleT (#Cons [LuxVar (#Cons [Type #Nil])]))])]) - (#Cons [## "lux;types" + (#Cons [## "lux;type-vars" (#AppT [(#AppT [Bindings Int]) Type]) (#Cons [## "lux;expected" Type @@ -390,7 +400,7 @@ #Nil])])])])])])])])]))]) Void]))) (_lux_export Compiler) -(_lux_declare-tags [#source #cursor #modules #envs #types #expected #seed #eval? #host]) +(_lux_declare-tags [#source #cursor #modules #envs #type-vars #expected #seed #eval? #host] Compiler) ## (deftype Macro ## (-> (List AST) (StateE Compiler (List AST)))) @@ -1046,12 +1056,13 @@ ## bind)) (def''' Monad Type - (All' [m] - (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) - (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) - ($' (B' m) (B' a)) - ($' (B' m) (B' b)))))))) -(_lux_declare-tags [#return #bind]) + (#NamedT ["lux" "Monad"] + (All' [m] + (#TupleT (list (All' [a] (->' (B' a) ($' (B' m) (B' a)))) + (All' [a b] (->' (->' (B' a) ($' (B' m) (B' b))) + ($' (B' m) (B' a)) + ($' (B' m) (B' b))))))))) +(_lux_declare-tags [#return #bind] Monad) (def''' Maybe/Monad ($' Monad Maybe) @@ -1070,7 +1081,7 @@ {#return (lambda' [x] (lambda' [state] - (#Right [state x]))) + (#Right state x))) #bind (lambda' [f ma] @@ -1079,12 +1090,12 @@ (#Left msg) (#Left msg) - (#Right [state' a]) + (#Right state' a) (f a state'))))}) (defmacro #export (^ tokens) (_lux_case tokens - (#Cons [(#Meta [_ (#SymbolS ["" class-name])]) #Nil]) + (#Cons (#Meta _ (#SymbolS "" class-name)) #Nil) (return (list (`' (#;DataT (~ (_meta (#TextS class-name))))))) _ @@ -1092,8 +1103,8 @@ (defmacro #export (-> tokens) (_lux_case (reverse tokens) - (#Cons [output inputs]) - (return (list (foldL (lambda' [o i] (`' (#;LambdaT [(~ i) (~ o)]))) + (#Cons output inputs) + (return (list (foldL (lambda' [o i] (`' (#;LambdaT (~ i) (~ o)))) output inputs))) @@ -1425,7 +1436,7 @@ ($' Lux Text) (_lux_case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (_lux_case (reverse envs) @@ -1441,7 +1452,7 @@ ($' Maybe Macro)) (do Maybe/Monad [$module (get module modules) - gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags} (_lux_: ($' Module Compiler) $module)] + gdef (let' [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} (_lux_: ($' Module Compiler) $module)] (get name bindings))] (_lux_case (_lux_: (, Bool ($' DefData' Macro)) gdef) [exported? (#MacroD macro')] @@ -1465,7 +1476,7 @@ (lambda' [state] (_lux_case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (#Right state (find-macro' modules current-module module name))))))) @@ -1632,7 +1643,7 @@ _ (fail "Wrong syntax for variant case.")))) cases)] - (return [(`' (#VariantT (~ (untemplate-list (map second members))))) + (return [(`' (#;VariantT (~ (untemplate-list (map second members))))) (#Some (|> members (map first) (map (: (-> Text AST) @@ -1687,16 +1698,18 @@ (_lux_case parts (#Some name args type) (do Lux/Monad - [type+tags?? (unfold-type-def type)] - (let' [[type tags??] type+tags?? + [type+tags?? (unfold-type-def type) + module-name get-module-name] + (let' [type-name (symbol$ ["" name]) + [type tags??] type+tags?? with-export (: (List AST) (if export? - (list (`' (_lux_export (~ (symbol$ ["" name]))))) + (list (`' (_lux_export (~ type-name)))) #Nil)) with-tags (: (List AST) (_lux_case tags?? (#Some tags) - (list (`' (_lux_declare-tags [(~@ tags)]))) + (list (`' (_lux_declare-tags [(~@ tags)] (~ type-name)))) _ (list))) @@ -1714,10 +1727,12 @@ (#Some type) _ - (#Some (`' (;All (~ (symbol$ ["" name])) [(~@ args)] (~ type)))))))] + (#Some (`' (;All (~ type-name) [(~@ args)] (~ type)))))))] (_lux_case type' (#Some type'') - (return (list& (`' (_lux_def (~ (symbol$ ["" name])) (;type (~ type'')))) + (return (list& (`' (_lux_def (~ type-name) (;type (#;NamedT [(~ (text$ module-name)) + (~ (text$ name))] + (~ type''))))) (list:++ with-export with-tags))) #None @@ -2001,37 +2016,15 @@ (-> Text (Lux AST)) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (#Right {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed (i+ 1 seed) #eval? eval? #expected expected #cursor cursor} (symbol$ ["" ($ text:++ "__gensym__" prefix (->text seed))])))) -(defmacro #export (sig tokens) - (do Lux/Monad - [tokens' (map% Lux/Monad macro-expand tokens) - members (map% Lux/Monad - (: (-> AST (Lux (, Ident AST))) - (lambda [token] - (case token - (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name)))))) - (do Lux/Monad - [name' (normalize name)] - (wrap (: (, Ident AST) [name' type]))) - - _ - (fail "Signatures require typed members!")))) - (list:join tokens'))] - (wrap (list (` (#;RecordT (~ (untemplate-list (map (: (-> (, Ident AST) AST) - (lambda [pair] - (let [[name type] pair] - (` [(~ (|> name ident->text text$)) - (~ type)])))) - members))))))))) - (defmacro #export (defsig tokens) (let [[export? tokens'] (: (, Bool (List AST)) (case tokens @@ -2040,28 +2033,48 @@ _ [false tokens])) - ?parts (: (Maybe (, AST (List AST) (List AST))) + ?parts (: (Maybe (, Ident (List AST) (List AST))) (case tokens' - (\ (list& (#Meta _ (#FormS (list& name args))) sigs)) + (\ (list& (#Meta _ (#FormS (list& (#Meta _ (#SymbolS name)) args))) sigs)) (#Some name args sigs) - (\ (list& name sigs)) + (\ (list& (#Meta _ (#SymbolS name)) sigs)) (#Some name #Nil sigs) _ #None))] (case ?parts (#Some name args sigs) - (let [sigs' (: AST - (case args - #Nil - (` (;sig (~@ sigs))) - - _ - (` (;All (~ name) [(~@ args)] (;sig (~@ sigs))))))] - (return (list& (` (_lux_def (~ name) (~ sigs'))) + (do Lux/Monad + [name+ (normalize name) + sigs' (map% Lux/Monad macro-expand sigs) + members (map% Lux/Monad + (: (-> AST (Lux (, Text AST))) + (lambda [token] + (case token + (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS ["" name])))))) + (wrap (: (, Text AST) [name type])) + + _ + (fail "Signatures require typed members!")))) + (list:join sigs')) + #let [[_module _name] name+ + def-name (symbol$ name) + tags (: (List AST) (map (. (: (-> Text AST) (lambda [n] (tag$ ["" n]))) first) members)) + types (map second members) + sig-type (: AST (` (#;TupleT (~ (untemplate-list types))))) + sig-decl (: AST (` (_lux_declare-tags [(~@ tags)] (~ def-name)))) + sig+ (: AST + (case args + #Nil + sig-type + + _ + (` (#;NamedT [(~ (text$ _module)) (~ (text$ _name))] (;All (~ def-name) [(~@ args)] (~ sig-type))))))]] + (return (list& (` (_lux_def (~ def-name) (~ sig+))) + sig-decl (if export? - (list (` (_lux_export (~ name)))) + (list (` (_lux_export (~ def-name)))) #Nil)))) #None @@ -2229,27 +2242,90 @@ #None)) (def (resolve-struct-type type) - (-> Type (Maybe Type)) + (-> Type (Maybe (List Type))) (case type (#TupleT slots) - (#Some type) + (#Some slots) (#AppT fun arg) - (apply-type fun arg) + (do Maybe/Monad + [output (apply-type fun arg)] + (resolve-struct-type output)) (#AllT _ _ _ body) (resolve-struct-type body) (#NamedT name type) (resolve-struct-type type) + _ #None)) +(def (find-module name) + (-> Text (Lux (Module Compiler))) + (lambda [state] + (let [{#source source #modules modules + #envs envs #type-vars types #host host + #seed seed #eval? eval? #expected expected + #cursor cursor} state] + (case (get name modules) + (#Some module) + (#Right state module) + + _ + (#Left ($ text:++ "Unknown module: " name)))))) + +(def get-current-module + (Lux (Module Compiler)) + (do Lux/Monad + [module-name get-module-name] + (find-module module-name))) + +(def (resolve-tag [module name]) + (-> Ident (Lux (, Int (List Ident) Type))) + (do Lux/Monad + [=module (find-module module) + #let [{#module-aliases _ #defs bindings #imports _ #tags tags-table #types types} =module]] + (case (get name tags-table) + (#Some output) + (return output) + + _ + (fail (text:++ "Unknown tag: " (ident->text [module name])))))) + +(def (resolve-type-tags type) + (-> Type (Lux (Maybe (, (List Ident) (List Type))))) + (case type + (#AppT fun arg) + (resolve-type-tags fun) + + (#AllT env name arg body) + (resolve-type-tags body) + + (#NamedT [module name] _) + (do Lux/Monad + [=module (find-module module) + #let [{#module-aliases _ #defs bindings #imports _ #tags tags #types types} =module]] + (case (get name types) + (#Some [tags (#NamedT _ _type)]) + (case (resolve-struct-type _type) + (#Some members) + (return (#Some [tags members])) + + _ + (return #None)) + + _ + (return #None))) + + _ + (return #None))) + (def expected-type (Lux Type) (lambda [state] (let [{#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] (#Right state expected)))) @@ -2450,7 +2526,7 @@ (-> Text (Lux Bool)) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (case (get module modules) @@ -2465,7 +2541,7 @@ (-> Text (Lux (List Text))) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (case (get module modules) @@ -2477,7 +2553,7 @@ (if export? (list name) (list))))) - (let [{#module-aliases _ #defs defs #imports _ #tags tags} =module] + (let [{#module-aliases _ #defs defs #imports _ #tags tags #types types} =module] defs))] (#Right state (list:join to-alias))) @@ -2648,7 +2724,7 @@ (-> Text Compiler (Maybe Type)) (case state {#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} (some (: (-> (Env Text (, LuxVar Type)) (Maybe Type)) @@ -2683,22 +2759,22 @@ (-> Ident Compiler (Maybe Type)) (let [[v-prefix v-name] name {#source source #modules modules - #envs envs #types types #host host + #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 _ #tags tags}) + (#Some {#defs defs #module-aliases _ #imports _ #tags tags #types types}) (case (get v-name defs) #None #None - (#Some _ def-data) + (#Some [_ def-data]) (case def-data (#TypeD _) (#Some Type) - (#ValueD [type _]) (#Some type) + (#ValueD type _) (#Some type) (#MacroD m) (#Some Macro) (#AliasD name') (find-in-defs name' state)))))) @@ -2720,7 +2796,7 @@ _ (let [{#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) @@ -2730,25 +2806,43 @@ _ (let [{#source source #modules modules - #envs envs #types types #host host + #envs envs #type-vars types #host host #seed seed #eval? eval? #expected expected #cursor cursor} state] (#Left ($ text:++ "Unknown var: " (ident->text ident) "\n\n" (show-envs envs)))))) ))) -(def (use-field field-name type) - (-> Text Type (, AST AST)) - (let [[module name] (split-slot field-name) - pattern (: AST - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (record$ (map (: (-> (, Text Type) (, AST AST)) - (lambda [[sname stype]] (use-field sname stype))) - slots)) +(def (zip2 xs ys) + (All [a b] (-> (List a) (List b) (List (, a b)))) + (case xs + (#Cons x xs') + (case ys + (#Cons y ys') + (list& [x y] (zip2 xs' ys')) - _ - (symbol$ ["" name])))] - [(tag$ [module name]) pattern])) + _ + (list)) + + _ + (list))) + +(def (use-field [module name] type) + (-> Ident Type (Lux (, AST AST))) + (do Lux/Monad + [output (resolve-type-tags type) + pattern (: (Lux AST) + (case output + (#Some [tags members]) + (do Lux/Monad + [slots (map% Lux/Monad + (: (-> (, Ident Type) (Lux (, AST AST))) + (lambda [[sname stype]] (use-field sname stype))) + (zip2 tags members))] + (return (record$ slots))) + + #None + (return (symbol$ ["" name]))))] + (return [(tag$ [module name]) pattern]))) (defmacro #export (using tokens) (case tokens @@ -2756,12 +2850,15 @@ (case struct (#Meta _ (#SymbolS name)) (do Lux/Monad - [struct-type (find-var-type name)] - (case (resolve-struct-type struct-type) - (#Some (#TupleT slots)) - (let [pattern (record$ (map (: (-> (, Text Type) (, AST AST)) - (lambda [[sname stype]] (use-field sname stype))) - slots))] + [struct-type (find-var-type name) + output (resolve-type-tags struct-type)] + (case output + (#Some [tags members]) + (do Lux/Monad + [slots (map% Lux/Monad (: (-> (, Ident Type) (Lux (, AST AST))) + (lambda [[sname stype]] (use-field sname stype))) + (zip2 tags members)) + #let [pattern (record$ slots)]] (return (list (` (_lux_case (~ struct) (~ pattern) (~ body)))))) _ @@ -2798,73 +2895,82 @@ _ (fail "Wrong syntax for cond")))) +(def (enumerate' idx xs) + (All [a] (-> Int (List a) (List (, Int a)))) + (case xs + (#Cons x xs') + (#Cons [idx x] (enumerate' (i+ 1 idx) xs')) + + #Nil + #Nil)) + +(def (enumerate xs) + (All [a] (-> (List a) (List (, Int a)))) + (enumerate' 0 xs)) + (defmacro #export (get@ tokens) (case tokens (\ (list (#Meta _ (#TagS slot')) record)) - (case record - (#Meta _ (#SymbolS name)) - (do Lux/Monad - [type (find-var-type name) - g!blank (gensym "") - g!output (gensym "")] - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (do Lux/Monad - [slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text Type) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-type] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - g!output - g!blank)]))) - slots))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output))))))) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output] + g!_ (gensym "_") + g!output (gensym "")] + (case (resolve-struct-type type) + (#Some members) + (let [pattern (record$ (map (: (-> (, Ident (, Int Type)) (, AST AST)) + (lambda [[[r-prefix r-name] [r-idx r-type]]] + [(tag$ [r-prefix r-name]) (if (i= idx r-idx) + g!output + g!_)])) + (zip2 tags (enumerate members))))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ g!output)))))) - _ - (fail "get@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (get@ (~ (tag$ slot')) (~ _record)))))))) + _ + (fail "get@ can only use records."))) _ (fail "Wrong syntax for get@"))) -(def (open-field prefix field-name source type) - (-> Text Text AST Type (List AST)) - (let [[module name] (split-slot field-name) - source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))] - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (list:join (map (: (-> (, Text Type) (List AST)) +(def (open-field prefix [module name] source type) + (-> Text Ident AST Type (Lux (List AST))) + (do Lux/Monad + [output (resolve-type-tags type) + #let [source+ (: AST (` (get@ (~ (tag$ [module name])) (~ source))))]] + (case output + (#Some [tags members]) + (do Lux/Monad + [decls' (map% Lux/Monad + (: (-> (, Ident Type) (Lux (List AST))) (lambda [[sname stype]] (open-field prefix sname source+ stype))) - slots)) + (zip2 tags members))] + (return (list:join decls'))) _ - (list (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+))))))) + (return (list (` (_lux_def (~ (symbol$ ["" (text:++ prefix name)])) (~ source+)))))))) (defmacro #export (open tokens) (case tokens (\ (list& (#Meta _ (#SymbolS struct-name)) tokens')) (do Lux/Monad - [#let [prefix (case tokens' + [@module get-module-name + #let [prefix (case tokens' (\ (list (#Meta _ (#TextS prefix)))) prefix _ "")] struct-type (find-var-type struct-name) + output (resolve-type-tags struct-type) #let [source (symbol$ struct-name)]] - (case (resolve-struct-type struct-type) - (#Some (#TupleT slots)) - (return (list:join (map (: (-> (, Text Type) (List AST)) - (lambda [[sname stype]] (open-field prefix sname source stype))) - slots))) + (case output + (#Some [tags members]) + (do Lux/Monad + [decls' (map% Lux/Monad (: (-> (, Ident Type) (Lux (List AST))) + (lambda [[sname stype]] (open-field prefix sname source stype))) + (zip2 tags members))] + (return (list:join decls'))) _ (fail "Can only \"open\" records."))) @@ -2911,47 +3017,34 @@ (defmacro #export (set@ tokens) (case tokens (\ (list (#Meta _ (#TagS slot')) value record)) - (case record - (#Meta _ (#SymbolS name)) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text AST))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text AST) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text AST) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - value - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) + (lambda [[r-slot-name [r-idx r-type]]] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (i= idx r-idx) + value + r-var)])) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) - _ - (fail "set@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (set@ (~ (tag$ slot')) (~ value) (~ _record)))))))) + _ + (fail "set@ can only use records."))) _ (fail "Wrong syntax for set@"))) @@ -2959,47 +3052,34 @@ (defmacro #export (update@ tokens) (case tokens (\ (list (#Meta _ (#TagS slot')) fun record)) - (case record - (#Meta _ (#SymbolS name)) - (do Lux/Monad - [type (find-var-type name)] - (case (resolve-struct-type type) - (#Some (#TupleT slots)) - (do Lux/Monad - [pattern' (map% Lux/Monad - (: (-> (, Text Type) (Lux (, Text AST))) - (lambda [slot] - (let [[r-slot-name r-type] slot] - (do Lux/Monad - [g!slot (gensym "")] - (return [r-slot-name g!slot]))))) - slots) - slot (normalize slot')] - (let [[s-prefix s-name] (: Ident slot) - pattern (record$ (map (: (-> (, Text AST) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-var] slot] - [(tag$ (split-slot r-slot-name)) r-var]))) - pattern')) - output (record$ (map (: (-> (, Text AST) (, AST AST)) - (lambda [slot] - (let [[r-slot-name r-var] slot - [r-prefix r-name] (split-slot r-slot-name)] - [(tag$ [r-prefix r-name]) (if (and (text:= s-prefix r-prefix) - (text:= s-name r-name)) - (` ((~ fun) (~ r-var))) - r-var)]))) - pattern'))] - (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) + (do Lux/Monad + [slot (normalize slot') + output (resolve-tag slot) + #let [[idx tags type] output]] + (case (resolve-struct-type type) + (#Some members) + (do Lux/Monad + [pattern' (map% Lux/Monad + (: (-> (, Ident (, Int Type)) (Lux (, Ident Int AST))) + (lambda [[r-slot-name [r-idx r-type]]] + (do Lux/Monad + [g!slot (gensym "")] + (return [r-slot-name r-idx g!slot])))) + (zip2 tags (enumerate members)))] + (let [pattern (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) r-var])) + pattern')) + output (record$ (map (: (-> (, Ident Int AST) (, AST AST)) + (lambda [[r-slot-name r-idx r-var]] + [(tag$ r-slot-name) (if (i= idx r-idx) + (` ((~ fun) (~ r-var))) + r-var)])) + pattern'))] + (return (list (` (_lux_case (~ record) (~ pattern) (~ output))))))) - _ - (fail "update@ can only use records."))) - - _ - (do Lux/Monad - [_record (gensym "")] - (return (list (` (let [(~ _record) (~ record)] - (update@ (~ (tag$ slot')) (~ fun) (~ _record)))))))) + _ + (fail "update@ can only use records."))) _ (fail "Wrong syntax for update@"))) @@ -3053,25 +3133,25 @@ (-> Type AST) (case type (#DataT name) - (` (#DataT (~ (text$ name)))) + (` (#;DataT (~ (text$ name)))) - (#VariantT cases) - (` (#VariantT (~ (untemplate-list (map type->syntax cases))))) + (#;VariantT cases) + (` (#;VariantT (~ (untemplate-list (map type->syntax cases))))) (#TupleT parts) - (` (#TupleT (~ (untemplate-list (map type->syntax parts))))) + (` (#;TupleT (~ (untemplate-list (map type->syntax parts))))) (#LambdaT in out) - (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) + (` (#;LambdaT (~ (type->syntax in)) (~ (type->syntax out)))) (#BoundT name) - (` (#BoundT (~ (text$ name)))) + (` (#;BoundT (~ (text$ name)))) (#VarT id) - (` (#VarT (~ (int$ id)))) + (` (#;VarT (~ (int$ id)))) (#ExT id) - (` (#ExT (~ (int$ id)))) + (` (#;ExT (~ (int$ id)))) (#AllT env name arg type) (let [env' (: AST @@ -3081,13 +3161,13 @@ (lambda [[label type]] (tuple$ (list (text$ label) (type->syntax type))))) _env)))))))] - (` (#AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) + (` (#;AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type))))) (#AppT fun arg) - (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) + (` (#;AppT (~ (type->syntax fun)) (~ (type->syntax arg)))) (#NamedT [module name] type) - (` (#NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type)))))) + (` (#;NamedT [(~ (text$ module)) (~ (text$ name))] (~ (type->syntax type)))))) (defmacro #export (loop tokens) (case tokens -- cgit v1.2.3