aboutsummaryrefslogtreecommitdiff
path: root/source/lux/meta/syntax.lux
diff options
context:
space:
mode:
Diffstat (limited to 'source/lux/meta/syntax.lux')
-rw-r--r--source/lux/meta/syntax.lux262
1 files changed, 262 insertions, 0 deletions
diff --git a/source/lux/meta/syntax.lux b/source/lux/meta/syntax.lux
new file mode 100644
index 000000000..1fe85c32f
--- /dev/null
+++ b/source/lux/meta/syntax.lux
@@ -0,0 +1,262 @@
+## 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
+ (.. (macro #as m #refer #all)
+ (lux #as l #refer (#only Lux/Monad gensym)))
+ (lux (control (functor #as F)
+ (monad #as M #refer (#only do)))
+ (data (eq #as E)
+ (bool #as b)
+ (char #as c)
+ (text #as t)
+ list)))
+
+## [Utils]
+(def (first xy)
+ (All [a b] (-> (, a b) a))
+ (let [[x y] xy]
+ x))
+
+(def (join-pairs pairs)
+ (All [a] (-> (List (, a a)) (List a)))
+ (case pairs
+ #;Nil #;Nil
+ (#;Cons [[x y] pairs']) (list& x y (join-pairs pairs'))))
+
+## Types
+(deftype #export (Parser a)
+ (-> (List Syntax) (Maybe (, (List Syntax) a))))
+
+## Structures
+(defstruct #export Parser/Functor (F;Functor Parser)
+ (def (F;map f ma)
+ (lambda [tokens]
+ (case (ma tokens)
+ #;None
+ #;None
+
+ (#;Some [tokens' a])
+ (#;Some [tokens' (f a)])))))
+
+(defstruct #export Parser/Monad (M;Monad Parser)
+ (def M;_functor Parser/Functor)
+
+ (def (M;wrap x tokens)
+ (#;Some [tokens x]))
+
+ (def (M;join mma)
+ (lambda [tokens]
+ (case (mma tokens)
+ #;None
+ #;None
+
+ (#;Some [tokens' ma])
+ (ma tokens')))))
+
+## Parsers
+(def #export (id^ tokens)
+ (Parser Syntax)
+ (case tokens
+ #;Nil #;None
+ (#;Cons [t tokens']) (#;Some [tokens' t])))
+
+(do-template [<name> <type> <tag>]
+ [(def #export (<name> tokens)
+ (Parser <type>)
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
+ (#;Some [tokens' x])
+
+ _
+ #;None))]
+
+ [ bool^ Bool #;BoolS]
+ [ int^ Int #;IntS]
+ [ real^ Real #;RealS]
+ [ char^ Char #;CharS]
+ [ text^ Text #;TextS]
+ [symbol^ Ident #;SymbolS]
+ [ tag^ Ident #;TagS]
+ )
+
+(do-template [<name> <tag>]
+ [(def #export (<name> tokens)
+ (Parser Text)
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> ["" x])]) tokens'])
+ (#;Some [tokens' x])
+
+ _
+ #;None))]
+
+ [local-symbol^ #;SymbolS]
+ [ local-tag^ #;TagS]
+ )
+
+(def (ident:= x y)
+ (-> Ident Ident Bool)
+ (let [[x1 x2] x
+ [y1 y2] y]
+ (and (text:= x1 y1)
+ (text:= x2 y2))))
+
+(do-template [<name> <type> <tag> <eq>]
+ [(def #export (<name> v tokens)
+ (-> <type> (Parser (,)))
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> x)]) tokens'])
+ (if (<eq> v x)
+ (#;Some [tokens' []])
+ #;None)
+
+ _
+ #;None))]
+
+ [ bool?^ Bool #;BoolS (:: b;Bool/Eq E;=)]
+ [ int?^ Int #;IntS i=]
+ [ real?^ Real #;RealS r=]
+ [ char?^ Char #;CharS (:: c;Char/Eq E;=)]
+ [ text?^ Text #;TextS (:: t;Text/Eq E;=)]
+ [symbol?^ Ident #;SymbolS ident:=]
+ [ tag?^ Ident #;TagS ident:=]
+ )
+
+(do-template [<name> <tag>]
+ [(def #export (<name> p tokens)
+ (All [a]
+ (-> (Parser a) (Parser a)))
+ (case tokens
+ (#;Cons [(#;Meta [_ (<tag> form)]) tokens'])
+ (case (p form)
+ (#;Some [#;Nil x]) (#;Some [tokens' x])
+ _ #;None)
+
+ _
+ #;None))]
+
+ [ form^ #;FormS]
+ [tuple^ #;TupleS]
+ )
+
+(def #export (?^ p tokens)
+ (All [a]
+ (-> (Parser a) (Parser (Maybe a))))
+ (case (p tokens)
+ #;None (#;Some [tokens #;None])
+ (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)])))
+
+(def (run-parser p tokens)
+ (All [a]
+ (-> (Parser a) (List Syntax) (Maybe (, (List Syntax) a))))
+ (p tokens))
+
+(def #export (*^ p tokens)
+ (All [a]
+ (-> (Parser a) (Parser (List a))))
+ (case (p tokens)
+ #;None (#;Some [tokens (list)])
+ (#;Some [tokens' x]) (run-parser (do Parser/Monad
+ [xs (*^ p)]
+ (M;wrap (list& x xs)))
+ tokens')))
+
+(def #export (+^ p)
+ (All [a]
+ (-> (Parser a) (Parser (List a))))
+ (do Parser/Monad
+ [x p
+ xs (*^ p)]
+ (M;wrap (list& x xs))))
+
+(def #export (&^ p1 p2)
+ (All [a b]
+ (-> (Parser a) (Parser b) (Parser (, a b))))
+ (do Parser/Monad
+ [x1 p1
+ x2 p2]
+ (M;wrap [x1 x2])))
+
+(def #export (|^ p1 p2 tokens)
+ (All [a b]
+ (-> (Parser a) (Parser b) (Parser (Either b))))
+ (case (p1 tokens)
+ (#;Some [tokens' x1]) (#;Some [tokens' (#;Left x1)])
+ #;None (run-parser (do Parser/Monad
+ [x2 p2]
+ (M;wrap (#;Right x2)))
+ tokens)))
+
+(def #export (||^ ps tokens)
+ (All [a]
+ (-> (List (Parser a)) (Parser (Maybe a))))
+ (case ps
+ #;Nil #;None
+ (#;Cons [p ps']) (case (p tokens)
+ #;None (||^ ps' tokens)
+ (#;Some [tokens' x]) (#;Some [tokens' (#;Some x)]))
+ ))
+
+(def #export (end^ tokens)
+ (Parser (,))
+ (case tokens
+ #;Nil (#;Some [tokens []])
+ _ #;None))
+
+## Syntax
+(defmacro #export (defsyntax tokens)
+ (let [[exported? tokens] (: (, Bool (List Syntax))
+ (case tokens
+ (\ (list& (#;Meta [_ (#;TagS ["" "export"])]) tokens'))
+ [true tokens']
+
+ _
+ [false tokens]))]
+ (case tokens
+ (\ (list (#;Meta [_ (#;FormS (list& (#;Meta [_ (#;SymbolS ["" name])]) args))])
+ body))
+ (do Lux/Monad
+ [names+parsers (M;map% Lux/Monad
+ (: (-> Syntax (Lux (, Syntax Syntax)))
+ (lambda [arg]
+ (case arg
+ (\ (#;Meta [_ (#;TupleS (list (#;Meta [_ (#;SymbolS var-name)])
+ parser))]))
+ (M;wrap [(symbol$ var-name) parser])
+
+ (\ (#;Meta [_ (#;SymbolS var-name)]))
+ (M;wrap [(symbol$ var-name) (` id^)])
+
+ _
+ (l;fail "Syntax pattern expects 2-tuples or symbols."))))
+ args)
+ g!tokens (gensym "tokens")
+ g!_ (gensym "_")
+ #let [names (:: List/Functor (F;map first names+parsers))
+ error-msg (text$ (text:++ "Wrong syntax for " name))
+ body' (foldL (: (-> Syntax (, Syntax Syntax) Syntax)
+ (lambda [body name+parser]
+ (let [[name parser] name+parser]
+ (` (_lux_case ((~ parser) (~ g!tokens))
+ (#;Some [(~ g!tokens) (~ name)])
+ (~ body)
+
+ (~ g!_)
+ (l;fail (~ error-msg)))))))
+ body
+ (reverse names+parsers))
+ macro-def (: Syntax
+ (` (m;defmacro ((~ (symbol$ ["" name])) (~ g!tokens))
+ (~ body'))))]]
+ (M;wrap (list& macro-def
+ (if exported?
+ (list (` (_lux_export (~ (symbol$ ["" name])))))
+ (list)))))
+
+ _
+ (l;fail "Wrong syntax for defsyntax"))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-13 02:19:14 +0000