diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/analysis/structure.lux')
| -rw-r--r-- | new-luxc/source/luxc/lang/analysis/structure.lux | 75 |
1 files changed, 36 insertions, 39 deletions
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux index 9308fcfef..b7047e105 100644 --- a/new-luxc/source/luxc/lang/analysis/structure.lux +++ b/new-luxc/source/luxc/lang/analysis/structure.lux @@ -26,14 +26,13 @@ (exception: #export Not-Variant-Type) (exception: #export Not-Tuple-Type) -(exception: #export Cannot-Infer-Numeric-Tag) - -(type: Type-Error - (-> Type Text)) +(exception: #export Not-Quantified-Type) -(def: (not-quantified type) - Type-Error - (format "Not a quantified type: " (%type type))) +(exception: #export Cannot-Infer-Numeric-Tag) +(exception: #export Record-Keys-Must-Be-Tags) +(exception: #export Cannot-Repeat-Tag) +(exception: #export Tag-Does-Not-Belong-To-Record) +(exception: #export Record-Size-Mismatch) (def: #export (analyse-sum analyse tag valueC) (-> &;Analyser Nat Code (Meta la;Analysis)) @@ -79,23 +78,19 @@ "Value: " (%code valueC) "\n" " Type: " (%type expectedT))))) - (#;UnivQ _) - (do @ - [[var-id var] (&;with-type-env - tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) - (analyse-sum analyse tag valueC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (&;with-type-env <instancer>)] + (&;with-expected-type (maybe;assume (type;apply (list instanceT) expectedT)) (analyse-sum analyse tag valueC)))) + ([#;UnivQ tc;existential] + [#;ExQ tc;var]) (#;Apply inputT funT) (case (type;apply (list inputT) funT) #;None - (&;fail (not-quantified funT)) + (&;throw Not-Quantified-Type (%type funT)) (#;Some outputT) (&;with-expected-type outputT @@ -188,23 +183,19 @@ (type;tuple (list/map product;left membersTA))))] (wrap (la;product (list/map product;right membersTA)))))) - (#;UnivQ _) - (do @ - [[var-id var] (&;with-type-env - tc;existential)] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) - (analyse-product analyse membersC))) - - (#;ExQ _) - (&common;with-var - (function [[var-id var]] - (&;with-expected-type (maybe;assume (type;apply (list var) expectedT)) + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (&;with-type-env <instancer>)] + (&;with-expected-type (maybe;assume (type;apply (list instanceT) expectedT)) (analyse-product analyse membersC)))) + ([#;UnivQ tc;existential] + [#;ExQ tc;var]) (#;Apply inputT funT) (case (type;apply (list inputT) funT) #;None - (&;fail (not-quantified funT)) + (&;throw Not-Quantified-Type (%type funT)) (#;Some outputT) (&;with-expected-type outputT @@ -248,7 +239,8 @@ (wrap [key val])) _ - (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key))))) + (&;throw Record-Keys-Must-Be-Tags (format " Key: " (%code key) "\n" + "Record: " (%code (code;record record)))))) record)) ## Lux already possesses the means to analyse tuples, so @@ -269,10 +261,10 @@ size-ts (list;size tag-set)] _ (if (n.= size-ts size-record) (wrap []) - (&;fail (format "Record size does not match tag-set size." "\n" - "Expected: " (|> size-ts nat-to-int %i) "\n" - " Actual: " (|> size-record nat-to-int %i) "\n" - "For type: " (%type recordT)))) + (&;throw Record-Size-Mismatch + (format "Expected: " (|> size-ts nat-to-int %i) "\n" + " Actual: " (|> size-record nat-to-int %i) "\n" + " Type: " (%type recordT)))) #let [tuple-range (list;n.range +0 (n.dec size-ts)) tag->idx (dict;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))] idx->val (monad;fold @ @@ -281,12 +273,17 @@ [key (meta;normalize key)] (case (dict;get key tag->idx) #;None - (&;fail (format "Tag " (%code (code;tag key)) - " does not belong to tag-set for type " (%type recordT))) + (&;throw Tag-Does-Not-Belong-To-Record + (format " Tag: " (%code (code;tag key)) "\n" + "Type: " (%type recordT))) (#;Some idx) (if (dict;contains? idx idx->val) - (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key)))) + (&;throw Cannot-Repeat-Tag + (format " Tag: " (%code (code;tag key)) "\n" + "Record: " (%code (code;record (list/map (function [[keyI valC]] + [(code;tag keyI) valC]) + record))))) (wrap (dict;put idx val idx->val)))))) (: (Dict Nat Code) (dict;new number;Hash<Nat>)) |