aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
authorEduardo Julian2016-12-29 17:02:23 -0400
committerEduardo Julian2016-12-29 17:02:23 -0400
commit30d58c84feb08150acd8e4f378b14e753538499c (patch)
tree8ababc373dbc7a74b28036630f0cbed5f86a768c /stdlib
parent859737d8c65327df47c9e400fca3c428bb906afb (diff)
- ::: can now work with arbitrary higher-order structures.
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/type/auto.lux74
1 files changed, 43 insertions, 31 deletions
diff --git a/stdlib/source/lux/type/auto.lux b/stdlib/source/lux/type/auto.lux
index d2b8cb1e5..27c1472c0 100644
--- a/stdlib/source/lux/type/auto.lux
+++ b/stdlib/source/lux/type/auto.lux
@@ -204,22 +204,32 @@
(set@ #tc;bindings (dict;from-list number;Hash<Nat> (get@ #;mappings type-vars))))]
(#;Right [compiler context]))))
-(def: (test-provision context dep alts)
- (-> tc;Context Type (List [Ident Type]) (Lux (List Ident)))
+(type: #rec Instance
+ {#constructor Ident
+ #dependencies (List Instance)})
+
+(def: (test-provision provision context dep alts)
+ (-> (-> Compiler tc;Context Type (Check Instance))
+ tc;Context Type (List [Ident Type])
+ (Lux (List Instance)))
(do Monad<Lux>
[compiler compiler;get-compiler]
(case (|> alts
- (list;filter (lambda [[alt-name alt-type]]
- (case (tc;run context
- (do Monad<Check>
- [_ (tc;check dep alt-type)]
- (wrap [])))
- (#;Left error)
- false
-
- (#;Right _)
- true)))
- (List/map product;left))
+ (List/map (lambda [[alt-name alt-type]]
+ (case (tc;run context
+ (do Monad<Check>
+ [[tvars alt-type] (concrete-type alt-type)
+ #let [[deps alt-type] (type;flatten-function alt-type)]
+ _ (tc;check dep alt-type)
+ context' tc;get-context
+ =deps (mapM @ (provision compiler context') deps)]
+ (wrap =deps)))
+ (#;Left error)
+ (list)
+
+ (#;Right =deps)
+ (list [alt-name =deps]))))
+ List/join)
#;Nil
(compiler;fail (format "No candidates for provisioning: " (%type dep)))
@@ -227,12 +237,12 @@
(wrap found))))
(def: (provision compiler context dep)
- (-> Compiler tc;Context Type (Check Ident))
+ (-> Compiler tc;Context Type (Check Instance))
(case (compiler;run compiler
($_ compiler;either
- (do Monad<Lux> [alts local-env] (test-provision context dep alts))
- (do Monad<Lux> [alts local-structs] (test-provision context dep alts))
- (do Monad<Lux> [alts import-structs] (test-provision context dep alts))))
+ (do Monad<Lux> [alts local-env] (test-provision provision context dep alts))
+ (do Monad<Lux> [alts local-structs] (test-provision provision context dep alts))
+ (do Monad<Lux> [alts import-structs] (test-provision provision context dep alts))))
(#;Left error)
(tc;fail error)
@@ -245,11 +255,11 @@
(:: Monad<Check> wrap winner)
_
- (tc;fail (format "Too many candidates for provisioning: " (%type dep) " --- " (%list %ident candidates))))
+ (tc;fail (format "Too many candidates for provisioning: " (%type dep) " --- " (%list (. %ident product;left) candidates))))
))
(def: (test-alternatives sig-type member-idx input-types output-type alts)
- (-> Type Nat (List Type) Type (List [Ident Type]) (Lux (List [Ident (List Ident)])))
+ (-> Type Nat (List Type) Type (List [Ident Type]) (Lux (List Instance)))
(do Monad<Lux>
[compiler compiler;get-compiler
context compiler-type-context]
@@ -262,7 +272,6 @@
_ (tc;check alt-type sig-type)
member-type (find-member-type member-idx alt-type)
_ (check-apply member-type input-types output-type)
- =tvars (mapM @ tc;deref tvars)
context' tc;get-context
=deps (mapM @ (provision compiler context') deps)]
(wrap =deps)))
@@ -283,7 +292,7 @@
(wrap found))))
(def: (find-alternatives sig-type member-idx input-types output-type)
- (-> Type Nat (List Type) Type (Lux (List [Ident (List Ident)])))
+ (-> Type Nat (List Type) Type (Lux (List Instance)))
(let [test (test-alternatives sig-type member-idx input-types output-type)]
($_ compiler;either
(do Monad<Lux> [alts local-env] (test alts))
@@ -303,6 +312,15 @@
(All [a] (-> [a a] (List a)))
(list l r))
+(def: (instance$ [constructor dependencies])
+ (-> Instance AST)
+ (case dependencies
+ #;Nil
+ (ast;symbol constructor)
+
+ _
+ (` ((~ (ast;symbol constructor)) (~@ (List/map instance$ dependencies))))))
+
(syntax: #export (::: [member s;symbol]
[args (s;alt (s;seq (s;some s;symbol) s;end)
(s;seq (s;some s;any) s;end))])
@@ -317,16 +335,10 @@
#;Nil
(compiler;fail (format "No structure option could be found for member: " (%ident member)))
- (#;Cons [chosen deps] #;Nil)
- (let [chosen-inst (case deps
- #;Nil
- (ast;symbol chosen)
-
- _
- (` ((~ (ast;symbol chosen)) (~@ (List/map ast;symbol deps)))))]
- (wrap (list (` (:: (~ chosen-inst)
- (~ (ast;local-symbol (product;right member)))
- (~@ (List/map ast;symbol args)))))))
+ (#;Cons chosen #;Nil)
+ (wrap (list (` (:: (~ (instance$ chosen))
+ (~ (ast;local-symbol (product;right member)))
+ (~@ (List/map ast;symbol args))))))
_
(compiler;fail (format "Too many options available: "