From 455018ec68f2c127db489048351bc48f3982fe23 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 01:03:19 -0400 Subject: - Expanded the standard library. - Fixed some minor bugs. - Added the updated code for the parser (forgot to add it to a previous commit). --- source/lux.lux | 16 ++++---- source/lux/control/enum.lux | 25 +++++++++++++ source/lux/control/fold.lux | 42 +++++++++++++++++++++ source/lux/control/monad.lux | 51 +++++++++++++++---------- source/lux/data/ident.lux | 33 +++++++++++++++++ source/lux/data/list.lux | 88 ++++++++++++++++++++++++++++++++++++++++++-- source/lux/data/maybe.lux | 3 +- source/lux/data/text.lux | 14 +++++-- source/lux/data/tuple.lux | 3 +- source/lux/math.lux | 22 ++++++++++- source/lux/meta/ast.lux | 72 +++++++++++++++++++++++++++++++++++- source/program.lux | 5 ++- src/lux/parser.clj | 49 ++++++++---------------- src/lux/type.clj | 6 +-- 14 files changed, 350 insertions(+), 79 deletions(-) create mode 100644 source/lux/control/enum.lux create mode 100644 source/lux/control/fold.lux create mode 100644 source/lux/data/ident.lux diff --git a/source/lux.lux b/source/lux.lux index 5f5c6925b..164dea835 100644 --- a/source/lux.lux +++ b/source/lux.lux @@ -2932,23 +2932,23 @@ _ (fail "Can only \"use\" records."))) + + [_ (#TupleS members)] + (return (@list (foldL (: (-> AST AST AST) + (lambda [body' struct'] (` (;;using (~ struct') (~ body'))))) + body + members))) _ (let [dummy (symbol$ ["" ""])] (return (@list (` (;_lux_case (~ struct) (~ dummy) - (;using (~ dummy) - (~ body)))))))) + (;;using (~ dummy) + (~ body)))))))) _ (fail "Wrong syntax for using"))) -(def (flip f) - (All [a b c] - (-> (-> a b c) (-> b a c))) - (lambda [y x] - (f x y))) - (defmacro #export (cond tokens) (if (i= 0 (i% (length tokens) 2)) (fail "cond requires an even number of arguments.") diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux new file mode 100644 index 000000000..34910c837 --- /dev/null +++ b/source/lux/control/enum.lux @@ -0,0 +1,25 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux/control ord)) + +## [Signatures] +(defsig #export (Enum e) + (: (Ord e) _ord) + (: (-> e e) succ) + (: (-> e e) pre)) + +## [Functions] +(def #export (range' <= succ from to) + (All [a] (-> (-> a a Bool) (-> a a) a a (List a))) + (if (<= from to) + (#;Cons from (range' <= succ (succ from) to)) + #;Nil)) + +(def #export (range enum from to) + (All [a] (-> (Enum a) a a (List a))) + (using enum + (range' <= succ from to))) diff --git a/source/lux/control/fold.lux b/source/lux/control/fold.lux new file mode 100644 index 000000000..d0aef1576 --- /dev/null +++ b/source/lux/control/fold.lux @@ -0,0 +1,42 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux (control monoid + eq) + (data/number/int #open ("i" Int/Number Int/Eq)))) + +## [Signatures] +(defsig #export (Fold F) + (: (All [a b] + (-> (-> a b a) a (F b) a)) + foldL) + (: (All [a b] + (-> (-> b a a) a (F b) a)) + foldR)) + +## [Functions] +(def #export (foldM mon fold xs) + (All [F a] (-> (Monoid a) (Fold F) (F a) a)) + (using [mon fold] + (foldL ++ unit xs))) + +(def #export (size fold xs) + (All [F a] (-> (Fold F) (F a) Int)) + (using fold + (foldL (lambda [count _] (i+ 1 count)) + 0 + xs))) + +(def #export (member? eq fold x xs) + (All [F a] (-> (Eq a) (Fold F) a (F a) Bool)) + (using [eq fold] + (foldL (lambda [prev x'] (or prev (= x x'))) + false + xs))) + +(def #export (empty? fold xs) + (All [F a] (-> (Fold F) (F a) Bool)) + (i= 0 (size fold xs))) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 8e59ae941..b286545a7 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -6,8 +6,7 @@ (;import lux (.. (functor #as F) (monoid #as M)) - (lux/meta macro - ast)) + (lux/meta macro)) ## [Utils] (def (foldL f init xs) @@ -17,21 +16,21 @@ #;Nil init - (#;Cons [x xs']) + (#;Cons x xs') (foldL f (f init x) xs'))) (def (reverse xs) (All [a] (-> (List a) (List a))) - (foldL (lambda [tail head] (#;Cons [head tail])) + (foldL (lambda [tail head] (#;Cons head tail)) #;Nil xs)) (def (as-pairs xs) (All [a] (-> (List a) (List (, a a)))) (case xs - (#;Cons [x1 (#;Cons [x2 xs'])]) - (#;Cons [[x1 x2] (as-pairs xs')]) + (#;Cons x1 (#;Cons x2 xs')) + (#;Cons [x1 x2] (as-pairs xs')) _ #;Nil)) @@ -50,10 +49,9 @@ ## [Syntax] (defmacro #export (do tokens state) (case tokens - ## (\ (list monad [_ (#;TupleS bindings)] body)) - (#;Cons [monad (#;Cons [[_ (#;TupleS bindings)] (#;Cons [body #;Nil])])]) - (let [g!map (symbol$ ["" " map "]) - g!join (symbol$ ["" " join "]) + (#;Cons monad (#;Cons [_ (#;TupleS bindings)] (#;Cons body #;Nil))) + (let [g!map (: AST [["" -1 -1] (#;SymbolS ["" " map "])]) + g!join (: AST [["" -1 -1] (#;SymbolS ["" " join "])]) body' (foldL (: (-> AST (, AST AST) AST) (lambda [body' binding] (let [[var value] binding] @@ -82,16 +80,31 @@ (using m (join (map f ma)))) -(def #export (map% m f xs) - (All [m a b] - (-> (Monad m) (-> a (m b)) (List a) (m (List b)))) +(def #export (seq% monad xs) + (All [M a] + (-> (Monad M) (List (M a)) (M (List a)))) + (case xs + #;Nil + (:: monad (;;wrap #;Nil)) + + (#;Cons x xs') + (do monad + [_x x + _xs (seq% monad xs')] + (wrap (#;Cons _x _xs))) + )) + +(def #export (map% monad f xs) + (All [M a b] + (-> (Monad M) (-> a (M b)) (List a) (M (List b)))) + ## (seq% monad (:: monad ;;_functor (F;map f xs))) (case xs #;Nil - (:: m (;;wrap #;Nil)) + (:: monad (;;wrap #;Nil)) - (#;Cons [x xs']) - (do m - [y (f x) - ys (map% m f xs')] - (wrap (#;Cons [y ys]))) + (#;Cons x xs') + (do monad + [_x (f x) + _xs (map% monad f xs')] + (wrap (#;Cons _x _xs))) )) diff --git a/source/lux/data/ident.lux b/source/lux/data/ident.lux new file mode 100644 index 000000000..cb2353e43 --- /dev/null +++ b/source/lux/data/ident.lux @@ -0,0 +1,33 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;import lux + (lux (control (eq #as E) + (show #as S)) + (data (text #open ("text:" Text/Monoid Text/Eq))))) + +## [Types] +## (deftype Ident +## (, Text Text)) + +## [Functions] +(do-template [ ] + [(def #export ( [left right]) + (-> Ident Text) + )] + + [module left] + [name right] + ) + +## [Structures] +(defstruct #export Ident/Eq (E;Eq Ident) + (def (= [xmodule xname] [ymodule yname]) + (and (text:= xmodule ymodule) + (text:= xname yname)))) + +(defstruct #export Ident/Show (S;Show Ident) + (def (show [module name]) + ($ text:++ module ";" name))) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index 489ac5b4f..b2049d419 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -8,7 +8,8 @@ (functor #as F #refer #all) (monad #as M #refer #all) (eq #as E) - (ord #as O)) + (ord #as O) + (fold #as f)) (data (number (int #open ("i" Int/Number Int/Ord))) bool) meta/macro)) @@ -39,6 +40,23 @@ (#;Cons [x xs']) (f x (foldR f init xs')))) +(defstruct #export List/Fold (f;Fold List) + (def (foldL f init xs) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (foldL f (f init x) xs'))) + + (def (foldR f init xs) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (f x (foldR f init xs'))))) + (def #export (fold mon xs) (All [a] (-> (m;Monoid a) (List a) a)) @@ -224,13 +242,75 @@ (case (reverse xs) (#;Cons last init) (#;Right state (@list (foldL (: (-> AST AST AST) - (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) - last - init))) + (lambda [tail head] (` (#;Cons (~ head) (~ tail))))) + last + init))) _ (#;Left "Wrong syntax for @list&"))) +## (defmacro #export (zip tokens state) +## (if (i> (size tokens) 0) +## (using List/Functor +## (let [indices (range 0 (i+ 1 (size tokens))) +## vars+lists (map (lambda [idx] +## (let [base (text:++ "_" idx)] +## [[["" -1 -1] (#SymbolS "" base)] +## [["" -1 -1] (#SymbolS "" (text:++ base "s"))]])) +## indices) +## pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) +## vars+lists))]) +## g!step [["" -1 -1] (#SymbolS "" "\tstep\t")] +## g!arg [["" -1 -1] (#SymbolS "" "\targ\t")] +## g!blank [["" -1 -1] (#SymbolS "" "\t_\t")] +## code (` ((lambda (~ g!step) [(~ g!arg)] +## (case (~ g!arg) +## (~ pattern) +## (#;Cons [(~@ vars)] ((~ g!step) [(~ (map second vars))])) + +## (~ g!blank) +## #;Nil)) +## [(~@ tokens)]))] +## (#;Right state (@list code)))) +## (#;Left "Can't zip no lists."))) + +## (defmacro #export (zip-with tokens state) +## (case tokens +## (@list& _f tokens) +## (case _f +## [_ (#;SymbolS _)] +## (if (i> (size tokens) 0) +## (using List/Functor +## (let [indices (range 0 (i+ 1 (size tokens))) +## vars+lists (map (lambda [idx] +## (let [base (text:++ "_" idx)] +## [[["" -1 -1] (#SymbolS "" base)] +## [["" -1 -1] (#SymbolS "" (text:++ base "s"))]])) +## indices) +## pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) +## vars+lists))]) +## g!step [["" -1 -1] (#SymbolS "" "\tstep\t")] +## g!arg [["" -1 -1] (#SymbolS "" "\targ\t")] +## g!blank [["" -1 -1] (#SymbolS "" "\t_\t")] +## code (` ((lambda (~ g!step) [(~ g!arg)] +## (case (~ g!arg) +## (~ pattern) +## (#;Cons ((~ _f) (~@ vars)) ((~ g!step) [(~ (map second vars))])) + +## (~ g!blank) +## #;Nil)) +## [(~@ tokens)]))] +## (#;Right state (@list code)))) +## (#;Left "Can't zip-with no lists.")) + +## _ +## (let [g!temp [["" -1 -1] (#SymbolS "" "\ttemp\t")]] +## (#;Right state (@list (` (let [(~ g!temp) (~ _f)] +## (;;zip-with (~@ (@list& g!temp tokens))))))))) + +## _ +## (#;Left "Wrong syntax for zip-with"))) + ## [Structures] ## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) ## (def (= xs ys) diff --git a/source/lux/data/maybe.lux b/source/lux/data/maybe.lux index 7c0affd68..2db3d768d 100644 --- a/source/lux/data/maybe.lux +++ b/source/lux/data/maybe.lux @@ -4,8 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (meta macro - ast) + (lux (meta macro) (control (monoid #as m #refer #all) (functor #as F #refer #all) (monad #as M #refer #all))) diff --git a/source/lux/data/text.lux b/source/lux/data/text.lux index e54dff5c0..f701f6079 100644 --- a/source/lux/data/text.lux +++ b/source/lux/data/text.lux @@ -4,8 +4,7 @@ ## You can obtain one at http://mozilla.org/MPL/2.0/. (;import lux - (lux (meta macro - ast) + (lux (meta macro) (control (monoid #as m) (eq #as E) (ord #as O) @@ -151,9 +150,18 @@ [_ in] (split 2 in) post-idx (index-of "}" in) [var post] (split post-idx in) - [_ post] (split 1 post)] + #let [[_ post] (? (: (, Text Text) ["" ""]) + (split 1 post))]] (wrap [pre var post]))) +(do-template [ ] + [(def ( value) + (-> AST) + [["" -1 -1] ( value)])] + + [text$ Text #;TextS] + [symbol$ Ident #;SymbolS]) + (def (unravel-template template) (-> Text (List AST)) (case (extract-var template) diff --git a/source/lux/data/tuple.lux b/source/lux/data/tuple.lux index f89f9b5ee..6eef74670 100644 --- a/source/lux/data/tuple.lux +++ b/source/lux/data/tuple.lux @@ -24,8 +24,7 @@ (def #export (uncurry f) (All [a b c] - (-> (-> a b c) - (-> (, a b) c))) + (-> (-> a b c) (-> (, a b) c))) (lambda [xy] (let [[x y] xy] (f x y)))) diff --git a/source/lux/math.lux b/source/lux/math.lux index f6fad566f..0f247cea8 100644 --- a/source/lux/math.lux +++ b/source/lux/math.lux @@ -3,7 +3,8 @@ ## If a copy of the MPL was not distributed with this file, ## You can obtain one at http://mozilla.org/MPL/2.0/. -(;import lux) +(;import lux + (lux/data/number/int #open ("i:" Int/Number))) ## [Constants] (do-template [ ] @@ -58,3 +59,22 @@ [atan2 "atan2"] [pow "pow"] ) + +(def (gcd' a b) + (-> Int Int Int) + (case b + 0 a + _ (gcd' b (i:% a b)))) + +(def #export (gcd a b) + (-> Int Int Int) + (gcd' (i:abs a) (i:abs b))) + +(def #export (lcm x y) + (-> Int Int Int) + (case (: (, Int Int) [x y]) + (\or [_ 0] [0 _]) + 0 + + _ + (i:abs (i:* (i:/ x (gcd x y)) y)))) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index a601739a1..78882c854 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -3,7 +3,17 @@ ## If a copy of the MPL was not distributed with this file, ## You can obtain one at http://mozilla.org/MPL/2.0/. -(;import lux) +(;import lux + (lux (control (show #as S #refer #all) + (eq #as E #refer #all)) + (data bool + (number int + real) + char + (text #refer #all #open ("text:" Text/Monoid)) + ident + (list #refer (#only List interpose) #open ("" List/Functor List/Fold)) + ))) ## [Types] ## (deftype (AST' w) @@ -41,3 +51,63 @@ [tuple$ (List AST) #;TupleS] [record$ (List (, AST AST)) #;RecordS] ) + +## [Structures] +(defstruct #export AST/Show (Show AST) + (def (show ast) + (case ast + (\template [ ] + [[_ ( value)] + (:: (S;show value))]) + [[#;BoolS Bool/Show] + [#;IntS Int/Show] + [#;RealS Real/Show] + [#;CharS Char/Show] + [#;TextS Text/Show]] + + (\template [ ] + [[_ ( ident)] + (text:++ (:: Ident/Show (S;show ident)))]) + [[#;SymbolS ""] [#;TagS "#"]] + + (\template [ ] + [[_ ( members)] + ($ text:++ (|> members (map show) (interpose "") (foldL text:++ text:unit)) )]) + [[#;FormS "(" ")"] [#;TupleS "[" "]"]] + + [_ (#;RecordS pairs)] + ($ text:++ "{" (|> pairs (map (lambda [[left right]] ($ text:++ (show left) " " (show right)))) (interpose "") (foldL text:++ text:unit)) "}") + ))) + +## (defstruct #export AST/Eq (Eq AST) +## (def (eq x y) +## (case [x y] +## (\template [ ] +## [[( x') ( y')] +## (:: (E;eq x' y'))]) +## [[#;BoolS Bool/Eq] +## [#;IntS Int/Eq] +## [#;RealS Real/Eq] +## [#;CharS Char/Eq] +## [#;TextS Text/Eq] +## [#;SymbolS Ident/Eq] +## [#;TagS Ident/Eq]] + +## (\template [] +## [[( xs') ( ys')] +## (and (:: Int/Eq (E;= (size xs') (size ys'))) +## (foldL (lambda [old [x' y']] +## (and old (= x' y'))) +## true +## (zip2 xs' ys')))]) +## [[#;FormS] [#;TupleS]] + +## [(#;RecordS xs') (#;RecordS ys')] +## (and (:: Int/Eq (E;= (size xs') (size ys'))) +## (foldL (lambda [old [[xl' xr'] [yl' yr']]] +## (and old (= xl' yl') (= xr' yr'))) +## true +## (zip2 xs' ys'))) + +## _ +## false))) diff --git a/source/program.lux b/source/program.lux index 69b9e811d..140710a4a 100644 --- a/source/program.lux +++ b/source/program.lux @@ -13,7 +13,8 @@ hash (ord #as O) (show #as S) - number) + number + enum) (data bool char (either #as e) @@ -21,7 +22,7 @@ io list maybe - (number (int #refer (#only)) + (number (int #refer (#only) #open ("i:" Int/Show)) (real #refer (#only))) (text #refer (#only <>) #open ("text:" Text/Monoid)) (writer #refer (#only)) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 2609bf9a5..dbd6ca2c5 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -10,25 +10,6 @@ (lux [base :as & :refer [deftags |do return fail |case]] [lexer :as &lexer]))) -;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" - ) - ;; [Utils] (do-template [ ] (defn [parse] @@ -41,8 +22,8 @@ _ (fail (str "[Parser Error] Unbalanced " "."))))) - ^:private parse-form $Close_Paren "parantheses" &/$FormS - ^:private parse-tuple $Close_Bracket "brackets" &/$TupleS + ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS + ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS ) (defn ^:private parse-record [parse] @@ -50,7 +31,7 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - [meta ($Close_Brace _)] + [meta (&lexer/$Close_Brace _)] (if (even? (&/|length elems)) (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) @@ -63,42 +44,42 @@ (|do [token &lexer/lex :let [[meta token*] token]] (|case token* - ($White_Space _) + (&lexer/$White_Space _) (return (&/|list)) - ($Comment _) + (&lexer/$Comment _) (return (&/|list)) - ($Bool ?value) + (&lexer/$Bool ?value) (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))) - ($Int ?value) + (&lexer/$Int ?value) (return (&/|list (&/T meta (&/V &/$IntS (Long/parseLong ?value))))) - ($Real ?value) + (&lexer/$Real ?value) (return (&/|list (&/T meta (&/V &/$RealS (Double/parseDouble ?value))))) - ($Char ^String ?value) + (&lexer/$Char ^String ?value) (return (&/|list (&/T meta (&/V &/$CharS (.charAt ?value 0))))) - ($Text ?value) + (&lexer/$Text ?value) (return (&/|list (&/T meta (&/V &/$TextS ?value)))) - ($Symbol ?ident) + (&lexer/$Symbol ?ident) (return (&/|list (&/T meta (&/V &/$SymbolS ?ident)))) - ($Tag ?ident) + (&lexer/$Tag ?ident) (return (&/|list (&/T meta (&/V &/$TagS ?ident)))) - ($Open_Paren _) + (&lexer/$Open_Paren _) (|do [syntax (parse-form parse)] (return (&/|list (&/T meta syntax)))) - ($Open_Bracket _) + (&lexer/$Open_Bracket _) (|do [syntax (parse-tuple parse)] (return (&/|list (&/T meta syntax)))) - ($Open_Brace _) + (&lexer/$Open_Brace _) (|do [syntax (parse-record parse)] (return (&/|list (&/T meta syntax)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 82eab3dd4..8300d470c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -724,9 +724,9 @@ (fn [state] (|case ((|do [F1 (deref ?eid)] (fn [state] - (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state)] + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state) (&/$Right state* output) (return* state* output) -- cgit v1.2.3