aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux752
-rw-r--r--source/lux/codata/function.lux4
-rw-r--r--source/lux/codata/lazy.lux12
-rw-r--r--source/lux/codata/reader.lux12
-rw-r--r--source/lux/codata/state.lux12
-rw-r--r--source/lux/codata/stream.lux8
-rw-r--r--source/lux/data/bool.lux8
-rw-r--r--source/lux/data/char.lux4
-rw-r--r--source/lux/data/error.lux8
-rw-r--r--source/lux/data/id.lux14
-rw-r--r--source/lux/data/io.lux8
-rw-r--r--source/lux/data/list.lux28
-rw-r--r--source/lux/data/maybe.lux14
-rw-r--r--source/lux/data/number/int.lux40
-rw-r--r--source/lux/data/number/real.lux40
-rw-r--r--source/lux/data/text.lux18
-rw-r--r--source/lux/data/writer.lux8
-rw-r--r--source/lux/meta/lux.lux16
-rw-r--r--source/lux/meta/syntax.lux8
-rw-r--r--src/lux/analyser.clj5
-rw-r--r--src/lux/analyser/lux.clj43
-rw-r--r--src/lux/analyser/module.clj97
-rw-r--r--src/lux/base.clj2
-rw-r--r--src/lux/compiler/host.clj8
-rw-r--r--src/lux/compiler/type.clj4
-rw-r--r--src/lux/host.clj7
-rw-r--r--src/lux/parser.clj4
-rw-r--r--src/lux/reader.clj14
-rw-r--r--src/lux/type.clj54
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)))
+ ))