aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--source/lux.lux561
-rw-r--r--source/lux/codata/function.lux4
-rw-r--r--source/lux/codata/stream.lux3
-rw-r--r--source/lux/control/hash.lux14
-rw-r--r--source/lux/data/bool.lux12
-rw-r--r--source/lux/data/list.lux83
-rw-r--r--source/lux/meta/lux.lux34
-rw-r--r--source/program.lux1
-rw-r--r--src/lux/analyser.clj103
-rw-r--r--src/lux/analyser/case.clj17
-rw-r--r--src/lux/analyser/lux.clj39
-rw-r--r--src/lux/base.clj30
-rw-r--r--src/lux/compiler/io.clj2
-rw-r--r--src/lux/type.clj4
14 files changed, 552 insertions, 355 deletions
diff --git a/source/lux.lux b/source/lux.lux
index dc186fb3d..3670a9e52 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -32,29 +32,29 @@
(_lux_def Void (#VariantT #Nil))
(_lux_export Void)
-(_lux_def Ident (#TupleT (#Cons [Text (#Cons [Text #Nil])])))
+(_lux_def Ident (#TupleT (#Cons Text (#Cons Text #Nil))))
(_lux_export Ident)
## (deftype (List a)
## (| #Nil
-## (#Cons (, a (List a)))))
+## (#Cons a (List a))))
(_lux_def 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])]))]))
+ (#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)))))
(_lux_export List)
## (deftype (Maybe a)
## (| #None
## (#Some a)))
(_lux_def Maybe
- (#AllT [(#Some #Nil) "lux;Maybe" "a"
- (#VariantT (#Cons [["lux;None" (#TupleT #Nil)]
- (#Cons [["lux;Some" (#BoundT "a")]
- #Nil])]))]))
+ (#AllT (#Some #Nil) "lux;Maybe" "a"
+ (#VariantT (#Cons ["lux;None" (#TupleT #Nil)]
+ (#Cons ["lux;Some" (#BoundT "a")]
+ #Nil)))))
(_lux_export Maybe)
## (deftype #rec Type
@@ -62,29 +62,29 @@
## (#TupleT (List Type))
## (#VariantT (List (, Text Type)))
## (#RecordT (List (, Text Type)))
-## (#LambdaT (, Type Type))
+## (#LambdaT Type Type)
## (#BoundT Text)
## (#VarT Int)
-## (#AllT (, (Maybe (List (, Text Type))) Text Text Type))
-## (#AppT (, Type Type))))
+## (#AllT (Maybe (List (, Text Type))) Text Text Type)
+## (#AppT Type Type)))
(_lux_def Type
- (_lux_case (#AppT [(#BoundT "Type") (#BoundT "_")])
+ (_lux_case (#AppT (#BoundT "Type") (#BoundT "_"))
Type
- (_lux_case (#AppT [List (#TupleT (#Cons [Text (#Cons [Type #Nil])]))])
+ (_lux_case (#AppT List (#TupleT (#Cons Text (#Cons Type #Nil))))
TypeEnv
- (#AppT [(#AllT [(#Some #Nil) "Type" "_"
- (#VariantT (#Cons [["lux;DataT" Text]
- (#Cons [["lux;TupleT" (#AppT [List Type])]
- (#Cons [["lux;VariantT" TypeEnv]
- (#Cons [["lux;RecordT" TypeEnv]
- (#Cons [["lux;LambdaT" (#TupleT (#Cons [Type (#Cons [Type #Nil])]))]
- (#Cons [["lux;BoundT" Text]
- (#Cons [["lux;VarT" 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;ExT" Int]
- #Nil])])])])])])])])])]))])
- Void]))))
+ (#AppT (#AllT (#Some #Nil) "Type" "_"
+ (#VariantT (#Cons ["lux;DataT" Text]
+ (#Cons ["lux;TupleT" (#AppT List Type)]
+ (#Cons ["lux;VariantT" TypeEnv]
+ (#Cons ["lux;RecordT" TypeEnv]
+ (#Cons ["lux;LambdaT" (#TupleT (#Cons Type (#Cons Type #Nil)))]
+ (#Cons ["lux;BoundT" Text]
+ (#Cons ["lux;VarT" 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;ExT" Int]
+ #Nil))))))))))))
+ Void))))
(_lux_export Type)
## (deftype (Bindings k v)
@@ -125,7 +125,7 @@
(_lux_export Cursor)
## (deftype (Meta m v)
-## (| (#Meta (, m v))))
+## (| (#Meta m v)))
(_lux_def Meta
(#AllT [(#Some #Nil) "lux;Meta" "m"
(#AllT [#None "" "v"
@@ -141,8 +141,8 @@
## (#RealS Real)
## (#CharS Char)
## (#TextS Text)
-## (#SymbolS (, Text Text))
-## (#TagS (, Text Text))
+## (#SymbolS Text Text)
+## (#TagS Text Text)
## (#FormS (List (w (Syntax' w))))
## (#TupleS (List (w (Syntax' w))))
## (#RecordS (List (, (w (Syntax' w)) (w (Syntax' w)))))))
@@ -267,7 +267,8 @@
## #types (Bindings Int Type)
## #host HostState
## #seed Int
-## #eval? Bool))
+## #eval? Bool
+## #expected Type))
(_lux_def Compiler
(#AppT [(#AllT [(#Some #Nil) "lux;Compiler" ""
(#RecordT (#Cons [["lux;source" Reader]
@@ -280,7 +281,8 @@
(#Cons [["lux;host" HostState]
(#Cons [["lux;seed" Int]
(#Cons [["lux;eval?" Bool]
- #Nil])])])])])])]))])
+ (#Cons [["lux;expected" Type]
+ #Nil])])])])])])])]))])
Void]))
(_lux_export Compiler)
@@ -348,6 +350,11 @@
(_lux_lambda _ text
(_meta (#TextS text)))))
+(_lux_def int$
+ (_lux_: (#LambdaT [Int Syntax])
+ (_lux_lambda _ value
+ (_meta (#IntS value)))))
+
(_lux_def symbol$
(_lux_: (#LambdaT [Ident Syntax])
(_lux_lambda _ ident
@@ -1039,6 +1046,15 @@
(f (g x))))
(def''' (get-ident x)
+ (-> Syntax ($' Maybe Ident))
+ (_lux_case x
+ (#Meta [_ (#SymbolS sname)])
+ (#Some sname)
+
+ _
+ #None))
+
+(def''' (get-name x)
(-> Syntax ($' Maybe Text))
(_lux_case x
(#Meta [_ (#SymbolS ["" sname])])
@@ -1127,7 +1143,7 @@
(_lux_case tokens
(#Cons [(#Meta [_ (#TupleS bindings)]) (#Cons [(#Meta [_ (#TupleS templates)]) data])])
(_lux_case (_lux_: (, ($' Maybe ($' List Text)) ($' Maybe ($' List ($' List Syntax))))
- [(map% Maybe/Monad get-ident bindings)
+ [(map% Maybe/Monad get-name bindings)
(map% Maybe/Monad tuple->list data)])
[(#Some bindings') (#Some data')]
(let' [apply (_lux_: (-> RepEnv ($' List Syntax))
@@ -1245,7 +1261,7 @@
["" tokens]))]
(_lux_case tokens'
(#Cons [(#Meta [_ (#TupleS args)]) (#Cons [body #Nil])])
- (_lux_case (map% Maybe/Monad get-ident args)
+ (_lux_case (map% Maybe/Monad get-name args)
(#Some idents)
(_lux_case idents
#Nil
@@ -1297,8 +1313,8 @@
($' Lux Text)
(_lux_case state
{#source source #modules modules
- #envs envs #types types #host host
- #seed seed #eval? eval?}
+ #envs envs #types types #host host
+ #seed seed #eval? eval? #expected expected}
(_lux_case (reverse envs)
#Nil
(#Left "Can't get the module name without a module!")
@@ -1337,7 +1353,7 @@
(_lux_case state
{#source source #modules modules
#envs envs #types types #host host
- #seed seed #eval? eval?}
+ #seed seed #eval? eval? #expected expected}
(#Right [state (find-macro' modules current-module module name)]))))))
(def''' (list:join xs)
@@ -1367,11 +1383,16 @@
[ident (normalize ident)]
(;return (`' [(~ (text$ (ident->text ident))) (;,)])))
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) (#Cons [value #Nil])]))])
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#TagS ident)]) values]))])
(do Lux/Monad
- [ident (normalize ident)]
- (;return (`' [(~ (text$ (ident->text ident))) (~ value)])))
-
+ [ident (normalize ident)
+ #let [case-body (_lux_: Syntax
+ (_lux_case values
+ #Nil (`' Unit)
+ (#Cons value #Nil) value
+ _ (`' (, (~@ values)))))]]
+ (;return (`' [(~ (text$ (ident->text ident))) (~ case-body)])))
+
_
(fail "Wrong syntax for |"))))
tokens)]
@@ -1412,9 +1433,9 @@
(#Cons [x xs'])
(list& x sep (interpose sep xs'))))
-(def''' (macro-expand syntax)
+(def''' (macro-expand token)
(-> Syntax ($' Lux ($' List Syntax)))
- (_lux_case syntax
+ (_lux_case token
(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))])
(do Lux/Monad
[macro-name' (normalize macro-name)
@@ -1427,19 +1448,39 @@
(;return (list:join expansion')))
#None
+ (return (list token))))
+
+ _
+ (return (list token))))
+
+(def''' (macro-expand-all syntax)
+ (-> Syntax ($' Lux ($' List Syntax)))
+ (_lux_case syntax
+ (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) args]))])
+ (do Lux/Monad
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (_lux_case ?macro
+ (#Some macro)
(do Lux/Monad
- [parts' (map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
+ [expansion (macro args)
+ expansion' (map% Lux/Monad macro-expand-all expansion)]
+ (;return (list:join expansion')))
+
+ #None
+ (do Lux/Monad
+ [parts' (map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))]
(;return (list (form$ (list:join parts')))))))
(#Meta [_ (#FormS (#Cons [harg targs]))])
(do Lux/Monad
- [harg+ (macro-expand harg)
- targs+ (map% Lux/Monad macro-expand targs)]
+ [harg+ (macro-expand-all harg)
+ targs+ (map% Lux/Monad macro-expand-all targs)]
(;return (list (form$ (list:++ harg+ (list:join targs+))))))
(#Meta [_ (#TupleS members)])
(do Lux/Monad
- [members' (map% Lux/Monad macro-expand members)]
+ [members' (map% Lux/Monad macro-expand-all members)]
(;return (list (tuple$ (list:join members')))))
_
@@ -1464,11 +1505,11 @@
(defmacro #export (type tokens)
(_lux_case tokens
- (#Cons [type #Nil])
+ (#Cons type #Nil)
(do Lux/Monad
- [type+ (macro-expand type)]
+ [type+ (macro-expand-all type)]
(_lux_case type+
- (#Cons [type' #Nil])
+ (#Cons type' #Nil)
(;return (list (walk-type type')))
_
@@ -1479,7 +1520,7 @@
(defmacro #export (: tokens)
(_lux_case tokens
- (#Cons [type (#Cons [value #Nil])])
+ (#Cons type (#Cons value #Nil))
(return (list (`' (_lux_: (;type (~ type)) (~ value)))))
_
@@ -1487,7 +1528,7 @@
(defmacro #export (:! tokens)
(_lux_case tokens
- (#Cons [type (#Cons [value #Nil])])
+ (#Cons type (#Cons value #Nil))
(return (list (`' (_lux_:! (;type (~ type)) (~ value)))))
_
@@ -1502,30 +1543,30 @@
(defmacro #export (deftype tokens)
(let' [[export? tokens'] (: (, Bool (List Syntax))
(_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+ (#Cons (#Meta _ (#TagS "" "export")) tokens')
[true tokens']
_
[false tokens]))
[rec? tokens'] (: (, Bool (List Syntax))
(_lux_case tokens'
- (#Cons [(#Meta [_ (#TagS ["" "rec"])]) tokens'])
+ (#Cons (#Meta _ (#TagS "" "rec")) tokens')
[true tokens']
_
[false tokens']))
parts (: (Maybe (, Text (List Syntax) Syntax))
(_lux_case tokens'
- (#Cons [(#Meta [_ (#SymbolS ["" name])]) (#Cons [type #Nil])])
- (#Some [name #Nil type])
+ (#Cons (#Meta _ (#SymbolS "" name)) (#Cons type #Nil))
+ (#Some name #Nil type)
- (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS ["" name])]) args]))]) (#Cons [type #Nil])])
- (#Some [name args type])
+ (#Cons (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS "" name)) args))) (#Cons type #Nil))
+ (#Some name args type)
_
#None))]
(_lux_case parts
- (#Some [name args type])
+ (#Some name args type)
(let' [with-export (: (List Syntax)
(if export?
(list (`' (_lux_export (~ (symbol$ ["" name])))))
@@ -1570,12 +1611,12 @@
## (#Some [(symbol$ name) #Nil type])
## (#Cons [(#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS name)]) args]))]) (#Cons [type #Nil])])
-## (#Some [(symbol$ name) args type])
+## (#Some (symbol$ name) args type)
## _
## #None))]
## (_lux_case parts
-## (#Some [name args type])
+## (#Some name args type])
## (let' [with-export (: (List Syntax)
## (if export?
## (list (`' (_lux_export (~ name))))
@@ -1596,7 +1637,7 @@
(defmacro #export (exec tokens)
(_lux_case (reverse tokens)
- (#Cons [value actions])
+ (#Cons value actions)
(let' [dummy (symbol$ ["" ""])]
(return (list (foldL (lambda' [post pre] (`' (_lux_case (~ pre) (~ dummy) (~ post))))
value
@@ -1608,29 +1649,29 @@
(defmacro (def' tokens)
(let' [[export? tokens'] (: (, Bool (List Syntax))
(_lux_case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+ (#Cons (#Meta _ (#TagS "" "export")) tokens')
[true tokens']
_
[false tokens]))
parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax))
(_lux_case tokens'
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [type (#Cons [body #Nil])])])
- (#Some [name args (#Some type) body])
+ (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons type (#Cons body #Nil)))
+ (#Some name args (#Some type) body)
- (#Cons [name (#Cons [type (#Cons [body #Nil])])])
- (#Some [name #Nil (#Some type) body])
+ (#Cons name (#Cons type (#Cons body #Nil)))
+ (#Some name #Nil (#Some type) body)
- (#Cons [(#Meta [_ (#FormS (#Cons [name args]))]) (#Cons [body #Nil])])
- (#Some [name args #None body])
+ (#Cons (#Meta _ (#FormS (#Cons name args))) (#Cons body #Nil))
+ (#Some name args #None body)
- (#Cons [name (#Cons [body #Nil])])
- (#Some [name #Nil #None body])
+ (#Cons name (#Cons body #Nil))
+ (#Some name #Nil #None body)
_
#None))]
(_lux_case parts
- (#Some [name args ?type body])
+ (#Some name args ?type body)
(let' [body' (: Syntax
(_lux_case args
#Nil
@@ -1660,16 +1701,16 @@
(defmacro #export (case tokens)
(_lux_case tokens
- (#Cons [value branches])
+ (#Cons value branches)
(do Lux/Monad
[expansions (map% Lux/Monad
(: (-> (, Syntax Syntax) (Lux (List (, Syntax Syntax))))
(lambda' expander [branch]
(let' [[pattern body] branch]
(_lux_case pattern
- (#Meta [_ (#FormS (#Cons [(#Meta [_ (#SymbolS macro-name)]) macro-args]))])
+ (#Meta _ (#FormS (#Cons (#Meta _ (#SymbolS macro-name)) macro-args)))
(do Lux/Monad
- [expansion (macro-expand (form$ (list& (symbol$ macro-name) body macro-args)))
+ [expansion (macro-expand-all (form$ (list& (symbol$ macro-name) body macro-args)))
expansions (map% Lux/Monad expander (as-pairs expansion))]
(;return (list:join expansions)))
@@ -1684,11 +1725,11 @@
(defmacro #export (\ tokens)
(case tokens
- (#Cons [body (#Cons [pattern #Nil])])
+ (#Cons body (#Cons pattern #Nil))
(do Lux/Monad
- [pattern+ (macro-expand pattern)]
+ [pattern+ (macro-expand-all pattern)]
(case pattern+
- (#Cons [pattern' #Nil])
+ (#Cons pattern' #Nil)
(;return (list pattern' body))
_
@@ -1699,14 +1740,14 @@
(defmacro #export (\or tokens)
(case tokens
- (#Cons [body patterns])
+ (#Cons body patterns)
(case patterns
#Nil
(fail "\\or can't have 0 patterns")
_
(do Lux/Monad
- [patterns' (map% Lux/Monad macro-expand patterns)]
+ [patterns' (map% Lux/Monad macro-expand-all patterns)]
(;return (list:join (map (lambda' [pattern] (list pattern body))
(list:join patterns'))))))
@@ -1726,7 +1767,7 @@
(def' (symbol? ast)
(-> Syntax Bool)
(case ast
- (#Meta [_ (#SymbolS _)])
+ (#Meta _ (#SymbolS _))
true
_
@@ -1734,7 +1775,7 @@
(defmacro #export (let tokens)
(case tokens
- (\ (list (#Meta [_ (#TupleS bindings)]) body))
+ (\ (list (#Meta _ (#TupleS bindings)) body))
(if (multiple? 2 (length bindings))
(|> bindings as-pairs reverse
(foldL (: (-> Syntax (, Syntax Syntax) Syntax)
@@ -1754,7 +1795,7 @@
(def' (ast:show ast)
(-> Syntax Text)
(case ast
- (#Meta [_ ast])
+ (#Meta _ ast)
(case ast
(\or (#BoolS val) (#IntS val) (#RealS val))
(->text val)
@@ -1771,10 +1812,10 @@
(#TupleS parts)
($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]")
- (#SymbolS [prefix name])
+ (#SymbolS prefix name)
($ text:++ prefix ";" name)
- (#TagS [prefix name])
+ (#TagS prefix name)
($ text:++ "#" prefix ";" name)
(#RecordS kvs)
@@ -1790,15 +1831,15 @@
(defmacro #export (lambda tokens)
(case (: (Maybe (, Ident Syntax (List Syntax) Syntax))
(case tokens
- (\ (list (#Meta [_ (#TupleS (#Cons [head tail]))]) body))
- (#Some [["" ""] head tail body])
+ (\ (list (#Meta _ (#TupleS (#Cons head tail))) body))
+ (#Some ["" ""] head tail body)
- (\ (list (#Meta [_ (#SymbolS ident)]) (#Meta [_ (#TupleS (#Cons [head tail]))]) body))
- (#Some [ident head tail body])
+ (\ (list (#Meta _ (#SymbolS ident)) (#Meta _ (#TupleS (#Cons head tail))) body))
+ (#Some ident head tail body)
_
#None))
- (#Some [ident head tail body])
+ (#Some ident head tail body)
(let [g!blank (symbol$ ["" ""])
g!name (symbol$ ident)
body+ (: Syntax (foldL (: (-> Syntax Syntax Syntax)
@@ -1819,29 +1860,29 @@
(defmacro #export (def tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
(case tokens
- (#Cons [(#Meta [_ (#TagS ["" "export"])]) tokens'])
+ (#Cons (#Meta _ (#TagS "" "export")) tokens')
[true tokens']
_
[false tokens]))
parts (: (Maybe (, Syntax (List Syntax) (Maybe Syntax) Syntax))
(case tokens'
- (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) type body))
- (#Some [name args (#Some type) body])
+ (\ (list (#Meta _ (#FormS (#Cons name args))) type body))
+ (#Some name args (#Some type) body)
(\ (list name type body))
- (#Some [name #Nil (#Some type) body])
+ (#Some name #Nil (#Some type) body)
- (\ (list (#Meta [_ (#FormS (#Cons [name args]))]) body))
- (#Some [name args #None body])
+ (\ (list (#Meta _ (#FormS (#Cons name args))) body))
+ (#Some name args #None body)
(\ (list name body))
- (#Some [name #Nil #None body])
+ (#Some name #Nil #None body)
_
#None))]
(case parts
- (#Some [name args ?type body])
+ (#Some name args ?type body)
(let [body (: Syntax
(case args
#Nil
@@ -1869,22 +1910,11 @@
(case state
{#source source #modules modules
#envs envs #types types #host host
- #seed seed #eval? eval?}
- (#Right [{#source source #modules modules
- #envs envs #types types #host host
- #seed (i+ 1 seed) #eval? eval?}
- (symbol$ ["__gensym__" (->text seed)])])))
-
-(def (macro-expand-1 token)
- (-> Syntax (Lux Syntax))
- (do Lux/Monad
- [token+ (macro-expand token)]
- (case token+
- (\ (list token'))
- (;return token')
-
- _
- (fail "Macro expanded to more than 1 element."))))
+ #seed seed #eval? eval? #expected expected}
+ (#Right {#source source #modules modules
+ #envs envs #types types #host host
+ #seed (i+ 1 seed) #eval? eval? #expected expected}
+ (symbol$ ["__gensym__" (->text seed)]))))
(defmacro #export (sig tokens)
(do Lux/Monad
@@ -1893,7 +1923,7 @@
(: (-> Syntax (Lux (, Ident Syntax)))
(lambda [token]
(case token
- (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_:"])]) type (#Meta [_ (#SymbolS name)])))]))
+ (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_:")) type (#Meta _ (#SymbolS name))))))
(do Lux/Monad
[name' (normalize name)]
(;return (: (, Ident Syntax) [name' type])))
@@ -1911,23 +1941,23 @@
(defmacro #export (defsig tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
(case tokens
- (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
+ (\ (list& (#Meta _ (#TagS "" "export")) tokens'))
[true tokens']
_
[false tokens]))
?parts (: (Maybe (, Syntax (List Syntax) (List Syntax)))
(case tokens'
- (\ (list& (#Meta [_ (#FormS (list& name args))]) sigs))
- (#Some [name args sigs])
+ (\ (list& (#Meta _ (#FormS (list& name args))) sigs))
+ (#Some name args sigs)
(\ (list& name sigs))
- (#Some [name #Nil sigs])
+ (#Some name #Nil sigs)
_
#None))]
(case ?parts
- (#Some [name args sigs])
+ (#Some name args sigs)
(let [sigs' (: Syntax
(case args
#Nil
@@ -1950,7 +1980,7 @@
(: (-> Syntax (Lux (, Syntax Syntax)))
(lambda [token]
(case token
- (\ (#Meta [_ (#FormS (list (#Meta [_ (#SymbolS [_ "_lux_def"])]) (#Meta [_ (#SymbolS name)]) value))]))
+ (\ (#Meta _ (#FormS (list (#Meta _ (#SymbolS _ "_lux_def")) (#Meta _ (#SymbolS name)) value))))
(do Lux/Monad
[name' (normalize name)]
(;return (: (, Syntax Syntax) [(tag$ name') value])))
@@ -1963,23 +1993,23 @@
(defmacro #export (defstruct tokens)
(let [[export? tokens'] (: (, Bool (List Syntax))
(case tokens
- (\ (list& (#Meta [_ (#TagS ["" "export"])]) tokens'))
+ (\ (list& (#Meta _ (#TagS "" "export")) tokens'))
[true tokens']
_
[false tokens]))
?parts (: (Maybe (, Syntax (List Syntax) Syntax (List Syntax)))
(case tokens'
- (\ (list& (#Meta [_ (#FormS (list& name args))]) type defs))
- (#Some [name args type defs])
+ (\ (list& (#Meta _ (#FormS (list& name args))) type defs))
+ (#Some name args type defs)
(\ (list& name type defs))
- (#Some [name #Nil type defs])
+ (#Some name #Nil type defs)
_
#None))]
(case ?parts
- (#Some [name args type defs])
+ (#Some name args type defs)
(let [defs' (: Syntax
(case args
#Nil
@@ -2031,7 +2061,7 @@
(: (-> Syntax (Lux Text))
(lambda [def]
(case def
- (#Meta [_ (#SymbolS ["" name])])
+ (#Meta _ (#SymbolS "" name))
(return name)
_
@@ -2041,7 +2071,7 @@
(def (parse-alias tokens)
(-> (List Syntax) (Lux (, (Maybe Text) (List Syntax))))
(case tokens
- (\ (list& (#Meta [_ (#TagS ["" "as"])]) (#Meta [_ (#SymbolS ["" alias])]) tokens'))
+ (\ (list& (#Meta _ (#TagS "" "as")) (#Meta _ (#SymbolS "" alias)) tokens'))
(return (: (, (Maybe Text) (List Syntax)) [(#Some alias) tokens']))
_
@@ -2050,17 +2080,17 @@
(def (parse-referrals tokens)
(-> (List Syntax) (Lux (, Referrals (List Syntax))))
(case tokens
- (\ (list& (#Meta [_ (#TagS ["" "refer"])]) referral tokens'))
+ (\ (list& (#Meta _ (#TagS "" "refer")) referral tokens'))
(case referral
- (#Meta [_ (#TagS ["" "all"])])
+ (#Meta _ (#TagS "" "all"))
(return (: (, Referrals (List Syntax)) [#All tokens']))
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "only"])]) defs))]))
+ (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "only")) defs))))
(do Lux/Monad
[defs' (extract-defs defs)]
(return (: (, Referrals (List Syntax)) [(#Only defs') tokens'])))
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#TagS ["" "exclude"])]) defs))]))
+ (\ (#Meta _ (#FormS (list& (#Meta _ (#TagS "" "exclude")) defs))))
(do Lux/Monad
[defs' (extract-defs defs)]
(return (: (, Referrals (List Syntax)) [(#Exclude defs') tokens'])))
@@ -2074,7 +2104,7 @@
(def (extract-symbol syntax)
(-> Syntax (Lux Ident))
(case syntax
- (#Meta [_ (#SymbolS ident)])
+ (#Meta _ (#SymbolS ident))
(return ident)
_
@@ -2083,10 +2113,10 @@
(def (parse-openings tokens)
(-> (List Syntax) (Lux (, (Maybe Openings) (List Syntax))))
(case tokens
- (\ (list& (#Meta [_ (#TagS ["" "open"])]) (#Meta [_ (#FormS (list& (#Meta [_ (#TextS prefix)]) structs))]) tokens'))
+ (\ (list& (#Meta _ (#TagS "" "open")) (#Meta _ (#FormS (list& (#Meta _ (#TextS prefix)) structs))) tokens'))
(do Lux/Monad
[structs' (map% Lux/Monad extract-symbol structs)]
- (return (: (, (Maybe Openings) (List Syntax)) [(#Some [prefix structs']) tokens'])))
+ (return (: (, (Maybe Openings) (List Syntax)) [(#Some prefix structs') tokens'])))
_
(return (: (, (Maybe Openings) (List Syntax)) [#None tokens]))))
@@ -2097,10 +2127,10 @@
(: (-> Syntax (Lux Syntax))
(lambda [token]
(case token
- (#Meta [_ (#SymbolS ["" sub-name])])
+ (#Meta _ (#SymbolS "" sub-name))
(return (symbol$ ["" ($ text:++ super-name "/" sub-name)]))
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" sub-name])]) parts))]))
+ (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" sub-name)) parts))))
(return (form$ (list& (symbol$ ["" ($ text:++ super-name "/" sub-name)]) parts)))
_
@@ -2114,10 +2144,10 @@
(: (-> Syntax (Lux (List Import)))
(lambda [token]
(case token
- (#Meta [_ (#SymbolS ["" m-name])])
+ (#Meta _ (#SymbolS "" m-name))
(;return (list [m-name #None #All #None]))
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS ["" m-name])]) extra))]))
+ (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS "" m-name)) extra))))
(do Lux/Monad
[alias+extra (parse-alias extra)
#let [[alias extra] alias+extra]
@@ -2141,13 +2171,13 @@
(case state
{#source source #modules modules
#envs envs #types types #host host
- #seed seed #eval? eval?}
+ #seed seed #eval? eval? #expected expected}
(case (get module modules)
(#Some =module)
- (#Right [state true])
+ (#Right state true)
#None
- (#Right [state false]))
+ (#Right state false))
))
(def (exported-defs module state)
@@ -2155,7 +2185,7 @@
(case state
{#source source #modules modules
#envs envs #types types #host host
- #seed seed #eval? eval?}
+ #seed seed #eval? eval? #expected expected}
(case (get module modules)
(#Some =module)
(let [to-alias (map (: (-> (, Text (, Bool (DefData' (-> (List Syntax) (StateE Compiler (List Syntax))))))
@@ -2167,7 +2197,7 @@
(list)))))
(let [{#module-aliases _ #defs defs #imports _} =module]
defs))]
- (#Right [state (list:join to-alias)]))
+ (#Right state (list:join to-alias)))
#None
(#Left ($ text:++ "Unknown module: " module)))
@@ -2195,18 +2225,18 @@
(def (split-module-contexts module)
(-> Text (List Text))
- (#Cons [module (let [idx (last-index-of "/" module)]
- (if (i< idx 0)
- #Nil
- (split-module-contexts (substring2 0 idx module))))]))
+ (#Cons module (let [idx (last-index-of "/" module)]
+ (if (i< idx 0)
+ #Nil
+ (split-module-contexts (substring2 0 idx module))))))
(def (split-module module)
(-> Text (List Text))
(let [idx (index-of "/" module)]
(if (i< idx 0)
- (#Cons [module #Nil])
- (#Cons [(substring2 0 idx module)
- (split-module (substring1 (i+ 1 idx) module))]))))
+ (#Cons module #Nil)
+ (#Cons (substring2 0 idx module)
+ (split-module (substring1 (i+ 1 idx) module))))))
(def (@ idx xs)
(All [a]
@@ -2215,7 +2245,7 @@
#Nil
#None
- (#Cons [x xs'])
+ (#Cons x xs')
(if (i= idx 0)
(#Some x)
(@ (i- idx 1) xs')
@@ -2228,7 +2258,7 @@
#Nil
[ys xs]
- (#Cons [x xs'])
+ (#Cons x xs')
(if (p x)
(split-with' p (list& x ys) xs')
[ys xs])))
@@ -2267,9 +2297,9 @@
#;Nil
(list)
- (#;Cons [x xs'])
+ (#;Cons x xs')
(if (p x)
- (#;Cons [x (filter p xs')])
+ (#;Cons x (filter p xs'))
(filter p xs'))))
(def (is-member? cases name)
@@ -2335,7 +2365,7 @@
#None
(list)
- (#Some [prefix structs])
+ (#Some prefix structs)
(map (: (-> Ident Syntax)
(lambda [struct]
(let [[_ name] struct]
@@ -2367,7 +2397,7 @@
#Nil
#None
- (#Cons [x xs'])
+ (#Cons x xs')
(case (f x)
#None
(some f xs')
@@ -2433,7 +2463,7 @@
(foldL text:++ ""))
")"))
- (#LambdaT [input output])
+ (#LambdaT input output)
($ text:++ "(-> " (type:show input) " " (type:show output) ")")
(#VarT id)
@@ -2445,10 +2475,10 @@
(#ExT ?id)
($ text:++ "⟨" (->text ?id) "⟩")
- (#AppT [?lambda ?param])
+ (#AppT ?lambda ?param)
($ text:++ "(" (type:show ?lambda) " " (type:show ?param) ")")
- (#AllT [?env ?name ?arg ?body])
+ (#AllT ?env ?name ?arg ?body)
($ text:++ "(All " ?name " [" ?arg "] " (type:show ?body) ")")
))
@@ -2472,19 +2502,19 @@
(#TupleT ?members)
(#TupleT (map (beta-reduce env) ?members))
- (#AppT [?type-fn ?type-arg])
- (#AppT [(beta-reduce env ?type-fn) (beta-reduce env ?type-arg)])
+ (#AppT ?type-fn ?type-arg)
+ (#AppT (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))
- (#AllT [?local-env ?local-name ?local-arg ?local-def])
+ (#AllT ?local-env ?local-name ?local-arg ?local-def)
(case ?local-env
#None
- (#AllT [(#Some env) ?local-name ?local-arg ?local-def])
+ (#AllT (#Some env) ?local-name ?local-arg ?local-def)
(#Some _)
type)
- (#LambdaT [?input ?output])
- (#LambdaT [(beta-reduce env ?input) (beta-reduce env ?output)])
+ (#LambdaT ?input ?output)
+ (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output))
(#BoundT ?name)
(case (get ?name env)
@@ -2501,7 +2531,7 @@
(def (apply-type type-fn param)
(-> Type Type (Maybe Type))
(case type-fn
- (#AllT [env name arg body])
+ (#AllT env name arg body)
(#Some (beta-reduce (|> (case env
(#Some env) env
_ (list))
@@ -2509,7 +2539,7 @@
(put arg param))
body))
- (#AppT [F A])
+ (#AppT F A)
(do Maybe/Monad
[type-fn* (apply-type F A)]
(apply-type type-fn* param))
@@ -2523,10 +2553,10 @@
(#RecordT slots)
(#Some type)
- (#AppT [fun arg])
+ (#AppT fun arg)
(apply-type fun arg)
- (#AllT [_ _ _ body])
+ (#AllT _ _ _ body)
(resolve-struct-type body)
_
@@ -2545,7 +2575,7 @@
(case state
{#source source #modules modules
#envs envs #types types #host host
- #seed seed #eval? eval?}
+ #seed seed #eval? eval? #expected expected}
(some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
(lambda [env]
(case env
@@ -2579,7 +2609,7 @@
(let [[v-prefix v-name] name
{#source source #modules modules
#envs envs #types types #host host
- #seed seed #eval? eval?} state]
+ #seed seed #eval? eval? #expected expected} state]
(case (get v-prefix modules)
#None
#None
@@ -2589,7 +2619,7 @@
#None
#None
- (#Some [_ def-data])
+ (#Some _ def-data)
(case def-data
#TypeD (#Some Type)
(#ValueD type) (#Some type)
@@ -2602,7 +2632,7 @@
## (let [[v-prefix v-name] name
## {#source source #modules modules
## #envs envs #types types #host host
-## #seed seed #eval? eval?} state]
+## #seed seed #eval? eval? #expected expected} state]
## (do Maybe/Monad
## [module (get v-prefix modules)
## #let [{#defs defs #module-aliases _ #imports _} module]
@@ -2621,24 +2651,32 @@
(lambda [state]
(case (find-in-env name state)
(#Some struct-type)
- (#Right [state struct-type])
+ (#Right state struct-type)
_
(case (find-in-defs name' state)
(#Some struct-type)
- (#Right [state struct-type])
+ (#Right state struct-type)
_
(let [{#source source #modules modules
#envs envs #types types #host host
- #seed seed #eval? eval?} state]
+ #seed seed #eval? eval? #expected expected} state]
(#Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs)))))))))
+(def expected-type
+ (Lux Type)
+ (lambda [state]
+ (let [{#source source #modules modules
+ #envs envs #types types #host host
+ #seed seed #eval? eval? #expected expected} state]
+ (#Right state expected))))
+
(defmacro #export (using tokens)
(case tokens
(\ (list struct body))
(case struct
- (#Meta [_ (#SymbolS name)])
+ (#Meta _ (#SymbolS name))
(do Lux/Monad
[struct-type (find-var-type name)]
(case (resolve-struct-type struct-type)
@@ -2687,9 +2725,9 @@
(defmacro #export (get@ tokens)
(case tokens
- (\ (list (#Meta [_ (#TagS slot')]) record))
+ (\ (list (#Meta _ (#TagS slot')) record))
(case record
- (#Meta [_ (#SymbolS name)])
+ (#Meta _ (#SymbolS name))
(do Lux/Monad
[type (find-var-type name)
g!blank (gensym "")
@@ -2724,10 +2762,10 @@
(defmacro #export (open tokens)
(case tokens
- (\ (list& (#Meta [_ (#SymbolS struct-name)]) tokens'))
+ (\ (list& (#Meta _ (#SymbolS struct-name)) tokens'))
(do Lux/Monad
[#let [prefix (case tokens'
- (\ (list (#Meta [_ (#TextS prefix)])))
+ (\ (list (#Meta _ (#TextS prefix))))
prefix
_
@@ -2754,7 +2792,7 @@
(-> (Monad m) (-> a b (m a)) a (List b)
(m a)))
(case ys
- (#Cons [y ys'])
+ (#Cons y ys')
(do M
[x' (f x y)]
(foldL% M f x' ys'))
@@ -2770,10 +2808,10 @@
(: (-> Syntax Syntax (Lux Syntax))
(lambda [so-far part]
(case part
- (#Meta [_ (#SymbolS slot)])
+ (#Meta _ (#SymbolS slot))
(return (` (get@ (~ (tag$ slot)) (~ so-far))))
- (\ (#Meta [_ (#FormS (list& (#Meta [_ (#SymbolS slot)]) args))]))
+ (\ (#Meta _ (#FormS (list& (#Meta _ (#SymbolS slot)) args))))
(return (` ((get@ (~ (tag$ slot)) (~ so-far))
(~@ args))))
@@ -2787,9 +2825,9 @@
(defmacro #export (set@ tokens)
(case tokens
- (\ (list (#Meta [_ (#TagS slot')]) value record))
+ (\ (list (#Meta _ (#TagS slot')) value record))
(case record
- (#Meta [_ (#SymbolS name)])
+ (#Meta _ (#SymbolS name))
(do Lux/Monad
[type (find-var-type name)]
(case (resolve-struct-type type)
@@ -2835,9 +2873,9 @@
(defmacro #export (update@ tokens)
(case tokens
- (\ (list (#Meta [_ (#TagS slot')]) fun record))
+ (\ (list (#Meta _ (#TagS slot')) fun record))
(case record
- (#Meta [_ (#SymbolS name)])
+ (#Meta _ (#SymbolS name))
(do Lux/Monad
[type (find-var-type name)]
(case (resolve-struct-type type)
@@ -2883,12 +2921,12 @@
(defmacro #export (\template tokens)
(case tokens
- (\ (list (#Meta [_ (#TupleS data)])
- (#Meta [_ (#TupleS bindings)])
- (#Meta [_ (#TupleS templates)])))
+ (\ (list (#Meta _ (#TupleS data))
+ (#Meta _ (#TupleS bindings))
+ (#Meta _ (#TupleS templates))))
(case (: (Maybe (List Syntax))
(do Maybe/Monad
- [bindings' (map% Maybe/Monad get-ident bindings)
+ [bindings' (map% Maybe/Monad get-name bindings)
data' (map% Maybe/Monad tuple->list data)]
(let [apply (: (-> RepEnv (List Syntax))
(lambda [env] (map (apply-template env) templates)))]
@@ -2904,28 +2942,109 @@
_
(fail "Wrong syntax for \\template")))
-(def #export complement
- (All [a] (-> (-> a Bool) (-> a Bool)))
- (. not))
-
-## (defmacro #export (loop tokens)
-## (case tokens
-## (\ (list bindings body))
-## (let [pairs (as-pairs bindings)
-## vars (map first pairs)
-## inits (map second pairs)]
-## (if (every? symbol? inits)
-## (do Lux/Monad
-## [inits' (map% Maybe/Monad get-ident inits)
-## init-types (map% Maybe/Monad find-var-type inits')]
-## (return (list (` ((lambda (~ (#SymbolS ["" "recur"])) [(~@ vars)]
-## (~ body))
-## (~@ inits))))))
-## (do Lux/Monad
-## [aliases (map% Maybe/Monad (lambda [_] (gensym "")) inits)]
-## (return (list (` (let [(~@ (interleave aliases inits))]
-## (loop [(~@ (interleave vars aliases))]
-## (~ body)))))))))
-
-## _
-## (fail "Wrong syntax for loop")))
+(do-template [<name> <type> <value>]
+ [(def (<name> [x y])
+ (All [a b] (-> (, a b) <type>))
+ <value>)]
+
+ [first a x]
+ [second b y])
+
+(def (interleave xs ys)
+ (All [a] (-> (List a) (List a) (List a)))
+ (case xs
+ #Nil
+ #Nil
+
+ (#Cons x xs')
+ (case ys
+ #Nil
+ #Nil
+
+ (#Cons y ys')
+ (list& x y (interleave xs' ys')))))
+
+(do-template [<name> <init> <op>]
+ [(def (<name> p xs)
+ (All [a]
+ (-> (-> a Bool) (List a) Bool))
+ (foldL (lambda [_1 _2] (<op> _1 (p _2))) <init> xs))]
+
+ [every? true and])
+
+(def (type->syntax type)
+ (-> Type Syntax)
+ (case type
+ (#DataT name)
+ (` (#DataT (~ (text$ name))))
+
+ (#TupleT parts)
+ (` (#TupleT (~ (untemplate-list (map type->syntax parts)))))
+
+ (#VariantT cases)
+ (` (#VariantT (~ (untemplate-list (map (: (-> (, Text Type) Syntax)
+ (lambda [[label type]]
+ (tuple$ (list (text$ label) (type->syntax type)))))
+ cases)))))
+
+ (#RecordT fields)
+ (` (#RecordT (~ (untemplate-list (map (: (-> (, Text Type) Syntax)
+ (lambda [[label type]]
+ (tuple$ (list (text$ label) (type->syntax type)))))
+ fields)))))
+
+ (#LambdaT in out)
+ (` (#LambdaT (~ (type->syntax in)) (~ (type->syntax out))))
+
+ (#BoundT name)
+ (` (#BoundT (~ (text$ name))))
+
+ (#VarT id)
+ (` (#VarT (~ (int$ id))))
+
+ (#ExT id)
+ (` (#ExT (~ (int$ id))))
+
+ (#AllT env name arg type)
+ (let [env' (: Syntax
+ (case env
+ #None (` #None)
+ (#Some _env) (` (#Some (~ (untemplate-list (map (: (-> (, Text Type) Syntax)
+ (lambda [[label type]]
+ (tuple$ (list (text$ label) (type->syntax type)))))
+ _env)))))))]
+ (` (#AllT (~ env') (~ (text$ name)) (~ (text$ arg)) (~ (type->syntax type)))))
+
+ (#AppT fun arg)
+ (` (#AppT (~ (type->syntax fun)) (~ (type->syntax arg))))))
+
+(defmacro #export (loop tokens)
+ (case tokens
+ (\ (list (#Meta _ (#TupleS bindings)) body))
+ (let [pairs (as-pairs bindings)
+ vars (map first pairs)
+ inits (map second pairs)]
+ (if (every? symbol? inits)
+ (do Lux/Monad
+ [inits' (: (Lux (List Ident))
+ (case (map% Maybe/Monad get-ident inits)
+ (#Some inits') (return inits')
+ #None (fail "Wrong syntax for loop")))
+ init-types (map% Lux/Monad find-var-type inits')
+ expected expected-type]
+ (return (list (` ((: (-> (~@ (map type->syntax init-types))
+ (~ (type->syntax expected)))
+ (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)]
+ (~ body)))
+ (~@ inits))))))
+ (do Lux/Monad
+ [aliases (map% Lux/Monad
+ (: (-> Syntax (Lux Syntax))
+ (lambda [_] (gensym "")))
+ inits)]
+ (return (list (` (let [(~@ (interleave aliases inits))]
+ (loop [(~@ (interleave vars aliases))]
+ (~ body)))))))))
+
+ _
+ (fail "Wrong syntax for loop")))
diff --git a/source/lux/codata/function.lux b/source/lux/codata/function.lux
index 3c40df188..7898e998d 100644
--- a/source/lux/codata/function.lux
+++ b/source/lux/codata/function.lux
@@ -10,6 +10,10 @@
(lux/control (monoid #as m)))
## [Functions]
+(def #export (const x y)
+ (All [a b] (-> a (-> b a)))
+ x)
+
(def #export (flip f)
(All [a b c]
(-> (-> a b c) (-> b a c)))
diff --git a/source/lux/codata/stream.lux b/source/lux/codata/stream.lux
index 2c854a61c..3bce9ee77 100644
--- a/source/lux/codata/stream.lux
+++ b/source/lux/codata/stream.lux
@@ -14,7 +14,8 @@
macro
syntax)
(data (list #as l #refer (#only list list& List/Monad))
- (number (int #open ("i" Int/Number Int/Ord))))
+ (number (int #open ("i" Int/Number Int/Ord)))
+ bool)
(codata (lazy #as L #refer #all))))
## [Types]
diff --git a/source/lux/control/hash.lux b/source/lux/control/hash.lux
new file mode 100644
index 000000000..bfb8e99c0
--- /dev/null
+++ b/source/lux/control/hash.lux
@@ -0,0 +1,14 @@
+## Copyright (c) Eduardo Julian. All rights reserved.
+## The use and distribution terms for this software are covered by the
+## Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+## which can be found in the file epl-v10.html at the root of this distribution.
+## By using this software in any fashion, you are agreeing to be bound by
+## the terms of this license.
+## You must not remove this notice, or any other, from this software.
+
+(;import lux)
+
+## [Signatures]
+(defsig #export (Hash a)
+ (: (-> a Int)
+ hash))
diff --git a/source/lux/data/bool.lux b/source/lux/data/bool.lux
index 5f4427a2c..92f5486ef 100644
--- a/source/lux/data/bool.lux
+++ b/source/lux/data/bool.lux
@@ -7,9 +7,10 @@
## You must not remove this notice, or any other, from this software.
(;import lux
- (lux/control (monoid #as m)
- (eq #as E)
- (show #as S)))
+ (lux (control (monoid #as m)
+ (eq #as E)
+ (show #as S))
+ (codata function)))
## [Structures]
(defstruct #export Bool/Eq (E;Eq Bool)
@@ -31,3 +32,8 @@
[ Or/Monoid false or]
[And/Monoid true and]
)
+
+## [Functions]
+(def #export complement
+ (All [a] (-> (-> a Bool) (-> a Bool)))
+ (. not))
diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux
index 8d6296b14..2bbbe66cc 100644
--- a/source/lux/data/list.lux
+++ b/source/lux/data/list.lux
@@ -12,7 +12,8 @@
(monad #as M #refer #all)
(eq #as E)
(dict #as D #refer #all))
- (data/number (int #open ("i" Int/Number Int/Ord Int/Eq)))
+ (data (number (int #open ("i" Int/Number Int/Ord Int/Eq)))
+ bool)
meta/macro))
## Types
@@ -23,43 +24,6 @@
(deftype #export (PList k v)
(| (#PList (, (E;Eq k) (List (, k v))))))
-## [Utils]
-(def (pl-get eq k kvs)
- (All [k v]
- (-> (E;Eq k) k (List (, k v)) (Maybe v)))
- (case kvs
- #;Nil
- #;None
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- (#;Some v')
- (pl-get eq k kvs'))))
-
-(def (pl-put eq k v kvs)
- (All [k v]
- (-> (E;Eq k) k v (List (, k v)) (List (, k v))))
- (case kvs
- #;Nil
- (#;Cons [[k v] kvs])
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- (#;Cons [[k v] kvs'])
- (#;Cons [[k' v'] (pl-put eq k v kvs')]))))
-
-(def (pl-remove eq k kvs)
- (All [k v]
- (-> (E;Eq k) k (List (, k v)) (List (, k v))))
- (case kvs
- #;Nil
- kvs
-
- (#;Cons [[k' v'] kvs'])
- (if (:: eq (E;= k k'))
- kvs'
- (#;Cons [[k' v'] (pl-remove eq k kvs')]))))
-
## [Constructors]
(def #export (plist eq)
(All [k v]
@@ -316,14 +280,35 @@
(foldL ++ unit mma))))
(defstruct #export PList/Dict (Dict PList)
- (def (D;get k plist)
- (let [(#PList [eq kvs]) plist]
- (pl-get eq k kvs)))
-
- (def (D;put k v plist)
- (let [(#PList [eq kvs]) plist]
- (#PList [eq (pl-put eq k v kvs)])))
-
- (def (D;remove k plist)
- (let [(#PList [eq kvs]) plist]
- (#PList [eq (pl-remove eq k kvs)]))))
+ (def (D;get k (#PList [eq kvs]))
+ (loop [kvs kvs]
+ (case kvs
+ #;Nil
+ #;None
+
+ (#;Cons [k' v'] kvs')
+ (if (:: eq (E;= k k'))
+ (#;Some v')
+ (recur kvs')))))
+
+ (def (D;put k v (#PList [eq kvs]))
+ (#PList [eq (loop [kvs kvs]
+ (case kvs
+ #;Nil
+ (#;Cons [k v] kvs)
+
+ (#;Cons [k' v'] kvs')
+ (if (:: eq (E;= k k'))
+ (#;Cons [k v] kvs')
+ (#;Cons [k' v'] (recur kvs')))))]))
+
+ (def (D;remove k (#PList [eq kvs]))
+ (#PList [eq (loop [kvs kvs]
+ (case kvs
+ #;Nil
+ kvs
+
+ (#;Cons [[k' v'] kvs'])
+ (if (:: eq (E;= k k'))
+ kvs'
+ (#;Cons [[k' v'] (recur kvs')]))))])))
diff --git a/source/lux/meta/lux.lux b/source/lux/meta/lux.lux
index 13dcae284..66e4cc341 100644
--- a/source/lux/meta/lux.lux
+++ b/source/lux/meta/lux.lux
@@ -133,19 +133,39 @@
(M;wrap (:: List/Monad (M;join expansion'))))
#;None
+ (:: Lux/Monad (M;wrap (list syntax)))))
+
+ _
+ (:: Lux/Monad (M;wrap (list syntax)))))
+
+(def #export (macro-expand-all syntax)
+ (-> Syntax (Lux (List Syntax)))
+ (case syntax
+ (#;Meta [_ (#;FormS (#;Cons [(#;Meta [_ (#;SymbolS macro-name)]) args]))])
+ (do Lux/Monad
+ [macro-name' (normalize macro-name)
+ ?macro (find-macro macro-name')]
+ (case ?macro
+ (#;Some macro)
+ (do Lux/Monad
+ [expansion (macro args)
+ expansion' (M;map% Lux/Monad macro-expand-all expansion)]
+ (M;wrap (:: List/Monad (M;join expansion'))))
+
+ #;None
(do Lux/Monad
- [parts' (M;map% Lux/Monad macro-expand (list& (symbol$ macro-name) args))]
+ [parts' (M;map% Lux/Monad macro-expand-all (list& (symbol$ macro-name) args))]
(M;wrap (list (form$ (:: List/Monad (M;join parts'))))))))
(#;Meta [_ (#;FormS (#;Cons [harg targs]))])
(do Lux/Monad
- [harg+ (macro-expand harg)
- targs+ (M;map% Lux/Monad macro-expand targs)]
+ [harg+ (macro-expand-all harg)
+ targs+ (M;map% Lux/Monad macro-expand-all targs)]
(M;wrap (list (form$ (list:++ harg+ (:: List/Monad (M;join (: (List (List Syntax)) targs+))))))))
(#;Meta [_ (#;TupleS members)])
(do Lux/Monad
- [members' (M;map% Lux/Monad macro-expand members)]
+ [members' (M;map% Lux/Monad macro-expand-all members)]
(M;wrap (list (tuple$ (:: List/Monad (M;join members'))))))
_
@@ -234,7 +254,7 @@
(case state
{#;source source #;modules modules
#;envs envs #;types types #;host host
- #;seed seed #;eval? eval?}
+ #;seed seed #;eval? eval? #;expected expected}
(some (: (-> (Env Text (, LuxVar Type)) (Maybe Type))
(lambda [env]
(case env
@@ -254,7 +274,7 @@
(let [[v-prefix v-name] name
{#;source source #;modules modules
#;envs envs #;types types #;host host
- #;seed seed #;eval? eval?} state]
+ #;seed seed #;eval? eval? #;expected expected} state]
(case (get v-prefix modules)
#;None
#;None
@@ -289,6 +309,6 @@
_
(let [{#;source source #;modules modules
#;envs envs #;types types #;host host
- #;seed seed #;eval? eval?} state]
+ #;seed seed #;eval? eval? #;expected expected} state]
(#;Left ($ text:++ "Unknown var: " (ident->text name) "\n\n" (show-envs envs))))))))
))
diff --git a/source/program.lux b/source/program.lux
index b9f737480..ae3421078 100644
--- a/source/program.lux
+++ b/source/program.lux
@@ -14,6 +14,7 @@
bounded
dict
eq
+ hash
ord
show
number)
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index de7fc8497..f10f6b913 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -446,45 +446,44 @@
[_]
(aba3 analyse eval! compile-module exo-type token)))
-(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))]
- (defn ^:private aba1 [analyse eval! compile-module exo-type token]
- (matchv ::M/objects [token]
- ;; Standard special forms
- [["lux;BoolS" ?value]]
- (|do [_ (&type/check exo-type &type/Bool)]
- (return (&/|list (&/T (&/V "bool" ?value) exo-type))))
+(defn ^:private aba1 [analyse eval! compile-module exo-type token]
+ (matchv ::M/objects [token]
+ ;; Standard special forms
+ [["lux;BoolS" ?value]]
+ (|do [_ (&type/check exo-type &type/Bool)]
+ (return (&/|list (&/T (&/V "bool" ?value) exo-type))))
- [["lux;IntS" ?value]]
- (|do [_ (&type/check exo-type &type/Int)]
- (return (&/|list (&/T (&/V "int" ?value) exo-type))))
+ [["lux;IntS" ?value]]
+ (|do [_ (&type/check exo-type &type/Int)]
+ (return (&/|list (&/T (&/V "int" ?value) exo-type))))
- [["lux;RealS" ?value]]
- (|do [_ (&type/check exo-type &type/Real)]
- (return (&/|list (&/T (&/V "real" ?value) exo-type))))
+ [["lux;RealS" ?value]]
+ (|do [_ (&type/check exo-type &type/Real)]
+ (return (&/|list (&/T (&/V "real" ?value) exo-type))))
- [["lux;CharS" ?value]]
- (|do [_ (&type/check exo-type &type/Char)]
- (return (&/|list (&/T (&/V "char" ?value) exo-type))))
+ [["lux;CharS" ?value]]
+ (|do [_ (&type/check exo-type &type/Char)]
+ (return (&/|list (&/T (&/V "char" ?value) exo-type))))
- [["lux;TextS" ?value]]
- (|do [_ (&type/check exo-type &type/Text)]
- (return (&/|list (&/T (&/V "text" ?value) exo-type))))
+ [["lux;TextS" ?value]]
+ (|do [_ (&type/check exo-type &type/Text)]
+ (return (&/|list (&/T (&/V "text" ?value) exo-type))))
- [["lux;TupleS" ?elems]]
- (&&lux/analyse-tuple analyse exo-type ?elems)
+ [["lux;TupleS" ?elems]]
+ (&&lux/analyse-tuple analyse exo-type ?elems)
- [["lux;RecordS" ?elems]]
- (&&lux/analyse-record analyse exo-type ?elems)
+ [["lux;RecordS" ?elems]]
+ (&&lux/analyse-record analyse exo-type ?elems)
- [["lux;TagS" ?ident]]
- (&&lux/analyse-variant analyse exo-type ?ident unit)
-
- [["lux;SymbolS" [_ "_jvm_null"]]]
- (&&host/analyse-jvm-null analyse exo-type)
+ [["lux;TagS" ?ident]]
+ (&&lux/analyse-variant analyse exo-type ?ident (&/|list))
+
+ [["lux;SymbolS" [_ "_jvm_null"]]]
+ (&&host/analyse-jvm-null analyse exo-type)
- [_]
- (aba2 analyse eval! compile-module exo-type token)
- )))
+ [_]
+ (aba2 analyse eval! compile-module exo-type token)
+ ))
(defn ^:private add-loc [meta ^String msg]
(if (.startsWith msg "@")
@@ -512,10 +511,10 @@
;; (assert false (aget token 0))
))
-(defn ^:private just-analyse [analyse-ast eval! compile-module syntax]
+(defn ^:private just-analyse [analyser syntax]
(&type/with-var
(fn [?var]
- (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)]
+ (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)]
(matchv ::M/objects [?var ?output-type]
[["lux;VarT" ?e-id] ["lux;VarT" ?a-id]]
(if (= ?e-id ?a-id)
@@ -528,25 +527,25 @@
))))
(defn ^:private analyse-ast [eval! compile-module exo-type token]
- (matchv ::M/objects [token]
- [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]]
- (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.")
- (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident (&/|head ?values)))
-
- [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]]
- (fn [state]
- (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state)
- ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)
- ]
- [["lux;Right" [state* =fn]]]
- (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0))
- ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*))
-
- [_]
- ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state)))
-
- [_]
- (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token)))
+ (&/with-expected-type exo-type
+ (matchv ::M/objects [token]
+ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]]
+ (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident ?values)
+
+ [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]]
+ (fn [state]
+ (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module) ?fn) state)
+ ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state)
+ ]
+ [["lux;Right" [state* =fn]]]
+ (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0))
+ ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*))
+
+ [_]
+ ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state)))
+
+ [_]
+ (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token))))
;; [Resources]
(defn analyse [eval! compile-module]
diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj
index ebbb6911a..77f8c418c 100644
--- a/src/lux/analyser/case.clj
+++ b/src/lux/analyser/case.clj
@@ -16,6 +16,9 @@
[env :as &env])))
;; [Utils]
+(def ^:private unit
+ (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list)))))
+
(defn ^:private resolve-type [type]
(matchv ::M/objects [type]
[["lux;VarT" ?id]]
@@ -198,19 +201,19 @@
(|do [=tag (&&/resolved-ident ?ident)
value-type* (adjust-type value-type)
case-type (&type/variant-case =tag value-type*)
- [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1)
- (&/V "lux;TupleS" (&/|list))))
- kont)]
+ [=test =kont] (analyse-pattern case-type unit kont)]
(return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
[["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]]
- ["lux;Cons" [?value
- ["lux;Nil" _]]]]]]]
+ ?values]]]]
(|do [=tag (&&/resolved-ident ?ident)
value-type* (adjust-type value-type)
case-type (&type/variant-case =tag value-type*)
- [=test =kont] (analyse-pattern case-type ?value
- kont)]
+ [=test =kont] (case (&/|length ?values)
+ 0 (analyse-pattern case-type unit kont)
+ 1 (analyse-pattern case-type (&/|head ?values) kont)
+ ;; 1+
+ (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" ?values))) kont))]
(return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont)))
)))
diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj
index 065e150d9..4fb9d1533 100644
--- a/src/lux/analyser/lux.clj
+++ b/src/lux/analyser/lux.clj
@@ -55,7 +55,25 @@
[_]
(fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))))
-(defn analyse-variant [analyse exo-type ident ?value]
+(defn ^:private analyse-variant-body [analyse exo-type ?values]
+ (|do [output (matchv ::M/objects [?values]
+ [["lux;Nil" _]]
+ (analyse-tuple analyse exo-type (&/|list))
+
+ [["lux;Cons" [?value ["lux;Nil" _]]]]
+ (analyse exo-type ?value)
+
+ [_]
+ (analyse-tuple analyse exo-type ?values)
+ )]
+ (matchv ::M/objects [output]
+ [["lux;Cons" [x ["lux;Nil" _]]]]
+ (return x)
+
+ [_]
+ (fail "[Analyser Error] Can't expand to other than 1 element."))))
+
+(defn analyse-variant [analyse exo-type ident ?values]
(|do [exo-type* (matchv ::M/objects [exo-type]
[["lux;VarT" ?id]]
(&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)]
@@ -69,7 +87,7 @@
[["lux;VariantT" ?cases]]
(|do [?tag (&&/resolved-ident ident)]
(if-let [vtype (&/|get ?tag ?cases)]
- (|do [=value (&&/analyse-1 analyse vtype ?value)]
+ (|do [=value (analyse-variant-body analyse vtype ?values)]
(return (&/|list (&/T (&/V "variant" (&/T ?tag =value))
exo-type))))
(fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*)))))
@@ -78,7 +96,7 @@
(&type/with-var
(fn [$var]
(|do [exo-type** (&type/apply-type exo-type* $var)]
- (analyse-variant analyse exo-type** ident ?value))))
+ (analyse-variant analyse exo-type** ident ?values))))
[_]
(fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))
@@ -108,6 +126,8 @@
(fail (str "[Analyser Error] The type of a record must be a record type:\n"
(&type/show-type exo-type*)
"\n")))
+ _ (&/assert! (= (&/|length types) (&/|length ?elems))
+ (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems)))
=slots (&/map% (fn [kv]
(matchv ::M/objects [kv]
[[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]]
@@ -258,14 +278,17 @@
(|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)]
(matchv ::M/objects [$def]
[["lux;MacroD" macro]]
- (|do [macro-expansion #(-> macro (.apply ?args) (.apply %))
+ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))]
+ macro-expansion #(-> macro (.apply ?args) (.apply %))
+ ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))]
:let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)]
- ;; :let [_ (when (and ;; (= "lux/control/monad" ?module)
- ;; (= "case" ?name))
+ ;; :let [_ (when (or (= "loop" r-name)
+ ;; ;; (= "struct" r-name)
+ ;; )
;; (->> (&/|map &/show-ast macro-expansion*)
;; (&/|interpose "\n")
;; (&/fold str "")
- ;; (prn ?module "case")))]
+ ;; (prn (str r-module ";" r-name))))]
]
(&/flat-map% (partial analyse exo-type) macro-expansion*))
@@ -356,6 +379,8 @@
(defn analyse-def [analyse ?name ?value]
;; (prn 'analyse-def/BEGIN ?name)
+ ;; (when (= "PList/Dict" ?name)
+ ;; (prn 'DEF ?name (&/show-ast ?value)))
(|do [module-name &/get-module-name
? (&&module/defined? module-name ?name)]
(if ?
diff --git a/src/lux/base.clj b/src/lux/base.clj
index eb94c2c90..ef3c81041 100644
--- a/src/lux/base.clj
+++ b/src/lux/base.clj
@@ -11,6 +11,9 @@
[clojure.core.match :as M :refer [matchv]]
clojure.core.match.array))
+;; [Tags]
+(def $Cons "lux;Cons")
+
;; [Fields]
;; Binding
(def $COUNTER 0)
@@ -27,14 +30,15 @@
(def $LOADER 1)
(def $WRITER 2)
-;; CompilerState
+;; Compiler
(def $ENVS 0)
(def $EVAL? 1)
-(def $HOST 2)
-(def $MODULES 3)
-(def $SEED 4)
-(def $SOURCE 5)
-(def $TYPES 6)
+(def $EXPECTED 2)
+(def $HOST 3)
+(def $MODULES 4)
+(def $SEED 5)
+(def $SOURCE 6)
+(def $TYPES 7)
;; [Exports]
(def +name-separator+ ";")
@@ -487,6 +491,8 @@
(|list)
;; "lux;eval?"
false
+ ;; "lux;expected"
+ (V "lux;VariantT" (|list))
;; "lux;host"
(host nil)
;; "lux;modules"
@@ -610,6 +616,18 @@
[_]
output))))
+(defn with-expected-type [type body]
+ "(All [a] (-> Type (Lux a)))"
+ (fn [state]
+ (let [output (body (set$ $EXPECTED type state))]
+ (matchv ::M/objects [output]
+ [["lux;Right" [?state ?value]]]
+ (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state)
+ ?value)
+
+ [_]
+ output))))
+
(defn show-ast [ast]
(matchv ::M/objects [ast]
[["lux;Meta" [_ ["lux;BoolS" ?value]]]]
diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj
index 176b4340d..0e7982a7f 100644
--- a/src/lux/compiler/io.clj
+++ b/src/lux/compiler/io.clj
@@ -11,7 +11,7 @@
))
;; [Resources]
-(defn read-file [path]
+(defn read-file [^String path]
(let [file (new java.io.File path)]
(if (.exists file)
(return (slurp file))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index f5b8d3f25..e3255ac5c 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -177,7 +177,9 @@
(&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type)))
(&/T "lux;host" HostState)
(&/T "lux;seed" Int)
- (&/T "lux;eval?" Bool))))
+ (&/T "lux;eval?" Bool)
+ (&/T "lux;expected" Type)
+ )))
$Void)))
(def Macro
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-05 14:58:42 +0000