diff options
18 files changed, 1253 insertions, 1350 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/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index b515f6c6b..d866c153e 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -4,8 +4,9 @@ ["p" parser]) (data ["e" error] [maybe] + [product] [text "text/" Monoid<Text>] - (coll [list "list/" Functor<List>])) + (coll [list "list/" Functor<List> Fold<List>])) [macro] (macro [code] ["s" syntax #+ syntax: Syntax] @@ -99,3 +100,22 @@ ((~! text/compose) (~ g!descriptor) (~ (maybe.default (' "") body))))}))))) ))) + +(def: #export (report' entries) + (-> (List [Text Text]) Text) + (let [largest-header-size (|> entries + (list/map (|>> product.left text.size)) + (list/fold n/max +0))] + (|> entries + (list/map (function (_ [header message]) + (let [padding (|> " " + (list.repeat (n/- (text.size header) + largest-header-size)) + (text.join-with ""))] + ($_ text/compose padding header ": " message)))) + (text.join-with "\n")))) + +(syntax: #export (report {entries (p.many (s.tuple (p.seq s.any s.any)))}) + (wrap (list (` (report' (list (~+ (|> entries + (list/map (function (_ [header message]) + (` [(~ header) (~ message)]))))))))))) diff --git a/stdlib/source/lux/data/coll/dictionary/plist.lux b/stdlib/source/lux/data/coll/dictionary/plist.lux new file mode 100644 index 000000000..e9e08107a --- /dev/null +++ b/stdlib/source/lux/data/coll/dictionary/plist.lux @@ -0,0 +1,62 @@ +(.module: + lux + (lux (data [text "text/" Eq<Text>]))) + +(type: #export (PList a) + (List [Text a])) + +(def: #export (get key properties) + (All [a] (-> Text (PList a) (Maybe a))) + (case properties + #.Nil + #.None + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Some v') + (get key properties')))) + +(def: #export (contains? key properties) + (All [a] (-> Text (PList a) Bool)) + (case (get key properties) + (#.Some _) + true + + #.None + false)) + +(def: #export (put key val properties) + (All [a] (-> Text a (PList a) (PList a))) + (case properties + #.Nil + (list [key val]) + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Cons [key val] + properties') + (#.Cons [k' v'] + (put key val properties'))))) + +(def: #export (update key f properties) + (All [a] (-> Text (-> a a) (PList a) (PList a))) + (case properties + #.Nil + #.Nil + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Cons [k' (f v')] properties') + (#.Cons [k' v'] (update key f properties'))))) + +(def: #export (remove key properties) + (All [a] (-> Text (PList a) (PList a))) + (case properties + #.Nil + properties + + (#.Cons [k' v'] properties') + (if (text/= key k') + properties' + (#.Cons [k' v'] + (remove key properties'))))) diff --git a/stdlib/source/lux/lang.lux b/stdlib/source/lux/lang.lux index c4a4e2db3..9f164b719 100644 --- a/stdlib/source/lux/lang.lux +++ b/stdlib/source/lux/lang.lux @@ -9,6 +9,9 @@ [macro] (macro ["s" syntax #+ syntax:]))) +(type: #export Eval + (-> Type Code (Meta Top))) + (def: #export (fail message) (All [a] (-> Text (Meta a))) (do macro.Monad<Meta> diff --git a/stdlib/source/lux/lang/analysis.lux b/stdlib/source/lux/lang/analysis.lux index 46927bae1..6b2ba097d 100644 --- a/stdlib/source/lux/lang/analysis.lux +++ b/stdlib/source/lux/lang/analysis.lux @@ -48,10 +48,12 @@ (#Constant Ident) (#Special (Special Text))) -## 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. +(type: #export Variant + {#lefts Nat + #right? Bool + #value Analysis}) + +(type: #export Tuple (List Analysis)) (do-template [<name> <tag>] [(def: <name> @@ -71,8 +73,8 @@ (let [identity (#Function (list) (#Variable (#Local +1)))] (#Apply value identity))) -(def: #export (sum tag size temp value) - (-> Tag Nat Register Analysis Analysis) +(def: #export (sum size tag value) + (-> Nat Tag Analysis Analysis) (if (last? size tag) (if (n/= +1 tag) (..right value) @@ -88,8 +90,8 @@ value) (list.n/range +0 tag)))) -(def: #export (tuple members) - (-> (List Analysis) Analysis) +(def: #export (product members) + (-> Tuple Analysis) (case (list.reverse members) #.Nil (#Primitive #Unit) @@ -107,3 +109,35 @@ (type: #export Analyser (-> Code (Meta Analysis))) + +(def: #export (tuple analysis) + (-> Analysis Tuple) + (case analysis + (#Structure (#Product left right)) + (#.Cons left (tuple right)) + + _ + (list analysis))) + +(def: #export (variant analysis) + (-> Analysis (Maybe Variant)) + (loop [lefts +0 + variantA analysis] + (case variantA + (#Structure (#Sum (#.Left valueA))) + (case valueA + (#Structure (#Sum _)) + (recur (inc lefts) valueA) + + _ + (#.Some {#lefts lefts + #right? false + #value valueA})) + + (#Structure (#Sum (#.Right valueA))) + (#.Some {#lefts lefts + #right? true + #value valueA}) + + _ + #.None))) diff --git a/stdlib/source/lux/lang/analysis/expression.lux b/stdlib/source/lux/lang/analysis/expression.lux new file mode 100644 index 000000000..a22e3d32b --- /dev/null +++ b/stdlib/source/lux/lang/analysis/expression.lux @@ -0,0 +1,125 @@ +(.module: + lux + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) + (data ["e" error] + [product] + text/format) + [macro] + [lang #+ Eval] + (lang [type] + (type ["tc" check]) + [".L" analysis #+ Analysis Analyser] + (analysis [".A" type] + [".A" primitive] + [".A" structure] + ## [".A" function] + ## [".A" reference] + ) + ## [".L" macro] + ## [".L" extension] + ))) + +(exception: #export (macro-expansion-failed {message Text}) + message) + +(do-template [<name>] + [(exception: #export (<name> {code Code}) + (%code code))] + + [macro-call-must-have-single-expansion] + [unrecognized-syntax] + ) + +(def: #export (analyser eval) + (-> Eval Analyser) + (: (-> Code (Meta 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. + (lang.with-cursor cursor + (case code' + (^template [<tag> <analyser>] + (<tag> value) + (<analyser> value)) + ([#.Bool primitiveA.bool] + [#.Nat primitiveA.nat] + [#.Int primitiveA.int] + [#.Deg primitiveA.deg] + [#.Frac primitiveA.frac] + [#.Text primitiveA.text]) + + (^template [<tag> <analyser>] + (^ (#.Form (list& [_ (<tag> tag)] + values))) + (case values + (#.Cons value #.Nil) + (<analyser> analyse tag value) + + _ + (<analyser> analyse tag (` [(~+ values)])))) + ([#.Nat structureA.sum] + [#.Tag structureA.tagged-sum]) + + (#.Tag tag) + (structureA.tagged-sum analyse tag (' [])) + + (^ (#.Tuple (list))) + primitiveA.unit + + (^ (#.Tuple (list singleton))) + (analyse singleton) + + (^ (#.Tuple elems)) + (structureA.product analyse elems) + + (^ (#.Record pairs)) + (structureA.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)) + + ## (^ (#.Form (list& func args))) + ## (do macro.Monad<Meta> + ## [[funcT funcA] (typeA.with-inference + ## (analyse func))] + ## (case funcA + ## [_ (#.Symbol def-name)] + ## (do @ + ## [?macro (lang.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) + ## ((lang.throw macro-expansion-failed error) compiler) + + ## output + ## output)))] + ## (case expansion + ## (^ (list single)) + ## (analyse single) + + ## _ + ## (lang.throw macro-call-must-have-single-expansion code))) + + ## _ + ## (functionA.analyse-apply analyse funcT funcA args))) + + ## _ + ## (functionA.analyse-apply analyse funcT funcA args))) + + _ + (lang.throw unrecognized-syntax code) + ))))))) 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)))) diff --git a/stdlib/source/lux/lang/analysis/structure.lux b/stdlib/source/lux/lang/analysis/structure.lux new file mode 100644 index 000000000..cc185ebe9 --- /dev/null +++ b/stdlib/source/lux/lang/analysis/structure.lux @@ -0,0 +1,358 @@ +(.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] + (lang [type] + (type ["tc" check]) + [analysis #+ Analysis Analyser] + (analysis [".A" type] + [".A" primitive] + [".A" inference])))) + +(exception: #export (invalid-variant-type {type Type} {tag analysis.Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)])) + +(do-template [<name>] + [(exception: #export (<name> {type Type} {members (List Code)}) + (ex.report ["Type" (%type type)] + ["Expression" (%code (` [(~+ members)]))]))] + + [invalid-tuple-type] + [cannot-analyse-tuple] + ) + +(exception: #export (not-a-quantified-type {type Type}) + (%type type)) + +(do-template [<name>] + [(exception: #export (<name> {type Type} {tag analysis.Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)]))] + + [cannot-analyse-variant] + [cannot-infer-numeric-tag] + ) + +(exception: #export (record-keys-must-be-tags {key Code} {record (List [Code Code])}) + (ex.report ["Key" (%code key)] + ["Record" (%code (code.record record))])) + +(do-template [<name>] + [(exception: #export (<name> {key Ident} {record (List [Ident Code])}) + (ex.report ["Tag" (%code (code.tag key))] + ["Record" (%code (code.record (list/map (function (_ [keyI valC]) + [(code.tag keyI) valC]) + record)))]))] + + [cannot-repeat-tag] + ) + +(exception: #export (tag-does-not-belong-to-record {key Ident} {type Type}) + (ex.report ["Tag" (%code (code.tag key))] + ["Type" (%type type)])) + +(exception: #export (record-size-mismatch {expected Nat} {actual Nat} {type Type} {record (List [Ident Code])}) + (ex.report ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)] + ["Type" (%type type)] + ["Expression" (%code (|> record + (list/map (function (_ [keyI valueC]) + [(code.tag keyI) valueC])) + code.record))])) + +(def: #export (sum analyse tag valueC) + (-> Analyser Nat Code (Meta Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] + (lang.with-stacked-errors + (function (_ _) + (ex.construct cannot-analyse-variant [expectedT tag 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 (typeA.with-type variant-type + (analyse valueC))] + (wrap (analysis.sum type-size tag valueA))) + + #.None + (lang.throw inferenceA.variant-tag-out-of-bounds [type-size tag expectedT]))) + + (#.Named name unnamedT) + (typeA.with-type unnamedT + (sum analyse tag valueC)) + + (#.Var id) + (do @ + [?expectedT' (typeA.with-env + (tc.read id))] + (case ?expectedT' + (#.Some expectedT') + (typeA.with-type expectedT' + (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. + (lang.throw cannot-infer-numeric-tag [expectedT tag valueC]) + )) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (typeA.with-env <instancer>)] + (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (sum analyse tag valueC)))) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (typeA.with-env (tc.read funT-id))] + (case ?funT' + (#.Some funT') + (typeA.with-type (#.Apply inputT funT') + (sum analyse tag valueC)) + + _ + (lang.throw invalid-variant-type [expectedT tag valueC]))) + + _ + (case (type.apply (list inputT) funT) + #.None + (lang.throw not-a-quantified-type funT) + + (#.Some outputT) + (typeA.with-type outputT + (sum analyse tag valueC)))) + + _ + (lang.throw invalid-variant-type [expectedT tag valueC]))))) + +(def: (typed-product analyse membersC+) + (-> Analyser (List Code) (Meta 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)] + (typeA.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 (typeA.with-type leftT + (analyse leftC)) + rightA (recur rightT rightC)] + (wrap (#analysis.Structure (#analysis.Product leftA rightA)))) + + ## If, however, the type runs out but there is still enough + ## tail, the remaining elements get packaged into another + ## tuple. + ## 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. + [tailT tailC] + (|> tailC + code.tuple + analyse + (typeA.with-type tailT) + (:: @ map analysis.no-op)))))) + +(def: #export (product analyse membersC) + (-> Analyser (List Code) (Meta Analysis)) + (do macro.Monad<Meta> + [expectedT macro.expected-type] + (lang.with-stacked-errors + (function (_ _) + (ex.construct cannot-analyse-tuple [expectedT membersC])) + (case expectedT + (#.Product _) + (..typed-product analyse membersC) + + (#.Named name unnamedT) + (typeA.with-type unnamedT + (product analyse membersC)) + + (#.Var id) + (do @ + [?expectedT' (typeA.with-env + (tc.read id))] + (case ?expectedT' + (#.Some expectedT') + (typeA.with-type expectedT' + (product analyse membersC)) + + _ + ## Must do inference... + (do @ + [membersTA (monad.map @ (|>> analyse typeA.with-inference) + membersC) + _ (typeA.with-env + (tc.check expectedT + (type.tuple (list/map product.left membersTA))))] + (wrap (analysis.product (list/map product.right membersTA)))))) + + (^template [<tag> <instancer>] + (<tag> _) + (do @ + [[instance-id instanceT] (typeA.with-env <instancer>)] + (typeA.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (product analyse membersC)))) + ([#.UnivQ tc.existential] + [#.ExQ tc.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (typeA.with-env (tc.read funT-id))] + (case ?funT' + (#.Some funT') + (typeA.with-type (#.Apply inputT funT') + (product analyse membersC)) + + _ + (lang.throw invalid-tuple-type [expectedT membersC]))) + + _ + (case (type.apply (list inputT) funT) + #.None + (lang.throw not-a-quantified-type funT) + + (#.Some outputT) + (typeA.with-type outputT + (product analyse membersC)))) + + _ + (lang.throw invalid-tuple-type [expectedT membersC]) + )))) + +(def: #export (tagged-sum analyse tag valueC) + (-> Analyser Ident Code (Meta 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 (inferenceA.variant idx case-size variantT) + [inferredT valueA+] (inferenceA.general analyse inferenceT (list valueC))] + (wrap (analysis.sum case-size idx (|> valueA+ list.head maybe.assume)))) + + _ + (..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])) + + _ + (lang.throw record-keys-must-be-tags [key 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 []) + (lang.throw record-size-mismatch [size-ts size-record recordT record])) + #let [tuple-range (list.n/range +0 (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 + (lang.throw tag-does-not-belong-to-record [key recordT]) + + (#.Some idx) + (if (dict.contains? idx idx->val) + (lang.throw cannot-repeat-tag [key 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 (record analyse members) + (-> Analyser (List [Code Code]) (Meta Analysis)) + (do macro.Monad<Meta> + [members (normalize members) + [membersC recordT] (order members)] + (case membersC + (^ (list)) + primitiveA.unit + + (^ (list singletonC)) + (analyse singletonC) + + _ + (do @ + [expectedT macro.expected-type] + (case expectedT + (#.Var _) + (do @ + [inferenceT (inferenceA.record recordT) + [inferredT membersA] (inferenceA.general analyse inferenceT membersC)] + (wrap (analysis.product membersA))) + + _ + (..product analyse membersC)))))) diff --git a/stdlib/source/lux/lang/module.lux b/stdlib/source/lux/lang/module.lux new file mode 100644 index 000000000..d5efb1d7e --- /dev/null +++ b/stdlib/source/lux/lang/module.lux @@ -0,0 +1,239 @@ +(.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>] + (dictionary [plist]))) + [macro]) + [//]) + +(type: #export Tag Text) + +(exception: #export (unknown-module {module Text}) + module) + +(exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) + (format "Module: " module "\n" + " Tag: " tag "\n")) + +(do-template [<name>] + [(exception: #export (<name> {tags (List Text)} {owner Type}) + (format "Tags: " (text.join-with " " tags) "\n" + "Type: " (%type owner) "\n"))] + + [cannot-declare-tags-for-unnamed-type] + [cannot-declare-tags-for-foreign-type] + ) + +(exception: #export (cannot-define-more-than-once {name Ident}) + (%ident name)) + +(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) + (format " Module: " module "\n" + "Desired state: " (case state + #.Active "Active" + #.Compiled "Compiled" + #.Cached "Cached") "\n")) + +(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) + (format " Module: " module "\n" + "Old annotations: " (%code old) "\n" + "New annotations: " (%code new) "\n")) + +(def: (new 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 + (plist.put self-name (set@ #.module-annotations (#.Some annotations) self)) + compiler) + []])) + + (#.Some old) + (//.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) + +(def: #export (import module) + (-> Text (Meta Top)) + (do macro.Monad<Meta> + [self-name macro.current-module-name] + (function (_ compiler) + (#e.Success [(update@ #.modules + (plist.update self-name (update@ #.imports (|>> (#.Cons module)))) + compiler) + []])))) + +(def: #export (alias alias module) + (-> Text Text (Meta Top)) + (do macro.Monad<Meta> + [self-name macro.current-module-name] + (function (_ compiler) + (#e.Success [(update@ #.modules + (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) + (|>> (#.Cons [alias module]))))) + compiler) + []])))) + +(def: #export (exists? module) + (-> Text (Meta Bool)) + (function (_ compiler) + (|> compiler + (get@ #.modules) + (plist.get module) + (case> (#.Some _) true #.None false) + [compiler] #e.Success))) + +(def: #export (define name definition) + (-> Text Definition (Meta [])) + (do macro.Monad<Meta> + [self-name macro.current-module-name + self macro.current-module] + (function (_ compiler) + (case (plist.get name (get@ #.definitions self)) + #.None + (#e.Success [(update@ #.modules + (plist.put self-name + (update@ #.definitions + (: (-> (List [Text Definition]) (List [Text Definition])) + (|>> (#.Cons [name definition]))) + self)) + compiler) + []]) + + (#.Some already-existing) + ((//.throw cannot-define-more-than-once [self-name name]) compiler))))) + +(def: #export (create hash name) + (-> Nat Text (Meta [])) + (function (_ compiler) + (let [module (new hash)] + (#e.Success [(update@ #.modules + (plist.put name module) + compiler) + []])))) + +(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 [<setter> <asker> <tag>] + [(def: #export (<setter> module-name) + (-> Text (Meta Top)) + (function (_ compiler) + (case (|> compiler (get@ #.modules) (plist.get module-name)) + (#.Some module) + (let [active? (case (get@ #.module-state module) + #.Active true + _ false)] + (if active? + (#e.Success [(update@ #.modules + (plist.put module-name (set@ #.module-state <tag> module)) + compiler) + []]) + ((//.throw can-only-change-state-of-active-module [module-name <tag>]) + compiler))) + + #.None + ((//.throw unknown-module module-name) compiler)))) + + (def: #export (<asker> module-name) + (-> Text (Meta Bool)) + (function (_ compiler) + (case (|> compiler (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#e.Success [compiler + (case (get@ #.module-state module) + <tag> true + _ false)]) + + #.None + ((//.throw unknown-module module-name) compiler))))] + + [set-active active? #.Active] + [set-compiled compiled? #.Compiled] + [set-cached cached? #.Cached] + ) + +(do-template [<name> <tag> <type>] + [(def: (<name> module-name) + (-> Text (Meta <type>)) + (function (_ compiler) + (case (|> compiler (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#e.Success [compiler (get@ <tag> module)]) + + #.None + ((//.throw unknown-module module-name) compiler))))] + + [tags #.tags (List [Text [Nat (List Ident) Bool Type]])] + [types #.types (List [Text [(List Ident) Bool Type]])] + [hash #.module-hash Nat] + ) + +(def: (ensure-undeclared-tags module-name tags) + (-> Text (List Tag) (Meta Top)) + (do macro.Monad<Meta> + [bindings (..tags module-name) + _ (monad.map @ + (function (_ tag) + (case (plist.get tag bindings) + #.None + (wrap []) + + (#.Some _) + (//.throw cannot-declare-tag-twice [module-name tag]))) + tags)] + (wrap []))) + +(def: #export (declare-tags tags exported? type) + (-> (List Tag) Bool Type (Meta Top)) + (do macro.Monad<Meta> + [self-name macro.current-module-name + [type-module type-name] (case type + (#.Named type-ident _) + (wrap type-ident) + + _ + (//.throw cannot-declare-tags-for-unnamed-type [tags type])) + _ (ensure-undeclared-tags self-name tags) + _ (//.assert cannot-declare-tags-for-foreign-type [tags type] + (text/= self-name type-module))] + (function (_ compiler) + (case (|> compiler (get@ #.modules) (plist.get self-name)) + (#.Some module) + (let [namespaced-tags (list/map (|>> [self-name]) tags)] + (#e.Success [(update@ #.modules + (plist.update self-name + (|>> (update@ #.tags (function (_ tag-bindings) + (list/fold (function (_ [idx tag] table) + (plist.put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list.enumerate tags)))) + (update@ #.types (plist.put type-name [namespaced-tags exported? type])))) + compiler) + []])) + #.None + ((//.throw unknown-module self-name) compiler))))) diff --git a/stdlib/test/test/lux/lang/analysis/primitive.lux b/stdlib/test/test/lux/lang/analysis/primitive.lux index 2e7c2057a..ed9d8bfc6 100644 --- a/stdlib/test/test/lux/lang/analysis/primitive.lux +++ b/stdlib/test/test/lux/lang/analysis/primitive.lux @@ -1,24 +1,46 @@ (.module: - lux + [lux #- primitive] (lux [io] (control [monad #+ do] pipe ["ex" exception #+ exception:]) (data (text format) ["e" error]) - ["r" math/random] + ["r" math/random "r/" Monad<Random>] [macro] (macro [code]) + [lang] (lang [".L" type "type/" Eq<Type>] [".L" init] [analysis #+ Analysis] (analysis [".A" type] - ["/" primitive])) + [".A" expression])) test)) +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(def: unit + (r.Random Code) + (r/wrap (' []))) + +(def: #export primitive + (r.Random [Type Code]) + (`` ($_ r.either + (~~ (do-template [<type> <code-wrapper> <value-gen>] + [(r.seq (r/wrap <type>) (r/map <code-wrapper> <value-gen>))] + + [Top code.tuple (r.list +0 ..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.unicode +5)] + ))))) + (exception: (wrong-inference {expected Type} {inferred Type}) - (format "Expected: " (%type expected) "\n" - "Inferred: " (%type inferred) "\n")) + (ex.report ["Expected" (%type expected)] + ["Inferred" (%type inferred)])) (def: (infer-primitive expected-type analysis) (-> Type (Meta Analysis) (e.Error Analysis)) @@ -34,30 +56,31 @@ (#e.Error error)))) (context: "Primitives" - (<| (times +100) - (`` ($_ seq - (test "Can analyse unit." - (|> (infer-primitive Top /.unit) - (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output)))) - (is? [] output) - - _ - false))) - (~~ (do-template [<desc> <type> <tag> <random> <analyser>] - [(do @ - [sample <random>] - (test (format "Can analyse " <desc> ".") - (|> (infer-primitive <type> (<analyser> sample)) - (case> (#e.Success (#analysis.Primitive (<tag> output))) - (is? sample output) - - _ - false))))] - - ["bool" Bool #analysis.Bool r.bool /.bool] - ["nat" Nat #analysis.Nat r.nat /.nat] - ["int" Int #analysis.Int r.int /.int] - ["deg" Deg #analysis.Deg r.deg /.deg] - ["frac" Frac #analysis.Frac r.frac /.frac] - ["text" Text #analysis.Text (r.unicode +5) /.text] - )))))) + ($_ seq + (test "Can analyse unit." + (|> (infer-primitive Top (..analyse (' []))) + (case> (^ (#e.Success (#analysis.Primitive (#analysis.Unit output)))) + (is? [] output) + + _ + false))) + (<| (times +100) + (`` ($_ seq + (~~ (do-template [<desc> <type> <tag> <random> <constructor>] + [(do @ + [sample <random>] + (test (format "Can analyse " <desc> ".") + (|> (infer-primitive <type> (..analyse (<constructor> sample))) + (case> (#e.Success (#analysis.Primitive (<tag> output))) + (is? sample output) + + _ + false))))] + + ["bool" Bool #analysis.Bool r.bool code.bool] + ["nat" Nat #analysis.Nat r.nat code.nat] + ["int" Int #analysis.Int r.int code.int] + ["deg" Deg #analysis.Deg r.deg code.deg] + ["frac" Frac #analysis.Frac r.frac code.frac] + ["text" Text #analysis.Text (r.unicode +5) code.text] + ))))))) diff --git a/stdlib/test/test/lux/lang/analysis/structure.lux b/stdlib/test/test/lux/lang/analysis/structure.lux new file mode 100644 index 000000000..110717a0a --- /dev/null +++ b/stdlib/test/test/lux/lang/analysis/structure.lux @@ -0,0 +1,292 @@ +(.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] + (lang [type "type/" Eq<Type>] + (type ["tc" check]) + [".L" module] + [".L" init] + [".L" analysis #+ Analysis] + (analysis [".A" type] + ["/" structure] + [".A" expression])) + test) + (// ["_." primitive])) + +(do-template [<name> <on-success> <on-error>] + [(def: <name> + (All [a] (-> (Meta a) Bool)) + (|>> (macro.run (initL.compiler [])) + (case> (#e.Success _) + <on-success> + + _ + <on-error>)))] + + [check-succeeds true false] + [check-fails false true] + ) + +(def: analyse (expressionA.analyser (:! lang.Eval []))) + +(def: (check-sum' size tag variant) + (-> Nat analysisL.Tag analysisL.Variant Bool) + (let [variant-tag (if (get@ #analysisL.right? variant) + (inc (get@ #analysisL.lefts variant)) + (get@ #analysisL.lefts variant))] + (|> size dec (n/= tag) + (bool/= (get@ #analysisL.right? variant)) + (and (n/= tag variant-tag))))) + +(def: (check-sum type size tag analysis) + (-> Type Nat analysisL.Tag (Meta Analysis) Bool) + (|> analysis + (typeA.with-type type) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success sumA) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + false))) + +(def: (tagged module tags type) + (All [a] (-> Text (List moduleL.Tag) Type (Meta a) (Meta [Module a]))) + (|>> (do macro.Monad<Meta> + [_ (moduleL.declare-tags tags false type)]) + (moduleL.with-module +0 module))) + +(def: (check-variant module tags type size tag analysis) + (-> Text (List moduleL.Tag) Type Nat analysisL.Tag (Meta Analysis) Bool) + (|> analysis + (tagged module tags type) + (typeA.with-type type) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success [_ sumA]) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size tag variant) + + _ + false))) + +(def: (right-size? size) + (-> Nat (-> Analysis Bool)) + (|>> analysisL.tuple list.size (n/= size))) + +(def: (check-record-inference module tags type size analysis) + (-> Text (List moduleL.Tag) Type Nat (Meta [Type Analysis]) Bool) + (|> analysis + (tagged module tags type) + (macro.run (initL.compiler [])) + (case> (#e.Success [_ productT productA]) + (and (type/= type productT) + (right-size? size productA)) + + _ + false))) + +(context: "Sums" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + choice (|> r.nat (:: @ map (n/% size))) + primitives (r.list size _primitive.primitive) + +choice (|> r.nat (:: @ map (n/% (inc size)))) + [_ +valueC] _primitive.primitive + #let [variantT (type.variant (list/map product.left primitives)) + [valueT valueC] (maybe.assume (list.nth choice primitives)) + +size (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." + (check-sum variantT size choice + (/.sum ..analyse choice valueC))) + (test "Can analyse sum through bound type-vars." + (|> (do macro.Monad<Meta> + [[_ varT] (typeA.with-env tc.var) + _ (typeA.with-env + (tc.check varT variantT))] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + (macro.run (initL.compiler [])) + (case> (^multi (#e.Success sumA) + [(analysisL.variant sumA) + (#.Some variant)]) + (check-sum' size choice variant) + + _ + false))) + (test "Cannot analyse sum through unbound type-vars." + (|> (do macro.Monad<Meta> + [[_ varT] (typeA.with-env tc.var)] + (typeA.with-type varT + (/.sum ..analyse choice valueC))) + check-fails)) + (test "Can analyse sum through existential quantification." + (|> (typeA.with-type (type.ex-q +1 +variantT) + (/.sum ..analyse +choice +valueC)) + check-succeeds)) + (test "Can analyse sum through universal quantification." + (let [check-outcome (if (not (n/= choice +choice)) + check-succeeds + check-fails)] + (|> (typeA.with-type (type.univ-q +1 +variantT) + (/.sum ..analyse +choice +valueC)) + check-outcome))) + )))) + +(context: "Products" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + primitives (r.list size _primitive.primitive) + choice (|> r.nat (:: @ map (n/% size))) + [_ +valueC] _primitive.primitive + #let [tupleT (type.tuple (list/map product.left primitives)) + [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." + (|> (typeA.with-type tupleT + (/.product ..analyse (list/map product.right primitives))) + (macro.run (initL.compiler [])) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + false))) + (test "Can infer product." + (|> (typeA.with-inference + (/.product ..analyse (list/map product.right primitives))) + (macro.run (initL.compiler [])) + (case> (#e.Success [_type tupleA]) + (and (type/= tupleT _type) + (right-size? size tupleA)) + + _ + false))) + (test "Can analyse pseudo-product (singleton tuple)" + (|> (typeA.with-type singletonT + (..analyse (` [(~ singletonC)]))) + check-succeeds)) + (test "Can analyse product through bound type-vars." + (|> (do macro.Monad<Meta> + [[_ varT] (typeA.with-env tc.var) + _ (typeA.with-env + (tc.check varT (type.tuple (list/map product.left primitives))))] + (typeA.with-type varT + (/.product ..analyse (list/map product.right primitives)))) + (macro.run (initL.compiler [])) + (case> (#e.Success tupleA) + (right-size? size tupleA) + + _ + false))) + (test "Can analyse product through existential quantification." + (|> (typeA.with-type (type.ex-q +1 +tupleT) + (/.product ..analyse (list/map product.right +primitives))) + check-succeeds)) + (test "Cannot analyse product through universal quantification." + (|> (typeA.with-type (type.univ-q +1 +tupleT) + (/.product ..analyse (list/map product.right +primitives))) + check-fails)) + )))) + +(context: "Tagged Sums" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash<Text> size (r.unicode +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 _primitive.primitive) + module-name (r.unicode +5) + type-name (r.unicode +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) + named-polyT (|> (type.variant (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q +1) + (#.Named [module-name type-name])) + choice-tag (maybe.assume (list.nth choice tags)) + other-choice-tag (maybe.assume (list.nth other-choice tags))]] + ($_ seq + (test "Can infer tagged sum." + (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) + (check-variant module-name tags namedT choice size))) + (test "Tagged sums specialize when type-vars get bound." + (|> (/.tagged-sum ..analyse [module-name choice-tag] choiceC) + (check-variant module-name tags named-polyT choice size))) + (test "Tagged sum inference retains universal quantification when type-vars are not bound." + (|> (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC) + (check-variant module-name tags named-polyT other-choice size))) + (test "Can specialize generic tagged sums." + (|> (typeA.with-type variantT + (/.tagged-sum ..analyse [module-name other-choice-tag] other-choiceC)) + (check-variant module-name tags named-polyT other-choice size))) + )))) + +(context: "Records" + (<| (times +100) + (do @ + [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +2)))) + tags (|> (r.set text.Hash<Text> size (r.unicode +5)) (:: @ map set.to-list)) + primitives (r.list size _primitive.primitive) + module-name (r.unicode +5) + type-name (r.unicode +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) + named-polyT (|> (type.tuple (list.concat (list (list.take choice primitivesT) + (list varT) + (list.drop (inc choice) primitivesT)))) + (type.univ-q +1) + (#.Named [module-name type-name]))]] + ($_ seq + (test "Can infer record." + (|> (typeA.with-inference + (/.record ..analyse recordC)) + (check-record-inference module-name tags namedT size))) + (test "Records specialize when type-vars get bound." + (|> (typeA.with-inference + (/.record ..analyse recordC)) + (check-record-inference module-name tags named-polyT size))) + (test "Can specialize generic records." + (|> (do macro.Monad<Meta> + [recordA (typeA.with-type tupleT + (/.record ..analyse recordC))] + (wrap [tupleT recordA])) + (check-record-inference module-name tags named-polyT size))) + )))) |