aboutsummaryrefslogtreecommitdiff
path: root/source/lux.lux
diff options
context:
space:
mode:
Diffstat (limited to 'source/lux.lux')
-rw-r--r--source/lux.lux752
1 files changed, 416 insertions, 336 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-16 05:43:17 +0000