aboutsummaryrefslogtreecommitdiff
path: root/source
diff options
context:
space:
mode:
authorEduardo Julian2015-09-01 11:18:26 -0400
committerEduardo Julian2015-09-01 11:18:26 -0400
commit2cfaf65019015ffe34fba5d5a723b94350cd4e84 (patch)
tree43c8582e355b3fbef5cfd011dbe24a65b17588f3 /source
parent7f0aa70c6115f9321e13f0452d724b9b40c3f981 (diff)
- Added a macro to write recursive types.
- Corrected some code that still involved the old names for the list macros. - Corrected some code in the pattern-matcher analyser to it fails properly when encountering invalid pattern-syntax.
Diffstat (limited to 'source')
-rw-r--r--source/lux.lux196
-rw-r--r--source/lux/control/comonad.lux8
-rw-r--r--source/lux/data/maybe.lux21
-rw-r--r--source/program.lux29
4 files changed, 136 insertions, 118 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 9e5fbea7b..722369131 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -1537,6 +1537,17 @@
_
#None)))
+(def''' (normalize ident)
+ (-> Ident ($' Lux Ident))
+ (_lux_case ident
+ ["" name]
+ (do Lux/Monad
+ [module-name get-module-name]
+ (wrap (_lux_: Ident [module-name name])))
+
+ _
+ (return ident)))
+
(def''' (find-macro ident)
(-> Ident ($' Lux ($' Maybe Macro)))
(do Lux/Monad
@@ -1550,22 +1561,20 @@
#cursor cursor}
(#Right state (find-macro' modules current-module module name)))))))
+(def''' (macro? ident)
+ (-> Ident ($' Lux Bool))
+ (do Lux/Monad
+ [ident (normalize ident)
+ output (find-macro ident)]
+ (wrap (_lux_case output
+ (#Some _) true
+ #None false))))
+
(def''' (list:join xs)
(All [a]
(-> ($' List ($' List a)) ($' List a)))
(foldL list:++ #Nil xs))
-(def''' (normalize ident)
- (-> Ident ($' Lux Ident))
- (_lux_case ident
- ["" name]
- (do Lux/Monad
- [module-name get-module-name]
- (wrap (_lux_: Ident [module-name name])))
-
- _
- (return ident)))
-
(def''' (interpose sep xs)
(All [a]
(-> a ($' List a) ($' List a)))
@@ -1582,7 +1591,7 @@
(def''' (macro-expand token)
(-> AST ($' Lux ($' List AST)))
(_lux_case token
- [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))]
+ [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))]
(do Lux/Monad
[macro-name' (normalize macro-name)
?macro (find-macro macro-name')]
@@ -1602,7 +1611,7 @@
(def''' (macro-expand-all syntax)
(-> AST ($' Lux ($' List AST)))
(_lux_case syntax
- [_ (#FormS (#Cons [[_ (#SymbolS macro-name)] args]))]
+ [_ (#FormS (#Cons [_ (#SymbolS macro-name)] args))]
(do Lux/Monad
[macro-name' (normalize macro-name)
?macro (find-macro macro-name')]
@@ -1615,14 +1624,13 @@
#None
(do Lux/Monad
- [parts' (map% Lux/Monad macro-expand-all (@list& (symbol$ macro-name) args))]
- (wrap (@list (form$ (list:join parts')))))))
+ [args' (map% Lux/Monad macro-expand-all args)]
+ (wrap (@list (form$ (#Cons (symbol$ macro-name) (list:join args'))))))))
- [_ (#FormS (#Cons [harg targs]))]
+ [_ (#FormS members)]
(do Lux/Monad
- [harg+ (macro-expand-all harg)
- targs+ (map% Lux/Monad macro-expand-all targs)]
- (wrap (@list (form$ (list:++ harg+ (list:join targs+))))))
+ [members' (map% Lux/Monad macro-expand-all members)]
+ (wrap (@list (form$ (list:join members')))))
[_ (#TupleS members)]
(do Lux/Monad
@@ -1740,6 +1748,28 @@
_
(return [type #None])))
+(def''' (gensym prefix state)
+ (-> Text ($' Lux AST))
+ (_lux_case state
+ {#source source #modules modules
+ #envs envs #type-vars types #host host
+ #seed seed #eval? eval? #expected expected
+ #cursor cursor}
+ (#Right {#source source #modules modules
+ #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 (Rec tokens)
+ (_lux_case tokens
+ (#Cons [_ (#SymbolS "" name)] (#Cons body #Nil))
+ (let' [body' (replace-syntax (@list [name (` (#AppT (~ (make-bound 0)) (~ (make-bound 1))))]) body)]
+ (return (@list (` (#UnivQ #Nil (~ body'))))))
+
+ _
+ (fail "Wrong syntax for Rec")))
+
(defmacro #export (deftype tokens)
(let' [[export? tokens'] (: (, Bool (List AST))
(_lux_case tokens
@@ -1872,6 +1902,48 @@
#None
(fail "Wrong syntax for def'"))))
+(def' (ast:show ast)
+ (-> AST Text)
+ (_lux_case ast
+ [_ ast]
+ (_lux_case ast
+ (#BoolS val)
+ (->text val)
+
+ (#IntS val)
+ (->text val)
+
+ (#RealS val)
+ (->text val)
+
+ (#CharS val)
+ ($ text:++ "#\"" (->text val) "\"")
+
+ (#TextS val)
+ ($ text:++ "\"" (->text val) "\"")
+
+ (#FormS parts)
+ ($ text:++ "(" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) ")")
+
+ (#TupleS parts)
+ ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]")
+
+ (#SymbolS prefix name)
+ ($ text:++ prefix ";" name)
+
+ (#TagS prefix name)
+ ($ text:++ "#" prefix ";" name)
+
+ (#RecordS kvs)
+ ($ text:++ "{"
+ (|> kvs
+ (map (: (-> (, AST AST) Text)
+ (lambda' [kv] (let' [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v))))))
+ (interpose " ")
+ (foldL text:++ ""))
+ "}")
+ )))
+
(def' (rejoin-pair pair)
(-> (, AST AST) (List AST))
(let' [[left right] pair]
@@ -1888,9 +1960,13 @@
(_lux_case pattern
[_ (#FormS (#Cons [_ (#SymbolS macro-name)] macro-args))]
(do Lux/Monad
- [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args)))
- expansions (map% Lux/Monad expander (as-pairs expansion))]
- (wrap (list:join expansions)))
+ [??? (macro? macro-name)]
+ (if ???
+ (do Lux/Monad
+ [expansion (macro-expand (form$ (@list& (symbol$ macro-name) body macro-args)))
+ expansions (map% Lux/Monad expander (as-pairs expansion))]
+ (wrap (list:join expansions)))
+ (wrap (@list branch))))
_
(wrap (@list branch))))))
@@ -1905,7 +1981,8 @@
(case tokens
(#Cons body (#Cons pattern #Nil))
(do Lux/Monad
- [pattern+ (macro-expand-all pattern)]
+ [module-name get-module-name
+ pattern+ (macro-expand-all pattern)]
(case pattern+
(#Cons pattern' #Nil)
(wrap (@list pattern' body))
@@ -1960,42 +2037,6 @@
_
(fail "Wrong syntax for let")))
-(def' (ast:show ast)
- (-> AST Text)
- (case ast
- [_ ast]
- (case ast
- (\or (#BoolS val) (#IntS val) (#RealS val))
- (->text val)
-
- (#CharS val)
- ($ text:++ "#\"" (->text val) "\"")
-
- (#TextS val)
- ($ text:++ "\"" (->text val) "\"")
-
- (#FormS parts)
- ($ text:++ "(" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) ")")
-
- (#TupleS parts)
- ($ text:++ "[" (|> parts (map ast:show) (interpose " ") (foldL text:++ "")) "]")
-
- (#SymbolS prefix name)
- ($ text:++ prefix ";" name)
-
- (#TagS prefix name)
- ($ text:++ "#" prefix ";" name)
-
- (#RecordS kvs)
- ($ text:++ "{"
- (|> kvs
- (map (: (-> (, AST AST) Text)
- (lambda' [kv] (let [[k v] kv] ($ text:++ (ast:show k) " " (ast:show v))))))
- (interpose " ")
- (foldL text:++ ""))
- "}")
- )))
-
(defmacro #export (lambda tokens)
(case (: (Maybe (, Ident AST (List AST) AST))
(case tokens
@@ -2073,19 +2114,6 @@
#None
(fail "Wrong syntax for def"))))
-(def (gensym prefix state)
- (-> Text (Lux AST))
- (case state
- {#source source #modules modules
- #envs envs #type-vars types #host host
- #seed seed #eval? eval? #expected expected
- #cursor cursor}
- (#Right {#source source #modules modules
- #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 (defsig tokens)
(let [[export? tokens'] (: (, Bool (List AST))
(case tokens
@@ -3238,7 +3266,7 @@
(defmacro #export (loop tokens)
(case tokens
- (\ (list [_ (#TupleS bindings)] body))
+ (\ (@list [_ (#TupleS bindings)] body))
(let [pairs (as-pairs bindings)
vars (map first pairs)
inits (map second pairs)]
@@ -3250,19 +3278,19 @@
#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))))))
+ (return (@list (` ((: (-> (~@ (map type->syntax init-types))
+ (~ (type->syntax expected)))
+ (lambda (~ (symbol$ ["" "recur"])) [(~@ vars)]
+ (~ body)))
+ (~@ inits))))))
(do Lux/Monad
[aliases (map% Lux/Monad
(: (-> AST (Lux AST))
(lambda [_] (gensym "")))
inits)]
- (return (list (` (let [(~@ (interleave aliases inits))]
- (;loop [(~@ (interleave vars aliases))]
- (~ body)))))))))
+ (return (@list (` (let [(~@ (interleave aliases inits))]
+ (;loop [(~@ (interleave vars aliases))]
+ (~ body)))))))))
_
(fail "Wrong syntax for loop")))
@@ -3272,7 +3300,7 @@
(defmacro #export (\slots tokens)
(case tokens
- (\ (list body [_ (#TupleS (list& hslot' tslots'))]))
+ (\ (@list body [_ (#TupleS (@list& hslot' tslots'))]))
(do Lux/Monad
[slots (: (Lux (, Ident (List Ident)))
(case (: (Maybe (, Ident (List Ident)))
@@ -3293,7 +3321,7 @@
#let [[idx tags type] output
slot-pairings (map (: (-> Ident (, Text AST))
(lambda [[module name]] [name (symbol$ ["" name])]))
- (list& hslot tslots))
+ (@list& hslot tslots))
pattern (record$ (map (: (-> Ident (, AST AST))
(lambda [[module name]]
(let [tag (tag$ [module name])]
@@ -3301,7 +3329,7 @@
(#Some binding) [tag binding]
#None [tag g!_]))))
tags))]]
- (return (list pattern body)))
+ (return (@list pattern body)))
_
(fail "Wrong syntax for \\slots")))
diff --git a/source/lux/control/comonad.lux b/source/lux/control/comonad.lux
index 052b8768d..8e12c24c0 100644
--- a/source/lux/control/comonad.lux
+++ b/source/lux/control/comonad.lux
@@ -29,7 +29,7 @@
## [Syntax]
(defmacro #export (be tokens state)
(case tokens
- (\ (list monad [_ (#;TupleS bindings)] body))
+ (\ (@list comonad [_ (#;TupleS bindings)] body))
(let [body' (foldL (: (-> AST (, AST AST) AST)
(lambda [body' binding]
(let [[var value] binding]
@@ -42,9 +42,9 @@
(~ value)))))))
body
(reverse (as-pairs bindings)))]
- (#;Right [state (list (` (;case (~ monad)
- {#;return ;return #;bind ;bind}
- (~ body'))))]))
+ (#;Right [state (@list (` (;case (~ comonad)
+ {#;return ;return #;bind ;bind}
+ (~ body'))))]))
_
(#;Left "Wrong syntax for be")))
diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux
index 77dbec5b1..7c0affd68 100644
--- a/source/lux/data/maybe.lux
+++ b/source/lux/data/maybe.lux
@@ -41,18 +41,9 @@
#;None #;None
(#;Some xs) xs)))
-## [Syntax]
-(defmacro #export (? tokens state)
- (case tokens
- (\ (list maybe else))
- (let [g!value (symbol$ ["" "_"])
- g!_ (symbol$ ["" "12_34"])]
- (#;Right state (list (` (case (~ maybe)
- (#;Some (~ g!value))
- (~ g!value)
-
- (~ g!_)
- (~ else))))))
-
- _
- (#;Left "Wrong syntax for ?")))
+## [Functions]
+(def #export (? else maybe)
+ (All [a] (-> a (Maybe a) a))
+ (case maybe
+ (#;Some x) x
+ _ else))
diff --git a/source/program.lux b/source/program.lux
index 716e3e6c6..1b6c6f398 100644
--- a/source/program.lux
+++ b/source/program.lux
@@ -4,32 +4,30 @@
## You can obtain one at http://mozilla.org/MPL/2.0/.
(;import lux
- (lux (control monoid
+ (lux (control (monoid #as m)
functor
monad
comonad
bounded
- dict
eq
hash
- ord
- show
- number
- stack)
+ (ord #as O)
+ (show #as S)
+ number)
(data bool
char
(either #as e)
- error
id
io
- list
+ (list #refer #all #open ("list:" List/Functor))
maybe
- (number int
+ (number (int #refer #all #open ("" Int/Show))
real)
- (text #refer (#only <>))
+ (text #refer (#only <>) #open ("text:" Text/Monoid))
writer
- tuple)
- (codata (stream #as S)
+ tuple
+ )
+ (codata (stream #as s)
lazy
function
(reader #as r)
@@ -39,13 +37,14 @@
lux
macro
syntax)
- (math #as m)
+ math
))
(program args
(case args
- (\ (list name))
+ (\ (@list name))
(println (<> "Hello, #{name}!"))
_
- (println "Hello, world!")))
+ (println "Hello, world!")
+ ))