aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/analysis
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis')
-rw-r--r--new-luxc/source/luxc/lang/analysis/procedure.lux2
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux75
2 files changed, 53 insertions, 24 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/procedure.lux b/new-luxc/source/luxc/lang/analysis/procedure.lux
index 9f5f61d59..8ab868036 100644
--- a/new-luxc/source/luxc/lang/analysis/procedure.lux
+++ b/new-luxc/source/luxc/lang/analysis/procedure.lux
@@ -20,7 +20,7 @@
(def: #export (analyse-procedure analyse eval proc-name proc-args)
(-> &;Analyser &;Eval Text (List Code) (Meta la;Analysis))
- (<| (maybe;default (&;throw Unknown-Procedure proc-name))
+ (<| (maybe;default (&;throw Unknown-Procedure (%t proc-name)))
(do maybe;Monad<Maybe>
[proc (dict;get proc-name procedures)]
(wrap ((proc proc-name) analyse eval proc-args)))))
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
index 1f1ef15d7..d2107c640 100644
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ b/new-luxc/source/luxc/lang/analysis/structure.lux
@@ -85,26 +85,47 @@
[#;ExQ tc;var])
(#;Apply inputT funT)
- (case (type;apply (list inputT) funT)
- #;None
- (&;throw Not-Quantified-Type (%type funT))
-
- (#;Some outputT)
- (&;with-expected-type outputT
- (analyse-sum analyse tag valueC)))
+ (case funT
+ (#;Var funT-id)
+ (do @
+ [?funT' (&;with-type-env (tc;read funT-id))]
+ (case ?funT'
+ (#;Some funT')
+ (&;with-expected-type (#;Apply inputT funT')
+ (analyse-sum analyse tag valueC))
+
+ _
+ (&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n"
+ " Tag: " (%n tag) "\n"
+ "Value: " (%code valueC)))))
+
+ _
+ (case (type;apply (list inputT) funT)
+ #;None
+ (&;throw Not-Quantified-Type (%type funT))
+
+ (#;Some outputT)
+ (&;with-expected-type outputT
+ (analyse-sum analyse tag valueC))))
_
(&;throw Not-Variant-Type (format " Type: " (%type expectedT) "\n"
" Tag: " (%n tag) "\n"
"Value: " (%code valueC)))))))
-(def: (analyse-typed-product analyse members)
+(def: (analyse-typed-product analyse membersC+)
(-> &;Analyser (List Code) (Meta la;Analysis))
(do meta;Monad<Meta>
[expectedT meta;expected-type]
(loop [expectedT expectedT
- members members]
- (case [expectedT members]
+ membersC+ membersC+]
+ (case [expectedT membersC+]
+ ## If the tuple runs out, whatever expression is the last gets
+ ## matched to the remaining type.
+ [tailT (#;Cons tailC #;Nil)]
+ (&;with-expected-type tailT
+ (analyse tailC))
+
## If the type and the code are still ongoing, match each
## sub-expression to its corresponding type.
[(#;Product leftT rightT) (#;Cons leftC rightC)]
@@ -114,12 +135,6 @@
rightA (recur rightT rightC)]
(wrap (` [(~ leftA) (~ rightA)])))
- ## If the tuple runs out, whatever expression is the last gets
- ## matched to the remaining type.
- [tailT (#;Cons tailC #;Nil)]
- (&;with-expected-type tailT
- (analyse tailC))
-
## If, however, the type runs out but there is still enough
## tail, the remaining elements get packaged into another
## tuple, and analysed through the intermediation of a
@@ -190,13 +205,27 @@
[#;ExQ tc;var])
(#;Apply inputT funT)
- (case (type;apply (list inputT) funT)
- #;None
- (&;throw Not-Quantified-Type (%type funT))
-
- (#;Some outputT)
- (&;with-expected-type outputT
- (analyse-product analyse membersC)))
+ (case funT
+ (#;Var funT-id)
+ (do @
+ [?funT' (&;with-type-env (tc;read funT-id))]
+ (case ?funT'
+ (#;Some funT')
+ (&;with-expected-type (#;Apply inputT funT')
+ (analyse-product analyse membersC))
+
+ _
+ (&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"
+ "Value: " (%code (` [(~@ membersC)]))))))
+
+ _
+ (case (type;apply (list inputT) funT)
+ #;None
+ (&;throw Not-Quantified-Type (%type funT))
+
+ (#;Some outputT)
+ (&;with-expected-type outputT
+ (analyse-product analyse membersC))))
_
(&;throw Not-Tuple-Type (format " Type: " (%type expectedT) "\n"