aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/analyser/structure.lux
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/analyser/structure.lux')
-rw-r--r--new-luxc/source/luxc/analyser/structure.lux351
1 files changed, 351 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/analyser/structure.lux b/new-luxc/source/luxc/analyser/structure.lux
new file mode 100644
index 000000000..ab6f6adae
--- /dev/null
+++ b/new-luxc/source/luxc/analyser/structure.lux
@@ -0,0 +1,351 @@
+(;module:
+ lux
+ (lux (control monad
+ pipe)
+ [io #- run]
+ [function]
+ (concurrency ["A" atom])
+ (data [text "T/" Eq<Text>]
+ text/format
+ [ident]
+ (coll [list "L/" Fold<List> Monoid<List> Monad<List>]
+ ["D" dict]
+ ["S" set])
+ [number]
+ [product])
+ [macro #+ Monad<Lux>]
+ (macro [code])
+ [type]
+ (type ["TC" check]))
+ (luxc ["&" base]
+ (lang ["la" analysis #+ Analysis]
+ ["lp" pattern])
+ ["&;" module]
+ ["&;" env]
+ (analyser ["&;" common]
+ ["&;" inference])))
+
+## [Analysers]
+(def: (analyse-typed-product analyse members)
+ (-> &;Analyser (List Code) (Lux Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (loop [expected expected
+ members members]
+ (case [expected members]
+ [(#;Product leftT rightT) (#;Cons leftC rightC)]
+ (do @
+ [leftA (&;with-expected-type leftT
+ (analyse leftC))
+ rightA (recur rightT rightC)]
+ (wrap (#la;Product leftA rightA)))
+
+ [tailT (#;Cons tailC #;Nil)]
+ (&;with-expected-type tailT
+ (analyse tailC))
+
+ [tailT tailC]
+ (do @
+ [g!tail (macro;gensym "tail")]
+ (&;with-expected-type tailT
+ (analyse (` ((~' _lux_case) [(~@ tailC)]
+ (~ g!tail)
+ (~ 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 Analysis) 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 Analysis))
+ (do Monad<Lux>
+ [expected macro;expected-type]
+ (&;with-stacked-errors
+ (function [_] (format "Invalid type for tuple: " (%type expected)))
+ (case expected
+ (#;Product _)
+ (analyse-typed-product analyse membersC)
+
+ (#;Named name unnamedT)
+ (&;with-expected-type unnamedT
+ (analyse-product analyse membersC))
+
+ (#;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-product analyse membersC)))
+ (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))))))
+
+ (#;UnivQ _)
+ (do @
+ [[var-id var] (&;within-type-env
+ TC;existential)]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-product analyse membersC)))
+
+ (#;ExQ _)
+ (&common;with-var
+ (function [[var-id var]]
+ (&;with-expected-type (assume (type;apply-type expected var))
+ (analyse-product analyse membersC))))
+
+ _
+ (&;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 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)
+ (-> Analysis Analysis)
+ (#la;Sum (<side> inner)))]
+
+ [sum-left #;Left]
+ [sum-right #;Right])
+
+(def: (variant tag size temp value)
+ (-> Nat Nat Nat Analysis 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 [(#lp;Bind temp)
+ (#la;Relative (#;Local temp))]))
+
+ _
+ value)
+ (list;n.range +0 tag))))
+
+(def: #export (analyse-tagged-sum analyse tag value)
+ (-> &;Analyser Ident Code (Lux 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))
+ 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 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
+ (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)))
+ (&;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))))
+
+ _
+ (if (n.= +0 tag)
+ (analyse valueC)
+ (&;fail ""))))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 15:53:46 +0000