aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/macro
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/macro')
-rw-r--r--stdlib/source/lux/macro/code.lux143
-rw-r--r--stdlib/source/lux/macro/poly.lux448
-rw-r--r--stdlib/source/lux/macro/poly/eq.lux147
-rw-r--r--stdlib/source/lux/macro/poly/functor.lux95
-rw-r--r--stdlib/source/lux/macro/poly/json.lux312
-rw-r--r--stdlib/source/lux/macro/syntax.lux297
-rw-r--r--stdlib/source/lux/macro/syntax/common.lux27
-rw-r--r--stdlib/source/lux/macro/syntax/common/reader.lux150
-rw-r--r--stdlib/source/lux/macro/syntax/common/writer.lux24
9 files changed, 1643 insertions, 0 deletions
diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux
new file mode 100644
index 000000000..d41dbe240
--- /dev/null
+++ b/stdlib/source/lux/macro/code.lux
@@ -0,0 +1,143 @@
+(;module:
+ lux
+ (lux (control [eq #+ Eq])
+ (data bool
+ number
+ [text #+ Eq<Text> "Text/" Monoid<Text>]
+ ident
+ (coll [list #* "" Functor<List> Fold<List>])
+ )))
+
+## [Types]
+## (type: (Code' w)
+## (#;Bool Bool)
+## (#;Nat Nat)
+## (#;Int Int)
+## (#;Frac Frac)
+## (#;Text Text)
+## (#;Symbol Text Text)
+## (#;Tag Text Text)
+## (#;Form (List (w (Code' w))))
+## (#;Tuple (List (w (Code' w))))
+## (#;Record (List [(w (Code' w)) (w (Code' w))])))
+
+## (type: Code
+## (Ann Cursor (Code' (Ann Cursor))))
+
+## [Utils]
+(def: _cursor Cursor ["" +0 +0])
+
+## [Functions]
+(do-template [<name> <type> <tag>]
+ [(def: #export (<name> x)
+ (-> <type> Code)
+ [_cursor (<tag> x)])]
+
+ [bool Bool #;Bool]
+ [nat Nat #;Nat]
+ [int Int #;Int]
+ [deg Deg #;Deg]
+ [frac Frac #;Frac]
+ [text Text #;Text]
+ [symbol Ident #;Symbol]
+ [tag Ident #;Tag]
+ [form (List Code) #;Form]
+ [tuple (List Code) #;Tuple]
+ [record (List [Code Code]) #;Record]
+ )
+
+(do-template [<name> <tag> <doc>]
+ [(def: #export (<name> name)
+ {#;doc <doc>}
+ (-> Text Code)
+ [_cursor (<tag> ["" name])])]
+
+ [local-symbol #;Symbol "Produces a local symbol (a symbol with no module prefix)."]
+ [local-tag #;Tag "Produces a local tag (a tag with no module prefix)."])
+
+## [Structures]
+(struct: #export _ (Eq Code)
+ (def: (= x y)
+ (case [x y]
+ (^template [<tag> <eq>]
+ [[_ (<tag> x')] [_ (<tag> y')]]
+ (:: <eq> = x' y'))
+ ([#;Bool Eq<Bool>]
+ [#;Nat Eq<Nat>]
+ [#;Int Eq<Int>]
+ [#;Deg Eq<Deg>]
+ [#;Frac Eq<Frac>]
+ [#;Text Eq<Text>]
+ [#;Symbol Eq<Ident>]
+ [#;Tag Eq<Ident>])
+
+ (^template [<tag>]
+ [[_ (<tag> xs')] [_ (<tag> ys')]]
+ (and (:: Eq<Nat> = (size xs') (size ys'))
+ (fold (function [[x' y'] old]
+ (and old (= x' y')))
+ true
+ (zip2 xs' ys'))))
+ ([#;Form]
+ [#;Tuple])
+
+ [[_ (#;Record xs')] [_ (#;Record ys')]]
+ (and (:: Eq<Nat> = (size xs') (size ys'))
+ (fold (function [[[xl' xr'] [yl' yr']] old]
+ (and old (= xl' yl') (= xr' yr')))
+ true
+ (zip2 xs' ys')))
+
+ _
+ false)))
+
+## [Values]
+(def: #export (to-text ast)
+ (-> Code Text)
+ (case ast
+ (^template [<tag> <struct>]
+ [_ (<tag> value)]
+ (:: <struct> encode value))
+ ([#;Bool Codec<Text,Bool>]
+ [#;Nat Codec<Text,Nat>]
+ [#;Int Codec<Text,Int>]
+ [#;Deg Codec<Text,Deg>]
+ [#;Frac Codec<Text,Frac>]
+ [#;Symbol Codec<Text,Ident>])
+
+ [_ (#;Text value)]
+ (text;encode value)
+
+ [_ (#;Tag ident)]
+ (Text/compose "#" (:: Codec<Text,Ident> encode ident))
+
+ (^template [<tag> <open> <close>]
+ [_ (<tag> members)]
+ ($_ Text/compose <open> (|> members (map to-text) (interpose " ") (text;join-with "")) <close>))
+ ([#;Form "(" ")"]
+ [#;Tuple "[" "]"])
+
+ [_ (#;Record pairs)]
+ ($_ Text/compose "{" (|> pairs (map (function [[left right]] ($_ Text/compose (to-text left) " " (to-text right)))) (interpose " ") (text;join-with "")) "}")
+ ))
+
+(def: #export (replace original substitute ast)
+ {#;doc "Replaces all code that looks like the 'original' with the 'substitute'."}
+ (-> Code Code Code Code)
+ (if (:: Eq<Code> = original ast)
+ substitute
+ (case ast
+ (^template [<tag>]
+ [cursor (<tag> parts)]
+ [cursor (<tag> (map (replace original substitute) parts))])
+ ([#;Form]
+ [#;Tuple])
+
+ [cursor (#;Record parts)]
+ [cursor (#;Record (map (function [[left right]]
+ [(replace original substitute left)
+ (replace original substitute right)])
+ parts))]
+
+ _
+ ast)))
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
new file mode 100644
index 000000000..7ed7fb2ee
--- /dev/null
+++ b/stdlib/source/lux/macro/poly.lux
@@ -0,0 +1,448 @@
+(;module:
+ [lux #- function]
+ (lux (control [monad #+ do Monad]
+ [eq]
+ ["p" parser])
+ [function]
+ (data [text "text/" Monoid<Text>]
+ (coll [list "list/" Fold<List> Monad<List> Monoid<List>]
+ [dict #+ Dict])
+ [number "nat/" Codec<Text,Nat>]
+ [product]
+ [bool]
+ [maybe]
+ [ident "ident/" Eq<Ident> Codec<Text,Ident>]
+ ["e" error])
+ [macro #+ with-gensyms]
+ (macro [code]
+ ["s" syntax #+ syntax: Syntax]
+ (syntax ["cs" common]
+ (common ["csr" reader]
+ ["csw" writer])))
+ (lang [type]
+ (type [check]))
+ ))
+
+(type: #export Env (Dict Nat [Type Code]))
+
+(type: #export (Poly a)
+ (p;Parser [Env (List Type)] a))
+
+(def: #export fresh Env (dict;new number;Hash<Nat>))
+
+(def: (run' env types poly)
+ (All [a] (-> Env (List Type) (Poly a) (e;Error a)))
+ (case (p;run [env types] poly)
+ (#e;Error error)
+ (#e;Error error)
+
+ (#e;Success [[env' remaining] output])
+ (case remaining
+ #;Nil
+ (#e;Success output)
+
+ _
+ (#e;Error (|> remaining
+ (list/map type;to-text)
+ (text;join-with ", ")
+ (text/compose "Unconsumed types: "))))))
+
+(def: #export (run type poly)
+ (All [a] (-> Type (Poly a) (e;Error a)))
+ (run' fresh (list type) poly))
+
+(def: #export env
+ (Poly Env)
+ (;function [[env inputs]]
+ (#e;Success [[env inputs] env])))
+
+(def: (with-env temp poly)
+ (All [a] (-> Env (Poly a) (Poly a)))
+ (;function [[env inputs]]
+ (case (p;run [temp inputs] poly)
+ (#e;Error error)
+ (#e;Error error)
+
+ (#e;Success [[_ remaining] output])
+ (#e;Success [[env remaining] output]))))
+
+(def: #export peek
+ (Poly Type)
+ (;function [[env inputs]]
+ (case inputs
+ #;Nil
+ (#e;Error "Empty stream of types.")
+
+ (#;Cons headT tail)
+ (#e;Success [[env inputs] headT]))))
+
+(def: #export any
+ (Poly Type)
+ (;function [[env inputs]]
+ (case inputs
+ #;Nil
+ (#e;Error "Empty stream of types.")
+
+ (#;Cons headT tail)
+ (#e;Success [[env tail] headT]))))
+
+(def: #export (local types poly)
+ (All [a] (-> (List Type) (Poly a) (Poly a)))
+ (;function [[env pass-through]]
+ (case (run' env types poly)
+ (#e;Error error)
+ (#e;Error error)
+
+ (#e;Success output)
+ (#e;Success [[env pass-through] output]))))
+
+(def: (label idx)
+ (-> Nat Code)
+ (code;local-symbol (text/compose "label\u0000" (nat/encode idx))))
+
+(def: #export (with-extension type poly)
+ (All [a] (-> Type (Poly a) (Poly [Code a])))
+ (;function [[env inputs]]
+ (let [current-id (dict;size env)
+ g!var (label current-id)]
+ (case (p;run [(dict;put current-id [type g!var] env)
+ inputs]
+ poly)
+ (#e;Error error)
+ (#e;Error error)
+
+ (#e;Success [[_ inputs'] output])
+ (#e;Success [[env inputs'] [g!var output]])))))
+
+(do-template [<combinator> <name> <type>]
+ [(def: #export <combinator>
+ (Poly Unit)
+ (do p;Monad<Parser>
+ [headT any]
+ (case (type;un-name headT)
+ <type>
+ (wrap [])
+
+ _
+ (p;fail ($_ text/compose "Not " <name> " type: " (type;to-text headT))))))]
+
+ [void "Void" #;Void]
+ [unit "Unit" #;Unit]
+ [bool "Bool" (#;Primitive "#Bool" #;Nil)]
+ [nat "Nat" (#;Primitive "#Nat" #;Nil)]
+ [int "Int" (#;Primitive "#Int" #;Nil)]
+ [deg "Deg" (#;Primitive "#Deg" #;Nil)]
+ [frac "Frac" (#;Primitive "#Frac" #;Nil)]
+ [text "Text" (#;Primitive "#Text" #;Nil)]
+ )
+
+(def: #export basic
+ (Poly Type)
+ (do p;Monad<Parser>
+ [headT any]
+ (case (run headT ($_ p;either
+ void
+ unit
+ bool
+ nat
+ int
+ deg
+ frac
+ text))
+ (#e;Error error)
+ (p;fail error)
+
+ (#e;Success _)
+ (wrap headT))))
+
+(do-template [<name> <flattener> <tag>]
+ [(def: #export (<name> poly)
+ (All [a] (-> (Poly a) (Poly a)))
+ (do p;Monad<Parser>
+ [headT any]
+ (let [members (<flattener> (type;un-name headT))]
+ (if (n.> +1 (list;size members))
+ (local members poly)
+ (p;fail ($_ text/compose "Not a " (ident/encode (ident-for <tag>)) " type: " (type;to-text headT)))))))]
+
+ [variant type;flatten-variant #;Sum]
+ [tuple type;flatten-tuple #;Product]
+ )
+
+(def: polymorphic'
+ (Poly [Nat Type])
+ (do p;Monad<Parser>
+ [headT any
+ #let [[num-arg bodyT] (type;flatten-univ-q (type;un-name headT))]]
+ (if (n.= +0 num-arg)
+ (p;fail ($_ text/compose "Non-polymorphic type: " (type;to-text headT)))
+ (wrap [num-arg bodyT]))))
+
+(def: #export (polymorphic poly)
+ (All [a] (-> (Poly a) (Poly [Code (List Code) a])))
+ (do p;Monad<Parser>
+ [headT any
+ funcI (:: @ map dict;size ;;env)
+ [num-args non-poly] (local (list headT) polymorphic')
+ env ;;env
+ #let [funcL (label funcI)
+ [all-varsL env'] (loop [current-arg +0
+ env' env
+ all-varsL (: (List Code) (list))]
+ (if (n.< num-args current-arg)
+ (if (n.= +0 current-arg)
+ (let [varL (label (n.inc funcI))]
+ (recur (n.inc current-arg)
+ (|> env'
+ (dict;put funcI [headT funcL])
+ (dict;put (n.inc funcI) [(#;Bound (n.inc funcI)) varL]))
+ (#;Cons varL all-varsL)))
+ (let [partialI (|> current-arg (n.* +2) (n.+ funcI))
+ partial-varI (n.inc partialI)
+ partial-varL (label partial-varI)
+ partialC (` ((~ funcL) (~@ (|> (list;n.range +0 (n.dec num-args))
+ (list/map (|>. (n.* +2) n.inc (n.+ funcI) label))
+ list;reverse))))]
+ (recur (n.inc current-arg)
+ (|> env'
+ (dict;put partialI [;Void partialC])
+ (dict;put partial-varI [(#;Bound partial-varI) partial-varL]))
+ (#;Cons partial-varL all-varsL))))
+ [all-varsL env']))]]
+ (|> (do @
+ [output poly]
+ (wrap [funcL all-varsL output]))
+ (local (list non-poly))
+ (with-env env'))))
+
+(def: #export (function in-poly out-poly)
+ (All [i o] (-> (Poly i) (Poly o) (Poly [i o])))
+ (do p;Monad<Parser>
+ [headT any
+ #let [[inputsT outputT] (type;flatten-function (type;un-name headT))]]
+ (if (n.> +0 (list;size inputsT))
+ (p;seq (local inputsT in-poly)
+ (local (list outputT) out-poly))
+ (p;fail ($_ text/compose "Non-function type: " (type;to-text headT))))))
+
+(def: #export (apply poly)
+ (All [a] (-> (Poly a) (Poly a)))
+ (do p;Monad<Parser>
+ [headT any
+ #let [[funcT paramsT] (type;flatten-application (type;un-name headT))]]
+ (if (n.= +0 (list;size paramsT))
+ (p;fail ($_ text/compose "Non-application type: " (type;to-text headT)))
+ (local (#;Cons funcT paramsT) poly))))
+
+(def: #export (this expected)
+ (-> Type (Poly Unit))
+ (do p;Monad<Parser>
+ [actual any]
+ (if (check;checks? expected actual)
+ (wrap [])
+ (p;fail ($_ text/compose
+ "Types do not match." "\n"
+ "Expected: " (type;to-text expected) "\n"
+ " Actual: " (type;to-text actual))))))
+
+(def: (adjusted-idx env idx)
+ (-> Env Nat Nat)
+ (let [env-level (n./ +2 (dict;size env))
+ bound-level (n./ +2 idx)
+ bound-idx (n.% +2 idx)]
+ (|> env-level n.dec (n.- bound-level) (n.* +2) (n.+ bound-idx))))
+
+(def: #export bound
+ (Poly Code)
+ (do p;Monad<Parser>
+ [env ;;env
+ headT any]
+ (case headT
+ (#;Bound idx)
+ (case (dict;get (adjusted-idx env idx) env)
+ (#;Some [poly-type poly-ast])
+ (wrap poly-ast)
+
+ #;None
+ (p;fail ($_ text/compose "Unknown bound type: " (type;to-text headT))))
+
+ _
+ (p;fail ($_ text/compose "Not a bound type: " (type;to-text headT))))))
+
+(def: #export (var id)
+ (-> Nat (Poly Unit))
+ (do p;Monad<Parser>
+ [env ;;env
+ headT any]
+ (case headT
+ (#;Bound idx)
+ (if (n.= id (adjusted-idx env idx))
+ (wrap [])
+ (p;fail ($_ text/compose "Wrong bound type.\n"
+ "Expected: " (nat/encode id) "\n"
+ " Actual: " (nat/encode idx))))
+
+ _
+ (p;fail ($_ text/compose "Not a bound type: " (type;to-text headT))))))
+
+(def: #export (recursive poly)
+ (All [a] (-> (Poly a) (Poly [Code a])))
+ (do p;Monad<Parser>
+ [headT any]
+ (case (type;un-name headT)
+ (#;Apply #;Void (#;UnivQ _ headT'))
+ (do @
+ [[recT _ output] (|> poly
+ (with-extension #;Void)
+ (with-extension headT)
+ (local (list headT')))]
+ (wrap [recT output]))
+
+ _
+ (p;fail ($_ text/compose "Not a recursive type: " (type;to-text headT))))))
+
+(def: #export recursive-self
+ (Poly Code)
+ (do p;Monad<Parser>
+ [env ;;env
+ headT any]
+ (case (type;un-name headT)
+ (^multi (#;Apply #;Void (#;Bound funcT-idx))
+ (n.= +0 (adjusted-idx env funcT-idx))
+ [(dict;get +0 env) (#;Some [self-type self-call])])
+ (wrap self-call)
+
+ _
+ (p;fail ($_ text/compose "Not a recursive type: " (type;to-text headT))))))
+
+(def: #export recursive-call
+ (Poly Code)
+ (do p;Monad<Parser>
+ [env ;;env
+ [funcT argsT] (apply (p;seq any (p;many any)))
+ _ (local (list funcT) (var +0))
+ allC (let [allT (list& funcT argsT)]
+ (|> allT
+ (monad;map @ (function;const bound))
+ (local allT)))]
+ (wrap (` ((~@ allC))))))
+
+(def: #export log
+ (All [a] (Poly a))
+ (do p;Monad<Parser>
+ [current any
+ #let [_ (log! ($_ text/compose
+ "{" (ident/encode (ident-for ;;log)) "} "
+ (type;to-text current)))]]
+ (p;fail "LOGGING")))
+
+## [Syntax]
+(syntax: #export (poly: [export csr;export]
+ [name s;local-symbol]
+ body)
+ (with-gensyms [g!type g!output]
+ (let [g!name (code;symbol ["" name])]
+ (wrap (;list (` (syntax: (~@ (csw;export export)) ((~ g!name) [(~ g!type) s;symbol])
+ (do macro;Monad<Meta>
+ [(~ g!type) (macro;find-type-def (~ g!type))]
+ (case (|> (~ body)
+ (;function [(~ g!name)])
+ p;rec
+ (do p;Monad<Parser> [])
+ (;;run (~ g!type))
+ (: (;Either ;Text ;Code)))
+ (#;Left (~ g!output))
+ (macro;fail (~ g!output))
+
+ (#;Right (~ g!output))
+ ((~' wrap) (;list (~ g!output))))))))))))
+
+(def: (common-poly-name? poly-func)
+ (-> Text Bool)
+ (text;contains? "?" poly-func))
+
+(def: (derivation-name poly args)
+ (-> Text (List Text) (Maybe Text))
+ (if (common-poly-name? poly)
+ (#;Some (list/fold (text;replace-once "?") poly args))
+ #;None))
+
+(syntax: #export (derived: [export csr;export]
+ [?name (p;maybe s;local-symbol)]
+ [[poly-func poly-args] (s;form (p;seq s;symbol (p;many s;symbol)))]
+ [?custom-impl (p;maybe s;any)])
+ (do @
+ [poly-args (monad;map @ macro;normalize poly-args)
+ name (case ?name
+ (#;Some name)
+ (wrap name)
+
+ (^multi #;None
+ [(derivation-name (product;right poly-func) (list/map product;right poly-args))
+ (#;Some derived-name)])
+ (wrap derived-name)
+
+ _
+ (p;fail "derived: was given no explicit name, and cannot generate one from given information."))
+ #let [impl (case ?custom-impl
+ (#;Some custom-impl)
+ custom-impl
+
+ #;None
+ (` ((~ (code;symbol poly-func)) (~@ (list/map code;symbol poly-args)))))]]
+ (wrap (;list (` (def: (~@ (csw;export export))
+ (~ (code;symbol ["" name]))
+ {#;struct? true}
+ (~ impl)))))))
+
+## [Derivers]
+(def: #export (to-ast env type)
+ (-> Env Type Code)
+ (case type
+ (#;Primitive name params)
+ (` (#;Primitive (~ (code;text name))
+ (list (~@ (list/map (to-ast env) params)))))
+
+ (^template [<tag>]
+ <tag>
+ (` <tag>))
+ ([#;Void] [#;Unit])
+
+ (^template [<tag>]
+ (<tag> idx)
+ (` (<tag> (~ (code;nat idx)))))
+ ([#;Var] [#;Ex])
+
+ (#;Bound idx)
+ (let [idx (adjusted-idx env idx)]
+ (if (n.= +0 idx)
+ (|> (dict;get idx env) maybe;assume product;left (to-ast env))
+ (` (;$ (~ (code;nat (n.dec idx)))))))
+
+ (#;Apply #;Void (#;Bound idx))
+ (let [idx (adjusted-idx env idx)]
+ (if (n.= +0 idx)
+ (|> (dict;get idx env) maybe;assume product;left (to-ast env))
+ (undefined)))
+
+ (^template [<tag>]
+ (<tag> left right)
+ (` (<tag> (~ (to-ast env left))
+ (~ (to-ast env right)))))
+ ([#;Function] [#;Apply])
+
+ (^template [<tag> <macro> <flattener>]
+ (<tag> left right)
+ (` (<macro> (~@ (list/map (to-ast env) (<flattener> type))))))
+ ([#;Sum | type;flatten-variant]
+ [#;Product & type;flatten-tuple])
+
+ (#;Named name sub-type)
+ (code;symbol name)
+
+ (^template [<tag>]
+ (<tag> scope body)
+ (` (<tag> (list (~@ (list/map (to-ast env) scope)))
+ (~ (to-ast env body)))))
+ ([#;UnivQ] [#;ExQ])
+ ))
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
new file mode 100644
index 000000000..099febb24
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -0,0 +1,147 @@
+(;module:
+ lux
+ (lux (control [monad #+ do Monad]
+ [eq]
+ ["p" parser])
+ (data [text "text/" Monoid<Text>]
+ text/format
+ (coll [list "list/" Monad<List>]
+ [sequence]
+ [array]
+ [queue]
+ [set]
+ [dict #+ Dict]
+ (tree [rose]))
+ [number "nat/" Codec<Text,Nat>]
+ [product]
+ [bool]
+ [maybe])
+ (time ["du" duration]
+ ["da" date]
+ ["i" instant])
+ [macro]
+ (macro [code]
+ [syntax #+ syntax: Syntax]
+ (syntax [common])
+ [poly #+ poly:])
+ (type [unit])
+ (lang [type])
+ ))
+
+## [Derivers]
+(poly: #export Eq<?>
+ (`` (do @
+ [#let [g!_ (code;local-symbol "\u0000_")]
+ *env* poly;env
+ inputT poly;peek
+ #let [@Eq (: (-> Type Code)
+ (function [type]
+ (` (eq;Eq (~ (poly;to-ast *env* type))))))]]
+ ($_ p;either
+ ## Basic types
+ (~~ (do-template [<matcher> <eq>]
+ [(do @
+ [_ <matcher>]
+ (wrap (` (: (~ (@Eq inputT))
+ <eq>))))]
+
+ [poly;unit (function [(~ g!_) (~ g!_)] true)]
+ [poly;bool bool;Eq<Bool>]
+ [poly;nat number;Eq<Nat>]
+ [poly;int number;Eq<Int>]
+ [poly;deg number;Eq<Deg>]
+ [poly;frac number;Eq<Frac>]
+ [poly;text text;Eq<Text>]))
+ ## Composite types
+ (~~ (do-template [<name> <eq>]
+ [(do @
+ [[_ argC] (poly;apply (p;seq (poly;this <name>)
+ Eq<?>))]
+ (wrap (` (: (~ (@Eq inputT))
+ (<eq> (~ argC))))))]
+
+ [;Maybe maybe;Eq<Maybe>]
+ [;List list;Eq<List>]
+ [sequence;Sequence sequence;Eq<Sequence>]
+ [;Array array;Eq<Array>]
+ [queue;Queue queue;Eq<Queue>]
+ [set;Set set;Eq<Set>]
+ [rose;Tree rose;Eq<Tree>]
+ ))
+ (do @
+ [[_ _ valC] (poly;apply ($_ p;seq
+ (poly;this dict;Dict)
+ poly;any
+ Eq<?>))]
+ (wrap (` (: (~ (@Eq inputT))
+ (dict;Eq<Dict> (~ valC))))))
+ ## Models
+ (~~ (do-template [<type> <eq>]
+ [(do @
+ [_ (poly;this <type>)]
+ (wrap (` (: (~ (@Eq inputT))
+ <eq>))))]
+
+ [du;Duration du;Eq<Duration>]
+ [i;Instant i;Eq<Instant>]
+ [da;Date da;Eq<Date>]
+ [da;Day da;Eq<Day>]
+ [da;Month da;Eq<Month>]))
+ (do @
+ [_ (poly;apply (p;seq (poly;this unit;Qty)
+ poly;any))]
+ (wrap (` (: (~ (@Eq inputT))
+ unit;Eq<Qty>))))
+ ## Variants
+ (do @
+ [members (poly;variant (p;many Eq<?>))
+ #let [g!left (code;local-symbol "\u0000left")
+ g!right (code;local-symbol "\u0000right")]]
+ (wrap (` (: (~ (@Eq inputT))
+ (function [(~ g!left) (~ g!right)]
+ (case [(~ g!left) (~ g!right)]
+ (~@ (list/join (list/map (function [[tag g!eq]]
+ (list (` [((~ (code;nat tag)) (~ g!left))
+ ((~ (code;nat tag)) (~ g!right))])
+ (` ((~ g!eq) (~ g!left) (~ g!right)))))
+ (list;enumerate members))))
+ (~ g!_)
+ false))))))
+ ## Tuples
+ (do @
+ [g!eqs (poly;tuple (p;many Eq<?>))
+ #let [indices (|> (list;size g!eqs) n.dec (list;n.range +0))
+ g!lefts (list/map (|>. nat/encode (text/compose "left") code;local-symbol) indices)
+ g!rights (list/map (|>. nat/encode (text/compose "right") code;local-symbol) indices)]]
+ (wrap (` (: (~ (@Eq inputT))
+ (function [[(~@ g!lefts)] [(~@ g!rights)]]
+ (and (~@ (|> (list;zip3 g!eqs g!lefts g!rights)
+ (list/map (function [[g!eq g!left g!right]]
+ (` ((~ g!eq) (~ g!left) (~ g!right)))))))))))))
+ ## Type recursion
+ (do @
+ [[g!self bodyC] (poly;recursive Eq<?>)]
+ (wrap (` (: (~ (@Eq inputT))
+ (eq;rec (;function [(~ g!self)]
+ (~ bodyC)))))))
+ poly;recursive-self
+ ## Type applications
+ (do @
+ [[funcC argsC] (poly;apply (p;seq Eq<?> (p;many Eq<?>)))]
+ (wrap (` ((~ funcC) (~@ argsC)))))
+ ## Bound type-vars
+ poly;bound
+ ## Polymorphism
+ (do @
+ [[funcC varsC bodyC] (poly;polymorphic Eq<?>)]
+ (wrap (` (: (All [(~@ varsC)]
+ (-> (~@ (list/map (|>. (~) eq;Eq (`)) varsC))
+ (eq;Eq ((~ (poly;to-ast *env* inputT)) (~@ varsC)))))
+ (function (~ funcC) [(~@ varsC)]
+ (~ bodyC))))))
+ poly;recursive-call
+ ## If all else fails...
+ (|> poly;any
+ (:: @ map (|>. %type (format "Cannot create Eq for: ") p;fail))
+ (:: @ join))
+ ))))
diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux
new file mode 100644
index 000000000..ba847d35b
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -0,0 +1,95 @@
+(;module:
+ lux
+ (lux (control [monad #+ do Monad]
+ [functor]
+ ["p" parser])
+ (data [text]
+ text/format
+ (coll [list "L/" Monad<List> Monoid<List>])
+ [product])
+ [macro]
+ (macro [code]
+ [syntax #+ syntax: Syntax]
+ (syntax [common])
+ [poly #+ poly:])
+ (lang [type])
+ ))
+
+(poly: #export Functor<?>
+ (do @
+ [#let [type-funcC (code;local-symbol "\u0000type-funcC")
+ funcC (code;local-symbol "\u0000funcC")
+ inputC (code;local-symbol "\u0000inputC")]
+ *env* poly;env
+ inputT poly;peek
+ [polyC varsC non-functorT] (poly;local (list inputT)
+ (poly;polymorphic poly;any))
+ #let [num-vars (list;size varsC)]
+ #let [@Functor (: (-> Type Code)
+ (function [unwrappedT]
+ (if (n.= +1 num-vars)
+ (` (functor;Functor (~ (poly;to-ast *env* unwrappedT))))
+ (let [paramsC (|> num-vars n.dec list;indices (L/map (|>. %n code;local-symbol)))]
+ (` (All [(~@ paramsC)]
+ (functor;Functor ((~ (poly;to-ast *env* unwrappedT)) (~@ paramsC)))))))))
+ Arg<?> (: (-> Code (poly;Poly Code))
+ (function Arg<?> [valueC]
+ ($_ p;either
+ ## Type-var
+ (do p;Monad<Parser>
+ [#let [varI (|> num-vars (n.* +2) n.dec)]
+ _ (poly;var varI)]
+ (wrap (` ((~ funcC) (~ valueC)))))
+ ## Variants
+ (do @
+ [_ (wrap [])
+ membersC (poly;variant (p;many (Arg<?> valueC)))]
+ (wrap (` (case (~ valueC)
+ (~@ (L/join (L/map (function [[tag memberC]]
+ (list (` ((~ (code;nat tag)) (~ valueC)))
+ (` ((~ (code;nat tag)) (~ memberC)))))
+ (list;enumerate membersC))))))))
+ ## Tuples
+ (do p;Monad<Parser>
+ [pairsCC (: (poly;Poly (List [Code Code]))
+ (poly;tuple (loop [idx +0
+ pairsCC (: (List [Code Code])
+ (list))]
+ (p;either (let [slotC (|> idx %n (format "\u0000slot") code;local-symbol)]
+ (do @
+ [_ (wrap [])
+ memberC (Arg<?> slotC)]
+ (recur (n.inc idx)
+ (L/compose pairsCC (list [slotC memberC])))))
+ (wrap pairsCC)))))]
+ (wrap (` (case (~ valueC)
+ [(~@ (L/map product;left pairsCC))]
+ [(~@ (L/map product;right pairsCC))]))))
+ ## Functions
+ (do @
+ [_ (wrap [])
+ #let [outL (code;local-symbol "\u0000outL")]
+ [inT+ outC] (poly;function (p;many poly;any)
+ (Arg<?> outL))
+ #let [inC+ (|> (list;size inT+) n.dec
+ (list;n.range +0)
+ (L/map (|>. %n (format "\u0000inC") code;local-symbol)))]]
+ (wrap (` (function [(~@ inC+)]
+ (let [(~ outL) ((~ valueC) (~@ inC+))]
+ (~ outC))))))
+ ## Recursion
+ (do p;Monad<Parser>
+ [_ poly;recursive-call]
+ (wrap (` ((~' map) (~ funcC) (~ valueC)))))
+ ## Bound type-variables
+ (do p;Monad<Parser>
+ [_ poly;any]
+ (wrap valueC))
+ )))]
+ [_ _ outputC] (: (poly;Poly [Code (List Code) Code])
+ (p;either (poly;polymorphic
+ (Arg<?> inputC))
+ (p;fail (format "Cannot create Functor for: " (%type inputT)))))]
+ (wrap (` (: (~ (@Functor inputT))
+ (struct (def: ((~' map) (~ funcC) (~ inputC))
+ (~ outputC))))))))
diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux
new file mode 100644
index 000000000..5c3a645ee
--- /dev/null
+++ b/stdlib/source/lux/macro/poly/json.lux
@@ -0,0 +1,312 @@
+(;module: {#;doc "Codecs for values in the JSON format."}
+ lux
+ (lux (control [monad #+ do Monad]
+ [eq #+ Eq]
+ codec
+ ["p" parser "p/" Monad<Parser>])
+ (data [bool]
+ [bit]
+ [text "text/" Eq<Text> Monoid<Text>]
+ (text ["l" lexer])
+ [number "frac/" Codec<Text,Frac> "nat/" Codec<Text,Nat>]
+ maybe
+ ["e" error]
+ [sum]
+ [product]
+ (coll [list "list/" Fold<List> Monad<List>]
+ [sequence #+ Sequence sequence "sequence/" Monad<Sequence>]
+ ["d" dict])
+ (format [".." json #+ JSON]))
+ (time ["i" instant]
+ ["du" duration]
+ ["da" date])
+ [macro #+ with-gensyms]
+ (macro ["s" syntax #+ syntax:]
+ [code]
+ [poly #+ poly:])
+ (type [unit])
+ (lang [type])
+ ))
+
+(def: #hidden _map_
+ (All [a b] (-> (-> a b) (List a) (List b)))
+ list/map)
+
+(def: tag
+ (-> Nat Frac)
+ (|>. nat-to-int int-to-frac))
+
+(def: #hidden (rec-encode non-rec)
+ (All [a] (-> (-> (-> a JSON)
+ (-> a JSON))
+ (-> a JSON)))
+ (function [input]
+ (non-rec (rec-encode non-rec) input)))
+
+(def: low-mask Nat (|> +1 (bit;shift-left +32) n.dec))
+(def: high-mask Nat (|> low-mask (bit;shift-left +32)))
+
+(struct: #hidden _ (Codec JSON Nat)
+ (def: (encode input)
+ (let [high (|> input (bit;and high-mask) (bit;shift-right +32))
+ low (bit;and low-mask input)]
+ (#..;Array (sequence (|> high nat-to-int int-to-frac #..;Number)
+ (|> low nat-to-int int-to-frac #..;Number)))))
+ (def: (decode input)
+ (<| (..;run input)
+ (do p;Monad<Parser>
+ [high ..;number
+ low ..;number])
+ (wrap (n.+ (|> high frac-to-int int-to-nat (bit;shift-left +32))
+ (|> low frac-to-int int-to-nat))))))
+
+(struct: #hidden _ (Codec JSON Int)
+ (def: encode (|>. int-to-nat (:: Codec<JSON,Nat> encode)))
+ (def: decode
+ (|>. (:: Codec<JSON,Nat> decode) (:: e;Functor<Error> map nat-to-int))))
+
+(def: #hidden (nullable writer)
+ {#;doc "Builds a JSON generator for potentially inexistent values."}
+ (All [a] (-> (-> a JSON) (-> (Maybe a) JSON)))
+ (function [elem]
+ (case elem
+ #;None #..;Null
+ (#;Some value) (writer value))))
+
+(struct: #hidden (Codec<JSON,Qty> carrier)
+ (All [unit] (-> unit (Codec JSON (unit;Qty unit))))
+ (def: encode
+ (|>. unit;out (:: Codec<JSON,Int> encode)))
+ (def: decode
+ (|>. (:: Codec<JSON,Int> decode) (:: e;Functor<Error> map (unit;in carrier)))))
+
+(poly: #hidden Codec<JSON,?>//encode
+ (with-expansions
+ [<basic> (do-template [<type> <matcher> <encoder>]
+ [(do @
+ [_ <matcher>]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ <encoder>))))]
+
+ [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
+ [Bool poly;bool (|>. #..;Boolean)]
+ [Nat poly;nat (:: ;;Codec<JSON,Nat> (~' encode))]
+ [Int poly;int (:: ;;Codec<JSON,Int> (~' encode))]
+ [Frac poly;frac (|>. #..;Number)]
+ [Text poly;text (|>. #..;String)])
+ <time> (do-template [<type> <codec>]
+ [(do @
+ [_ (poly;this <type>)]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ (|>. (:: <codec> (~' encode)) #..;String)))))]
+
+ [du;Duration du;Codec<Text,Duration>]
+ [i;Instant i;Codec<Text,Instant>]
+ [da;Date da;Codec<Text,Date>]
+ [da;Day da;Codec<Text,Day>]
+ [da;Month da;Codec<Text,Month>])]
+ (do @
+ [*env* poly;env
+ #let [@JSON//encode (: (-> Type Code)
+ (function [type]
+ (` (-> (~ (poly;to-ast *env* type)) ..;JSON))))]
+ inputT poly;peek]
+ ($_ p;either
+ <basic>
+ <time>
+ (do @
+ [unitT (poly;apply (p;after (poly;this unit;Qty)
+ poly;any))]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ (:: (Codec<JSON,Qty> (:! (~ (poly;to-ast *env* unitT)) [])) (~' encode))))))
+ (do @
+ [#let [g!key (code;local-symbol "\u0000key")
+ g!val (code;local-symbol "\u0000val")]
+ [_ _ .val.] (poly;apply ($_ p;seq
+ (poly;this d;Dict)
+ poly;text
+ Codec<JSON,?>//encode))]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ (|>. d;entries
+ (;;_map_ (function [[(~ g!key) (~ g!val)]]
+ [(~ g!key) ((~ .val.) (~ g!val))]))
+ (d;from-list text;Hash<Text>)
+ #..;Object)))))
+ (do @
+ [[_ .sub.] (poly;apply ($_ p;seq
+ (poly;this ;Maybe)
+ Codec<JSON,?>//encode))]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ (;;nullable (~ .sub.))))))
+ (do @
+ [[_ .sub.] (poly;apply ($_ p;seq
+ (poly;this ;List)
+ Codec<JSON,?>//encode))]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ (|>. (;;_map_ (~ .sub.)) sequence;from-list #..;Array)))))
+ (do @
+ [#let [g!input (code;local-symbol "\u0000input")]
+ members (poly;variant (p;many Codec<JSON,?>//encode))]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ (function [(~ g!input)]
+ (case (~ g!input)
+ (~@ (list/join (list/map (function [[tag g!encode]]
+ (list (` ((~ (code;nat tag)) (~ g!input)))
+ (` (..;json [(~ (code;frac (;;tag tag)))
+ ((~ g!encode) (~ g!input))]))))
+ (list;enumerate members))))))))))
+ (do @
+ [g!encoders (poly;tuple (p;many Codec<JSON,?>//encode))
+ #let [g!members (|> (list;size g!encoders) n.dec
+ (list;n.range +0)
+ (list/map (|>. nat/encode code;local-symbol)))]]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ (function [[(~@ g!members)]]
+ (..;json [(~@ (list/map (function [[g!member g!encode]]
+ (` ((~ g!encode) (~ g!member))))
+ (list;zip2 g!members g!encoders)))]))))))
+ ## Type recursion
+ (do @
+ [[selfC non-recC] (poly;recursive Codec<JSON,?>//encode)]
+ (wrap (` (: (~ (@JSON//encode inputT))
+ (;;rec-encode (;function [(~ selfC)]
+ (~ non-recC)))))))
+ poly;recursive-self
+ ## Type applications
+ (do @
+ [partsC (poly;apply (p;many Codec<JSON,?>//encode))]
+ (wrap (` ((~@ partsC)))))
+ ## Polymorphism
+ (do @
+ [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//encode)]
+ (wrap (` (: (All [(~@ varsC)]
+ (-> (~@ (list/map (function [varC] (` (-> (~ varC) ..;JSON)))
+ varsC))
+ (-> ((~ (poly;to-ast *env* inputT)) (~@ varsC))
+ ..;JSON)))
+ (function (~ funcC) [(~@ varsC)]
+ (~ bodyC))))))
+ poly;bound
+ poly;recursive-call
+ ## If all else fails...
+ (p;fail (text/compose "Cannot create JSON encoder for: " (type;to-text inputT)))
+ ))))
+
+(poly: #hidden Codec<JSON,?>//decode
+ (with-expansions
+ [<basic> (do-template [<type> <matcher> <decoder>]
+ [(do @
+ [_ <matcher>]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ <decoder>))))]
+
+ [Unit poly;unit ..;null]
+ [Bool poly;bool ..;boolean]
+ [Nat poly;nat (p;codec ;;Codec<JSON,Nat> ..;any)]
+ [Int poly;int (p;codec ;;Codec<JSON,Int> ..;any)]
+ [Frac poly;frac ..;number]
+ [Text poly;text ..;string])
+ <time> (do-template [<type> <codec>]
+ [(do @
+ [_ (poly;this <type>)]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (p;codec <codec> ..;string)))))]
+
+ [du;Duration du;Codec<Text,Duration>]
+ [i;Instant i;Codec<Text,Instant>]
+ [da;Date da;Codec<Text,Date>]
+ [da;Day da;Codec<Text,Day>]
+ [da;Month da;Codec<Text,Month>])]
+ (do @
+ [*env* poly;env
+ #let [@JSON//decode (: (-> Type Code)
+ (function [type]
+ (` (..;Reader (~ (poly;to-ast *env* type))))))]
+ inputT poly;peek]
+ ($_ p;either
+ <basic>
+ <time>
+ (do @
+ [unitT (poly;apply (p;after (poly;this unit;Qty)
+ poly;any))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (p;codec (Codec<JSON,Qty> (:! (~ (poly;to-ast *env* unitT)) [])) ..;any)))))
+ (do @
+ [[_ _ valC] (poly;apply ($_ p;seq
+ (poly;this d;Dict)
+ poly;text
+ Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (..;object (~ valC))))))
+ (do @
+ [[_ subC] (poly;apply (p;seq (poly;this ;Maybe)
+ Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (..;nullable (~ subC))))))
+ (do @
+ [[_ subC] (poly;apply (p;seq (poly;this ;List)
+ Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (..;array (p;some (~ subC)))))))
+ (do @
+ [members (poly;variant (p;many Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ ($_ p;alt
+ (~@ (list/map (function [[tag memberC]]
+ (` (|> (~ memberC)
+ (p;after (..;number! (~ (code;frac (;;tag tag)))))
+ ..;array)))
+ (list;enumerate members))))))))
+ (do @
+ [g!decoders (poly;tuple (p;many Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (..;array ($_ p;seq (~@ g!decoders)))))))
+ ## Type recursion
+ (do @
+ [[selfC bodyC] (poly;recursive Codec<JSON,?>//decode)]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (p;rec (;function [(~ selfC)]
+ (~ bodyC)))))))
+ poly;recursive-self
+ ## Type applications
+ (do @
+ [[funcC argsC] (poly;apply (p;seq Codec<JSON,?>//decode (p;many Codec<JSON,?>//decode)))]
+ (wrap (` ((~ funcC) (~@ argsC)))))
+ ## Polymorphism
+ (do @
+ [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//decode)]
+ (wrap (` (: (All [(~@ varsC)]
+ (-> (~@ (list/map (|>. (~) ..;Reader (`)) varsC))
+ (..;Reader ((~ (poly;to-ast *env* inputT)) (~@ varsC)))))
+ (function (~ funcC) [(~@ varsC)]
+ (~ bodyC))))))
+ poly;bound
+ poly;recursive-call
+ ## If all else fails...
+ (p;fail (text/compose "Cannot create JSON decoder for: " (type;to-text inputT)))
+ ))))
+
+(syntax: #export (Codec<JSON,?> inputT)
+ {#;doc (doc "A macro for automatically producing JSON codecs."
+ (type: Variant
+ (#Case0 Bool)
+ (#Case1 Text)
+ (#Case2 Frac))
+
+ (type: Record
+ {#unit Unit
+ #bool Bool
+ #frac Frac
+ #text Text
+ #maybe (Maybe Frac)
+ #list (List Frac)
+ #variant Variant
+ #tuple [Bool Frac Text]
+ #dict (Dict Text Frac)})
+
+ (derived: (Codec<JSON,?> Record)))}
+ (with-gensyms [g!inputs]
+ (wrap (list (` (: (Codec ..;JSON (~ inputT))
+ (struct (def: (~' encode) (Codec<JSON,?>//encode (~ inputT)))
+ (def: ((~' decode) (~ g!inputs)) (..;run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT))))
+ )))))))
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:"))))
diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux
new file mode 100644
index 000000000..72e52a4ab
--- /dev/null
+++ b/stdlib/source/lux/macro/syntax/common.lux
@@ -0,0 +1,27 @@
+(;module: {#;doc "Commons syntax readers and writers.
+
+ The goal is to be able to reuse common syntax in macro definitions across libraries."}
+ lux)
+
+(type: #export Export
+ #Exported
+ #Hidden)
+
+(type: #export Declaration
+ {#declaration-name Text
+ #declaration-args (List Text)})
+
+(type: #export Annotations
+ (List [Ident Code]))
+
+(def: #export empty-annotations
+ Annotations
+ (list))
+
+(type: #export Definition
+ {#definition-name Text
+ #definition-type (Maybe Code)
+ #definition-value Code
+ #definition-anns Annotations
+ #definition-args (List Text)
+ })
diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux
new file mode 100644
index 000000000..9ab6d6381
--- /dev/null
+++ b/stdlib/source/lux/macro/syntax/common/reader.lux
@@ -0,0 +1,150 @@
+(;module: {#;doc "Commons syntax readers."}
+ lux
+ (lux (control monad
+ ["p" parser])
+ (data (coll [list])
+ [ident "ident/" Eq<Ident>]
+ [product]
+ [maybe])
+ [macro]
+ (macro ["s" syntax #+ syntax: Syntax]))
+ [.. #*])
+
+## Exports
+(def: #export export
+ {#;doc (doc "A reader for export levels."
+ "Such as:"
+ #export
+ #hidden)}
+ (Syntax (Maybe Export))
+ (p;maybe (p;alt (s;this (' #export))
+ (s;this (' #hidden)))))
+
+## Declarations
+(def: #export declaration
+ {#;doc (doc "A reader for declaration syntax."
+ "Such as:"
+ quux
+ (foo bar baz))}
+ (Syntax Declaration)
+ (p;either (p;seq s;local-symbol
+ (:: p;Monad<Parser> wrap (list)))
+ (s;form (p;seq s;local-symbol
+ (p;many s;local-symbol)))))
+
+## Annotations
+(def: #export annotations
+ {#;doc "Reader for the common annotations syntax used by def: statements."}
+ (Syntax Annotations)
+ (s;record (p;some (p;seq s;tag s;any))))
+
+## Definitions
+(def: check^
+ (Syntax [(Maybe Code) Code])
+ (p;either (s;form (do p;Monad<Parser>
+ [_ (s;this (' "lux check"))
+ type s;any
+ value s;any]
+ (wrap [(#;Some type) value])))
+ (p;seq (:: p;Monad<Parser> wrap #;None)
+ s;any)))
+
+(def: _definition-anns-tag^
+ (Syntax Ident)
+ (s;tuple (p;seq s;text s;text)))
+
+(def: (_definition-anns^ _)
+ (-> Top (Syntax Annotations))
+ (p;alt (s;this (' #lux;Nil))
+ (s;form (do p;Monad<Parser>
+ [_ (s;this (' #lux;Cons))
+ [head tail] (p;seq (s;tuple (p;seq _definition-anns-tag^ s;any))
+ (_definition-anns^ []))]
+ (wrap [head tail])))
+ ))
+
+(def: (flat-list^ _)
+ (-> Top (Syntax (List Code)))
+ (p;either (do p;Monad<Parser>
+ [_ (s;this (' #lux;Nil))]
+ (wrap (list)))
+ (s;form (do p;Monad<Parser>
+ [_ (s;this (' #lux;Cons))
+ [head tail] (s;tuple (p;seq s;any s;any))
+ tail (s;local (list tail) (flat-list^ []))]
+ (wrap (#;Cons head tail))))))
+
+(do-template [<name> <type> <tag> <then>]
+ [(def: <name>
+ (Syntax <type>)
+ (<| s;tuple
+ (p;after s;any)
+ s;form
+ (do p;Monad<Parser>
+ [_ (s;this (' <tag>))]
+ <then>)))]
+
+ [tuple-meta^ (List Code) #lux;Tuple (flat-list^ [])]
+ [text-meta^ Text #lux;Text s;text]
+ )
+
+(def: (find-definition-args meta-data)
+ (-> (List [Ident Code]) (List Text))
+ (<| (maybe;default (list))
+ (case (list;find (|>. product;left (ident/= ["lux" "func-args"])) meta-data)
+ (^multi (#;Some [_ value])
+ [(p;run (list value) tuple-meta^)
+ (#;Right [_ args])]
+ [(p;run args (p;some text-meta^))
+ (#;Right [_ args])])
+ (#;Some args)
+
+ _
+ #;None)
+ ))
+
+(def: #export (definition compiler)
+ {#;doc "A reader that first macro-expands and then analyses the input Code, to ensure it's a definition."}
+ (-> Compiler (Syntax Definition))
+ (do p;Monad<Parser>
+ [definition-raw s;any
+ me-definition-raw (s;on compiler
+ (macro;expand-all definition-raw))]
+ (s;local me-definition-raw
+ (s;form (do @
+ [_ (s;this (' "lux def"))
+ definition-name s;local-symbol
+ [?definition-type definition-value] check^
+ definition-anns s;any
+ definition-anns (s;local (list definition-anns)
+ (_definition-anns^ []))
+ #let [definition-args (find-definition-args definition-anns)]]
+ (wrap {#..;definition-name definition-name
+ #..;definition-type ?definition-type
+ #..;definition-anns definition-anns
+ #..;definition-value definition-value
+ #..;definition-args definition-args}))))))
+
+(def: #export (typed-definition compiler)
+ {#;doc "A reader for definitions that ensures the input syntax is typed."}
+ (-> Compiler (Syntax Definition))
+ (do p;Monad<Parser>
+ [_definition (definition compiler)
+ _ (case (get@ #..;definition-type _definition)
+ (#;Some _)
+ (wrap [])
+
+ #;None
+ (p;fail "Typed definition must have a type!")
+ )]
+ (wrap _definition)))
+
+(def: #export typed-input
+ {#;doc "Reader for the common typed-argument syntax used by many macros."}
+ (Syntax [Text Code])
+ (s;tuple (p;seq s;local-symbol s;any)))
+
+(def: #export type-variables
+ {#;doc "Reader for the common type var/param used by many macros."}
+ (Syntax (List Text))
+ (s;tuple (p;some s;local-symbol)))
diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux
new file mode 100644
index 000000000..72e4a11eb
--- /dev/null
+++ b/stdlib/source/lux/macro/syntax/common/writer.lux
@@ -0,0 +1,24 @@
+(;module: {#;doc "Commons syntax writers."}
+ lux
+ (lux (data (coll [list "L/" Functor<List>])
+ [product])
+ (macro [code]))
+ [.. #*])
+
+## Exports
+(def: #export (export ?el)
+ (-> (Maybe Export) (List Code))
+ (case ?el
+ #;None
+ (list)
+
+ (#;Some #..;Exported)
+ (list (' #export))
+
+ (#;Some #..;Hidden)
+ (list (' #hidden))))
+
+## Annotations
+(def: #export (annotations anns)
+ (-> Annotations Code)
+ (|> anns (L/map (product;both code;tag id)) code;record))
generated by cgit v1.2.3 (git 2.25.1) at 2024-09-13 01:36:38 +0000