aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/macro/syntax.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/macro/syntax.lux')
-rw-r--r--stdlib/source/lux/macro/syntax.lux297
1 files changed, 297 insertions, 0 deletions
diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux
new file mode 100644
index 000000000..917b7e094
--- /dev/null
+++ b/stdlib/source/lux/macro/syntax.lux
@@ -0,0 +1,297 @@
+(;module:
+ lux
+ (lux [macro #+ with-gensyms]
+ (control [monad #+ do Monad]
+ [eq #+ Eq]
+ ["p" parser])
+ (data [bool]
+ [number]
+ [text "text/" Monoid<Text>]
+ [ident]
+ (coll [list "list/" Functor<List>])
+ [product]
+ [maybe]
+ ["E" error]))
+ (.. [code "code/" Eq<Code>]))
+
+## [Utils]
+(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]
+(type: #export Syntax
+ {#;doc "A Lux syntax parser."}
+ (p;Parser (List Code)))
+
+## [Utils]
+(def: (remaining-inputs asts)
+ (-> (List Code) Text)
+ ($_ text/compose "\nRemaining input: "
+ (|> asts (list/map code;to-text) (list;interpose " ") (text;join-with ""))))
+
+## [Syntaxs]
+(def: #export any
+ {#;doc "Just returns the next input without applying any logic."}
+ (Syntax Code)
+ (function [tokens]
+ (case tokens
+ #;Nil (#E;Error "There are no tokens to parse!")
+ (#;Cons [t tokens']) (#E;Success [tokens' t]))))
+
+(do-template [<get-name> <type> <tag> <eq> <desc>]
+ [(def: #export <get-name>
+ {#;doc (code;text ($_ text/compose "Parses the next " <desc> " input Code."))}
+ (Syntax <type>)
+ (function [tokens]
+ (case tokens
+ (#;Cons [[_ (<tag> x)] tokens'])
+ (#E;Success [tokens' x])
+
+ _
+ (#E;Error ($_ text/compose "Cannot parse " <desc> (remaining-inputs tokens))))))]
+
+ [ bool Bool #;Bool bool;Eq<Bool> "bool"]
+ [ nat Nat #;Nat number;Eq<Nat> "nat"]
+ [ int Int #;Int number;Eq<Int> "int"]
+ [ deg Deg #;Deg number;Eq<Deg> "deg"]
+ [ frac Frac #;Frac number;Eq<Frac> "frac"]
+ [ text Text #;Text text;Eq<Text> "text"]
+ [symbol Ident #;Symbol ident;Eq<Ident> "symbol"]
+ [ tag Ident #;Tag ident;Eq<Ident> "tag"]
+ )
+
+(def: #export (this? ast)
+ {#;doc "Asks if the given Code is the next input."}
+ (-> Code (Syntax Bool))
+ (function [tokens]
+ (case tokens
+ (#;Cons [token tokens'])
+ (let [is-it? (code/= ast token)
+ remaining (if is-it?
+ tokens'
+ tokens)]
+ (#E;Success [remaining is-it?]))
+
+ _
+ (#E;Success [tokens false]))))
+
+(def: #export (this ast)
+ {#;doc "Ensures the given Code is the next input."}
+ (-> Code (Syntax Unit))
+ (function [tokens]
+ (case tokens
+ (#;Cons [token tokens'])
+ (if (code/= ast token)
+ (#E;Success [tokens' []])
+ (#E;Error ($_ text/compose "Expected a " (code;to-text ast) " but instead got " (code;to-text token)
+ (remaining-inputs tokens))))
+
+ _
+ (#E;Error "There are no tokens to parse!"))))
+
+(do-template [<name> <comp> <error>]
+ [(def: #export <name>
+ (Syntax Int)
+ (do p;Monad<Parser>
+ [n int
+ _ (p;assert <error> (<comp> 0 n))]
+ (wrap n)))]
+
+ [pos-int i.> "Expected a positive integer: N > 0"]
+ [neg-int i.< "Expected a negative integer: N < 0"]
+ )
+
+(do-template [<name> <tag> <desc>]
+ [(def: #export <name>
+ {#;doc (code;text ($_ text/compose "Parse a local " <desc> " (a " <desc> " that has no module prefix)."))}
+ (Syntax Text)
+ (function [tokens]
+ (case tokens
+ (#;Cons [[_ (<tag> ["" x])] tokens'])
+ (#E;Success [tokens' x])
+
+ _
+ (#E;Error ($_ text/compose "Cannot parse local " <desc> (remaining-inputs tokens))))))]
+
+ [local-symbol #;Symbol "symbol"]
+ [ local-tag #;Tag "tag"]
+ )
+
+(do-template [<name> <tag> <desc>]
+ [(def: #export (<name> p)
+ {#;doc (code;text ($_ text/compose "Parse inside the contents of a " <desc> " as if they were the input Codes."))}
+ (All [a]
+ (-> (Syntax a) (Syntax a)))
+ (function [tokens]
+ (case tokens
+ (#;Cons [[_ (<tag> members)] tokens'])
+ (case (p members)
+ (#E;Success [#;Nil x]) (#E;Success [tokens' x])
+ _ (#E;Error ($_ text/compose "Syntax was expected to fully consume " <desc> (remaining-inputs tokens))))
+
+ _
+ (#E;Error ($_ text/compose "Cannot parse " <desc> (remaining-inputs tokens))))))]
+
+ [ form #;Form "form"]
+ [tuple #;Tuple "tuple"]
+ )
+
+(def: #export (record p)
+ {#;doc (code;text ($_ text/compose "Parse inside the contents of a record as if they were the input Codes."))}
+ (All [a]
+ (-> (Syntax a) (Syntax a)))
+ (function [tokens]
+ (case tokens
+ (#;Cons [[_ (#;Record pairs)] tokens'])
+ (case (p (join-pairs pairs))
+ (#E;Success [#;Nil x]) (#E;Success [tokens' x])
+ _ (#E;Error ($_ text/compose "Syntax was expected to fully consume record" (remaining-inputs tokens))))
+
+ _
+ (#E;Error ($_ text/compose "Cannot parse record" (remaining-inputs tokens))))))
+
+(def: #export end!
+ {#;doc "Ensures there are no more inputs."}
+ (Syntax Unit)
+ (function [tokens]
+ (case tokens
+ #;Nil (#E;Success [tokens []])
+ _ (#E;Error ($_ text/compose "Expected list of tokens to be empty!" (remaining-inputs tokens))))))
+
+(def: #export end?
+ {#;doc "Checks whether there are no more inputs."}
+ (Syntax Bool)
+ (function [tokens]
+ (case tokens
+ #;Nil (#E;Success [tokens true])
+ _ (#E;Success [tokens false]))))
+
+(def: #export (on compiler action)
+ {#;doc "Run a Lux operation as if it was a Syntax parser."}
+ (All [a] (-> Compiler (Meta a) (Syntax a)))
+ (function [input]
+ (case (macro;run compiler action)
+ (#E;Error error)
+ (#E;Error error)
+
+ (#E;Success value)
+ (#E;Success [input value])
+ )))
+
+(def: #export (run inputs syntax)
+ (All [a] (-> (List Code) (Syntax a) (E;Error a)))
+ (case (syntax inputs)
+ (#E;Error error)
+ (#E;Error error)
+
+ (#E;Success [unconsumed value])
+ (case unconsumed
+ #;Nil
+ (#E;Success value)
+
+ _
+ (#E;Error (text/compose "Unconsumed inputs: "
+ (|> (list/map code;to-text unconsumed)
+ (text;join-with ", ")))))))
+
+(def: #export (local inputs syntax)
+ {#;doc "Run a syntax parser with the given list of inputs, instead of the real ones."}
+ (All [a] (-> (List Code) (Syntax a) (Syntax a)))
+ (function [real]
+ (do E;Monad<Error>
+ [value (run inputs syntax)]
+ (wrap [real value]))))
+
+## [Syntax]
+(def: #hidden text.join-with text;join-with)
+
+(def: #hidden _run_ p;run)
+(def: #hidden _Monad<Parser>_ p;Monad<Parser>)
+
+(macro: #export (syntax: tokens)
+ {#;doc (doc "A more advanced way to define macros than macro:."
+ "The inputs to the macro can be parsed in complex ways through the use of syntax parsers."
+ "The macro body is also (implicitly) run in the Monad<Meta>, to save some typing."
+ "Also, the compiler state can be accessed through the *compiler* binding."
+ (syntax: #export (object [#let [imports (class-imports *compiler*)]]
+ [#let [class-vars (list)]]
+ [super (opt (super-class-decl^ imports class-vars))]
+ [interfaces (tuple (some (super-class-decl^ imports class-vars)))]
+ [constructor-args (constructor-args^ imports class-vars)]
+ [methods (some (overriden-method-def^ imports))])
+ (let [def-code ($_ text/compose "anon-class:"
+ (spaced (list (super-class-decl$ (maybe;default object-super-class super))
+ (with-brackets (spaced (list/map super-class-decl$ interfaces)))
+ (with-brackets (spaced (list/map constructor-arg$ constructor-args)))
+ (with-brackets (spaced (list/map (method-def$ id) methods))))))]
+ (wrap (list (` ((~ (code;text def-code)))))))))}
+ (let [[exported? tokens] (case tokens
+ (^ (list& [_ (#;Tag ["" "hidden"])] tokens'))
+ [(#;Some #;Left) tokens']
+
+ (^ (list& [_ (#;Tag ["" "export"])] tokens'))
+ [(#;Some #;Right) tokens']
+
+ _
+ [#;None tokens])
+ ?parts (: (Maybe [Text (List Code) Code Code])
+ (case tokens
+ (^ (list [_ (#;Form (list& [_ (#;Symbol ["" name])] args))]
+ body))
+ (#;Some name args (` {}) body)
+
+ (^ (list [_ (#;Form (list& [_ (#;Symbol ["" name])] args))]
+ meta-data
+ body))
+ (#;Some name args meta-data body)
+
+ _
+ #;None))]
+ (case ?parts
+ (#;Some [name args meta body])
+ (with-gensyms [g!tokens g!body g!msg]
+ (do macro;Monad<Meta>
+ [vars+parsers (monad;map @
+ (: (-> Code (Meta [Code Code]))
+ (function [arg]
+ (case arg
+ (^ [_ (#;Tuple (list var parser))])
+ (wrap [var parser])
+
+ [_ (#;Symbol var-name)]
+ (wrap [(code;symbol var-name) (` any)])
+
+ _
+ (macro;fail "Syntax pattern expects tuples or symbols."))))
+ args)
+ #let [g!state (code;symbol ["" "*compiler*"])
+ error-msg (code;text (text/compose "Wrong syntax for " name))
+ export-ast (: (List Code) (case exported?
+ (#;Some #E;Error)
+ (list (' #hidden))
+
+ (#;Some #E;Success)
+ (list (' #export))
+
+ _
+ (list)))]]
+ (wrap (list (` (macro: (~@ export-ast) ((~ (code;symbol ["" name])) (~ g!tokens) (~ g!state))
+ (~ meta)
+ ("lux case" (;;run (~ g!tokens)
+ (: (Syntax (Meta (List Code)))
+ (do ;;_Monad<Parser>_
+ [(~@ (join-pairs vars+parsers))]
+ ((~' wrap) (do macro;Monad<Meta>
+ []
+ (~ body))))))
+ {(#E;Success (~ g!body))
+ ((~ g!body) (~ g!state))
+
+ (#E;Error (~ g!msg))
+ (#E;Error (text.join-with ": " (list (~ error-msg) (~ g!msg))))})))))))
+
+ _
+ (macro;fail "Wrong syntax for syntax:"))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 06:44:03 +0000