aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser/structure.lux
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux429
1 files changed, 197 insertions, 232 deletions
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
index 9447ea059..f93534463 100644
--- a/new-luxc/source/luxc/analyser/structure.lux
+++ b/new-luxc/source/luxc/analyser/structure.lux
@@ -24,7 +24,109 @@
(analyser ["&;" common]
["&;" inference])))
-## [Analysers]
+## Variants get analysed as binary sum types for the sake of semantic
+## simplicity.
+## This is because you can encode a variant of any size using just
+## binary sums by nesting them.
+
+(do-template [<name> <side>]
+ [(def: (<name> inner)
+ (-> la;Analysis la;Analysis)
+ (#la;Sum (<side> inner)))]
+
+ [sum-left #;Left]
+ [sum-right #;Right])
+
+(def: (variant tag size temp value)
+ (-> Nat Nat Nat la;Analysis la;Analysis)
+ (if (n.= (n.dec size) tag)
+ (if (n.= +1 tag)
+ (sum-right value)
+ (L/fold (function;const sum-left)
+ (sum-right value)
+ (list;n.range +0 (n.- +2 tag))))
+ (L/fold (function;const sum-left)
+ (case value
+ (#la;Sum _)
+ (#la;Case value (list [(#la;BindP temp)
+ (#la;Relative (#;Local temp))]))
+
+ _
+ value)
+ (list;n.range +0 tag))))
+
+(def: #export (analyse-sum analyse tag valueC)
+ (-> &;Analyser Nat Code (Lux la;Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (&;with-stacked-errors
+ (function [_] (format "Invalid type for variant: " (%type expected)))
+ (case expected
+ (#;Sum _)
+ (let [flat (type;flatten-variant expected)
+ type-size (list;size flat)]
+ (case (list;nth tag flat)
+ (#;Some variant-type)
+ (do @
+ [valueA (&;with-expected-type variant-type
+ (analyse valueC))
+ temp &env;next-local]
+ (wrap (variant tag type-size temp valueA)))
+
+ #;None
+ (&common;variant-out-of-bounds-error expected type-size tag)))
+
+ (#;Named name unnamedT)
+ (&;with-expected-type unnamedT
+ (analyse-sum analyse tag valueC))
+
+ (#;Var id)
+ (do @
+ [bound? (&;within-type-env
+ (TC;bound? id))]
+ (if bound?
+ (do @
+ [expected' (&;within-type-env
+ (TC;read-var id))]
+ (&;with-expected-type expected'
+ (analyse-sum analyse tag valueC)))
+ ## Cannot do inference when the tag is numeric.
+ ## This is because there is no way of knowing how many
+ ## cases the inferred sum type would have.
+ (&;fail (format "Invalid type for variant: " (%type expected)))))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;within-type-env
+ TC;existential)]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-sum analyse tag valueC)))
+
+ (#;ExQ _)
+ (&common;with-var
+ (function [[var-id var]]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-sum analyse tag valueC))))
+
+ _
+ (&;fail "")))))
+
+## Tuples get analysed into binary products for the sake of semantic
+## simplicity, since products/pairs can encode tuples of any length
+## through nesting.
+
+(def: (product members)
+ (-> (List la;Analysis) la;Analysis)
+ (case members
+ #;Nil
+ #la;Unit
+
+ (#;Cons singleton #;Nil)
+ singleton
+
+ (#;Cons left right)
+ (#la;Product left (product right))))
+
(def: (analyse-typed-product analyse members)
(-> &;Analyser (List Code) (Lux la;Analysis))
(do Monad<Lux>
@@ -32,6 +134,8 @@
(loop [expected expected
members members]
(case [expected members]
+ ## If the type and the code are still ongoing, match each
+ ## sub-expression to its corresponding type.
[(#;Product leftT rightT) (#;Cons leftC rightC)]
(do @
[leftA (&;with-expected-type leftT
@@ -39,10 +143,29 @@
rightA (recur rightT rightC)]
(wrap (#la;Product 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
+ ## temporary local variable.
+ ## The reason for this is that it is assumed that the type of
+ ## the tuple represents the expectations of the user.
+ ## If the type is for a 3-tuple, but a 5-tuple is provided, it
+ ## is assumed that the user intended the following layout:
+ ## [0, 1, [2, 3, 4]]
+ ## but that, for whatever reason, it was written in a flat
+ ## way.
+ ## The reason why an intermediate variable is used is that if
+ ## the code was just re-written with just tuple nesting, the
+ ## resulting analysis would have undone the explicity nesting,
+ ## since Product nodes rely on nesting inherently, thereby
+ ## blurring the line between what was wanted (the separation)
+ ## and what was analysed.
[tailT tailC]
(do @
[g!tail (macro;gensym "tail")]
@@ -52,73 +175,6 @@
(~ g!tail))))))
))))
-(def: #export (normalize-record pairs)
- (-> (List [Code Code]) (Lux (List [Ident Code])))
- (mapM Monad<Lux>
- (function [[key val]]
- (case key
- [_ (#;Tag key)]
- (do Monad<Lux>
- [key (macro;normalize key)]
- (wrap [key val]))
-
- _
- (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key)))))
- pairs))
-
-(def: #export (order-record pairs)
- (-> (List [Ident Code]) (Lux [(List Code) Type]))
- (case pairs
- (#;Cons [head-k head-v] _)
- (do Monad<Lux>
- [head-k (macro;normalize head-k)
- [_ tag-set recordT] (macro;resolve-tag head-k)
- #let [size-record (list;size pairs)
- 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))))
- #let [tuple-range (list;n.range +0 (n.dec size-ts))
- tag->idx (D;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))]
- idx->val (foldM @
- (function [[key val] idx->val]
- (do @
- [key (macro;normalize key)]
- (case (D;get key tag->idx)
- #;None
- (&;fail (format "Tag " (%code (code;tag key))
- " does not belong to tag-set for type " (%type recordT)))
-
- (#;Some idx)
- (if (D;contains? idx idx->val)
- (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key))))
- (wrap (D;put idx val idx->val))))))
- (: (D;Dict Nat Code)
- (D;new number;Hash<Nat>))
- pairs)
- #let [ordered-tuple (L/map (function [idx]
- (assume (D;get idx idx->val)))
- tuple-range)]]
- (wrap [ordered-tuple recordT]))
-
- _
- (:: Monad<Lux> wrap [(list) Unit])))
-
-(def: (tuple members)
- (-> (List la;Analysis) la;Analysis)
- (case members
- #;Nil
- #la;Unit
-
- (#;Cons singleton #;Nil)
- singleton
-
- (#;Cons left right)
- (#la;Product left (tuple right))))
-
(def: #export (analyse-product analyse membersC)
(-> &;Analyser (List Code) (Lux la;Analysis))
(do Monad<Lux>
@@ -143,13 +199,14 @@
(TC;read-var id))]
(&;with-expected-type expected'
(analyse-product analyse membersC)))
+ ## Must do inference...
(do @
[membersTA (mapM @ (|>. analyse &common;with-unknown-type)
membersC)
_ (&;within-type-env
(TC;check expected
(type;tuple (L/map product;left membersTA))))]
- (wrap (tuple (L/map product;right membersTA))))))
+ (wrap (product (L/map product;right membersTA))))))
(#;UnivQ _)
(do @
@@ -168,183 +225,91 @@
(&;fail "")
))))
-(def: (record-function-type type)
- (-> Type (Lux Type))
- (case type
- (#;Named name unnamedT)
- (do Monad<Lux>
- [unnamedT+ (record-function-type unnamedT)]
- (wrap (#;Named name unnamedT+)))
-
- (^template [<tag>]
- (<tag> env bodyT)
- (do Monad<Lux>
- [bodyT+ (record-function-type bodyT)]
- (wrap (<tag> env bodyT+))))
- ([#;UnivQ]
- [#;ExQ])
-
- (#;Product _)
- (:: Monad<Lux> wrap (type;function (type;flatten-tuple type) type))
-
- _
- (&;fail (format "Not a record type: " (%type type)))))
-
-(def: (out-of-bounds-error type size tag)
- (All [a] (-> Type Nat Nat (Lux a)))
- (&;fail (format "Trying to create variant with tag beyond type's limitations." "\n"
- " Tag: " (%i (nat-to-int tag)) "\n"
- "Size: " (%i (nat-to-int size)) "\n"
- "Type: " (%type type))))
-
-(def: (variant-function-type tag expected-size type)
- (-> Nat Nat Type (Lux Type))
- (case type
- (#;Named name unnamedT)
- (do Monad<Lux>
- [unnamedT+ (variant-function-type tag expected-size unnamedT)]
- (wrap (#;Named name unnamedT+)))
-
- (^template [<tag>]
- (<tag> env bodyT)
- (do Monad<Lux>
- [bodyT+ (variant-function-type tag expected-size bodyT)]
- (wrap (<tag> env bodyT+))))
- ([#;UnivQ]
- [#;ExQ])
-
- (#;Sum _)
- (let [cases (type;flatten-variant type)
- actual-size (list;size cases)
- boundary (n.dec expected-size)]
- (cond (or (n.= expected-size actual-size)
- (and (n.> expected-size actual-size)
- (n.< boundary tag)))
- (case (list;nth tag cases)
- (#;Some caseT)
- (:: Monad<Lux> wrap (type;function (list caseT) type))
-
- #;None
- (out-of-bounds-error type expected-size tag))
-
- (n.< expected-size actual-size)
- (&;fail (format "Variant type is smaller than expected." "\n"
- "Expected: " (%i (nat-to-int expected-size)) "\n"
- " Actual: " (%i (nat-to-int actual-size))))
-
- (n.= boundary tag)
- (let [caseT (type;variant (list;drop boundary cases))]
- (:: Monad<Lux> wrap (type;function (list caseT) type)))
-
- ## else
- (out-of-bounds-error type expected-size tag)))
-
- _
- (&;fail (format "Not a variant type: " (%type type)))))
-
-(def: #export (analyse-record analyse members)
- (-> &;Analyser (List [Code Code]) (Lux la;Analysis))
- (do Monad<Lux>
- [members (normalize-record members)
- [members recordT] (order-record members)
- expectedT macro;expected-type
- functionT (record-function-type recordT)
- [inferredT membersA] (&inference;apply-function analyse functionT members)
- _ (&;within-type-env
- (TC;check expectedT inferredT))]
- (wrap (tuple membersA))))
-
-(do-template [<name> <side>]
- [(def: (<name> inner)
- (-> la;Analysis la;Analysis)
- (#la;Sum (<side> inner)))]
-
- [sum-left #;Left]
- [sum-right #;Right])
-
-(def: (variant tag size temp value)
- (-> Nat Nat Nat la;Analysis la;Analysis)
- (if (n.= (n.dec size) tag)
- (if (n.= +1 tag)
- (sum-right value)
- (L/fold (function;const sum-left)
- (sum-right value)
- (list;n.range +0 (n.- +2 tag))))
- (L/fold (function;const sum-left)
- (case value
- (#la;Sum _)
- (#la;Case value (list [(#la;BindP temp)
- (#la;Relative (#;Local temp))]))
-
- _
- value)
- (list;n.range +0 tag))))
-
(def: #export (analyse-tagged-sum analyse tag value)
(-> &;Analyser Ident Code (Lux la;Analysis))
(do Monad<Lux>
[tag (macro;normalize tag)
[idx group variantT] (macro;resolve-tag tag)
#let [case-size (list;size group)]
- functionT (variant-function-type idx case-size variantT)
- [inferredT valueA+] (&inference;apply-function analyse functionT (list value))
+ inferenceT (&inference;variant-inference-type idx case-size variantT)
+ [inferredT valueA+] (&inference;apply-function analyse inferenceT (list value))
expectedT macro;expected-type
_ (&;within-type-env
(TC;check expectedT inferredT))
temp &env;next-local]
(wrap (variant idx case-size temp (|> valueA+ list;head assume)))))
-(def: #export (analyse-sum analyse tag valueC)
- (-> &;Analyser Nat Code (Lux la;Analysis))
- (do Monad<Lux>
- [expected macro;expected-type]
- (&;with-stacked-errors
- (function [_] (format "Invalid type for variant: " (%type expected)))
- (case expected
- (#;Sum _)
- (let [flat (type;flatten-variant expected)
- type-size (list;size flat)]
- (case (list;nth tag flat)
- (#;Some variant-type)
- (do @
- [valueA (&;with-expected-type variant-type
- (analyse valueC))
- temp &env;next-local]
- (wrap (variant tag type-size temp valueA)))
+## There cannot be any ambiguity or improper syntax when analysing
+## records, so they must be normalized for further analysis.
+## Normalization just means that all the tags get resolved to their
+## canonical form (with their corresponding module identified).
+(def: #export (normalize record)
+ (-> (List [Code Code]) (Lux (List [Ident Code])))
+ (mapM Monad<Lux>
+ (function [[key val]]
+ (case key
+ [_ (#;Tag key)]
+ (do Monad<Lux>
+ [key (macro;normalize key)]
+ (wrap [key val]))
- #;None
- (out-of-bounds-error expected type-size tag)))
+ _
+ (&;fail (format "Cannot use non-tag tokens in key positions in records: " (%code key)))))
+ record))
- (#;Named name unnamedT)
- (&;with-expected-type unnamedT
- (analyse-sum analyse tag valueC))
+## Lux already possesses the means to analyse tuples, so
+## re-implementing the same functionality for records makes no sense.
+## Records, thus, get transformed into tuples by ordering the elements.
+(def: #export (order record)
+ (-> (List [Ident Code]) (Lux [(List Code) Type]))
+ (case record
+ ## empty-record = empty-tuple = unit = []
+ #;Nil
+ (:: Monad<Lux> wrap [(list) Unit])
- (#;Var id)
- (do @
- [bound? (&;within-type-env
- (TC;bound? id))]
- (if bound?
- (do @
- [expected' (&;within-type-env
- (TC;read-var id))]
- (&;with-expected-type expected'
- (analyse-sum analyse tag valueC)))
- (&;fail (format "Invalid type for variant: " (%type expected)))))
+ (#;Cons [head-k head-v] _)
+ (do Monad<Lux>
+ [head-k (macro;normalize head-k)
+ [_ tag-set recordT] (macro;resolve-tag head-k)
+ #let [size-record (list;size record)
+ 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))))
+ #let [tuple-range (list;n.range +0 (n.dec size-ts))
+ tag->idx (D;from-list ident;Hash<Ident> (list;zip2 tag-set tuple-range))]
+ idx->val (foldM @
+ (function [[key val] idx->val]
+ (do @
+ [key (macro;normalize key)]
+ (case (D;get key tag->idx)
+ #;None
+ (&;fail (format "Tag " (%code (code;tag key))
+ " does not belong to tag-set for type " (%type recordT)))
- (#;UnivQ _)
- (do @
- [[var-id var] (&;within-type-env
- TC;existential)]
- (&;with-expected-type (assume (type;apply-type expected var))
- (analyse-sum analyse tag valueC)))
+ (#;Some idx)
+ (if (D;contains? idx idx->val)
+ (&;fail (format "Cannot repeat tag inside record: " (%code (code;tag key))))
+ (wrap (D;put idx val idx->val))))))
+ (: (D;Dict Nat Code)
+ (D;new number;Hash<Nat>))
+ record)
+ #let [ordered-tuple (L/map (function [idx] (assume (D;get idx idx->val)))
+ tuple-range)]]
+ (wrap [ordered-tuple recordT]))
+ ))
- (#;ExQ _)
- (&common;with-var
- (function [[var-id var]]
- (&;with-expected-type (assume (type;apply-type expected var))
- (analyse-sum analyse tag valueC))))
-
- _
- (if (n.= +0 tag)
- (analyse valueC)
- (&;fail ""))))))
+(def: #export (analyse-record analyse members)
+ (-> &;Analyser (List [Code Code]) (Lux la;Analysis))
+ (do Monad<Lux>
+ [members (normalize members)
+ [members recordT] (order members)
+ expectedT macro;expected-type
+ inferenceT (&inference;record-inference-type recordT)
+ [inferredT membersA] (&inference;apply-function analyse inferenceT members)
+ _ (&;within-type-env
+ (TC;check expectedT inferredT))]
+ (wrap (product membersA))))