diff options
| author | Eduardo Julian | 2015-08-17 16:59:18 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2015-08-17 16:59:18 -0400 |
| commit | 1b48e9e06cb90187b28381bcadbeeba60806964d (patch) | |
| tree | 1e30e61bd5ec7f5d3b0c2c12f1f549bc23b5ee48 | |
| parent | df3e4ba2df6462812174e69ea5c334a7edbbd5c7 (diff) | |
- 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.
29 files changed, 696 insertions, 556 deletions
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 diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux index 8eb87c00b..7898e998d 100644 --- a/source/lux/codata/function.lux +++ b/source/lux/codata/function.lux @@ -26,5 +26,5 @@ ## [Structures] (defstruct #export Comp/Monoid (All [a] (m;Monoid (-> a a))) - (def unit id) - (def ++ .)) + (def m;unit id) + (def m;++ .)) diff --git a/source/lux/codata/lazy.lux b/source/lux/codata/lazy.lux index de5c40eef..893c74d9e 100644 --- a/source/lux/codata/lazy.lux +++ b/source/lux/codata/lazy.lux @@ -9,8 +9,8 @@ (;import lux (lux (meta macro ast) - (control functor - monad) + (control (functor #as F #refer #all) + (monad #as M #refer #all)) (data list)) (.. function)) @@ -37,13 +37,13 @@ ## [Structs] (defstruct #export Lazy/Functor (Functor Lazy) - (def (map f ma) + (def (F;map f ma) (lambda [k] (ma (. k f))))) (defstruct #export Lazy/Monad (Monad Lazy) - (def _functor Lazy/Functor) + (def M;_functor Lazy/Functor) - (def (wrap a) + (def (M;wrap a) (... a)) - (def join !)) + (def M;join !)) diff --git a/source/lux/codata/reader.lux b/source/lux/codata/reader.lux index ee1798793..e91687c3a 100644 --- a/source/lux/codata/reader.lux +++ b/source/lux/codata/reader.lux @@ -7,8 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import (lux #refer (#exclude Reader)) - (lux/control functor - monad)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) ## [Types] (deftype #export (Reader r a) @@ -17,17 +17,17 @@ ## [Structures] (defstruct #export Reader/Functor (All [r] (Functor (Reader r))) - (def (map f fa) + (def (F;map f fa) (lambda [env] (f (fa env))))) (defstruct #export Reader/Monad (All [r] (Monad (Reader r))) - (def _functor Reader/Functor) + (def M;_functor Reader/Functor) - (def (wrap x) + (def (M;wrap x) (lambda [env] x)) - (def (join mma) + (def (M;join mma) (lambda [env] (mma env env)))) diff --git a/source/lux/codata/state.lux b/source/lux/codata/state.lux index c6fd8397d..bc9858a29 100644 --- a/source/lux/codata/state.lux +++ b/source/lux/codata/state.lux @@ -7,8 +7,8 @@ ## You must not remove this notice, or any other, from this software. (;import lux - (lux/control functor - monad)) + (lux/control (functor #as F #refer #all) + (monad #as M #refer #all))) ## [Types] (deftype #export (State s a) @@ -16,20 +16,20 @@ ## [Structures] (defstruct #export State/Functor (Functor State) - (def (map f ma) + (def (F;map f ma) (lambda [state] (let [[state' a] (ma state)] [state' (f a)])))) (defstruct #export State/Monad (All [s] (Monad (State s))) - (def _functor State/Functor) + (def M;_functor State/Functor) - (def (wrap x) + (def (M;wrap x) (lambda [state] [state x])) - (def (join mma) + (def (M;join mma) (lambda [state] (let [[state' ma] (mma state)] (ma state'))))) diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux index 728adc174..64491eb5c 100644 --- a/source/lux/codata/stream.lux +++ b/source/lux/codata/stream.lux @@ -113,14 +113,14 @@ ## [Structures] (defstruct #export Stream/Functor (Functor Stream) - (def (map f fa) + (def (F;map f fa) (let [[h t] (! fa)] (... [(f h) (map f t)])))) (defstruct #export Stream/CoMonad (CoMonad Stream) - (def _functor Stream/Functor) - (def unwrap head) - (def (split wa) + (def CM;_functor Stream/Functor) + (def CM;unwrap head) + (def (CM;split wa) (:: Stream/Functor (F;map repeat wa)))) ## [Pattern-matching] diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux index 8f7a3bd13..92f5486ef 100644 --- a/source/lux/data/bool.lux +++ b/source/lux/data/bool.lux @@ -14,19 +14,19 @@ ## [Structures] (defstruct #export Bool/Eq (E;Eq Bool) - (def (= x y) + (def (E;= x y) (if x y (not y)))) (defstruct #export Bool/Show (S;Show Bool) - (def (show x) + (def (S;show x) (if x "true" "false"))) (do-template [<name> <unit> <op>] [(defstruct #export <name> (m;Monoid Bool) - (def unit <unit>) - (def (++ x y) + (def m;unit <unit>) + (def (m;++ x y) (<op> x y)))] [ Or/Monoid false or] diff --git a/source/lux/data/char.lux b/source/lux/data/char.lux index 04579c3a7..b97ec644d 100644 --- a/source/lux/data/char.lux +++ b/source/lux/data/char.lux @@ -13,9 +13,9 @@ ## [Structures] (defstruct #export Char/Eq (E;Eq Char) - (def (= x y) + (def (E;= x y) (_jvm_ceq x y))) (defstruct #export Char/Show (S;Show Char) - (def (show x) + (def (S;show x) ($ text:++ "#\"" (_jvm_invokevirtual "java.lang.Object" "toString" [] x []) "\""))) diff --git a/source/lux/data/error.lux b/source/lux/data/error.lux index 7388dd786..cb5c309a6 100644 --- a/source/lux/data/error.lux +++ b/source/lux/data/error.lux @@ -17,18 +17,18 @@ ## [Structures] (defstruct #export Error/Functor (Functor Error) - (def (map f ma) + (def (F;map f ma) (case ma (#Fail msg) (#Fail msg) (#Ok datum) (#Ok (f datum))))) (defstruct #export Error/Monad (Monad Error) - (def _functor Error/Functor) + (def M;_functor Error/Functor) - (def (wrap a) + (def (M;wrap a) (#Ok a)) - (def (join mma) + (def (M;join mma) (case mma (#Fail msg) (#Fail msg) (#Ok ma) ma))) diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 58e7360b8..3ad6b056b 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -17,16 +17,16 @@ ## [Structures] (defstruct #export Id/Functor (Functor Id) - (def (map f fa) + (def (F;map f fa) (let [(#Id a) fa] (#Id (f a))))) (defstruct #export Id/Monad (Monad Id) - (def _functor Id/Functor) - (def (wrap a) (#Id a)) - (def (join mma) (let [(#Id ma) mma] ma))) + (def M;_functor Id/Functor) + (def (M;wrap a) (#Id a)) + (def (M;join mma) (let [(#Id ma) mma] ma))) (defstruct #export Id/CoMonad (CoMonad Id) - (def _functor Id/Functor) - (def (unwrap wa) (let [(#Id a) wa] a)) - (def (split wa) (#Id wa))) + (def CM;_functor Id/Functor) + (def (CM;unwrap wa) (let [(#Id a) wa] a)) + (def (CM;split wa) (#Id wa))) diff --git a/source/lux/data/io.lux b/source/lux/data/io.lux index ae71f9f34..f03dbddc6 100644 --- a/source/lux/data/io.lux +++ b/source/lux/data/io.lux @@ -30,16 +30,16 @@ ## [Structures] (defstruct #export IO/Functor (F;Functor IO) - (def (map f ma) + (def (F;map f ma) (io (f (ma []))))) (defstruct #export IO/Monad (M;Monad IO) - (def _functor IO/Functor) + (def M;_functor IO/Functor) - (def (wrap x) + (def (M;wrap x) (io x)) - (def (join mma) + (def (M;join mma) (mma []))) ## [Functions] diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 87afe7fe9..5a8357251 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -258,30 +258,30 @@ (defstruct #export List/Monoid (All [a] (Monoid (List a))) - (def unit #;Nil) - (def (++ xs ys) + (def m;unit #;Nil) + (def (m;++ xs ys) (case xs #;Nil ys (#;Cons [x xs']) (#;Cons [x (++ xs' ys)])))) (defstruct #export List/Functor (Functor List) - (def (map f ma) + (def (F;map f ma) (case ma #;Nil #;Nil (#;Cons [a ma']) (#;Cons [(f a) (map f ma')])))) (defstruct #export List/Monad (Monad List) - (def _functor List/Functor) + (def M;_functor List/Functor) - (def (wrap a) + (def (M;wrap a) (#;Cons [a #;Nil])) - (def (join mma) + (def (M;join mma) (using List/Monoid (foldL ++ unit mma)))) (defstruct #export PList/Dict (Dict PList) - (def (get k (#PList [eq kvs])) + (def (D;get k (#PList [eq kvs])) (loop [kvs kvs] (case kvs #;Nil @@ -292,7 +292,7 @@ (#;Some v') (recur kvs'))))) - (def (put k v (#PList [eq kvs])) + (def (D;put k v (#PList [eq kvs])) (#PList [eq (loop [kvs kvs] (case kvs #;Nil @@ -303,7 +303,7 @@ (#;Cons [k v] kvs') (#;Cons [k' v'] (recur kvs')))))])) - (def (remove k (#PList [eq kvs])) + (def (D;remove k (#PList [eq kvs])) (#PList [eq (loop [kvs kvs] (case kvs #;Nil @@ -315,18 +315,18 @@ (#;Cons [[k' v'] (recur kvs')]))))]))) (defstruct #export List/Stack (S;Stack List) - (def empty (list)) - (def (empty? xs) + (def S;empty (list)) + (def (S;empty? xs) (case xs #;Nil true _ false)) - (def (push x xs) + (def (S;push x xs) (#;Cons x xs)) - (def (pop xs) + (def (S;pop xs) (case xs #;Nil #;None (#;Cons x xs') (#;Some xs'))) - (def (top xs) + (def (S;top xs) (case xs #;Nil #;None (#;Cons x xs') (#;Some x)))) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index e23dbe291..9405c3a60 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -20,26 +20,26 @@ ## (#;Some a))) ## [Structures] -(defstruct #export Maybe/Monoid (Monoid Maybe) - (def unit #;None) - (def (++ xs ys) +(defstruct #export Maybe/Monoid (All [a] (Monoid (Maybe a))) + (def m;unit #;None) + (def (m;++ xs ys) (case xs #;None ys (#;Some x) (#;Some x)))) (defstruct #export Maybe/Functor (Functor Maybe) - (def (map f ma) + (def (F;map f ma) (case ma #;None #;None (#;Some a) (#;Some (f a))))) (defstruct #export Maybe/Monad (Monad Maybe) - (def _functor Maybe/Functor) + (def M;_functor Maybe/Functor) - (def (wrap x) + (def (M;wrap x) (#;Some x)) - (def (join mma) + (def (M;join mma) (case mma #;None #;None (#;Some xs) xs))) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index f3c81ef4e..35c8d34bf 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -18,20 +18,20 @@ ## Number (do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] [(defstruct #export <name> (N;Number <type>) - (def (+ x y) (<+> x y)) - (def (- x y) (<-> x y)) - (def (* x y) (<*> x y)) - (def (/ x y) (</> x y)) - (def (% x y) (<%> x y)) - (def (from-int x) + (def (N;+ x y) (<+> x y)) + (def (N;- x y) (<-> x y)) + (def (N;* x y) (<*> x y)) + (def (N;/ x y) (</> x y)) + (def (N;% x y) (<%> x y)) + (def (N;from-int x) (<from> x)) - (def (negate x) + (def (N;negate x) (<*> <-1> x)) - (def (abs x) + (def (N;abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (signum x) + (def (N;signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else @@ -42,18 +42,18 @@ ## Eq (defstruct #export Int/Eq (E;Eq Int) - (def (= x y) (_jvm_leq x y))) + (def (E;= x y) (_jvm_leq x y))) ## Ord (do-template [<name> <type> <eq> <=> <lt> <gt>] [(defstruct #export <name> (O;Ord <type>) - (def _eq <eq>) - (def (< x y) (<lt> x y)) - (def (<= x y) + (def O;_eq <eq>) + (def (O;< x y) (<lt> x y)) + (def (O;<= x y) (or (<lt> x y) (<=> x y))) - (def (> x y) (<gt> x y)) - (def (>= x y) + (def (O;> x y) (<gt> x y)) + (def (O;>= x y) (or (<gt> x y) (<=> x y))))] @@ -62,16 +62,16 @@ ## Bounded (do-template [<name> <type> <top> <bottom>] [(defstruct #export <name> (B;Bounded <type>) - (def top <top>) - (def bottom <bottom>))] + (def B;top <top>) + (def B;bottom <bottom>))] [ Int/Bounded Int (_jvm_getstatic "java.lang.Long" "MAX_VALUE") (_jvm_getstatic "java.lang.Long" "MIN_VALUE")]) ## Monoid (do-template [<name> <type> <unit> <++>] [(defstruct #export <name> (m;Monoid <type>) - (def unit <unit>) - (def (++ x y) (<++> x y)))] + (def m;unit <unit>) + (def (m;++ x y) (<++> x y)))] [ IntAdd/Monoid Int 0 _jvm_ladd] [ IntMul/Monoid Int 1 _jvm_lmul] @@ -82,7 +82,7 @@ ## Show (do-template [<name> <type> <body>] [(defstruct #export <name> (S;Show <type>) - (def (show x) + (def (S;show x) <body>))] [ Int/Show Int (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux index 9ba05df62..4f9e4fa5f 100644 --- a/source/lux/data/number/real.lux +++ b/source/lux/data/number/real.lux @@ -18,20 +18,20 @@ ## Number (do-template [<name> <type> <+> <-> <*> </> <%> <=> <<> <from> <0> <1> <-1>] [(defstruct #export <name> (N;Number <type>) - (def (+ x y) (<+> x y)) - (def (- x y) (<-> x y)) - (def (* x y) (<*> x y)) - (def (/ x y) (</> x y)) - (def (% x y) (<%> x y)) - (def (from-int x) + (def (N;+ x y) (<+> x y)) + (def (N;- x y) (<-> x y)) + (def (N;* x y) (<*> x y)) + (def (N;/ x y) (</> x y)) + (def (N;% x y) (<%> x y)) + (def (N;from-int x) (<from> x)) - (def (negate x) + (def (N;negate x) (<*> <-1> x)) - (def (abs x) + (def (N;abs x) (if (<<> x <0>) (<*> <-1> x) x)) - (def (signum x) + (def (N;signum x) (cond (<=> x <0>) <0> (<<> x <0>) <-1> ## else @@ -42,18 +42,18 @@ ## Eq (defstruct #export Real/Eq (E;Eq Real) - (def (= x y) (_jvm_deq x y))) + (def (E;= x y) (_jvm_deq x y))) ## Ord (do-template [<name> <type> <eq> <=> <lt> <gt>] [(defstruct #export <name> (O;Ord <type>) - (def _eq <eq>) - (def (< x y) (<lt> x y)) - (def (<= x y) + (def O;_eq <eq>) + (def (O;< x y) (<lt> x y)) + (def (O;<= x y) (or (<lt> x y) (<=> x y))) - (def (> x y) (<gt> x y)) - (def (>= x y) + (def (O;> x y) (<gt> x y)) + (def (O;>= x y) (or (<gt> x y) (<=> x y))))] @@ -62,16 +62,16 @@ ## Bounded (do-template [<name> <type> <top> <bottom>] [(defstruct #export <name> (B;Bounded <type>) - (def top <top>) - (def bottom <bottom>))] + (def B;top <top>) + (def B;bottom <bottom>))] [Real/Bounded Real (_jvm_getstatic "java.lang.Double" "MAX_VALUE") (_jvm_getstatic "java.lang.Double" "MIN_VALUE")]) ## Monoid (do-template [<name> <type> <unit> <++>] [(defstruct #export <name> (m;Monoid <type>) - (def unit <unit>) - (def (++ x y) (<++> x y)))] + (def m;unit <unit>) + (def (m;++ x y) (<++> x y)))] [RealAdd/Monoid Real 0.0 _jvm_dadd] [RealMul/Monoid Real 1.0 _jvm_dmul] @@ -82,7 +82,7 @@ ## Show (do-template [<name> <type> <body>] [(defstruct #export <name> (S;Show <type>) - (def (show x) + (def (S;show x) <body>))] [Real/Show Real (_jvm_invokevirtual "java.lang.Object" "toString" [] x [])] diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index 81a642698..d1c06b6a7 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -118,12 +118,12 @@ ## [Structures] (defstruct #export Text/Eq (E;Eq Text) - (def (= x y) + (def (E;= x y) (_jvm_invokevirtual "java.lang.Object" "equals" ["java.lang.Object"] x [y]))) (defstruct #export Text/Ord (O;Ord Text) - (def _eq Text/Eq) + (def O;_eq Text/Eq) (do-template [<name> <op>] [(def (<name> x y) @@ -131,17 +131,17 @@ x [y])) 0))] - [< i<] - [<= i<=] - [> i>] - [>= i>=])) + [O;< i<] + [O;<= i<=] + [O;> i>] + [O;>= i>=])) (defstruct #export Text/Show (S;Show Text) - (def show id)) + (def S;show id)) (defstruct #export Text/Monoid (m;Monoid Text) - (def unit "") - (def (++ x y) + (def m;unit "") + (def (m;++ x y) (_jvm_invokevirtual "java.lang.String" "concat" ["java.lang.String"] x [y]))) diff --git a/source/lux/data/writer.lux b/source/lux/data/writer.lux index 7c6831e85..f71492e35 100644 --- a/source/lux/data/writer.lux +++ b/source/lux/data/writer.lux @@ -18,17 +18,17 @@ ## [Structures] (defstruct #export Writer/Functor (All [l] (Functor (Writer l))) - (def (map f fa) + (def (F;map f fa) (let [[log datum] fa] [log (f datum)]))) (defstruct #export (Writer/Monad mon) (All [l] (-> (Monoid l) (Monad (Writer l)))) - (def _functor Writer/Functor) + (def M;_functor Writer/Functor) - (def (wrap x) + (def (M;wrap x) [(:: mon m;unit) x]) - (def (join mma) + (def (M;join mma) (let [[log1 [log2 a]] mma] [(:: mon (m;++ log1 log2)) a]))) diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux index d1bc4e219..057345622 100644 --- a/source/lux/meta/lux.lux +++ b/source/lux/meta/lux.lux @@ -29,7 +29,7 @@ ## [Structures] (defstruct #export Lux/Functor (F;Functor Lux) - (def (map f fa) + (def (F;map f fa) (lambda [state] (case (fa state) (#;Left msg) @@ -39,11 +39,11 @@ (#;Right [state' (f a)]))))) (defstruct #export Lux/Monad (M;Monad Lux) - (def _functor Lux/Functor) - (def (wrap x) + (def M;_functor Lux/Functor) + (def (M;wrap x) (lambda [state] (#;Right [state x]))) - (def (join mma) + (def (M;join mma) (lambda [state] (case (mma state) (#;Left msg) @@ -254,7 +254,7 @@ (let [vname' (ident->text name)] (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)) @@ -275,14 +275,14 @@ (-> 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 _}) + (#;Some {#;defs defs #;module-aliases _ #;imports _ #;tags _ #;types _}) (case (get v-name defs) #;None #;None @@ -311,7 +311,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 name) "\n\n" (show-envs envs)))))))) diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux index f1644cdb5..b9834f972 100644 --- a/source/lux/meta/syntax.lux +++ b/source/lux/meta/syntax.lux @@ -38,7 +38,7 @@ ## [Structures] (defstruct #export Parser/Functor (F;Functor Parser) - (def (map f ma) + (def (F;map f ma) (lambda [tokens] (case (ma tokens) #;None @@ -48,12 +48,12 @@ (#;Some [tokens' (f a)]))))) (defstruct #export Parser/Monad (M;Monad Parser) - (def _functor Parser/Functor) + (def M;_functor Parser/Functor) - (def (wrap x tokens) + (def (M;wrap x tokens) (#;Some [tokens x])) - (def (join mma) + (def (M;join mma) (lambda [tokens] (case (mma tokens) #;None diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3b6a93005..8c88328f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -442,9 +442,10 @@ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) (&/$Cons (&/$Meta _ (&/$TupleS tags)) - (&/$Nil)))) + (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) + (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] - (&&lux/analyse-declare-tags tags*)) + (&&lux/analyse-declare-tags tags* type-name)) (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) (&/$Cons (&/$Meta _ (&/$TextS ?path)) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 8a79e0494..d241201f4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -300,8 +300,8 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= ":" (aget real-name 1)) - ;; (= "type" (aget real-name 1)) + ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; ;; (= "type" (aget real-name 1)) ;; ;; (= &&/$struct r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion) @@ -409,7 +409,7 @@ (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] (|case =value - [(&/$Global ?r-module ?r-name) _] + [(&&/$var (&/$Global ?r-module ?r-name)) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] @@ -418,10 +418,10 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) - :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - _ (println 'DEF (str module-name ";" ?name))]] - (return (&/|list))))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) + _ (println 'DEF (str module-name ";" ?name))]] + (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] @@ -433,28 +433,13 @@ ] (return (&/|list)))) -(defn ensure-undeclared-tags [module tags] - (|do [;; :let [_ (prn 'ensure-undeclared-tags/_0)] - tags-table (&&module/tags-by-module module) - ;; :let [_ (prn 'ensure-undeclared-tags/_1)] - _ (&/map% (fn [tag] - (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) - (return nil))) - tags) - ;; :let [_ (prn 'ensure-undeclared-tags/_2)] - ] - (return nil))) - -(defn analyse-declare-tags [tags] - (|do [;; :let [_ (prn 'analyse-declare-tags/_0)] - module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags/_1)] - _ (ensure-undeclared-tags module-name tags) - ;; :let [_ (prn 'analyse-declare-tags/_2)] - _ (&&module/declare-tags module-name tags) - ;; :let [_ (prn 'analyse-declare-tags/_3)] - ] +(defn analyse-declare-tags [tags type-name] + (|do [module-name &/get-module-name + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] + [_ def-data] (&&module/find-def module-name type-name) + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + def-type (&&module/ensure-type-def def-data) + _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) (defn analyse-import [analyse compile-module compile-token ?path] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 08ad0b9a5..5190e2dcf 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -8,7 +8,8 @@ (ns lux.analyser.module (:refer-clojure :exclude [alias]) - (:require [clojure.string :as string] + (:require (clojure [string :as string] + [template :refer [do-template]]) clojure.core.match clojure.core.match.array (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] @@ -20,7 +21,8 @@ "module-aliases" "defs" "imports" - "tags") + "tags" + "types") (def ^:private +init+ (&/T ;; "lux;module-aliases" (&/|table) @@ -29,7 +31,9 @@ ;; "lux;imports" (&/|list) ;; "lux;tags" - (&/|list) + (&/|table) + ;; "lux;types" + (&/|table) )) ;; [Exports] @@ -46,6 +50,7 @@ nil)))) (defn define [module name def-data type] + ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) @@ -151,6 +156,15 @@ (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) +(defn ensure-type-def [def-data] + "(-> DefData (Lux Type))" + (|case def-data + (&/$TypeD type) + (return type) + + _ + (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data))))) + (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def module name)] (return true)) @@ -250,32 +264,59 @@ (&/set$ &/$envs (&/|list (&/env name)))) nil))) -(defn tags-by-module [module] - "(-> Text (Lux (List (, Text (, Int (List Text))))))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ $tags =module)) - (fail* (str "[Lux Error] Unknown module: " module))) - )) +(do-template [<name> <tag> <type>] + (defn <name> [module] + <type> + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ <tag> =module)) + (fail* (str "[Lux Error] Unknown module: " module))) + )) -(defn declare-tags [module tag-names] - "(-> Text (List Text) (Lux (,)))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] - (return* (&/update$ &/$modules - (fn [=modules] - (&/|update module - #(&/set$ $tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name (&/T idx tags) table))) - (&/get$ $tags %) - (&/enumerate tag-names)) - %) - =modules)) - state) - nil)) - (fail* (str "[Lux Error] Unknown module: " module))))) + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + ) + +(defn ensure-undeclared-tags [module tags] + (|do [tags-table (tags-by-module module) + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (return nil))) + tags)] + (return nil))) + +(defn ensure-undeclared-type [module name] + (|do [types-table (types-by-module module) + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] + (return nil))) + +(defn declare-tags [module tag-names type] + "(-> Text (List Text) Type (Lux (,)))" + (|do [;; :let [_ (prn 'declare-tags (&/->seq tag-names) (&/adt->text type))] + _ (ensure-undeclared-tags module tag-names) + type-name (&type/type-name type) + :let [[_module _name] type-name] + _ (&/assert! (= module _module) + (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) + _ (ensure-undeclared-type _module _name)] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags type) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T tags type)))) + =modules)) + state) + nil)) + (fail* (str "[Lux Error] Unknown module: " module)))))) (defn tag-index [module tag-name] "(-> Text Text (Lux Int))" diff --git a/src/lux/base.clj b/src/lux/base.clj index 44875d1df..84b09bcac 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -86,7 +86,7 @@ "cursor" "modules" "envs" - "types" + "type-vars" "expected" "seed" "eval?" diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 78b9e72f6..0ae4ce2da 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -80,7 +80,13 @@ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) (&/$DataT _) - nil) + nil + + (&/$NamedT ?name ?type) + (prepare-return! *writer* ?type) + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*)))) *writer*)) ;; [Resources] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index a7c5176ad..7e2bc6961 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -84,4 +84,8 @@ (&/$AppT ?fun ?arg) (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + + (&/$NamedT [?module ?name] ?type) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) + (->analysis ?type)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 8ffe77b96..dfd4df23d 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -68,6 +68,7 @@ )) (defn ->java-sig [^objects type] + "(-> Type Text)" (|case type (&/$DataT ?name) (->type-signature ?name) @@ -77,6 +78,12 @@ (&/$TupleT (&/$Nil)) "V" + + (&/$NamedT ?name ?type) + (->java-sig ?type) + + _ + (assert false (str '->java-sig " " (&type/show-type type))) )) (do-template [<name> <static?>] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index a8b2cfc16..eaa22db20 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -76,10 +76,10 @@ (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) ($Int ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Integer/parseInt ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) ($Real ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Float/parseFloat ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) ($Char ^String ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index e0195658f..e3f95b5f9 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -26,7 +26,7 @@ (fail* "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] line] - more) + more) (|case (body file-name line-num column-num line) ($No msg) (fail* msg) @@ -87,7 +87,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) match)) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] @@ -100,7 +100,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] @@ -113,7 +113,7 @@ (&/V &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] - reader**) + reader**) (if-let [^String match (do ;; (prn 'read-regex+ regex line) (re-find1! regex column-num line))] (let [match-length (.length match) @@ -121,8 +121,8 @@ (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) - reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) + reader**) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] @@ -135,7 +135,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) text)) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") diff --git a/src/lux/type.clj b/src/lux/type.clj index e78b5616a..9f3adb036 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -235,10 +235,10 @@ (def DefData* (All$ empty-env "lux;DefData'" "" (Variant$ (&/|list - ;; "lux;TypeD" - Type ;; "lux;ValueD" (Tuple$ (&/|list Type Unit)) + ;; "lux;TypeD" + Type ;; "lux;MacroD" (Bound$ "") ;; "lux;AliasD" @@ -270,12 +270,18 @@ ;; "lux;imports" (App$ List Text) ;; "lux;tags" - ;; (List (, Text (List Ident))) + ;; (List (, Text (, Int (List Ident) Type))) (App$ List (Tuple$ (&/|list Text (Tuple$ (&/|list Int - (App$ List - Ident)))))) + (App$ List Ident) + Type))))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list (App$ List Ident) + Type))))) )))) (def $Compiler @@ -315,7 +321,7 @@ (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -326,7 +332,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -337,26 +343,26 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$types (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) - ts)) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) + ts)) state) nil)) - (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$types) (&/get$ &/$mappings) &/|length)))))) + (fail* (str "[Type Error] <set-var> Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$types) (&/get$ &/$counter))] - (return* (&/update$ &/$types #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) state) id)))) @@ -391,11 +397,11 @@ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/get$ &/$types) (&/get$ &/$mappings)))] + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$types #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings (&/|remove id mappings*))) + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) state) nil))) state)))) @@ -966,3 +972,13 @@ _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) + +(defn type-name [type] + "(-> Type (Lux Ident))" + (|case type + (&/$NamedT name _) + (return name) + + _ + (fail (str "[Type Error] Type is not named: " (show-type type))) + )) |