aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux.lux2
-rw-r--r--stdlib/source/lux/data/format/json/codec.lux301
-rw-r--r--stdlib/source/lux/macro/poly.lux571
-rw-r--r--stdlib/source/lux/macro/poly/eq.lux170
-rw-r--r--stdlib/source/lux/macro/poly/functor.lux194
5 files changed, 615 insertions, 623 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 30f38897b..caf38c7b6 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -2598,7 +2598,7 @@
(#Cons [_ (#Symbol "" name)] (#Cons body #Nil))
(let' [body' (replace-syntax (list [name (` (#Apply (~ (make-bound +1)) (~ (make-bound +0))))])
(update-bounds body))]
- (return (list (` (#Apply Void (#UnivQ #Nil (~ body')))))))
+ (return (list (` (#Apply #;Void (#UnivQ #Nil (~ body')))))))
_
(fail "Wrong syntax for Rec")))
diff --git a/stdlib/source/lux/data/format/json/codec.lux b/stdlib/source/lux/data/format/json/codec.lux
index 98e3874fd..073d3636b 100644
--- a/stdlib/source/lux/data/format/json/codec.lux
+++ b/stdlib/source/lux/data/format/json/codec.lux
@@ -4,7 +4,7 @@
lux
(lux (control functor
applicative
- ["M" monad #+ do Monad]
+ [monad #+ do Monad]
[eq #+ Eq]
codec
["p" parser "p/" Monad<Parser>])
@@ -191,200 +191,175 @@
(function [input]
(non-rec (rec-encode non-rec) input)))
-(poly: #hidden (Codec<JSON,?>//encode env :x:)
- (let [->Codec//encode (: (-> Code Code)
- (function [.type.] (` (-> (~ .type.) ..;JSON))))]
- (with-expansions
- [<basic> (do-template [<type> <matcher> <encoder>]
- [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//encode (` <type>))) <encoder>))))]
+(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]
- [Real poly;real ..;number]
- [Text poly;text ..;string])]
- ($_ macro;either
+ [Unit poly;unit (function [(~ (code;symbol ["" "0"]))] #..;Null)]
+ [Bool poly;bool ..;boolean]
+ [Real poly;real ..;number]
+ [Text poly;text ..;string])]
+ (do @
+ [*env* poly;env
+ #let [@JSON//encode (: (-> Type Code)
+ (function [type]
+ (` (-> (~ (poly;to-ast *env* type)) ..;JSON))))]
+ inputT poly;peek]
+ ($_ p;either
<basic>
- (with-gensyms [g!input g!key g!val]
- (do @
- [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:)
- _ (poly;text :key:)
- .val. (Codec<JSON,?>//encode env :val:)]
- (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
- (function [(~ g!input)]
- (|> (~ g!input)
- d;entries
- (;;_map_ (: (-> [Text (~ (poly;to-ast env :val:))]
- [Text ..;JSON])
- (function [[(~ g!key) (~ g!val)]]
- [(~ g!key)
- ((~ .val.) (~ g!val))])))
- (d;from-list text;Hash<Text>)
- #..;Object))
- )))))
(do @
- [:sub: (poly;apply-1 (ident-for ;Maybe) :x:)
- .sub. (Codec<JSON,?>//encode env :sub:)]
- (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+ [#let [g!key (code;local-symbol "\u0000key")
+ g!val (code;local-symbol "\u0000val")]
+ [_ _ .val.] (poly;apply ($_ p;seq
+ (poly;named (ident-for 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;named (ident-for ;Maybe))
+ Codec<JSON,?>//encode))]
+ (wrap (` (: (~ (@JSON//encode inputT))
(..;nullable (~ .sub.))))))
(do @
- [:sub: (poly;apply-1 (ident-for ;List) :x:)
- .sub. (Codec<JSON,?>//encode env :sub:)]
- (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+ [[_ .sub.] (poly;apply ($_ p;seq
+ (poly;named (ident-for ;List))
+ Codec<JSON,?>//encode))]
+ (wrap (` (: (~ (@JSON//encode inputT))
(|>. (;;_map_ (~ .sub.)) vector;from-list ..;array)))))
- (with-gensyms [g!input]
- (do @
- [members (poly;sum+ :x:)
- pattern-matching (M;map @
- (function [[tag :case:]]
- (do @
- [g!encode (Codec<JSON,?>//encode env :case:)]
- (wrap (list (` ((~ (code;nat tag)) (~ g!input)))
+ (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)
+ (~@ (L/join (L/map (function [[tag g!encode]]
+ (list (` ((~ (code;nat tag)) (~ g!input)))
(` (..;json [(~ (code;real (;;tag tag)))
- ((~ g!encode) (~ g!input))]))))))
- (list;enumerate members))]
- (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
- (function [(~ g!input)]
- (case (~ g!input)
- (~@ (L/join pattern-matching)))))))))
+ ((~ g!encode) (~ g!input))]))))
+ (list;enumerate members))))))))))
(do @
- [members (poly;prod+ :x:)
- #let [g!members (|> (list;size members) n.dec
+ [g!encoders (poly;tuple (p;many Codec<JSON,?>//encode))
+ #let [g!members (|> (list;size g!encoders) n.dec
(list;n.range +0)
- (L/map (|>. nat/encode code;local-symbol)))]
- g!encoders (M;map @ (Codec<JSON,?>//encode env) members)]
- (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
+ (L/map (|>. nat/encode code;local-symbol)))]]
+ (wrap (` (: (~ (@JSON//encode inputT))
(function [[(~@ g!members)]]
(..;json [(~@ (L/map (function [[g!member g!encode]]
(` ((~ g!encode) (~ g!member))))
- (list;zip2 g!members g!encoders)))]))
- ))))
+ (list;zip2 g!members g!encoders)))]))))))
## Type recursion
- (with-gensyms [g!rec]
- (do @
- [:non-rec: (poly;recursive :x:)
- #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)]
- .non-rec. (Codec<JSON,?>//encode new-env :non-rec:)]
- (wrap (` (: (~ (poly;gen-type new-env ->Codec//encode g!rec (list) :x:))
- (;;rec-encode (;function [(~ g!rec)]
- (~ .non-rec.))))))))
- (poly;self env :x:)
- (poly;recursion env :x:)
+ (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 @
- [[:func: :args:] (poly;apply :x:)
- .func. (Codec<JSON,?>//encode env :func:)
- .args. (M;map @ (Codec<JSON,?>//encode env) :args:)]
- (wrap (` (: (~ (->Codec//encode (poly;to-ast env :x:)))
- ((~ .func.) (~@ .args.))))))
- ## Bound type-vars
- (poly;bound env :x:)
+ [partsC (poly;apply (p;many Codec<JSON,?>//encode))]
+ (wrap (` ((~@ partsC)))))
## Polymorphism
- (with-gensyms [g!type-fun]
- (do @
- [[g!vars :non-poly:] (poly;polymorphic :x:)
- #let [new-env (poly;extend-env [:x: g!type-fun]
- (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
- env)]
- .non-poly. (Codec<JSON,?>//encode new-env :non-poly:)]
- (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Codec//encode g!vars))
- (~ (->Codec//encode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
- (function (~ g!type-fun) [(~@ g!vars)]
- (~ .non-poly.)))))))
+ (do @
+ [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//encode)]
+ (wrap (` (: (All [(~@ varsC)]
+ (-> (~@ (L/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...
- (macro;fail ($_ text/append "Cannot create JSON encoder for: " (type;to-text :x:)))
+ (p;fail (text/append "Cannot create JSON encoder for: " (type;to-text inputT)))
))))
-(poly: #hidden (Codec<JSON,?>//decode env :x:)
- (let [->Codec//decode (: (-> Code Code)
- (function [.type.] (` (..;Reader (~ .type.)))))]
- (with-expansions
- [<basic> (do-template [<type> <matcher> <decoder>]
- [(do @ [_ (<matcher> :x:)] (wrap (` (: (~ (->Codec//decode (` <type>))) <decoder>))))]
+(poly: #hidden Codec<JSON,?>//decode
+ (with-expansions
+ [<basic> (do-template [<type> <matcher> <decoder>]
+ [(do @
+ [_ <matcher>]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ <decoder>))))]
- [Unit poly;unit ../reader;null]
- [Bool poly;bool ../reader;boolean]
- [Real poly;real ../reader;number]
- [Text poly;text ../reader;string])]
- ($_ macro;either
+ [Unit poly;unit ../reader;null]
+ [Bool poly;bool ../reader;boolean]
+ [Real poly;real ../reader;number]
+ [Text poly;text ../reader;string])]
+ (do @
+ [*env* poly;env
+ #let [@JSON//decode (: (-> Type Code)
+ (function [type]
+ (` (..;Reader (~ (poly;to-ast *env* type))))))]
+ inputT poly;peek]
+ ($_ p;either
<basic>
(do @
- [[:key: :val:] (poly;apply-2 (ident-for d;Dict) :x:)
- _ (poly;text :key:)
- .val. (Codec<JSON,?>//decode env :val:)]
- (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
- (../reader;object (~ .val.))))))
+ [[_ _ valC] (poly;apply ($_ p;seq
+ (poly;named (ident-for d;Dict))
+ poly;text
+ Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (../reader;object (~ valC))))))
(do @
- [:sub: (poly;apply-1 (ident-for ;Maybe) :x:)
- .sub. (Codec<JSON,?>//decode env :sub:)]
- (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
- (../reader;nullable (~ .sub.))))))
+ [[_ subC] (poly;apply (p;seq (poly;named (ident-for ;Maybe))
+ Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (../reader;nullable (~ subC))))))
(do @
- [:sub: (poly;apply-1 (ident-for ;List) :x:)
- .sub. (Codec<JSON,?>//decode env :sub:)]
- (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
- (../reader;array (p;some (~ .sub.)))))))
+ [[_ subC] (poly;apply (p;seq (poly;named (ident-for ;List))
+ Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (../reader;array (p;some (~ subC)))))))
(do @
- [members (poly;sum+ :x:)
- pattern-matching (M;map @
- (function [[tag :case:]]
- (do @
- [g!decode (Codec<JSON,?>//decode env :case:)]
- (wrap (list (` (|> (~ g!decode)
- (p;after (../reader;number! (~ (code;real (;;tag tag)))))
- ../reader;array))))))
- (list;enumerate members))]
- (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
+ [members (poly;variant (p;many Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
($_ p;alt
- (~@ (L/join pattern-matching)))))))
+ (~@ (L/map (function [[tag memberC]]
+ (` (|> (~ memberC)
+ (p;after (../reader;number! (~ (code;real (;;tag tag)))))
+ ../reader;array)))
+ (list;enumerate members))))))))
(do @
- [members (poly;prod+ :x:)
- #let [g!members (|> (list;size members) n.dec
- (list;n.range +0)
- (L/map (|>. nat/encode code;local-symbol)))]
- g!decoders (M;map @ (Codec<JSON,?>//decode env) members)]
- (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
+ [g!decoders (poly;tuple (p;many Codec<JSON,?>//decode))]
+ (wrap (` (: (~ (@JSON//decode inputT))
(../reader;array ($_ p;seq (~@ g!decoders)))))))
## Type recursion
- (with-gensyms [g!rec]
- (do @
- [:non-rec: (poly;recursive :x:)
- #let [new-env (poly;extend-env [:x: g!rec] (list [:x: (` (;undefined))]) env)]
- .non-rec. (Codec<JSON,?>//decode new-env :non-rec:)]
- (wrap (` (: (~ (poly;gen-type new-env ->Codec//decode g!rec (list) :x:))
- (p;rec (;function [(~ g!rec)]
- (~ .non-rec.))))))))
- (poly;self env :x:)
- (poly;recursion env :x:)
- ## Type applications
(do @
- [[:func: :args:] (poly;apply :x:)
- .func. (Codec<JSON,?>//decode env :func:)
- .args. (M;map @ (Codec<JSON,?>//decode env) :args:)]
- (wrap (` (: (~ (->Codec//decode (poly;to-ast env :x:)))
- ((~ .func.) (~@ .args.))))))
- ## Bound type-vars
+ [[selfC bodyC] (poly;recursive Codec<JSON,?>//decode)]
+ (wrap (` (: (~ (@JSON//decode inputT))
+ (p;rec (;function [(~ selfC)]
+ (~ bodyC)))))))
+ poly;recursive-self
+ ## Type applications
(do @
- [g!bound (poly;bound env :x:)]
- (wrap g!bound))
+ [[funcC argsC] (poly;apply (p;seq Codec<JSON,?>//decode (p;many Codec<JSON,?>//decode)))]
+ (wrap (` ((~ funcC) (~@ argsC)))))
## Polymorphism
- (with-gensyms [g!type-fun]
- (do @
- [[g!vars :non-poly:] (poly;polymorphic :x:)
- #let [new-env (poly;extend-env [:x: g!type-fun]
- (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
- env)]
- .non-poly. (Codec<JSON,?>//decode new-env :non-poly:)]
- (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Codec//decode g!vars))
- (~ (->Codec//decode (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
- (function (~ g!type-fun) [(~@ g!vars)]
- (~ .non-poly.)))))))
+ (do @
+ [[funcC varsC bodyC] (poly;polymorphic Codec<JSON,?>//decode)]
+ (wrap (` (: (All [(~@ varsC)]
+ (-> (~@ (L/map (|>. (~) ..;Reader (`)) varsC))
+ (..;Reader ((~ (poly;to-ast *env* inputT)) (~@ varsC)))))
+ (function (~ funcC) [(~@ varsC)]
+ (~ bodyC))))))
+ poly;bound
+ poly;recursive-call
## If all else fails...
- (macro;fail ($_ text/append "Cannot create JSON decoder for: " (type;to-text :x:)))
+ (p;fail (text/append "Cannot create JSON decoder for: " (type;to-text inputT)))
))))
-(syntax: #export (Codec<JSON,?> :x:)
+(syntax: #export (Codec<JSON,?> inputT)
{#;doc (doc "A macro for automatically producing JSON codecs."
(type: Variant
(#Case0 Bool)
@@ -404,7 +379,7 @@
(derived: (Codec<JSON,?> Record)))}
(with-gensyms [g!inputs]
- (wrap (list (` (: (Codec ..;JSON (~ :x:))
- (struct (def: (~' encode) (Codec<JSON,?>//encode (~ :x:)))
- (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ :x:))))
+ (wrap (list (` (: (Codec ..;JSON (~ inputT))
+ (struct (def: (~' encode) (Codec<JSON,?>//encode (~ inputT)))
+ (def: ((~' decode) (~ g!inputs)) (../reader;run (~ g!inputs) (Codec<JSON,?>//decode (~ inputT))))
)))))))
diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux
index 7af9eefc1..995cc023a 100644
--- a/stdlib/source/lux/macro/poly.lux
+++ b/stdlib/source/lux/macro/poly.lux
@@ -1,17 +1,19 @@
(;module:
[lux #- function]
- (lux (control ["M" monad #+ do Monad]
+ (lux (control [monad #+ do Monad]
[eq]
["p" parser])
+ [function]
(data [text "text/" Monoid<Text>]
- (coll [list "List/" Fold<List> Monad<List>]
+ (coll [list "L/" Fold<List> Monad<List> Monoid<List>]
[dict #+ Dict])
- [number]
+ [number "nat/" Codec<Text,Nat>]
[product]
[bool]
[maybe]
- [ident "Ident/" Eq<Ident> Codec<Text,Ident>])
- [macro #+ with-gensyms "Lux/" Monad<Lux>]
+ [ident "Ident/" Eq<Ident> Codec<Text,Ident>]
+ ["R" result])
+ [macro #+ with-gensyms]
(macro [code]
["s" syntax #+ syntax: Syntax]
(syntax ["cs" common]
@@ -20,168 +22,229 @@
[type]
))
-## [Types]
-(type: #export (Matcher a)
- (-> Type (Lux a)))
-
(type: #export Env (Dict Nat [Type Code]))
-## [Combinators]
+(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) (R;Result a)))
+ (case (p;run [env types] poly)
+ (#R;Error error)
+ (#R;Error error)
+
+ (#R;Success [[env' remaining] output])
+ (case remaining
+ #;Nil
+ (#R;Success output)
+
+ _
+ (#R;Error (|> remaining
+ (L/map type;to-text)
+ (text;join-with ", ")
+ (text/append "Unconsumed types: "))))))
+
+(def: #export (run type poly)
+ (All [a] (-> Type (Poly a) (R;Result a)))
+ (run' fresh (list type) poly))
+
+(def: #export env
+ (Poly Env)
+ (;function [[env inputs]]
+ (#R;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)
+ (#R;Error error)
+ (#R;Error error)
+
+ (#R;Success [[_ remaining] output])
+ (#R;Success [[env remaining] output]))))
+
+(def: #export peek
+ (Poly Type)
+ (;function [[env inputs]]
+ (case inputs
+ #;Nil
+ (#R;Error "Empty stream of types.")
+
+ (#;Cons headT tail)
+ (#R;Success [[env inputs] headT]))))
+
+(def: #export any
+ (Poly Type)
+ (;function [[env inputs]]
+ (case inputs
+ #;Nil
+ (#R;Error "Empty stream of types.")
+
+ (#;Cons headT tail)
+ (#R;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)
+ (#R;Error error)
+ (#R;Error error)
+
+ (#R;Success output)
+ (#R;Success [[env pass-through] output]))))
+
+(def: (label idx)
+ (-> Nat Code)
+ (code;local-symbol (text/append "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)
+ (#R;Error error)
+ (#R;Error error)
+
+ (#R;Success [[_ inputs'] output])
+ (#R;Success [[env inputs'] [g!var output]])))))
+
(do-template [<combinator> <name> <type>]
[(def: #export <combinator>
- (Matcher Unit)
- (;function [:type:]
- (case (type;un-name :type:)
+ (Poly Unit)
+ (do p;Monad<Parser>
+ [headT any]
+ (case (type;un-name headT)
<type>
- (Lux/wrap [])
+ (wrap [])
_
- (macro;fail ($_ text/append "Not " <name> " type: " (type;to-text :type:))))))]
+ (p;fail ($_ text/append "Not " <name> " type: " (type;to-text headT))))))]
[void "Void" #;Void]
[unit "Unit" #;Unit]
- )
-
-(do-template [<combinator> <name>]
- [(def: #export <combinator>
- (Matcher Unit)
- (;function [:type:]
- (case (type;un-alias :type:)
- (#;Named ["lux" <name>] _)
- (Lux/wrap [])
-
- _
- (macro;fail ($_ text/append "Not " <name> " type: " (type;to-text :type:))))))]
-
- [bool "Bool"]
- [nat "Nat"]
- [int "Int"]
- [deg "Deg"]
- [real "Real"]
- [text "Text"]
+ [bool "Bool" (#;Host "#Bool" #;Nil)]
+ [nat "Nat" (#;Host "#Nat" #;Nil)]
+ [int "Int" (#;Host "#Int" #;Nil)]
+ [deg "Deg" (#;Host "#Deg" #;Nil)]
+ [real "Real" (#;Host "#Real" #;Nil)]
+ [text "Text" (#;Host "#Text" #;Nil)]
)
(def: #export primitive
- (Matcher Type)
- (;function [:type:]
- (with-expansions
- [<primitives> (do-template [<parser> <type>]
- [(do macro;Monad<Lux>
- [_ (<parser> :type:)]
- (wrap <type>))]
-
- [void Void]
- [unit Unit]
- [bool Bool]
- [nat Nat]
- [int Int]
- [deg Deg]
- [real Real]
- [text Text])]
- ($_ macro;either
- <primitives>))))
-
-(do-template [<single> <multi> <flattener> <tag>]
- [(def: #export <single>
- (Matcher [Type Type])
- (;function [:type:]
- (case (type;un-name :type:)
- (<tag> :left: :right:)
- (Lux/wrap [:left: :right:])
-
- _
- (macro;fail ($_ text/append "Not a " (Ident/encode (ident-for <tag>)) " type: " (type;to-text :type:))))))
-
- (def: #export <multi>
- (Matcher (List Type))
- (;function [:type:]
- (let [members (<flattener> (type;un-name :type:))]
+ (Poly Type)
+ (do p;Monad<Parser>
+ [headT any]
+ (case (run headT ($_ p;either
+ void
+ unit
+ bool
+ nat
+ int
+ deg
+ real
+ text))
+ (#R;Error error)
+ (p;fail error)
+
+ (#R;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))
- (Lux/wrap members)
- (macro;fail ($_ text/append "Not a " (Ident/encode (ident-for <tag>)) " type: " (type;to-text :type:)))))))]
+ (local members poly)
+ (p;fail ($_ text/append "Not a " (Ident/encode (ident-for <tag>)) " type: " (type;to-text headT)))))))]
- [sum sum+ type;flatten-variant #;Sum]
- [prod prod+ type;flatten-tuple #;Product]
+ [variant type;flatten-variant #;Sum]
+ [tuple type;flatten-tuple #;Product]
)
-(def: #export polymorphic
- (Matcher [(List Code) Type])
- (;function [:type:]
- (let [:type: (type;un-name :type:)]
- (case :type:
- (#;UnivQ _)
- (loop [:type: :type:]
- (case :type:
- (#;UnivQ _ :type:')
- (do macro;Monad<Lux>
- [[g!tail :type:''] (recur :type:')
- g!head (macro;gensym "type-var")]
- (wrap [(list& g!head g!tail)
- :type:'']))
-
- _
- (Lux/wrap [(;list) :type:])))
-
- _
- (macro;fail ($_ text/append "Non-polymorphic type: " (type;to-text :type:)))))))
-
-(def: #export function
- (Matcher [(List Type) Type])
- (;function [:type:]
- (:: macro;Monad<Lux> wrap (type;flatten-function (type;un-name :type:)))))
-
-(def: #export apply
- (Matcher [Type (List Type)])
- (;function [:type:]
- (do macro;Monad<Lux>
- [#let [[:func: :args:] (loop [:type: (type;un-name :type:)]
- (case :type:
- (#;Apply :arg: :func:)
- (let [[:func:' :args:] (recur :func:)]
- [:func:' (list& :arg: :args:)])
-
- _
- [:type: (;list)]))]]
- (case :args:
- #;Nil
- (macro;fail "Not a type application.")
-
- _
- (wrap [:func: (list;reverse :args:)])))))
-
-(def: #export (apply-1 name)
- (-> Ident (Matcher Type))
- (;function [:type:]
- (case (type;un-name :type:)
- (^multi (#;Apply :arg: :quant:)
- [(type;un-alias :quant:) (#;Named actual _)]
- (Ident/= name actual))
- (Lux/wrap :arg:)
-
- _
- (macro;fail ($_ text/append "Not " (Ident/encode name) " type: " (type;to-text :type:))))))
-
-(def: #export (apply-2 name)
- (-> Ident (Matcher [Type Type]))
- (;function [:type:]
- (case (type;un-name :type:)
- (^multi (#;Apply :arg1: (#;Apply :arg0: :quant:))
- [(type;un-alias :quant:) (#;Named actual _)]
- (Ident/= name actual))
- (Lux/wrap [:arg0: :arg1:])
-
- _
- (macro;fail ($_ text/append "Not " (Ident/encode name) " type: " (type;to-text :type:))))))
-
-(def: #export recursive
- (Matcher Type)
- (;function [:type:]
- (case (type;un-name :type:)
- (#;Apply #;Void (#;UnivQ _ :type:'))
- (Lux/wrap :type:')
+(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/append "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))
+ (L/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/append "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/append "Non-application type: " (type;to-text headT)))
+ (local (#;Cons funcT paramsT) poly))))
+
+(def: #export (named expected)
+ (-> Ident (Poly Unit))
+ (do p;Monad<Parser>
+ [headT any]
+ (case (type;un-alias headT)
+ (#;Named actual _)
+ (if (Ident/= expected actual)
+ (wrap [])
+ (p;fail ($_ text/append "Not " (Ident/encode expected) " type: " (type;to-text headT))))
_
- (macro;fail ($_ text/append "Not a recursive type: " (type;to-text :type:))))))
+ (p;fail ($_ text/append "Not a named type: " (type;to-text headT))))))
(def: (adjusted-idx env idx)
(-> Env Nat Nat)
@@ -190,110 +253,110 @@
bound-idx (n.% +2 idx)]
(|> env-level n.dec (n.- bound-level) (n.* +2) (n.+ bound-idx))))
-(def: #export (bound env)
- (-> Env (Matcher Code))
- (;function [:type:]
- (case :type:
+(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])
- (Lux/wrap poly-ast)
+ (wrap poly-ast)
#;None
- (macro;fail ($_ text/append "Unknown bound type: " (type;to-text :type:))))
+ (p;fail ($_ text/append "Unknown bound type: " (type;to-text headT))))
_
- (macro;fail ($_ text/append "Not a bound type: " (type;to-text :type:))))))
-
-(def: #export (recursion env)
- (-> Env (Matcher Code))
- (;function [:type:]
- (do macro;Monad<Lux>
- [[t-func t-args] (apply :type:)]
- (case t-func
- (^multi (#;Bound t-func-idx)
- (n.= +0 (adjusted-idx env t-func-idx))
- [(do maybe;Monad<Maybe>
- [=func (dict;get +0 env)
- =args (M;map @ (;function [t-arg]
- (case t-arg
- (#;Bound idx)
- (dict;get (adjusted-idx env idx) env)
-
- _
- #;None))
- t-args)]
- (wrap (` ((~ (product;right =func)) (~@ (List/map product;right =args))))))
- (#;Some call)])
- (wrap call)
-
- _
- (macro;fail ($_ text/append "Type is not a recursive instance: " (type;to-text :type:))))
- )))
-
-(def: #export (self env)
- (-> Env (Matcher Code))
- (;function [:type:]
- (case :type:
- (^multi (#;Apply #;Void (#;Bound t-func-idx))
- (n.= +0 (adjusted-idx env t-func-idx))
- [(dict;get +0 env)
- (#;Some [self-type self-call])])
- (Lux/wrap self-call)
+ (p;fail ($_ text/append "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/append "Wrong bound type.\n"
+ "Expected: " (nat/encode id) "\n"
+ " Actual: " (nat/encode idx))))
_
- (macro;fail ($_ text/append "Type is not a recursive self-call: " (type;to-text :type:))))))
+ (p;fail ($_ text/append "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]))
-(def: #export (var env var-id)
- (-> Env Nat (Matcher Unit))
- (;function [:type:]
- (case :type:
- (^multi (#;Bound idx)
- (n.= var-id (adjusted-idx env idx)))
- (Lux/wrap [])
+ _
+ (p;fail ($_ text/append "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)
_
- (macro;fail ($_ text/append "Not a bound type: " (type;to-text :type:))))))
+ (p;fail ($_ text/append "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/append
+ "{" (Ident/encode (ident-for ;;log)) "} "
+ (type;to-text current)))]]
+ (p;fail "LOGGING")))
## [Syntax]
-(def: #export (extend-env [funcT funcA] type-vars env)
- (-> [Type Code] (List [Type Code]) Env Env)
- (case type-vars
- #;Nil
- env
-
- (#;Cons [varT varA] type-vars')
- (let [current-size (dict;size env)]
- (|> env
- (dict;put current-size [funcT funcA])
- (dict;put (n.inc current-size) [varT varA])
- (extend-env [(#;Apply varT funcT) (` (#;Apply (~ varA) (~ funcA)))]
- type-vars')
- ))))
-
-(syntax: #export (poly: [_ex-lev csr;export]
- [[name env inputs] (s;form ($_ p;seq
- s;local-symbol
- s;local-symbol
- (p;many s;local-symbol)))]
+(syntax: #export (poly: [export csr;export]
+ [name s;local-symbol]
body)
- (with-gensyms [g!body]
- (let [g!inputs (List/map (|>. [""] code;symbol) inputs)
- g!name (code;symbol ["" name])
- g!env (code;symbol ["" env])]
- (wrap (;list (` (syntax: (~@ (csw;export _ex-lev)) ((~ g!name) (~@ (List/map (;function [g!input] (` [(~ g!input) s;symbol]))
- g!inputs)))
+ (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<Lux>
- [(~@ (List/join (List/map (;function [g!input] (;list g!input (` (macro;find-type-def (~ g!input)))))
- g!inputs)))
- (~' #let) [(~ g!env) (: Env (dict;new number;Hash<Nat>))]
- (~ g!body) (: (Lux Code)
- (loop [(~ g!env) (~ g!env)
- (~@ (List/join (List/map (;function [g!input] (;list g!input g!input))
- g!inputs)))]
- (let [(~ g!name) (~' recur)]
- (~ body))))]
- ((~' wrap) (;list (~ g!body)))))))))))
+ [(~ 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)
@@ -302,33 +365,33 @@
(def: (derivation-name poly args)
(-> Text (List Text) (Maybe Text))
(if (common-poly-name? poly)
- (#;Some (List/fold (text;replace-once "?") poly args))
+ (#;Some (L/fold (text;replace-once "?") poly args))
#;None))
-(syntax: #export (derived: [_ex-lev csr;export]
+(syntax: #export (derived: [export csr;export]
[?name (p;opt s;local-symbol)]
[[poly-func poly-args] (s;form (p;seq s;symbol (p;many s;symbol)))]
[?custom-impl (p;opt s;any)])
(do @
- [poly-args (M;map @ macro;normalize poly-args)
+ [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))
+ [(derivation-name (product;right poly-func) (L/map product;right poly-args))
(#;Some derived-name)])
(wrap derived-name)
_
- (macro;fail "derived: was given no explicit name, and cannot generate one from given information."))
+ (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 _ex-lev))
+ (` ((~ (code;symbol poly-func)) (~@ (L/map code;symbol poly-args)))))]]
+ (wrap (;list (` (def: (~@ (csw;export export))
(~ (code;symbol ["" name]))
{#;struct? true}
(~ impl)))))))
@@ -339,7 +402,7 @@
(case type
(#;Host name params)
(` (#;Host (~ (code;text name))
- (list (~@ (List/map (to-ast env) params)))))
+ (list (~@ (L/map (to-ast env) params)))))
(^template [<tag>]
<tag>
@@ -371,7 +434,7 @@
(^template [<tag> <macro> <flattener>]
(<tag> left right)
- (` (<macro> (~@ (List/map (to-ast env) (<flattener> type))))))
+ (` (<macro> (~@ (L/map (to-ast env) (<flattener> type))))))
([#;Sum | type;flatten-variant]
[#;Product & type;flatten-tuple])
@@ -380,23 +443,7 @@
(^template [<tag>]
(<tag> scope body)
- (` (<tag> (list (~@ (List/map (to-ast env) scope)))
+ (` (<tag> (list (~@ (L/map (to-ast env) scope)))
(~ (to-ast env body)))))
([#;UnivQ] [#;ExQ])
))
-
-(def: #export (gen-type env converter type-fun tvars type)
- (-> Env (-> Code Code) Code (List Code) Type Code)
- (let [type' (to-ast env type)]
- (case tvars
- #;Nil
- (converter type')
-
- _
- (` (All (~ type-fun) [(~@ tvars)]
- (-> (~@ (List/map converter tvars))
- (~ (converter (` ((~ type') (~@ tvars)))))))))))
-
-(def: #export (type-var-indices num-vars)
- (-> Nat (List Type))
- (|> num-vars list;indices (List/map (|>. #;Bound))))
diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux
index 9de2a8784..20bda8be7 100644
--- a/stdlib/source/lux/macro/poly/eq.lux
+++ b/stdlib/source/lux/macro/poly/eq.lux
@@ -1,7 +1,8 @@
(;module:
lux
(lux (control [monad #+ do Monad]
- [eq])
+ [eq]
+ ["p" parser])
(data [text "text/" Monoid<Text>]
text/format
(coll [list "L/" Monad<List>]
@@ -25,109 +26,108 @@
))
## [Derivers]
-(poly: #export (Eq<?> env :x:)
- (let [->Eq (: (-> Code Code)
- (function [.type.] (` (eq;Eq (~ .type.)))))]
- (with-expansions
- [<basic> (do-template [<type> <matcher> <eq>]
- [(do @
- [_ (<matcher> :x:)]
- (wrap (` (: (~ (->Eq (` <type>)))
- <eq>))))]
+(poly: #export Eq<?>
+ (with-expansions
+ [<basic> (do-template [<type> <matcher> <eq>]
+ [(do @
+ [[primT _] (p;seq poly;peek <matcher>)]
+ (wrap (` (: (~ (@Eq primT))
+ <eq>))))]
- [Unit poly;unit (function [(~' test) (~' input)] true)]
- [Bool poly;bool bool;Eq<Bool>]
- [Nat poly;nat number;Eq<Nat>]
- [Int poly;int number;Eq<Int>]
- [Deg poly;deg number;Eq<Deg>]
- [Real poly;real number;Eq<Real>]
- [Text poly;text text;Eq<Text>])
- <composites> (do-template [<name> <eq>]
- [(do @
- [:arg: (poly;apply-1 (ident-for <name>) :x:)
- g!arg (Eq<?> env :arg:)]
- (wrap (` (: (~ (->Eq (type;to-ast :x:)))
- (<eq> (~ g!arg))))))]
+ [Unit poly;unit (function [(~' test) (~' input)] true)]
+ [Bool poly;bool bool;Eq<Bool>]
+ [Nat poly;nat number;Eq<Nat>]
+ [Int poly;int number;Eq<Int>]
+ [Deg poly;deg number;Eq<Deg>]
+ [Real poly;real number;Eq<Real>]
+ [Text poly;text text;Eq<Text>])
+ <composites> (do-template [<name> <eq>]
+ [(do @
+ [[collT [_ argC]] (p;seq poly;peek
+ (poly;apply (p;seq (poly;named (ident-for <name>))
+ Eq<?>)))]
+ (wrap (` (: (~ (@Eq collT))
+ (<eq> (~ argC))))))]
- [list;List list;Eq<List>]
- [vector;Vector vector;Eq<Vector>]
- [array;Array array;Eq<Array>]
- [queue;Queue queue;Eq<Queue>]
- [set;Set set;Eq<Set>]
- [seq;Seq seq;Eq<Seq>]
- [rose;Tree rose;Eq<Tree>]
- )]
- ($_ macro;either
+ ## [;Maybe maybe;Eq<Maybe>]
+ ## [;List list;Eq<List>]
+ [vector;Vector vector;Eq<Vector>]
+ [array;Array array;Eq<Array>]
+ [queue;Queue queue;Eq<Queue>]
+ [set;Set set;Eq<Set>]
+ [seq;Seq seq;Eq<Seq>]
+ [rose;Tree rose;Eq<Tree>]
+ )]
+ (do @
+ [*env* poly;env
+ #let [@Eq (: (-> Type Code)
+ (function [type]
+ (` (eq;Eq (~ (poly;to-ast *env* type))))))]]
+ ($_ p;either
## Primitive types
<basic>
## Composite types
<composites>
(do @
- [[:key: :val:] (poly;apply-2 (ident-for dict;Dict) :x:)
- g!val (Eq<?> env :val:)]
- (wrap (` (: (~ (->Eq (type;to-ast :x:)))
- (dict;Eq<Dict> (~ g!val))))))
+ [[collT [_ _ valC]] (p;seq poly;peek
+ (poly;apply ($_ p;seq
+ (poly;named (ident-for dict;Dict))
+ poly;any
+ Eq<?>)))]
+ (wrap (` (: (~ (@Eq collT))
+ (dict;Eq<Dict> (~ valC))))))
## Variants
- (with-gensyms [g!left g!right]
- (do @
- [members (poly;sum+ :x:)
- pattern-matching (monad;map @
- (function [[tag :case:]]
- (do @
- [g!eq (Eq<?> env :case:)]
- (wrap (list (` [((~ (code;nat tag)) (~ g!left))
- ((~ (code;nat tag)) (~ g!right))])
- (` ((~ g!eq) (~ g!left) (~ g!right)))))))
- (list;enumerate members))]
- (wrap (` (: (~ (->Eq (poly;to-ast env :x:)))
- (function [(~ g!left) (~ g!right)]
- (case [(~ g!left) (~ g!right)]
- (~@ (L/join pattern-matching)))))))))
+ (do @
+ [[variantT members] (p;seq poly;peek
+ (poly;variant (p;many Eq<?>)))
+ #let [g!left (code;local-symbol "\u0000left")
+ g!right (code;local-symbol "\u0000right")]]
+ (wrap (` (: (~ (@Eq variantT))
+ (function [(~ g!left) (~ g!right)]
+ (case [(~ g!left) (~ g!right)]
+ (~@ (L/join (L/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))))))))))
## Tuples
(do @
- [:members: (poly;prod+ :x:)
- #let [indices (|> (list;size :members:) n.dec (list;n.range +0))
+ [[tupleT g!eqs] (p;seq poly;peek
+ (poly;tuple (p;many Eq<?>)))
+ #let [indices (|> (list;size g!eqs) n.dec (list;n.range +0))
g!lefts (L/map (|>. nat/encode (text/append "left") code;local-symbol) indices)
- g!rights (L/map (|>. nat/encode (text/append "right") code;local-symbol) indices)]
- g!eqs (monad;map @ (Eq<?> env) :members:)]
- (wrap (` (: (~ (->Eq (poly;to-ast env :x:)))
+ g!rights (L/map (|>. nat/encode (text/append "right") code;local-symbol) indices)]]
+ (wrap (` (: (~ (@Eq tupleT))
(function [[(~@ g!lefts)] [(~@ g!rights)]]
(and (~@ (|> (list;zip3 g!eqs g!lefts g!rights)
(L/map (function [[g!eq g!left g!right]]
(` ((~ g!eq) (~ g!left) (~ g!right)))))))))))))
## Type recursion
- (with-gensyms [g!rec]
- (do @
- [:non-rec: (poly;recursive :x:)
- #let [new-env (poly;extend-env [:x: g!rec] (list [Bottom (` (;undefined))]) env)]
- .non-rec. (Eq<?> new-env :non-rec:)]
- (wrap (` (: (~ (poly;gen-type new-env ->Eq g!rec (list) :x:))
- (eq;rec (;function [(~ g!rec)]
- (~ .non-rec.))))))))
- (poly;self env :x:)
- (poly;recursion env :x:)
+ (do @
+ [[recT [g!self bodyC]] (p;seq poly;peek
+ (poly;recursive Eq<?>))]
+ (wrap (` (: (~ (@Eq recT))
+ (eq;rec (;function [(~ g!self)]
+ (~ bodyC)))))))
+ poly;recursive-self
## Type applications
(do @
- [[:func: :args:] (poly;apply :x:)
- .func. (Eq<?> env :func:)
- .args. (monad;map @ (Eq<?> env) :args:)]
- (wrap (` (: (~ (->Eq (type;to-ast :x:)))
- ((~ .func.) (~@ .args.))))))
+ [[funcC argsC] (poly;apply (p;seq Eq<?> (p;many Eq<?>)))]
+ (wrap (` ((~ funcC) (~@ argsC)))))
## Bound type-vars
- (poly;bound env :x:)
+ poly;bound
## Polymorphism
- (with-gensyms [g!type-fun]
- (do @
- [[g!vars :non-poly:] (poly;polymorphic :x:)
- #let [new-env (poly;extend-env [:x: g!type-fun]
- (list;zip2 (|> g!vars list;size poly;type-var-indices) g!vars)
- env)]
- .non-poly. (Eq<?> new-env :non-poly:)]
- (wrap (` (: (All (~ g!type-fun) [(~@ g!vars)]
- (-> (~@ (L/map ->Eq g!vars))
- (~ (->Eq (` ((~ (poly;to-ast env :x:)) (~@ g!vars)))))))
- (function (~ g!type-fun) [(~@ g!vars)]
- (~ .non-poly.)))))))
+ (do @
+ [[polyT [funcC varsC bodyC]] (p;seq poly;peek
+ (poly;polymorphic Eq<?>))]
+ (wrap (` (: (All [(~@ varsC)]
+ (-> (~@ (L/map (|>. (~) eq;Eq (`)) varsC))
+ (eq;Eq ((~ (poly;to-ast *env* polyT)) (~@ varsC)))))
+ (function (~ funcC) [(~@ varsC)]
+ (~ bodyC))))))
+ poly;recursive-call
## If all else fails...
- (macro;fail (format "Cannot create Eq for: " (%type :x:)))
+ (|> 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
index 0acd49a8e..cc6007220 100644
--- a/stdlib/source/lux/macro/poly/functor.lux
+++ b/stdlib/source/lux/macro/poly/functor.lux
@@ -1,16 +1,12 @@
(;module:
lux
- (lux (control ["M" monad #+ do Monad]
- [functor])
+ (lux (control [monad #+ do Monad]
+ [functor]
+ ["p" parser])
(data [text]
text/format
- (coll [list "List/" Monad<List>]
- [dict #+ Dict])
- [number]
- [product]
- [bool]
- [maybe]
- [ident "Ident/" Codec<Text,Ident>])
+ (coll [list "L/" Monad<List> Monoid<List>])
+ [product])
[macro #+ Monad<Lux> with-gensyms]
(macro [code]
[syntax #+ syntax: Syntax]
@@ -19,107 +15,81 @@
[type]
))
-## [Derivers]
-(poly: #export (Functor<?> env :input:)
- (with-gensyms [g!type-fun g!func g!input]
- (do @
- [[g!vars :x:] (poly;polymorphic :input:)
- #let [num-vars (list;size g!vars)
- new-env (poly;extend-env [:input: g!type-fun]
- (list;zip2 (poly;type-var-indices num-vars) g!vars)
- env)]]
- (let [->Functor (: (-> Code Code)
- (function [.type.]
- (if (n.= +1 num-vars)
- (` (functor;Functor (~ .type.)))
- (let [type-params (|> num-vars n.dec list;indices (List/map (|>. %n code;local-symbol)))]
- (` (All [(~@ type-params)] (functor;Functor ((~ .type.) (~@ type-params)))))))))
- Arg<?> (: (-> Code (poly;Matcher Code))
- (function Arg<?> [value :type:]
- ($_ macro;either
- ## Nothing to do.
- (do @
- [_ (poly;primitive :type:)]
- (wrap value))
- ## Type-var
- (do @
- [_ (poly;var new-env (|> num-vars (n.* +2) n.dec) :type:)]
- (wrap (` ((~ g!func) (~ value)))))
- ## Bound type-variables
- (do @
- [_ (poly;bound new-env :type:)]
- (wrap value))
- ## Tuples/records
- (do @
- [members (poly;prod+ :type:)
- pm (M;map @
- (function [:slot:]
- (do @
- [g!slot (macro;gensym "g!slot")
- body (Arg<?> g!slot :slot:)]
- (wrap [g!slot body])))
- members)]
- (wrap (` (case (~ value)
- [(~@ (List/map product;left pm))]
- [(~@ (List/map product;right pm))])
- )))
- ## Recursion
- (do @
- [_ (poly;recursion new-env :type:)]
- (wrap (` ((~' map) (~ g!func) (~ value)))))
- )))]
- ($_ macro;either
- ## Variants
- (do @
- [cases (poly;sum+ :x:)
- pattern-matching (M;map @
- (function [[tag :case:]]
- (do @
- [synthesis (Arg<?> g!input :case:)]
- (wrap (list (` ((~ (code;nat tag)) (~ g!input)))
- (` ((~ (code;nat tag)) (~ synthesis)))))))
- (list;enumerate cases))]
- (wrap (` (: (~ (->Functor (type;to-ast :input:)))
- (struct (def: ((~' map) (~ g!func) (~ g!input))
- (case (~ g!input)
- (~@ (List/join pattern-matching)))))
- ))))
- ## Tuples/Records
- (do @
- [members (poly;prod+ :x:)
- pm (M;map @
- (function [:slot:]
+(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 @
- [g!slot (macro;gensym "g!slot")
- body (Arg<?> g!slot :slot:)]
- (wrap [g!slot body])))
- members)]
- (wrap (` (: (~ (->Functor (type;to-ast :input:)))
- (struct (def: ((~' map) (~ g!func) (~ g!input))
- (case (~ g!input)
- [(~@ (List/map product;left pm))]
- [(~@ (List/map product;right pm))])))
- ))))
- ## Functions
- (with-gensyms [g!out]
- (do @
- [[:ins: :out:] (poly;function :x:)
- .out. (Arg<?> g!out :out:)
- g!envs (M;seq @
- (list;repeat (list;size :ins:)
- (macro;gensym "g!envs")))]
- (wrap (` (: (~ (->Functor (type;to-ast :input:)))
- (struct (def: ((~' map) (~ g!func) (~ g!input))
- (function [(~@ g!envs)]
- (let [(~ g!out) ((~ g!input) (~@ g!envs))]
- (~ .out.))))))))))
- ## No structure (as you'd expect from Identity)
- (do @
- [_ (poly;var new-env num-vars :x:)]
- (wrap (` (: (~ (->Functor (type;to-ast :input:)))
- (struct (def: ((~' map) (~ g!func) (~ g!input))
- ((~ g!func) (~ g!input))))))))
- ## Failure...
- (macro;fail (format "Cannot create Functor for: " (%type :x:)))
- ))
- )))
+ [_ (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/append 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))))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 02:18:29 +0000