aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang.lux47
-rw-r--r--new-luxc/source/luxc/lang/analysis.lux111
-rw-r--r--new-luxc/source/luxc/lang/analysis/common.lux21
-rw-r--r--new-luxc/source/luxc/lang/analysis/expression.lux126
-rw-r--r--new-luxc/source/luxc/lang/analysis/structure.lux365
-rw-r--r--new-luxc/source/luxc/lang/module.lux234
-rw-r--r--new-luxc/test/test/luxc/lang/analysis/common.lux22
-rw-r--r--new-luxc/test/test/luxc/lang/analysis/structure.lux331
-rw-r--r--stdlib/source/lux/lang/analysis/inference.lux (renamed from new-luxc/source/luxc/lang/analysis/inference.lux)108
9 files changed, 56 insertions, 1309 deletions
diff --git a/new-luxc/source/luxc/lang.lux b/new-luxc/source/luxc/lang.lux
index 1060eeb8e..28dd302c2 100644
--- a/new-luxc/source/luxc/lang.lux
+++ b/new-luxc/source/luxc/lang.lux
@@ -13,53 +13,6 @@
(lang (type ["tc" check])))
(luxc (lang ["la" analysis])))
-(type: #export Eval
- (-> Type Code (Meta Top)))
-
-(def: #export (pl-get key table)
- (All [a] (-> Text (List [Text a]) (Maybe a)))
- (case table
- #.Nil
- #.None
-
- (#.Cons [k' v'] table')
- (if (text/= key k')
- (#.Some v')
- (pl-get key table'))))
-
-(def: #export (pl-contains? key table)
- (All [a] (-> Text (List [Text a]) Bool))
- (case (pl-get key table)
- (#.Some _)
- true
-
- #.None
- false))
-
-(def: #export (pl-put key val table)
- (All [a] (-> Text a (List [Text a]) (List [Text a])))
- (case table
- #.Nil
- (list [key val])
-
- (#.Cons [k' v'] table')
- (if (text/= key k')
- (#.Cons [key val]
- table')
- (#.Cons [k' v']
- (pl-put key val table')))))
-
-(def: #export (pl-update key f table)
- (All [a] (-> Text (-> a a) (List [Text a]) (List [Text a])))
- (case table
- #.Nil
- #.Nil
-
- (#.Cons [k' v'] table')
- (if (text/= key k')
- (#.Cons [k' (f v')] table')
- (#.Cons [k' v'] (pl-update key f table')))))
-
(def: (normalize-char char)
(-> Nat Text)
(case char
diff --git a/new-luxc/source/luxc/lang/analysis.lux b/new-luxc/source/luxc/lang/analysis.lux
deleted file mode 100644
index 369e9dd7e..000000000
--- a/new-luxc/source/luxc/lang/analysis.lux
+++ /dev/null
@@ -1,111 +0,0 @@
-(.module:
- lux
- (lux [function]
- (data (coll [list "list/" Fold<List>]))
- (macro [code]))
- (luxc (lang [".L" variable #+ Variable])))
-
-(type: #export Pattern Code)
-
-(type: #export Analysis Code)
-
-## 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)
- (-> Analysis Analysis)
- (` (<side> (~ inner))))]
-
- [sum-left "lux sum left"]
- [sum-right "lux sum right"])
-
-(def: (local-variable idx)
- (-> Nat Int)
- (nat-to-int idx))
-
-(def: #export (sum tag size temp value)
- (-> Nat Nat Nat Analysis Analysis)
- (if (n/= (n/dec size) tag)
- (if (n/= +1 tag)
- (sum-right value)
- (list/fold (function.const sum-left)
- (sum-right value)
- (list.n/range +0 (n/- +2 tag))))
- (list/fold (function.const sum-left)
- (case value
- (^or (^code ("lux sum left" (~ inner)))
- (^code ("lux sum right" (~ inner))))
- (` ("lux case" (~ value)
- {("lux case bind" (~ (code.nat temp)))
- ((~ (code.int (local-variable temp))))}))
-
- _
- value)
- (list.n/range +0 tag))))
-
-## Tuples get analysed into binary products for the sake of semantic
-## simplicity, since products/pairs can encode tuples of any length
-## through nesting.
-
-(def: #export (product members)
- (-> (List Analysis) Analysis)
- (case members
- #.Nil
- (` [])
-
- (#.Cons singleton #.Nil)
- singleton
-
- (#.Cons left right)
- (` [(~ left) (~ (product right))])))
-
-## Function application gets analysed into single-argument
-## applications, since every other kind of application can be encoded
-## into a finite series of single-argument applications.
-
-(def: #export (apply args func)
- (-> (List Analysis) Analysis Analysis)
- (list/fold (function (_ arg func)
- (` ("lux apply" (~ arg) (~ func))))
- func
- args))
-
-(def: #export (procedure name args)
- (-> Text (List Analysis) Analysis)
- (` ((~ (code.text name)) (~+ args))))
-
-(def: #export (var idx)
- (-> Variable Analysis)
- (` ((~ (code.int idx)))))
-
-(def: #export (unfold-tuple analysis)
- (-> Analysis (List Analysis))
- (case analysis
- (^code [(~ left) (~ right)])
- (#.Cons left (unfold-tuple right))
-
- _
- (list analysis)))
-
-(def: #export (unfold-variant analysis)
- (-> Analysis (Maybe [Nat Bool Analysis]))
- (loop [so-far +0
- variantA analysis]
- (case variantA
- (^code ("lux sum left" (~ valueA)))
- (case valueA
- (^or (^code ("lux sum left" (~ _)))
- (^code ("lux sum right" (~ _))))
- (recur (n/inc so-far) valueA)
-
- _
- (#.Some [so-far false valueA]))
-
- (^code ("lux sum right" (~ valueA)))
- (#.Some [(n/inc so-far) true valueA])
-
- _
- #.None)))
diff --git a/new-luxc/source/luxc/lang/analysis/common.lux b/new-luxc/source/luxc/lang/analysis/common.lux
deleted file mode 100644
index 072616cfa..000000000
--- a/new-luxc/source/luxc/lang/analysis/common.lux
+++ /dev/null
@@ -1,21 +0,0 @@
-(.module:
- lux
- (lux (control monad
- ["ex" exception #+ exception:])
- (data text/format
- [product])
- [macro]
- (lang [type]
- (type ["tc" check])))
- (luxc ["&" lang]
- (lang analysis)))
-
-(exception: #export (Variant-Tag-Out-Of-Bounds {message Text})
- message)
-
-(def: #export (variant-out-of-bounds-error type size tag)
- (All [a] (-> Type Nat Nat (Meta a)))
- (&.throw Variant-Tag-Out-Of-Bounds
- (format " Tag: " (%n tag) "\n"
- "Variant Size: " (%n size) "\n"
- "Variant Type: " (%type type))))
diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
deleted file mode 100644
index aaa64940b..000000000
--- a/new-luxc/source/luxc/lang/analysis/expression.lux
+++ /dev/null
@@ -1,126 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data ["e" error]
- [product]
- text/format)
- [macro]
- (lang [type]
- (type ["tc" check]))
- [host])
- (luxc ["&" lang]
- (lang ["&." module]
- [".L" host]
- [".L" macro]
- [".L" extension]
- ["la" analysis]
- (translation (jvm [".T" common]))))
- (// [".A" common]
- [".A" function]
- [".A" primitive]
- [".A" reference]
- [".A" structure]))
-
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Macro-Expression-Must-Have-Single-Expansion]
- [Unrecognized-Syntax]
- [Macro-Expansion-Failed]
- )
-
-(def: #export (analyser eval)
- (-> &.Eval &.Analyser)
- (: (-> Code (Meta la.Analysis))
- (function (analyse code)
- (do macro.Monad<Meta>
- [expectedT macro.expected-type]
- (let [[cursor code'] code]
- ## The cursor must be set in the compiler for the sake
- ## of having useful error messages.
- (&.with-cursor cursor
- (case code'
- (^template [<tag> <analyser>]
- (<tag> value)
- (<analyser> value))
- ([#.Bool primitiveA.analyse-bool]
- [#.Nat primitiveA.analyse-nat]
- [#.Int primitiveA.analyse-int]
- [#.Deg primitiveA.analyse-deg]
- [#.Frac primitiveA.analyse-frac]
- [#.Text primitiveA.analyse-text])
-
- (^ (#.Tuple (list)))
- primitiveA.analyse-unit
-
- ## Singleton tuples are equivalent to the element they contain.
- (^ (#.Tuple (list singleton)))
- (analyse singleton)
-
- (^ (#.Tuple elems))
- (structureA.analyse-product analyse elems)
-
- (^ (#.Record pairs))
- (structureA.analyse-record analyse pairs)
-
- (#.Symbol reference)
- (referenceA.analyse-reference reference)
-
- (^ (#.Form (list& [_ (#.Text proc-name)] proc-args)))
- (do macro.Monad<Meta>
- [procedure (extensionL.find-analysis proc-name)]
- (procedure analyse eval proc-args))
-
- (^template [<tag> <analyser>]
- (^ (#.Form (list& [_ (<tag> tag)]
- values)))
- (case values
- (#.Cons value #.Nil)
- (<analyser> analyse tag value)
-
- _
- (<analyser> analyse tag (` [(~+ values)]))))
- ([#.Nat structureA.analyse-sum]
- [#.Tag structureA.analyse-tagged-sum])
-
- (#.Tag tag)
- (structureA.analyse-tagged-sum analyse tag (' []))
-
- (^ (#.Form (list& func args)))
- (do macro.Monad<Meta>
- [[funcT funcA] (commonA.with-unknown-type
- (analyse func))]
- (case funcA
- [_ (#.Symbol def-name)]
- (do @
- [?macro (&.with-error-tracking
- (macro.find-macro def-name))]
- (case ?macro
- (#.Some macro)
- (do @
- [expansion (: (Meta (List Code))
- (function (_ compiler)
- (case (macroL.expand macro args compiler)
- (#e.Error error)
- ((&.throw Macro-Expansion-Failed error) compiler)
-
- output
- output)))]
- (case expansion
- (^ (list single))
- (analyse single)
-
- _
- (&.throw Macro-Expression-Must-Have-Single-Expansion (%code code))))
-
- _
- (functionA.analyse-apply analyse funcT funcA args)))
-
- _
- (functionA.analyse-apply analyse funcT funcA args)))
-
- _
- (&.throw Unrecognized-Syntax (%code code))
- )))))))
diff --git a/new-luxc/source/luxc/lang/analysis/structure.lux b/new-luxc/source/luxc/lang/analysis/structure.lux
deleted file mode 100644
index f9e7ad8fc..000000000
--- a/new-luxc/source/luxc/lang/analysis/structure.lux
+++ /dev/null
@@ -1,365 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data [ident]
- [number]
- [product]
- [maybe]
- (coll [list "list/" Functor<List>]
- (dictionary ["dict" unordered #+ Dict]))
- text/format)
- [macro]
- (macro [code])
- (lang [type]
- (type ["tc" check])))
- (luxc ["&" lang]
- (lang ["&." scope]
- ["&." module]
- ["la" analysis]
- (analysis ["&." common]
- [".A" primitive]
- ["&." inference]))))
-
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Invalid-Variant-Type]
- [Invalid-Tuple-Type]
- [Not-Quantified-Type]
-
- [Cannot-Analyse-Variant]
- [Cannot-Analyse-Tuple]
-
- [Cannot-Infer-Numeric-Tag]
- [Record-Keys-Must-Be-Tags]
- [Cannot-Repeat-Tag]
- [Tag-Does-Not-Belong-To-Record]
- [Record-Size-Mismatch]
- )
-
-(def: #export (analyse-sum analyse tag valueC)
- (-> &.Analyser Nat Code (Meta la.Analysis))
- (do macro.Monad<Meta>
- [expectedT macro.expected-type]
- (&.with-stacked-errors
- (function (_ _)
- (ex.construct Cannot-Analyse-Variant
- (format " Type: " (%type expectedT) "\n"
- " Tag: " (%n tag) "\n"
- "Expression: " (%code valueC))))
- (case expectedT
- (#.Sum _)
- (let [flat (type.flatten-variant expectedT)
- type-size (list.size flat)]
- (case (list.nth tag flat)
- (#.Some variant-type)
- (do @
- [valueA (&.with-type variant-type
- (analyse valueC))
- temp &scope.next-local]
- (wrap (la.sum tag type-size temp valueA)))
-
- #.None
- (&common.variant-out-of-bounds-error expectedT type-size tag)))
-
- (#.Named name unnamedT)
- (&.with-type unnamedT
- (analyse-sum analyse tag valueC))
-
- (#.Var id)
- (do @
- [?expectedT' (&.with-type-env
- (tc.read id))]
- (case ?expectedT'
- (#.Some expectedT')
- (&.with-type expectedT'
- (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.
- (&.throw Cannot-Infer-Numeric-Tag
- (format " Type: " (%type expectedT) "\n"
- " Tag: " (%n tag) "\n"
- "Expression: " (%code valueC)))
- ))
-
- (^template [<tag> <instancer>]
- (<tag> _)
- (do @
- [[instance-id instanceT] (&.with-type-env <instancer>)]
- (&.with-type (maybe.assume (type.apply (list instanceT) expectedT))
- (analyse-sum analyse tag valueC))))
- ([#.UnivQ tc.existential]
- [#.ExQ tc.var])
-
- (#.Apply inputT funT)
- (case funT
- (#.Var funT-id)
- (do @
- [?funT' (&.with-type-env (tc.read funT-id))]
- (case ?funT'
- (#.Some funT')
- (&.with-type (#.Apply inputT funT')
- (analyse-sum analyse tag valueC))
-
- _
- (&.throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n"
- " Tag: " (%n tag) "\n"
- "Expression: " (%code valueC)))))
-
- _
- (case (type.apply (list inputT) funT)
- #.None
- (&.throw Not-Quantified-Type (%type funT))
-
- (#.Some outputT)
- (&.with-type outputT
- (analyse-sum analyse tag valueC))))
-
- _
- (&.throw Invalid-Variant-Type (format " Type: " (%type expectedT) "\n"
- " Tag: " (%n tag) "\n"
- "Expression: " (%code valueC)))))))
-
-(def: (analyse-typed-product analyse membersC+)
- (-> &.Analyser (List Code) (Meta la.Analysis))
- (do macro.Monad<Meta>
- [expectedT macro.expected-type]
- (loop [expectedT expectedT
- 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-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)]
- (do @
- [leftA (&.with-type leftT
- (analyse leftC))
- rightA (recur rightT rightC)]
- (wrap (` [(~ leftA) (~ rightA)])))
-
- ## 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]
- (macro.with-gensyms [g!tail]
- (&.with-type tailT
- (analyse (` ("lux case" [(~+ tailC)]
- (~ g!tail)
- (~ g!tail))))))
- ))))
-
-(def: #export (analyse-product analyse membersC)
- (-> &.Analyser (List Code) (Meta la.Analysis))
- (do macro.Monad<Meta>
- [expectedT macro.expected-type]
- (&.with-stacked-errors
- (function (_ _)
- (ex.construct Cannot-Analyse-Tuple
- (format " Type: " (%type expectedT) "\n"
- "Expression: " (%code (` [(~+ membersC)])))))
- (case expectedT
- (#.Product _)
- (analyse-typed-product analyse membersC)
-
- (#.Named name unnamedT)
- (&.with-type unnamedT
- (analyse-product analyse membersC))
-
- (#.Var id)
- (do @
- [?expectedT' (&.with-type-env
- (tc.read id))]
- (case ?expectedT'
- (#.Some expectedT')
- (&.with-type expectedT'
- (analyse-product analyse membersC))
-
- _
- ## Must do inference...
- (do @
- [membersTA (monad.map @ (|>> analyse &common.with-unknown-type)
- membersC)
- _ (&.with-type-env
- (tc.check expectedT
- (type.tuple (list/map product.left membersTA))))]
- (wrap (la.product (list/map product.right membersTA))))))
-
- (^template [<tag> <instancer>]
- (<tag> _)
- (do @
- [[instance-id instanceT] (&.with-type-env <instancer>)]
- (&.with-type (maybe.assume (type.apply (list instanceT) expectedT))
- (analyse-product analyse membersC))))
- ([#.UnivQ tc.existential]
- [#.ExQ tc.var])
-
- (#.Apply inputT funT)
- (case funT
- (#.Var funT-id)
- (do @
- [?funT' (&.with-type-env (tc.read funT-id))]
- (case ?funT'
- (#.Some funT')
- (&.with-type (#.Apply inputT funT')
- (analyse-product analyse membersC))
-
- _
- (&.throw Invalid-Tuple-Type
- (format " Type: " (%type expectedT) "\n"
- "Expression: " (%code (` [(~+ membersC)]))))))
-
- _
- (case (type.apply (list inputT) funT)
- #.None
- (&.throw Not-Quantified-Type (%type funT))
-
- (#.Some outputT)
- (&.with-type outputT
- (analyse-product analyse membersC))))
-
- _
- (&.throw Invalid-Tuple-Type
- (format " Type: " (%type expectedT) "\n"
- "Expression: " (%code (` [(~+ membersC)]))))
- ))))
-
-(def: #export (analyse-tagged-sum analyse tag valueC)
- (-> &.Analyser Ident Code (Meta la.Analysis))
- (do macro.Monad<Meta>
- [tag (macro.normalize tag)
- [idx group variantT] (macro.resolve-tag tag)
- expectedT macro.expected-type]
- (case expectedT
- (#.Var _)
- (do @
- [#let [case-size (list.size group)]
- inferenceT (&inference.variant idx case-size variantT)
- [inferredT valueA+] (&inference.general analyse inferenceT (list valueC))
- temp &scope.next-local]
- (wrap (la.sum idx case-size temp (|> valueA+ list.head maybe.assume))))
-
- _
- (analyse-sum analyse idx valueC))))
-
-## 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]) (Meta (List [Ident Code])))
- (monad.map macro.Monad<Meta>
- (function (_ [key val])
- (case key
- [_ (#.Tag key)]
- (do macro.Monad<Meta>
- [key (macro.normalize key)]
- (wrap [key val]))
-
- _
- (&.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
-## 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]) (Meta [(List Code) Type]))
- (case record
- ## empty-record = empty-tuple = unit = []
- #.Nil
- (:: macro.Monad<Meta> wrap [(list) Top])
-
- (#.Cons [head-k head-v] _)
- (do macro.Monad<Meta>
- [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 [])
- (&.throw Record-Size-Mismatch
- (format " Expected: " (|> size-ts nat-to-int %i) "\n"
- " Actual: " (|> size-record nat-to-int %i) "\n"
- " Type: " (%type recordT) "\n"
- "Expression: " (%code (|> record
- (list/map (function (_ [keyI valueC])
- [(code.tag keyI) valueC]))
- code.record)))))
- #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 @
- (function (_ [key val] idx->val)
- (do @
- [key (macro.normalize key)]
- (case (dict.get key tag->idx)
- #.None
- (&.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)
- (&.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>))
- record)
- #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val)))
- tuple-range)]]
- (wrap [ordered-tuple recordT]))
- ))
-
-(def: #export (analyse-record analyse members)
- (-> &.Analyser (List [Code Code]) (Meta la.Analysis))
- (do macro.Monad<Meta>
- [members (normalize members)
- [membersC recordT] (order members)]
- (case membersC
- (^ (list))
- primitiveA.analyse-unit
-
- (^ (list singletonC))
- (analyse singletonC)
-
- _
- (do @
- [expectedT macro.expected-type]
- (case expectedT
- (#.Var _)
- (do @
- [inferenceT (&inference.record recordT)
- [inferredT membersA] (&inference.general analyse inferenceT membersC)]
- (wrap (la.product membersA)))
-
- _
- (analyse-product analyse membersC))))))
diff --git a/new-luxc/source/luxc/lang/module.lux b/new-luxc/source/luxc/lang/module.lux
deleted file mode 100644
index 8e24d0cf4..000000000
--- a/new-luxc/source/luxc/lang/module.lux
+++ /dev/null
@@ -1,234 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:]
- pipe)
- (data [text "text/" Eq<Text>]
- text/format
- ["e" error]
- (coll [list "list/" Fold<List> Functor<List>]))
- [macro]
- (macro [code]))
- (luxc ["&" lang]
- (lang ["&." scope])))
-
-(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Unknown-Module]
- [Cannot-Declare-Tag-Twice]
- [Cannot-Declare-Tags-For-Unnamed-Type]
- [Cannot-Declare-Tags-For-Foreign-Type]
- [Cannot-Define-More-Than-Once]
- [Cannot-Define-In-Unknown-Module]
- [Can-Only-Change-State-Of-Active-Module]
- [Cannot-Set-Module-Annotations-More-Than-Once]
- )
-
-(def: (new-module hash)
- (-> Nat Module)
- {#.module-hash hash
- #.module-aliases (list)
- #.definitions (list)
- #.imports (list)
- #.tags (list)
- #.types (list)
- #.module-annotations #.None
- #.module-state #.Active})
-
-(def: #export (set-annotations annotations)
- (-> Code (Meta Top))
- (do macro.Monad<Meta>
- [self-name macro.current-module-name
- self macro.current-module]
- (case (get@ #.module-annotations self)
- #.None
- (function (_ compiler)
- (#e.Success [(update@ #.modules
- (&.pl-put self-name (set@ #.module-annotations (#.Some annotations) self))
- compiler)
- []]))
-
- (#.Some old)
- (&.throw Cannot-Set-Module-Annotations-More-Than-Once
- (format " Module: " self-name "\n"
- "Old annotations: " (%code old) "\n"
- "New annotations: " (%code annotations) "\n")))))
-
-(def: #export (import module)
- (-> Text (Meta Top))
- (do macro.Monad<Meta>
- [self macro.current-module-name]
- (function (_ compiler)
- (#e.Success [(update@ #.modules
- (&.pl-update self (update@ #.imports (|>> (#.Cons module))))
- compiler)
- []]))))
-
-(def: #export (alias alias module)
- (-> Text Text (Meta Top))
- (do macro.Monad<Meta>
- [self macro.current-module-name]
- (function (_ compiler)
- (#e.Success [(update@ #.modules
- (&.pl-update self (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text]))
- (|>> (#.Cons [alias module])))))
- compiler)
- []]))))
-
-(def: #export (exists? module)
- (-> Text (Meta Bool))
- (function (_ compiler)
- (|> (get@ #.modules compiler)
- (&.pl-get module)
- (case> (#.Some _) true #.None false)
- [compiler] #e.Success)))
-
-(def: #export (define (^@ full-name [module-name def-name])
- definition)
- (-> Ident Definition (Meta Top))
- (function (_ compiler)
- (case (&.pl-get module-name (get@ #.modules compiler))
- (#.Some module)
- (case (&.pl-get def-name (get@ #.definitions module))
- #.None
- (#e.Success [(update@ #.modules
- (&.pl-put module-name
- (update@ #.definitions
- (: (-> (List [Text Definition]) (List [Text Definition]))
- (|>> (#.Cons [def-name definition])))
- module))
- compiler)
- []])
-
- (#.Some already-existing)
- ((&.throw Cannot-Define-More-Than-Once (%ident full-name)) compiler))
-
- #.None
- ((&.throw Cannot-Define-In-Unknown-Module (%ident full-name)) compiler))))
-
-(def: #export (create hash name)
- (-> Nat Text (Meta Module))
- (function (_ compiler)
- (let [module (new-module hash)]
- (#e.Success [(update@ #.modules
- (&.pl-put name module)
- compiler)
- module]))))
-
-(def: #export (with-module hash name action)
- (All [a] (-> Nat Text (Meta a) (Meta [Module a])))
- (do macro.Monad<Meta>
- [_ (create hash name)
- output (&.with-current-module name
- action)
- module (macro.find-module name)]
- (wrap [module output])))
-
-(do-template [<flagger> <asker> <tag> <description>]
- [(def: #export (<flagger> module-name)
- (-> Text (Meta Top))
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (&.pl-get module-name))
- (#.Some module)
- (let [active? (case (get@ #.module-state module)
- #.Active true
- _ false)]
- (if active?
- (#e.Success [(update@ #.modules
- (&.pl-put module-name (set@ #.module-state <tag> module))
- compiler)
- []])
- ((&.throw Can-Only-Change-State-Of-Active-Module
- (format " Module: " module-name "\n"
- "Desired state: " <description>))
- compiler)))
-
- #.None
- ((&.throw Unknown-Module module-name) compiler))))
- (def: #export (<asker> module-name)
- (-> Text (Meta Bool))
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (&.pl-get module-name))
- (#.Some module)
- (#e.Success [compiler
- (case (get@ #.module-state module)
- <tag> true
- _ false)])
-
- #.None
- ((&.throw Unknown-Module module-name) compiler))
- ))]
-
- [flag-active! active? #.Active "Active"]
- [flag-compiled! compiled? #.Compiled "Compiled"]
- [flag-cached! cached? #.Cached "Cached"]
- )
-
-(do-template [<name> <tag> <type>]
- [(def: (<name> module-name)
- (-> Text (Meta <type>))
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (&.pl-get module-name))
- (#.Some module)
- (#e.Success [compiler (get@ <tag> module)])
-
- #.None
- ((&.throw Unknown-Module module-name) compiler))
- ))]
-
- [tags-by-module #.tags (List [Text [Nat (List Ident) Bool Type]])]
- [types-by-module #.types (List [Text [(List Ident) Bool Type]])]
- [module-hash #.module-hash Nat]
- )
-
-(def: (ensure-undeclared-tags module-name tags)
- (-> Text (List Text) (Meta Top))
- (do macro.Monad<Meta>
- [bindings (tags-by-module module-name)
- _ (monad.map @
- (function (_ tag)
- (case (&.pl-get tag bindings)
- #.None
- (wrap [])
-
- (#.Some _)
- (&.throw Cannot-Declare-Tag-Twice (format "Module: " module-name "\n"
- " Tag: " tag))))
- tags)]
- (wrap [])))
-
-(def: #export (declare-tags tags exported? type)
- (-> (List Text) Bool Type (Meta Top))
- (do macro.Monad<Meta>
- [current-module macro.current-module-name
- [type-module type-name] (case type
- (#.Named type-ident _)
- (wrap type-ident)
-
- _
- (&.throw Cannot-Declare-Tags-For-Unnamed-Type
- (format "Tags: " (|> tags (list/map code.text) code.tuple %code) "\n"
- "Type: " (%type type))))
- _ (ensure-undeclared-tags current-module tags)
- _ (&.assert Cannot-Declare-Tags-For-Foreign-Type
- (format "Tags: " (|> tags (list/map code.text) code.tuple %code) "\n"
- "Type: " (%type type))
- (text/= current-module type-module))]
- (function (_ compiler)
- (case (|> compiler (get@ #.modules) (&.pl-get current-module))
- (#.Some module)
- (let [namespaced-tags (list/map (|>> [current-module]) tags)]
- (#e.Success [(update@ #.modules
- (&.pl-update current-module
- (|>> (update@ #.tags (function (_ tag-bindings)
- (list/fold (function (_ [idx tag] table)
- (&.pl-put tag [idx namespaced-tags exported? type] table))
- tag-bindings
- (list.enumerate tags))))
- (update@ #.types (&.pl-put type-name [namespaced-tags exported? type]))))
- compiler)
- []]))
- #.None
- ((&.throw Unknown-Module current-module) compiler)))))
diff --git a/new-luxc/test/test/luxc/lang/analysis/common.lux b/new-luxc/test/test/luxc/lang/analysis/common.lux
index 35212e55d..7e343cc88 100644
--- a/new-luxc/test/test/luxc/lang/analysis/common.lux
+++ b/new-luxc/test/test/luxc/lang/analysis/common.lux
@@ -11,28 +11,6 @@
[eval]))
(test/luxc common))
-(def: gen-unit
- (r.Random Code)
- (r/wrap (' [])))
-
-(def: #export gen-primitive
- (r.Random [Type Code])
- (with-expansions
- [<generators> (do-template [<type> <code-wrapper> <value-gen>]
- [(r.seq (r/wrap <type>) (r/map <code-wrapper> <value-gen>))]
-
- [Top code.tuple (r.list +0 gen-unit)]
- [Bool code.bool r.bool]
- [Nat code.nat r.nat]
- [Int code.int r.int]
- [Deg code.deg r.deg]
- [Frac code.frac r.frac]
- [Text code.text (r.text +5)]
- )]
- ($_ r.either
- <generators>
- )))
-
(def: #export analyse
&.Analyser
(expressionA.analyser eval.eval))
diff --git a/new-luxc/test/test/luxc/lang/analysis/structure.lux b/new-luxc/test/test/luxc/lang/analysis/structure.lux
deleted file mode 100644
index 0a94e37da..000000000
--- a/new-luxc/test/test/luxc/lang/analysis/structure.lux
+++ /dev/null
@@ -1,331 +0,0 @@
-(.module:
- lux
- (lux [io]
- (control [monad #+ do]
- pipe)
- (data [bool "bool/" Eq<Bool>]
- ["e" error]
- [product]
- [maybe]
- [text]
- text/format
- (coll [list "list/" Functor<List>]
- (set ["set" unordered])))
- ["r" math/random "r/" Monad<Random>]
- [macro]
- (macro [code])
- (lang [type "type/" Eq<Type>]
- (type ["tc" check]))
- test)
- (luxc ["&" lang]
- (lang ["@." module]
- ["la" analysis]
- (analysis [".A" expression]
- ["@" structure]
- ["@." common])))
- (// common)
- (test/luxc common))
-
-(context: "Sums"
- (<| (times +100)
- (do @
- [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
- choice (|> r.nat (:: @ map (n/% size)))
- primitives (r.list size gen-primitive)
- +choice (|> r.nat (:: @ map (n/% (n/inc size))))
- [_ +valueC] gen-primitive
- #let [variantT (type.variant (list/map product.left primitives))
- [valueT valueC] (maybe.assume (list.nth choice primitives))
- +size (n/inc size)
- +primitives (list.concat (list (list.take choice primitives)
- (list [(#.Bound +1) +valueC])
- (list.drop choice primitives)))
- [+valueT +valueC] (maybe.assume (list.nth +choice +primitives))
- +variantT (type.variant (list/map product.left +primitives))]]
- ($_ seq
- (test "Can analyse sum."
- (|> (&.with-scope
- (&.with-type variantT
- (@.analyse-sum analyse choice valueC)))
- (macro.run (io.run init-jvm))
- (case> (^multi (#e.Success [_ sumA])
- [(la.unfold-variant sumA)
- (#.Some [tag last? valueA])])
- (and (n/= tag choice)
- (bool/= last? (n/= (n/dec size) choice)))
-
- _
- false)))
- (test "Can analyse sum through bound type-vars."
- (|> (&.with-scope
- (do macro.Monad<Meta>
- [[_ varT] (&.with-type-env tc.var)
- _ (&.with-type-env
- (tc.check varT variantT))]
- (&.with-type varT
- (@.analyse-sum analyse choice valueC))))
- (macro.run (io.run init-jvm))
- (case> (^multi (#e.Success [_ sumA])
- [(la.unfold-variant sumA)
- (#.Some [tag last? valueA])])
- (and (n/= tag choice)
- (bool/= last? (n/= (n/dec size) choice)))
-
- _
- false)))
- (test "Cannot analyse sum through unbound type-vars."
- (|> (&.with-scope
- (do macro.Monad<Meta>
- [[_ varT] (&.with-type-env tc.var)]
- (&.with-type varT
- (@.analyse-sum analyse choice valueC))))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- false
-
- _
- true)))
- (test "Can analyse sum through existential quantification."
- (|> (&.with-scope
- (&.with-type (type.ex-q +1 +variantT)
- (@.analyse-sum analyse +choice +valueC)))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- true
-
- (#e.Error error)
- false)))
- (test "Can analyse sum through universal quantification."
- (|> (&.with-scope
- (&.with-type (type.univ-q +1 +variantT)
- (@.analyse-sum analyse +choice +valueC)))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- (not (n/= choice +choice))
-
- (#e.Error error)
- (n/= choice +choice))))
- ))))
-
-(context: "Products"
- (<| (times +100)
- (do @
- [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
- primitives (r.list size gen-primitive)
- choice (|> r.nat (:: @ map (n/% size)))
- [_ +valueC] gen-primitive
- #let [[singletonT singletonC] (|> primitives (list.nth choice) maybe.assume)
- +primitives (list.concat (list (list.take choice primitives)
- (list [(#.Bound +1) +valueC])
- (list.drop choice primitives)))
- +tupleT (type.tuple (list/map product.left +primitives))]]
- ($_ seq
- (test "Can analyse product."
- (|> (&.with-type (type.tuple (list/map product.left primitives))
- (@.analyse-product analyse (list/map product.right primitives)))
- (macro.run (io.run init-jvm))
- (case> (#e.Success tupleA)
- (n/= size (list.size (la.unfold-tuple tupleA)))
-
- _
- false)))
- (test "Can infer product."
- (|> (@common.with-unknown-type
- (@.analyse-product analyse (list/map product.right primitives)))
- (macro.run (io.run init-jvm))
- (case> (#e.Success [_type tupleA])
- (and (type/= (type.tuple (list/map product.left primitives))
- _type)
- (n/= size (list.size (la.unfold-tuple tupleA))))
-
- _
- false)))
- (test "Can analyse pseudo-product (singleton tuple)"
- (|> (&.with-type singletonT
- (analyse (` [(~ singletonC)])))
- (macro.run (io.run init-jvm))
- (case> (#e.Success singletonA)
- true
-
- (#e.Error error)
- false)))
- (test "Can analyse product through bound type-vars."
- (|> (&.with-scope
- (do macro.Monad<Meta>
- [[_ varT] (&.with-type-env tc.var)
- _ (&.with-type-env
- (tc.check varT (type.tuple (list/map product.left primitives))))]
- (&.with-type varT
- (@.analyse-product analyse (list/map product.right primitives)))))
- (macro.run (io.run init-jvm))
- (case> (#e.Success [_ tupleA])
- (n/= size (list.size (la.unfold-tuple tupleA)))
-
- _
- false)))
- (test "Can analyse product through existential quantification."
- (|> (&.with-scope
- (&.with-type (type.ex-q +1 +tupleT)
- (@.analyse-product analyse (list/map product.right +primitives))))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- true
-
- (#e.Error error)
- false)))
- (test "Cannot analyse product through universal quantification."
- (|> (&.with-scope
- (&.with-type (type.univ-q +1 +tupleT)
- (@.analyse-product analyse (list/map product.right +primitives))))
- (macro.run (io.run init-jvm))
- (case> (#e.Success _)
- false
-
- (#e.Error error)
- true)))
- ))))
-
-(def: (check-variant variantT choice size analysis)
- (-> Type Nat Nat (Meta [Module Scope la.Analysis]) Bool)
- (|> analysis
- (&.with-type variantT)
- (macro.run (io.run init-jvm))
- (case> (^multi (#e.Success [_ _ sumA])
- [(la.unfold-variant sumA)
- (#.Some [tag last? valueA])])
- (and (n/= tag choice)
- (bool/= last? (n/= (n/dec size) choice)))
-
- _
- false)))
-
-(def: (check-record-inference tupleT size analysis)
- (-> Type Nat (Meta [Module Scope Type la.Analysis]) Bool)
- (|> analysis
- (macro.run (io.run init-jvm))
- (case> (^multi (#e.Success [_ _ productT productA])
- [(la.unfold-tuple productA)
- membersA])
- (and (type/= tupleT productT)
- (n/= size (list.size membersA)))
-
- _
- false)))
-
-(context: "Tagged Sums"
- (<| (times +100)
- (do @
- [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
- tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map set.to-list))
- choice (|> r.nat (:: @ map (n/% size)))
- other-choice (|> r.nat (:: @ map (n/% size)) (r.filter (|>> (n/= choice) not)))
- primitives (r.list size gen-primitive)
- module-name (r.text +5)
- type-name (r.text +5)
- #let [varT (#.Bound +1)
- primitivesT (list/map product.left primitives)
- [choiceT choiceC] (maybe.assume (list.nth choice primitives))
- [other-choiceT other-choiceC] (maybe.assume (list.nth other-choice primitives))
- variantT (type.variant primitivesT)
- namedT (#.Named [module-name type-name] variantT)
- polyT (|> (type.variant (list.concat (list (list.take choice primitivesT)
- (list varT)
- (list.drop (n/inc choice) primitivesT))))
- (type.univ-q +1))
- named-polyT (#.Named [module-name type-name] polyT)
- choice-tag (maybe.assume (list.nth choice tags))
- other-choice-tag (maybe.assume (list.nth other-choice tags))]]
- ($_ seq
- (test "Can infer tagged sum."
- (|> (@module.with-module +0 module-name
- (do macro.Monad<Meta>
- [_ (@module.declare-tags tags false namedT)]
- (&.with-scope
- (@.analyse-tagged-sum analyse [module-name choice-tag] choiceC))))
- (check-variant variantT choice size)))
- (test "Tagged sums specialize when type-vars get bound."
- (|> (@module.with-module +0 module-name
- (do macro.Monad<Meta>
- [_ (@module.declare-tags tags false named-polyT)]
- (&.with-scope
- (@.analyse-tagged-sum analyse [module-name choice-tag] choiceC))))
- (check-variant variantT choice size)))
- (test "Tagged sum inference retains universal quantification when type-vars are not bound."
- (|> (@module.with-module +0 module-name
- (do macro.Monad<Meta>
- [_ (@module.declare-tags tags false named-polyT)]
- (&.with-scope
- (@.analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC))))
- (check-variant polyT other-choice size)))
- (test "Can specialize generic tagged sums."
- (|> (@module.with-module +0 module-name
- (do macro.Monad<Meta>
- [_ (@module.declare-tags tags false named-polyT)]
- (&.with-scope
- (&.with-type variantT
- (@.analyse-tagged-sum analyse [module-name other-choice-tag] other-choiceC)))))
- (macro.run (io.run init-jvm))
- (case> (^multi (#e.Success [_ _ sumA])
- [(la.unfold-variant sumA)
- (#.Some [tag last? valueA])])
- (and (n/= tag other-choice)
- (bool/= last? (n/= (n/dec size) other-choice)))
-
- _
- false)))
- ))))
-
-(context: "Records"
- (<| (times +100)
- (do @
- [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2))))
- tags (|> (r.set text.Hash<Text> size (r.text +5)) (:: @ map set.to-list))
- primitives (r.list size gen-primitive)
- module-name (r.text +5)
- type-name (r.text +5)
- choice (|> r.nat (:: @ map (n/% size)))
- #let [varT (#.Bound +1)
- tagsC (list/map (|>> [module-name] code.tag) tags)
- primitivesT (list/map product.left primitives)
- primitivesC (list/map product.right primitives)
- tupleT (type.tuple primitivesT)
- namedT (#.Named [module-name type-name] tupleT)
- recordC (list.zip2 tagsC primitivesC)
- polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT)
- (list varT)
- (list.drop (n/inc choice) primitivesT))))
- (type.univ-q +1))
- named-polyT (#.Named [module-name type-name] polyT)]]
- ($_ seq
- (test "Can infer record."
- (|> (@module.with-module +0 module-name
- (do macro.Monad<Meta>
- [_ (@module.declare-tags tags false namedT)]
- (&.with-scope
- (@common.with-unknown-type
- (@.analyse-record analyse recordC)))))
- (check-record-inference tupleT size)))
- (test "Records specialize when type-vars get bound."
- (|> (@module.with-module +0 module-name
- (do macro.Monad<Meta>
- [_ (@module.declare-tags tags false named-polyT)]
- (&.with-scope
- (@common.with-unknown-type
- (@.analyse-record analyse recordC)))))
- (check-record-inference tupleT size)))
- (test "Can specialize generic records."
- (|> (@module.with-module +0 module-name
- (do macro.Monad<Meta>
- [_ (@module.declare-tags tags false named-polyT)]
- (&.with-scope
- (&.with-type tupleT
- (@.analyse-record analyse recordC)))))
- (macro.run (io.run init-jvm))
- (case> (^multi (#e.Success [_ _ productA])
- [(la.unfold-tuple productA)
- membersA])
- (n/= size (list.size membersA))
-
- _
- false)))
- ))))
diff --git a/new-luxc/source/luxc/lang/analysis/inference.lux b/stdlib/source/lux/lang/analysis/inference.lux
index 9bc668050..732a8e6e3 100644
--- a/new-luxc/source/luxc/lang/analysis/inference.lux
+++ b/stdlib/source/lux/lang/analysis/inference.lux
@@ -7,33 +7,41 @@
text/format
(coll [list "list/" Functor<List>]))
[macro "macro/" Monad<Meta>]
+ [lang]
(lang [type]
- (type ["tc" check])))
- (luxc ["&" lang]
- (lang ["la" analysis #+ Analysis]
- (analysis ["&." common]))))
+ (type ["tc" check])
+ [analysis #+ Analysis Analyser]
+ (analysis [".A" type]))))
+
+(exception: #export (variant-tag-out-of-bounds {size Nat} {tag analysis.Tag} {type Type})
+ (ex.report ["Tag" (%n tag)]
+ ["Variant size" (%n size)]
+ ["Variant type" (%type type)]))
+
+(exception: #export (cannot-infer {type Type} {args (List Code)})
+ (ex.report ["Type" (%type type)]
+ ["Arguments" (|> args
+ list.enumerate
+ (list/map (function (_ [idx argC])
+ (format "\n " (%n idx) " " (%code argC))))
+ (text.join-with ""))]))
+
+(exception: #export (cannot-infer-argument {inferred Type} {argument Code})
+ (ex.report ["Inferred Type" (%type inferred)]
+ ["Argument" (%code argument)]))
+
+(exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat})
+ (ex.report ["Expected" (%i (.int expected))]
+ ["Actual" (%i (.int actual))]))
(do-template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Cannot-Infer]
- [Cannot-Infer-Argument]
- [Smaller-Variant-Than-Expected]
- [Invalid-Type-Application]
- [Not-A-Record-Type]
- [Not-A-Variant-Type]
- )
+ [(exception: #export (<name> {type Type})
+ (%type type))]
-(def: (cannot-infer type args)
- (-> Type (List Code) Text)
- (format " Type: " (%type type) "\n"
- "Arguments:"
- (|> args
- list.enumerate
- (list/map (function (_ [idx argC])
- (format "\n " (%n idx) " " (%code argC))))
- (text.join-with ""))))
+ [not-a-variant-type]
+ [not-a-record-type]
+ [invalid-type-application]
+ )
(def: (replace-bound bound-idx replacementT type)
(-> Nat Type Type Type)
@@ -69,7 +77,7 @@
(Meta Type)
(do macro.Monad<Meta>
[[_module _line _column] macro.cursor
- [ex-id exT] (&.with-type-env tc.existential)]
+ [ex-id exT] (typeA.with-env tc.existential)]
(wrap (#.Primitive (format "{New Type @ " (%t _module)
"," (%n _line)
"," (%n _column)
@@ -84,11 +92,11 @@
## But, so long as the type being used for the inference can be treated
## as a function type, this method of inference should work.
(def: #export (general analyse inferT args)
- (-> &.Analyser Type (List Code) (Meta [Type (List Analysis)]))
+ (-> Analyser Type (List Code) (Meta [Type (List Analysis)]))
(case args
#.Nil
(do macro.Monad<Meta>
- [_ (&.infer inferT)]
+ [_ (typeA.infer inferT)]
(wrap [inferT (list)]))
(#.Cons argC args')
@@ -98,22 +106,22 @@
(#.UnivQ _)
(do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)]
+ [[var-id varT] (typeA.with-env tc.var)]
(general analyse (maybe.assume (type.apply (list varT) inferT)) args))
(#.ExQ _)
(do macro.Monad<Meta>
- [[var-id varT] (&.with-type-env tc.var)
+ [[var-id varT] (typeA.with-env tc.var)
output (general analyse
(maybe.assume (type.apply (list varT) inferT))
args)
- bound? (&.with-type-env
+ bound? (typeA.with-env
(tc.bound? var-id))
_ (if bound?
(wrap [])
(do @
[newT new-named-type]
- (&.with-type-env
+ (typeA.with-env
(tc.check varT newT))))]
(wrap output))
@@ -123,7 +131,7 @@
(general analyse outputT args)
#.None
- (&.throw Invalid-Type-Application (%type inferT)))
+ (lang.throw invalid-type-application inferT))
## Arguments are inferred back-to-front because, by convention,
## Lux functions take the most important arguments *last*, which
@@ -135,27 +143,25 @@
(#.Function inputT outputT)
(do macro.Monad<Meta>
[[outputT' args'A] (general analyse outputT args')
- argA (&.with-stacked-errors
+ argA (lang.with-stacked-errors
(function (_ _)
- (ex.construct Cannot-Infer-Argument
- (format "Inferred Type: " (%type inputT) "\n"
- " Argument: " (%code argC))))
- (&.with-type inputT
+ (ex.construct cannot-infer-argument [inputT argC]))
+ (typeA.with-type inputT
(analyse argC)))]
(wrap [outputT' (list& argA args'A)]))
(#.Var infer-id)
(do macro.Monad<Meta>
- [?inferT' (&.with-type-env (tc.read infer-id))]
+ [?inferT' (typeA.with-env (tc.read infer-id))]
(case ?inferT'
(#.Some inferT')
(general analyse inferT' args)
_
- (&.throw Cannot-Infer (cannot-infer inferT args))))
+ (lang.throw cannot-infer [inferT args])))
_
- (&.throw Cannot-Infer (cannot-infer inferT args)))
+ (lang.throw cannot-infer [inferT args]))
))
## Turns a record type into the kind of function type suitable for inference.
@@ -179,13 +185,13 @@
(record outputT)
#.None
- (&.throw Invalid-Type-Application (%type inferT)))
+ (lang.throw invalid-type-application inferT))
(#.Product _)
(macro/wrap (type.function (type.flatten-tuple inferT) inferT))
_
- (&.throw Not-A-Record-Type (%type inferT))))
+ (lang.throw not-a-record-type inferT)))
## Turns a variant type into the kind of function type suitable for inference.
(def: #export (variant tag expected-size inferT)
@@ -201,7 +207,7 @@
(^template [<tag>]
(<tag> env bodyT)
(do macro.Monad<Meta>
- [bodyT+ (recur (n/inc depth) bodyT)]
+ [bodyT+ (recur (inc depth) bodyT)]
(wrap (<tag> env bodyT+))))
([#.UnivQ]
[#.ExQ])
@@ -209,7 +215,7 @@
(#.Sum _)
(let [cases (type.flatten-variant currentT)
actual-size (list.size cases)
- boundary (n/dec expected-size)]
+ boundary (dec expected-size)]
(cond (or (n/= expected-size actual-size)
(and (n/> expected-size actual-size)
(n/< boundary tag)))
@@ -217,28 +223,26 @@
(#.Some caseT)
(macro/wrap (if (n/= +0 depth)
(type.function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)]
+ (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)]
(type.function (list (replace! caseT))
(replace! currentT)))))
#.None
- (&common.variant-out-of-bounds-error inferT expected-size tag))
+ (lang.throw variant-tag-out-of-bounds [expected-size tag inferT]))
(n/< expected-size actual-size)
- (&.throw Smaller-Variant-Than-Expected
- (format "Expected: " (%i (nat-to-int expected-size)) "\n"
- " Actual: " (%i (nat-to-int actual-size))))
+ (lang.throw smaller-variant-than-expected [expected-size actual-size])
(n/= boundary tag)
(let [caseT (type.variant (list.drop boundary cases))]
(macro/wrap (if (n/= +0 depth)
(type.function (list caseT) currentT)
- (let [replace! (replace-bound (|> depth n/dec (n/* +2)) inferT)]
+ (let [replace! (replace-bound (|> depth dec (n/* +2)) inferT)]
(type.function (list (replace! caseT))
(replace! currentT))))))
## else
- (&common.variant-out-of-bounds-error inferT expected-size tag)))
+ (lang.throw variant-tag-out-of-bounds [expected-size tag inferT])))
(#.Apply inputT funcT)
(case (type.apply (list inputT) funcT)
@@ -246,7 +250,7 @@
(variant tag expected-size outputT)
#.None
- (&.throw Invalid-Type-Application (%type inferT)))
+ (lang.throw invalid-type-application inferT))
_
- (&.throw Not-A-Variant-Type (%type inferT)))))
+ (lang.throw not-a-variant-type inferT))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 06:58:31 +0000